{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}

-- | This module provides miscellaneous general-purpose auxiliary
-- functions.

module Quipper.Utils.Auxiliary (
  -- * List operations
  applyAt,
  overwriteAt,
  has_duplicates,
  substitute,
  
  -- * Set and Map related operations
  map_provide,
  intset_inserts,
  intmap_zip,
  intmap_zip_errmsg,
  intmap_map,
  intmap_mapM,
  
  -- * XIntMaps
  XIntMap,
  xintmap_delete,
  xintmap_deletes,
  xintmap_insert,
  xintmap_inserts,
  xintmap_lookup,
  xintmap_member,
  xintmap_empty,
  xintmap_freshkey,
  xintmap_freshkeys,
  xintmap_to_intmap,
  xintmap_size,
  xintmap_dirty,
  xintmap_reserves,
  xintmap_unreserves,  
  xintmap_makeclean,
  
  -- * Various map- and fold-like list combinators
  loop,
  loop_with_index,
  fold_right_zip,
  zip_strict,
  zip_strict_errmsg,
  zip_rightstrict,
  zip_rightstrict_errmsg,
  zipWith_strict,
  zipWith_rightstrict,
  
  -- * Monadic versions of list combinators
  loopM,
  loop_with_indexM,
  zipRightWithRightStrictM,
  zipRightWithRightStrictM_,
  fold_right_zipM,
  foldRightPairM,
  foldRightPairM_,
  sequence_right,
  sequence_right_,
  
  -- * Loops
  -- $LOOPS
  for,
  endfor,
  foreach,
  
  -- * Operations for monads
  mmap,
  monad_join1,
  
  -- * Operations for disjoint unions
  map_either,
  map_eitherM,
  
  -- * Operations for tuples
  map_pair,
  map_pairM,
  
  -- * Arithmetic operations
  int_ceiling,
  
  -- * Bit vectors
  Boollist(..),
  boollist_of_int_bh,
  boollist_of_int_lh,
  int_of_boollist_unsigned_bh,
  int_of_boollist_signed_bh,
  bool_xor,
  boollist_xor,
  
  -- * Formatting of lists and strings
  string_of_list,
  optional,
  
  -- * Lists optimized for fast concatenation
  BList,
  blist_of_list,
  list_of_blist,
  (+++),
  blist_empty,
  blist_concat,
  
  -- * Strings optimized for fast concatenation
  Strbuf,
  strbuf_of_string,
  string_of_strbuf,
  strbuf_empty,
  strbuf_concat,
  
  -- * The identity monad
  Id(..),
  
  -- * Identity types
  Identity,
  reflexivity,
  symmetry,
  transitivity,
  identity,
  
  -- * Error messages
  ErrMsg,
  
  -- * The Curry type class
  Curry (..)
  ) where

-- import other stuff
import Data.List (foldl')

import Data.Set (Set)
import qualified Data.Set as Set

import Data.Map (Map)
import qualified Data.Map as Map

import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet

import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap

import qualified Data.Traversable as Traversable

import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)

-- ----------------------------------------------------------------------
-- * List operations

-- | Apply a function to a specified position in a list.
applyAt :: Int -> (a -> a) -> [a] -> [a]
applyAt _ _ [] = []
applyAt 0 f (x:xs) = (f x):xs
applyAt n f (x:xs) = x:(applyAt (n-1) f xs)

-- | Overwrite an element at a specified position in a list.
overwriteAt :: Int -> a -> [a] -> [a]
overwriteAt n a = applyAt n (const a)

-- | Check whether a list has duplicates.
has_duplicates :: Ord a => [a] -> Bool
has_duplicates list = aux list (Set.empty) where
  aux [] _ = False
  aux (h:t) set = if Set.member h set then True else aux t (Set.insert h set)

-- | @'substitute' string character replacement@: 
-- Replace the first occurrence of /character/ in /string/ by /replacement/.
substitute :: (Eq a) => [a] -> a -> [a] -> [a]
substitute string character replacement =    
  case break (== character) string of
    (x, []) -> x
    (x, h:y) -> x ++ replacement ++ y

-- ----------------------------------------------------------------------
-- * Set related operations

-- | Insert the elements of a list in an 'IntSet' (cf. 'IntSet.insert').
intset_inserts :: [Int] -> IntSet -> IntSet
intset_inserts list set =
  foldl' (\t x -> IntSet.insert x t) set list


-- ----------------------------------------------------------------------
-- * Map related operations

-- | Insert the given key-value pair in a 'Map', but only if the given
-- key is not already present. If the key is present, keep the old
-- value.
map_provide :: Ord k => k -> a -> Map k a -> Map k a
map_provide = Map.insertWith (\x y -> y)

-- | Take two 'IntMap's /m/[sub 1] and /m/[sub 2], and form a new
-- 'IntMap' whose domain is that of /m/[sub 2], and whose value at /k/
-- is the pair (/m/[sub 1] ! /k/, /m/[sub 2] ! /k/). It is an error if
-- the domain of /m/[sub 2] is not a subset of the domain of /m/[sub 1].
intmap_zipright :: IntMap x -> IntMap y -> IntMap (x, y)
intmap_zipright m1 m2 = m where
  m = IntMap.mapWithKey f m2
  f k y = case IntMap.lookup k m1 of
    Just x -> (x, y)
    Nothing -> error "intmap_zipright: shape mismatch"
  
-- | Take two 'IntMap's with the same domain, and form a new 'IntMap'
-- whose values are pairs. It is an error if the two inputs don't have
-- identical domains.
intmap_zip :: IntMap x -> IntMap y -> IntMap (x, y)
intmap_zip m1 m2 = intmap_zip_errmsg m1 m2 "intmap_zip: shape mismatch"
  
-- | Like 'intmap_zip', but also takes an error message to use in case of
-- domain mismatch.
intmap_zip_errmsg :: IntMap x -> IntMap y -> String -> IntMap (x, y)
intmap_zip_errmsg m1 m2 errmsg = 
  if all (\k -> IntMap.member k m2) (IntMap.keys m1) 
    then intmap_zipright m1 m2
    else error errmsg
  
-- | Map a function over all values in an 'IntMap'.
intmap_map :: (x -> y) -> IntMap x -> IntMap y
intmap_map = IntMap.map

-- | Monadic version of 'intmap_map'. Map a function over all values
-- in an 'IntMap'.
intmap_mapM :: (Monad m) => (x -> m y) -> IntMap x -> m (IntMap y)
intmap_mapM = Traversable.mapM

-- ----------------------------------------------------------------------
-- * XIntMaps. 

-- | A 'XIntMap' is just like an 'IntMap', except that it supports
-- some additional efficient operations: to find the smallest unused
-- key, to find the set of all keys ever used in the past, and to
-- reserve a set of keys so that they will not be allocated. Moreover,
-- it keeps track of the highest key ever used (whether or not it is
-- still used in the current map).

-- This is implemented as a tuple (/m/, /n/, /free/, /h/), where /m/ is an
-- 'IntMap', /n/ is an integer such that dom /m/ ⊆ [0../n/-1], /free/
-- ⊆ [0../n/-1] \\ dom /m/ is a set of integers not currently reserved
-- or used, and /h/ is the set of all integers used in the past (the
-- set of /touched/ wires).

data XIntMap a = XIntMap !(IntMap a) !Int !IntSet !IntSet

instance (Show a) => Show (XIntMap a) where
  show = show . xintmap_to_intmap
    
-- | Delete a key from the 'XIntMap'.
xintmap_delete :: Int -> XIntMap a -> XIntMap a
xintmap_delete k (XIntMap m n free h) = (XIntMap m' n free' h) where
  m' = IntMap.delete k m
  free' = IntSet.insert k free
  
-- | Delete a list of keys from a 'XIntMap'.
xintmap_deletes :: [Int] -> XIntMap a -> XIntMap a
xintmap_deletes list map =
  foldl' (\map k -> xintmap_delete k map) map list

-- | Insert a new key-value pair in the 'XIntMap'. 
xintmap_insert :: Int -> a -> XIntMap a -> XIntMap a
xintmap_insert k v (XIntMap m n free h) = (XIntMap m' n' free' h') where
  m' = IntMap.insert k v m
  h' = IntSet.insert k h
  n' = max n (k+1)
  free' = IntSet.delete k (intset_inserts [n..n'-1] free)

-- | Insert a list of key-value pairs in the 'XIntMap'.
xintmap_inserts :: [(Int,a)] -> XIntMap a -> XIntMap a
xintmap_inserts list map =
  foldl' (\map (k,v) -> xintmap_insert k v map) map list

-- | Look up the value at a key in the 'XIntMap'. Return 'Nothing' if
-- not found.
xintmap_lookup :: Int -> XIntMap a -> Maybe a
xintmap_lookup k (XIntMap m n free h) =
  IntMap.lookup k m

-- | Check whether the given key is in the 'XIntMap'.
xintmap_member :: Int -> XIntMap a -> Bool
xintmap_member k (XIntMap m n free h) =
    IntMap.member k m

-- | The empty 'XIntMap'.
xintmap_empty :: XIntMap a
xintmap_empty = (XIntMap m n free h) where
  m = IntMap.empty
  n = 0
  free = IntSet.empty
  h = IntSet.empty

-- | Return the first free key in the 'XIntMap', but without actually
-- using it yet.
xintmap_freshkey :: XIntMap a -> Int
xintmap_freshkey (XIntMap m n free h) = 
  if IntSet.null free then n else IntSet.findMin free

-- | Return the next /k/ unused keys in the 'XIntMap', but without
-- actually using them yet.
xintmap_freshkeys :: Int -> XIntMap a -> [Int]
xintmap_freshkeys k (XIntMap m n free h) = ks1 ++ ks2 where
  ks1 = take k (IntSet.elems free)
  delta = k - (length ks1)
  ks2 = [n .. n+delta-1]

-- | Convert a 'XIntMap' to an 'IntMap'.
xintmap_to_intmap :: XIntMap a -> IntMap a
xintmap_to_intmap (XIntMap m n free h) = m

-- | Return the smallest key never used in the 'XIntMap'.
xintmap_size :: XIntMap a -> Int
xintmap_size (XIntMap m n free k) = n

-- | Return the set of all keys ever used in the 'XIntMap'.
xintmap_touched :: XIntMap a -> IntSet
xintmap_touched (XIntMap m n free h) = h 

-- | A wire is /dirty/ if it is touched but currently free. 
xintmap_dirty :: XIntMap a -> IntSet
xintmap_dirty (XIntMap m n free h) = h `IntSet.intersection` free

-- | Reserve a key in the 'XIntMap'. If the key is not free, do
-- nothing. The key must have been used before; for example, this is
-- the case if it was returned by 'xintmap_dirty'.
xintmap_reserve :: Int -> XIntMap a -> XIntMap a
xintmap_reserve k (XIntMap m n free h) = (XIntMap m n free' h) where
  free' = IntSet.delete k free
  
-- | Reserve a set of keys in the 'XIntMap'. For any keys that are not
-- free, do nothing. All keys must have been used before; for example,
-- this is the case if they were returned by 'xintmap_dirty'.
xintmap_reserves :: IntSet -> XIntMap a -> XIntMap a
xintmap_reserves ks (XIntMap m n free h) = (XIntMap m n free' h) where
  free' = free `IntSet.difference` ks

-- | Unreserve a key in the 'XIntMap'. If the key is currently used,
-- do nothing. The key must have been reserved before, and (therefore)
-- must have been used before.
xintmap_unreserve :: Int -> XIntMap a -> XIntMap a
xintmap_unreserve k (XIntMap m n free h) 
  | IntMap.member k m = (XIntMap m n free h)
  | otherwise = (XIntMap m n free' h)
    where
      free' = IntSet.insert k free

-- | Unreserve a list of keys in the 'XIntMap'. If any key is
-- currently used, do nothing. All keys must have been reserved
-- before, and (therefore) must have been used before.
xintmap_unreserves :: IntSet -> XIntMap a -> XIntMap a
xintmap_unreserves ks map = 
  IntSet.fold (\k map -> xintmap_unreserve k map) map ks

-- | Make an exact copy of the 'XIntMap', except that the set of
-- touched wires is initially set to the set of used wires. In other
-- words, we mark all free and reserved wires as untouched.
xintmap_makeclean :: XIntMap a -> XIntMap a
xintmap_makeclean (XIntMap m n free h) = (XIntMap m n free h') where
  h' = IntMap.keysSet m

-- ----------------------------------------------------------------------
-- * Map- and fold-like list combinators

-- ** Combinators for looping

-- | Like 'loop', but also pass a loop counter to the function being
-- iterated. Example:
-- 
-- > loop_with_index 3 x f = f 2 (f 1 (f 0 x))
loop_with_index :: (Eq int, Num int) => int -> t -> (int -> t -> t) -> t
loop_with_index n x f = aux 0 x
  where
    aux i x = if i == n then x else aux (i+1) (f i x)

-- | Monadic version of 'loop_with_index'. Thus, 
-- 
-- > loop_with_indexM 3 x0 f
-- 
-- will do the following:
-- 
-- > do
-- >   x1 <- f 0 x0
-- >   x2 <- f 1 x1
-- >   x3 <- f 2 x2    
-- >   return x3
loop_with_indexM :: (Eq int, Num int, Monad m) => int -> t -> (int -> t -> m t) -> m t
loop_with_indexM n x f = aux 0 x
  where
    aux i x =
      if i == n then return x else do
        x <- f i x
        aux (i+1) x

-- | Iterate a function /n/ times. Example: 
-- 
-- > loop 3 x f = f (f (f x))
loop :: (Eq int, Num int) => int -> t -> (t -> t) -> t
loop n x f = loop_with_index n x (\_ -> f)

-- | Monadic version of 'loop'.
loopM :: (Eq int, Num int, Monad m) => int -> t -> (t -> m t) -> m t
loopM n x f = loop_with_indexM n x (\_ -> f)

-- ** Combinators for sequencing

-- | A right-to-left version of 'sequence': Evaluate each action in the
-- sequence from right to left, and collect the results.
sequence_right :: Monad m => [m a] -> m [a]
sequence_right [] = return []
sequence_right (x:xs) = do
  ys <- sequence_right xs
  y <- x
  return (y:ys)

-- | Same as 'sequence_right', but ignore the result.
sequence_right_ :: Monad m => [m a] -> m ()
sequence_right_ [] = return ()
sequence_right_ (x:xs) = do
  ys <- sequence_right_ xs
  y <- x
  return ()

-- ** Combinators for zipping

-- | A \"strict\" version of 'zip', i.e., raises an error when the
-- lists are not of the same length.
zip_strict :: [a] -> [b] -> [(a, b)]
zip_strict a b = zip_strict_errmsg a b "zip_strict: lists are not of the same length"

-- | Like 'zip_strict', but also takes an explicit error message to
-- use in case of failure.
zip_strict_errmsg :: [a] -> [b] -> String -> [(a, b)]
zip_strict_errmsg [] [] e = []
zip_strict_errmsg (h:t) (h':t') e = (h,h') : zip_strict_errmsg t t' e
zip_strict_errmsg _ _ e = error e

-- | A \"right strict\" version of 'zip', i.e., raises an error when the
-- left list is shorter than the right one. 
zip_rightstrict :: [a] -> [b] -> [(a, b)]
zip_rightstrict a b = zip_rightstrict_errmsg a b "zip_rightstrict: list too short"

-- | A version of 'zip_rightstrict' that also takes an explicit error
-- message to use in case of failure.
zip_rightstrict_errmsg :: [a] -> [b] -> String -> [(a, b)]
zip_rightstrict_errmsg _ [] s = []
zip_rightstrict_errmsg (h:t) (h':t') s = (h,h') : zip_rightstrict_errmsg t t' s
zip_rightstrict_errmsg _ _ s = error s

-- | A \"strict\" version of 'zipWith', i.e., raises an error when the
-- lists are not of the same length.
zipWith_strict :: (a -> b -> c) -> [a] -> [b] -> [c]
zipWith_strict f [] [] = []
zipWith_strict f (h:t) (h':t') = f h h' : zipWith_strict f t t'
zipWith_strict f _ _ = error "zipWith_strict: lists are not of the same length"

-- | A \"right strict\" version of 'zipWith', i.e., raises an error when the
-- right list is shorter than the left one.
zipWith_rightstrict :: (a -> b -> c) -> [a] -> [b] -> [c]
zipWith_rightstrict f _ [] = []
zipWith_rightstrict f (h:t) (h':t') = f h h' : zipWith_rightstrict f t t'
zipWith_rightstrict f _ _ = error "zipWith_rightstrict: list too short"

-- | A right-to-left version of 'Control.Monad.zipWithM', which is
-- also \"right strict\", i.e., raises an error when the right list is
-- shorter than the left one. Example:
-- 
-- > zipRightWithM f [a,b] [x,y] = [f a x, f b y],
-- 
-- computed right-to-left.
zipRightWithRightStrictM :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
zipRightWithRightStrictM f l1 l2 =
  sequence_right $ zipWith_rightstrict f l1 l2

-- | Same as 'zipRightWithRightStrictM', but ignore the result.
zipRightWithRightStrictM_ :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()
zipRightWithRightStrictM_ f l1 l2 =
  sequence_right_ $ zipWith_rightstrict f l1 l2

-- ** Combinators combining mapping with folding

-- | Fold over two lists with state, and do it right-to-left.  For example,
-- 
-- > foldRightPairM (w0, [1,2,3], [a,b,c]) f
-- 
-- will do the following:
-- 
-- > do
-- >   w1 <- f (w0, 3, c)
-- >   w2 <- f (w1, 2, b)
-- >   w3 <- f (w2, 1, a)
-- >   return w3
foldRightPairM :: (Monad m) => (w, [a], [b]) -> ((w, a, b) -> m w) -> m w
foldRightPairM (w, [], _) f = return w
foldRightPairM (w, _, []) f = return w
foldRightPairM (w, a:as, b:bs) f = do
  w <- foldRightPairM (w, as, bs) f
  w <- f (w, a, b)
  return w

-- | Like 'foldRightPairM', but ignore the final result.
foldRightPairM_ :: (Monad m) => (w, [a], [b]) -> ((w, a, b) -> m w) -> m ()
foldRightPairM_ x f = do
  foldRightPairM x f
  return ()

-- | Combine right-to-left zipping and folding. Example:
-- 
-- > fold_right_zip f (w0, [a,b,c], [x,y,z]) = (w3, [a',b',c'])
-- >  where f (w0,c,z) = (w1,c')
-- >        f (w1,b,y) = (w2,b')
-- >        f (w2,a,x) = (w3,a')
fold_right_zip :: ((w, a, b) -> (w, c)) -> (w, [a], [b]) -> (w, [c])
fold_right_zip f (w, [], []) = (w, [])
fold_right_zip f (w, a:bb, x:yy) = (w2, a':bb')
  where
    (w1, bb') = fold_right_zip f (w, bb, yy)
    (w2, a') = f (w1, a, x)
fold_right_zip f _ = error "fold_right_zip"

-- | Monadic version of 'fold_right_zip'.
fold_right_zipM ::
  (Monad m) => ((w, a, b) -> m(w, c)) -> (w, [a], [b]) -> m(w, [c])
fold_right_zipM f (w, [], []) = return (w, [])
fold_right_zipM f (w, a:bb, x:yy) = do
    (w1, bb') <- fold_right_zipM f (w, bb, yy)
    (w2, a') <- f (w1, a, x)
    return (w2, a':bb')
fold_right_zipM f _ = error "fold_right_zipM"

-- ----------------------------------------------------------------------
-- * Loops.

-- $LOOPS We provide a syntax for \"for\"-style loops.

-- | A \"for\" loop. Counts from /a/ to /b/ in increments of /s/.
-- 
-- Standard notation: 
-- 
-- > for i = a to b by s do
-- >   commands             
-- > end for
-- 
-- Our notation: 
-- 
-- > for a b s $ \i -> do
-- >   commands
-- > endfor

for :: Monad m => Int -> Int -> Int -> (Int -> m()) -> m()
for a b s f = if s > 0 then aux a (<= b) else aux a (>= b)
  where
    aux i cond = 
      if cond i then do
        f i
        aux (i+s) cond
      else
        return ()

-- | Mark the end of a \"for\"-loop. This command actually does
-- nothing, but can be used to make the loop look prettier.
endfor :: Monad m => m()
endfor = return ()

-- | Iterate a parameter over a list of values. It can be used as
-- follows:
-- 
-- > foreach [1,2,3,4] $ \n -> do
-- >   <<<loop body depending on the parameter n>>>
-- > endfor
-- 
-- The loop body will get executed once for each /n/ ∈ {1,2,3,4}.

foreach :: Monad m => [a] -> (a -> m b) -> m ()
foreach l f = mapM_ f l

-- ----------------------------------------------------------------------
-- * Operations for monads

-- | Every monad is a functor. Input a function /f/ : /a/ → /b/ and output
-- /m/ /f/ : /m/ /a/ → /m/ /b/.
mmap :: (Monad m) => (a -> b) -> m a -> m b
mmap f a = a >>= (return . f)

-- | Remove an outer application of a monad from a monadic function.
monad_join1 :: (Monad m) => m (a -> m b) -> a -> m b
monad_join1 mf a = do
  f <- mf
  f a

-- ----------------------------------------------------------------------
-- * Operations for disjoint unions

-- | Take two functions /f/ : /a/ → /b/ and /g/ : /c/ → /d/, and return
-- /f/ ⊕ /g/ : /a/ ⊕ /c/ → /c/ ⊕ /d/.
map_either :: (a -> b) -> (c -> d) -> Either a c -> Either b d
map_either f g (Left x) = Left (f x)
map_either f g (Right x) = Right (g x)

-- | Monadic version of 'map_either'.
map_eitherM :: (Monad m) => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d)
map_eitherM f g (Left x) = mmap Left (f x)
map_eitherM f g (Right x) = mmap Right (g x)

-- ----------------------------------------------------------------------
-- * Operations for tuples

-- | Take two functions /f/ : /a/ → /b/ and /g/ : /c/ → /d/, and return
-- /f/ × /g/ : /a/ × /c/ → /c/ × /d/.
map_pair :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
map_pair f g (x, y) = (f x, g y)

-- | Monadic version of 'map_pair'.
map_pairM :: (Monad m) => (a -> m b) -> (c -> m d) -> (a, c) -> m (b, d)
map_pairM f g (a, c) = do
  b <- f a
  d <- g c
  return (b, d)

-- ----------------------------------------------------------------------
-- * Arithmetic operations
  
-- | A version of the 'ceiling' function that returns an 'Integer'.
int_ceiling :: RealFrac a => a -> Integer
int_ceiling = toInteger . ceiling

-- ----------------------------------------------------------------------
-- * Bit vectors

-- | The type of bit vectors. True = 1, False = 0.
type Boollist = [Bool]

-- | Convert an integer to a bit vector. The first argument is the
-- length in bits, and the second argument the integer to be
-- converted. The conversion is big-headian (or equivalently,
-- little-tailian), i.e., the head of the list holds the integer's most
-- significant digit.
boollist_of_int_bh :: Integral a => Int -> a -> Boollist
boollist_of_int_bh m = reverse . boollist_of_int_lh m

-- | Convert an integer to a bit vector. The first argument is the
-- length in bits, and the second argument the integer to be
-- converted. The conversion is little-headian (or equivalently,
-- big-tailian), i.e., the head of the list holds the integer's least
-- significant digit.
boollist_of_int_lh :: Integral a => Int -> a -> Boollist
boollist_of_int_lh m x | m <= 0 = []
boollist_of_int_lh m x = digit : boollist_of_int_lh (m-1) tail where
  digit = (x `mod` 2 == 1)
  tail = x `div` 2

-- | Convert a bit vector to an integer. The conversion is big-headian
-- (or equivalently, little-tailian), i.e., the head of the list holds
-- the integer's most significant digit. This function is unsigned,
-- i.e., the integer returned is ≥ 0.
int_of_boollist_unsigned_bh :: Integral a => Boollist -> a
int_of_boollist_unsigned_bh v = aux v 0
  where
    aux v acc =
      case v of
        [] -> acc
        digit : vs -> aux vs (2*acc+(if digit then 1 else 0))

-- | Convert a bit vector to an integer, signed.
int_of_boollist_signed_bh :: Integral a => Boollist -> a
int_of_boollist_signed_bh [] = 0
int_of_boollist_signed_bh (False:v) = int_of_boollist_unsigned_bh v
int_of_boollist_signed_bh (True:v) = -1 - int_of_boollist_unsigned_bh (map not v)

-- | Exclusive or operation on booleans.
bool_xor :: Bool -> Bool -> Bool
bool_xor a b = (a /= b)

-- | Exclusive or operation on bit vectors.
boollist_xor :: Boollist -> Boollist -> Boollist
boollist_xor = zipWith bool_xor

-- ----------------------------------------------------------------------
-- * Formatting of lists and strings

-- | A general list-to-string function. Example:
-- 
-- > string_of_list "{" ", " "}" "{}" show [1,2,3] = "{1, 2, 3}"
string_of_list :: String -> String -> String -> String -> (t -> String) -> [t] -> String
string_of_list lpar comma rpar nil string_of_elt lst =
  let string_of_tail lst =
        case lst of
          [] -> ""
          h:t -> comma ++ string_of_elt h ++ string_of_tail t
  in
  case lst of
    [] -> nil
    h:t -> lpar ++ string_of_elt h ++ string_of_tail t ++ rpar

-- | @'optional' b s@: if /b/ = 'True', return /s/, else the empty
-- string. This function is for convenience.
optional :: Bool -> String -> String
optional True s = s
optional False s = ""

-- ----------------------------------------------------------------------
-- * Lists optimized for fast concatenation

-- | The type of bidirectional lists. This is similar to [a], but
-- optimized for fast concatenation and appending on both sides.
newtype BList a = BList { getBList :: [a] -> [a] }

-- | Convert a List to a 'BList'.
blist_of_list :: [a] -> BList a
blist_of_list s = BList (\x -> s ++ x)

-- | Convert a 'BList' to a List.
list_of_blist :: BList a -> [a]
list_of_blist buf = getBList buf []

-- | Fast concatenation of 'BList's or string buffers.
(+++) :: BList a -> BList a -> BList a
(+++) buf1 buf2 = BList ((getBList buf1) . (getBList buf2))

-- | The empty 'BList'.
blist_empty :: BList a
blist_empty = BList id

-- | Concatenate a list of 'BList's.
blist_concat :: [BList a] -> BList a
blist_concat l = foldr (+++) blist_empty l

instance (Show a) => Show (BList a) where
        show bl = show (list_of_blist bl) 

-- ----------------------------------------------------------------------
-- * Strings optimized for fast concatenation

-- | A string buffer holds a string that is optimized for fast
-- concatenation. Note that this is an instance of 'BList', and hence
-- 'BList' operations (in particular '+++') can be applied to string
-- buffers. The following functions are synonyms of the respective
-- 'BList' functions, and are provided for convenience.
type Strbuf = BList Char

-- | Convert a string to a string buffer.
strbuf_of_string :: String -> Strbuf
strbuf_of_string = blist_of_list

-- | Convert a string buffer to a string.
string_of_strbuf :: Strbuf -> String
string_of_strbuf = list_of_blist

-- | The empty string buffer.
strbuf_empty :: Strbuf
strbuf_empty = blist_empty

-- | Concatenate a list of string buffers.
strbuf_concat :: [Strbuf] -> Strbuf
strbuf_concat = blist_concat

-- ----------------------------------------------------------------------
-- * The identity monad
      
-- | The identity monad. Using /m/ = 'Id' gives useful special cases
-- of monadic functions.
newtype Id a = Id { getId :: a }

instance Monad Id where
  return a = Id a
  (Id a) >>= b = b a

instance Applicative Id where
  pure = return
  (<*>) = ap

instance Functor Id where
  fmap = liftM

-- ----------------------------------------------------------------------
-- * Identity types
  
-- | The type 'Identity' /a/ /b/ witnesses the fact that /a/ and /b/
-- are the same type. In other words, this type is non-empty if and
-- only if /a/ = /b/. This property is not guaranteed by the type
-- system, but by the API, via the fact that the operators
-- 'reflexivity', 'symmetry', and 'transitivity' are the only exposed
-- constructors for this type. The implementation of this type is
-- deliberately hidden, as this is the only way to guarantee its
-- defining property.
-- 
-- Identity types are useful in certain situations. For example, they
-- can be used to define a data type which is polymorphic in some type
-- variable /x/, and which has certain constructors that are only
-- available when /x/ is a particular type. For example, in the
-- declaration
-- 
-- > data ExampleType x = Constructor1 x | Constructor2 x (Identity x Bool),
-- 
-- @Constructor1@ is available for all /x/, but @Constructor2@ is only
-- available when /x/ = 'Bool'.
newtype Identity a b = Identity (a -> b, b -> a)

-- | Witness the fact that /a/=/a/.
reflexivity :: Identity a a
reflexivity = Identity (id, id)

-- | Witness the fact that /a/=/b/ implies /b/=/a/.
symmetry :: Identity a b -> Identity b a
symmetry (Identity (f,g)) = Identity (g,f)

-- | Witness the fact that /a/=/b/ and /b/=/c/ implies /a/=/c/.
transitivity :: Identity a b -> Identity b c -> Identity a c
transitivity (Identity (f,g)) (Identity (f',g')) = Identity (f'',g'') where
  f'' = f' . f
  g'' = g . g'

-- | The identity function 'id' : /a/ → /b/, provided that /a/ and /b/
-- are the same type.
identity :: Identity a b -> a -> b
identity (Identity (f,g)) = f

instance Show (Identity a b) where
  show x = "id"

-- ======================================================================
-- * Error messages

-- | Often a low-level function, such as
-- 'Quipper.Internal.QData.qcdata_zip' or
-- 'Quipper.Internal.QData.qcdata_promote', throws an error because of
-- a failure of some low-level condition, such as \"list too
-- short\". To produce error messages that are meaningful to
-- user-level code, these functions do not have a hard-coded error
-- message. Instead, they input a stub error message.
-- 
-- A meaningful error message typically consists of at least three parts:
-- 
-- * the name of the user-level function where the error occurred, for
-- example: \"reverse_generic\";
-- 
-- * what the function was doing when the error occurred, for example:
-- \"operation not permitted in reversible circuit\";
-- 
-- * a specific low-level reason for the error, for example: \"dynamic
-- lifting\".
-- 
-- Thus, a meaningful error message may be: \"reverse_generic:
-- operation not permitted in reversible circuit: dynamic lifting\".
-- 
-- The problem is that the three pieces of information are not usually
-- present in the same place. The user-level function is often a
-- wrapper function that performs several different mid-level
-- operations (e.g., transforming, reversing). The mid-level function
-- knows what operation was being performed when the error occurred,
-- but often calls a lower-level function to do the actual work (e.g.,
-- encapsulating).
--   
-- Therefore, a stub error message is a function that inputs some
-- lower-level reason for a failure (example: \"list too short\") and
-- translates this into a higher-level error message (example:
-- \"qterm: shape of parameter does not data: list too short\").
-- 
-- Sometimes, the stub error message may also ignore the low-level
-- message and completely replace it by a higher-level one. For
-- example, a function that implements integers as bit lists may wish
-- to report a problem with integers, rather than a problem with the
-- underlying lists.
type ErrMsg = String -> String

-- ======================================================================
-- * The Curry type class

-- | The 'Curry' type class is used to implement functions that have a
-- variable number of arguments. It provides a family of type
-- isomorphisms
-- 
-- @fun  ≅  args -> res,@
-- 
-- where
-- 
-- > fun = a1 -> a2 -> ... -> an -> res,
-- > args = (a1, (a2, (..., (an, ())))).

class Curry fun args res | args res -> fun where
  -- | Multiple curry: map a function 
  -- (/a/[sub 1], (/a/[sub 2], (…, ())) → /b/ 
  -- to its curried form 
  -- /a/[sub 1] → /a/[sub 2] → … → /b/.
  mcurry :: (args -> res) -> fun
  -- | Multiple uncurry: map a function
  -- /a/[sub 1] → /a/[sub 2] → … → /b/
  -- to its uncurried form 
  -- (/a/[sub 1], (/a/[sub 2], (…, ())) → /b/.
  muncurry :: fun -> (args -> res)
               
instance Curry b () b where
  mcurry g = g ()
  muncurry x = const x

instance Curry fun args res => Curry (a -> fun) (a,args) res where
  mcurry g x = mcurry (\xs -> g (x,xs))
  muncurry f (x,xs) = muncurry (f x) xs