BUtil.hs

   1 {-# OPTIONS -XRank2Types -XCPP #-}
   2 module BUtil where
   3
   4 import qualified Data.IntMap as IntMap
   5 import Control.Monad
   6
   7 import System.IO.Unsafe
   8
   9 #if __GLASGOW_HASKELL__ >= 610
  10 import Control.OldException
  11 #else
  12 import Control.Exception
  13 #endif
  14
  15 data Nat = S Nat | Z deriving (Show,Eq)
  16
  17 toNat x = if x == 0 then
  18               Z
  19           else
  20               S (toNat $ x-1)
  21
  22 fromNat Z     = 0
  23 fromNat (S x) = 1 + fromNat x
  24
  25 fromDistinctList = IntMap.fromList
  26
  27 gen_put_bias :: Bias
  28                 -> (forall a. [a] -> [a])
  29                 -> (Nat -> Nat -> Maybe Nat)
  30                 -> [a] -> [a]
  31                 -> Maybe [Maybe a]
  32 gen_put_bias bias get sput s v =
  33     do { let ls = length s
  34        ; let g = fromDistinctList (zip (bias ls) s)
  35        ; l' <- maybe (fail "...")
  36                      return
  37                      (sput (toNat ls) (toNat (length v)))
  38        ; let t = bias (fromNat l')
  39        ; let h = fromDistinctList (zip (get t) v)
  40        ; let h'= IntMap.union h g
  41        ; return (map (flip IntMap.lookup h') t) }
  42
  43 withDefaultBias put bias d s v =
  44     do { s' <- put bias s v
  45        ; return (map (maybe d id) s') }
  46
  47 withDefault put d s v =
  48     do { s' <- put s v
  49        ; return (map (maybe d id) s') }
  50
  51 gen_put_dbias :: Bias -> (forall a. [a] -> [a])
  52                  -> (Nat -> Nat -> Maybe Nat)
  53                  -> a -> [a] -> [a] -> Maybe [a]
  54 gen_put_dbias bias get sput d s v =
  55     do { s' <- gen_put_bias bias get sput s v
  56        ; return (map (maybe d id) s') }
  57
  58 castError :: a -> Maybe a
  59 castError f = unsafePerformIO $
  60     do { r <- try (evaluate f)
  61        ; case r of
  62            Left  e -> return $ Nothing
  63            Right r -> return $ Just $ r }
  64
  65 type Bias = Int -> [ Int ]
  66 rear l    = [ 0 .. l - 1 ]
  67 front l   = reverse [ 0 .. l - 1 ]
  68 middle l  = [1,3..l] + (reverse [2,4..l])
  69 borders l = (reverse [1,3..l])+[2,4..l]