a3/code/Generics/GenCompress.icl

   1 implementation module GenCompress
   2
   3 import StdGeneric, StdEnv, StdMaybe, _Array
   4
   5 //--------------------------------------------------
   6 // uncompressor monad
   7
   8 ret :: !.a !u:CompressSt -> (!Maybe .a,!u:CompressSt)
   9 ret a st = (Just a, st)
  10 (>>=) infixl 5
  11 (>>=) pa pb = bind pa pb
  12 where
  13         bind pa pb st
  14                 #! (ma, st) = pa st
  15                 = case ma of
  16                         Nothing -> (Nothing, st)
  17                         Just x  -> pb x st
  18
  19 //--------------------------------------------------
  20
  21 :: BitVector :== {#Int}
  22 :: BitPos :== Int
  23
  24 :: CompressSt = { cs_pos :: !Int, cs_bits :: !.{#Int} }
  25 mkCompressSt arr = { cs_pos = 0, cs_bits = arr}
  26
  27
  28 :: Compress a :== a -> *CompressSt -> *CompressSt
  29 :: Uncompress a :== .CompressSt -> .(.(Maybe a), .CompressSt)
  30
  31 compressBool :: !Bool !*CompressSt -> *CompressSt
  32 compressBool bit {cs_pos = pos, cs_bits = bits}
  33         #! s = size bits
  34         #! int_pos = pos >> (IF_INT_64_OR_32 6 5)
  35         #! bit_pos = pos bitand (IF_INT_64_OR_32 63 31)
  36         | s == int_pos
  37                 = abort "reallocate"
  38                 #! int = bits.[int_pos]
  39                 #! bit_mask = 1 << bit_pos
  40                 #! new_int = if bit (int bitor bit_mask) (int bitand (bitnot bit_mask))
  41                 = {cs_pos = inc pos, cs_bits = {bits & [int_pos] = new_int}}
  42
  43 uncompressBool :: !u:CompressSt -> (.(Maybe Bool),v:CompressSt), [u <= v]
  44 uncompressBool cs=:{cs_pos = pos, cs_bits = bits}
  45         #! s = size bits
  46         #! int_pos = pos >> (IF_INT_64_OR_32 6 5)
  47         #! bit_pos = pos bitand (IF_INT_64_OR_32 63 31)
  48         | s == int_pos
  49                 = (Nothing, cs)
  50                 #! int = bits.[int_pos]
  51                 #! bit_mask = 1 << bit_pos
  52                 #! bit = (bit_mask bitand int) <> 0
  53                 = (Just bit, {cs & cs_pos = inc pos})
  54
  55 compressIntB :: !.Int !.Int -> .(*CompressSt -> .CompressSt)
  56 compressIntB num_bits int
  57         = compress 0 num_bits int
  58 where
  59         compress i n int
  60                 | i == n
  61                         = id
  62                 | otherwise
  63                         = compress (inc i) n (int >> 1)
  64                         o compressBool ((int bitand 1) == 1)
  65
  66
  67 compressInt = compressIntB (IF_INT_64_OR_32 64 32)
  68 compressChar c = compressIntB 8 (toInt c)
  69
  70 uncompressIntB :: !.Int -> u:CompressSt -> (.(Maybe Int),v:CompressSt), [u <= v]
  71 uncompressIntB num_bits
  72         = uncompress 0 num_bits 0
  73 where
  74         uncompress i n int
  75                 | i == n
  76                         = ret int
  77                 | otherwise
  78                         =       uncompressBool
  79                         >>=     \bit -> uncompress (inc i) n int
  80                         >>=     \x -> ret ((if bit 1 0) + (x << 1))
  81
  82 uncompressInt :: (u:CompressSt -> (.(Maybe Int),v:CompressSt)), [u <= v]
  83 uncompressInt = uncompressIntB (IF_INT_64_OR_32 64 32)
  84
  85 uncompressChar :: (u:CompressSt -> (.(Maybe Char),v:CompressSt)), [u <= v]
  86 uncompressChar = uncompressIntB 8 >>= ret o toChar
  87
  88 realToBinary32 :: !Real -> (!Int,!Int);
  89 realToBinary32 _ = code {
  90     pop_b 0
  91     };
  92
  93 realToBinary64 :: !Real -> Int;
  94 realToBinary64 _ = code {
  95     pop_b 0
  96     };
  97
  98 binaryToReal32 :: !(!Int,!Int) -> Real;
  99 binaryToReal32 _ = code {
 100     pop_b 0
 101     };
 102
 103 binaryToReal64 :: !Int -> Real;
 104 binaryToReal64 _ = code {
 105     pop_b 0
 106     };
 107
 108 compressReal real
 109         = IF_INT_64_OR_32
 110                 (compressInt (realToBinary64 real))
 111                 (let (i1, i2) = realToBinary32 real in compressInt i2 o compressInt i1)
 112
 113 uncompressReal :: (u:CompressSt -> (.(Maybe Real),v:CompressSt)), [u <= v]
 114 uncompressReal
 115         = IF_INT_64_OR_32
 116                 (uncompressInt
 117                 >>= \i -> ret (binaryToReal64 i))
 118                 (uncompressInt
 119                 >>= \i1 -> uncompressInt
 120                 >>= \i2 -> ret (binaryToReal32 (i1,i2)))
 121
 122 compressArray :: (a -> u:(v:CompressSt -> w:CompressSt)) !.(b a) -> x:(*CompressSt -> y:CompressSt) | Array b a, [x <= u,w <= v,w <= y]
 123 compressArray f xs
 124         = foldSt f [x \\ x <-: xs] o compressInt (size xs)
 125
 126 foldSt f [] = id
 127 foldSt f [x:xs] = foldSt f xs o f x
 128
 129 uncompressArray :: (u:CompressSt -> ((Maybe v:a),w:CompressSt)) -> .(x:CompressSt -> ((Maybe y:(b v:a)),z:CompressSt)) | Array b a, [x w <= u,y <= v,x w <= z]
 130 uncompressArray f
 131         =       uncompressInt >>= \s -> uncompress_array 0 s (createArrayUnsafe s)
 132 where
 133         uncompress_array i s arr
 134                 | i == s
 135                         = ret arr
 136                         = f >>= \x -> uncompress_array (inc i) s {arr & [i] = x}
 137
 138 compressList :: (a *CompressSt -> *CompressSt) ![a] -> *CompressSt -> *CompressSt
 139 compressList c xs = compressArray c (list_to_arr xs)
 140 where
 141         list_to_arr :: [b] -> {b} | Array {} b
 142         list_to_arr xs = {x \\ x <- xs}
 143
 144
 145 uncompressList xs = uncompressArray xs >>= ret o arr_to_list
 146 where
 147         arr_to_list :: {b} -> [b] | Array {} b
 148         arr_to_list xs = [x \\ x <-: xs]
 149
 150 //--------------------------------------------------------------------------------------
 151
 152 generic gCompress a :: !a -> *CompressSt -> *CompressSt
 153 gCompress{|Int|} x = compressInt x
 154 gCompress{|Real|} x = compressReal x
 155 gCompress{|Char|} x = compressChar x
 156 gCompress{|Bool|} x = compressBool x
 157 gCompress{|UNIT|} x = id
 158 gCompress{|PAIR|} cx cy (PAIR x y) = cy y o cx x
 159 gCompress{|EITHER|} cl cr (LEFT x) = cl x o compressBool False
 160 gCompress{|EITHER|} cl cr (RIGHT x) = cr x o compressBool True
 161 gCompress{|CONS|} c (CONS x) = c x
 162 gCompress{|FIELD|} c (FIELD x) = c x
 163 gCompress{|OBJECT|} c (OBJECT x) = c x
 164 gCompress{|{}|} c xs = compressArray c xs
 165 gCompress{|{!}|} c xs = compressArray c xs
 166 gCompress{|String|} xs = compressArray compressChar xs
 167 gCompress{|[]|} c xs = compressList c xs
 168
 169
 170 generic gCompressedSize a :: a -> Int
 171 gCompressedSize{|Int|} _ = IF_INT_64_OR_32 64 32
 172 gCompressedSize{|Real|} _ = 64
 173 gCompressedSize{|Char|} _ = 8
 174 gCompressedSize{|Bool|} _ = 1
 175 gCompressedSize{|UNIT|} _ = 0
 176 gCompressedSize{|PAIR|} cx cy (PAIR x y) = cx x + cy y
 177 gCompressedSize{|EITHER|} cl cr (LEFT x) = 1 + cl x
 178 gCompressedSize{|EITHER|} cl cr (RIGHT x) = 1 + cr x
 179 gCompressedSize{|CONS|} c (CONS x) = c x
 180 gCompressedSize{|FIELD|} c (FIELD x) = c x
 181 gCompressedSize{|OBJECT|} c (OBJECT x) = c x
 182 gCompressedSize{|[]|} c xs = foldSt (\x st -> c x + st) xs (IF_INT_64_OR_32 64 32)
 183 gCompressedSize{|{}|} c xs = foldSt (\x st -> c x + st) [x\\x<-:xs] (IF_INT_64_OR_32 64 32)
 184 gCompressedSize{|{!}|} c xs = foldSt (\x st -> c x + st) [x\\x<-:xs] (IF_INT_64_OR_32 64 32)
 185 gCompressedSize{|String|} xs = (IF_INT_64_OR_32 64 32) + size xs * 8
 186
 187 generic gUncompress a :: (u:CompressSt -> ((Maybe a),u:CompressSt))
 188 gUncompress{|Int|} = uncompressInt
 189 gUncompress{|Real|} = uncompressReal
 190 gUncompress{|Char|} = uncompressChar
 191 gUncompress{|Bool|} = uncompressBool
 192 gUncompress{|UNIT|} = ret UNIT
 193 gUncompress{|PAIR|} fx fy = fx >>= \x -> fy >>= \y -> ret (PAIR x y)
 194 gUncompress{|EITHER|} fl fr = uncompressBool >>= either
 195 where
 196         either is_right
 197                 | is_right
 198                         = fr >>= ret o RIGHT
 199                         = fl >>= ret o LEFT
 200 gUncompress{|CONS|} f = f >>= ret o CONS
 201 gUncompress{|FIELD|} f = f >>= ret o FIELD
 202 gUncompress{|OBJECT|} f = f >>= ret o OBJECT
 203 gUncompress{|[]|} f = uncompressList f
 204 gUncompress{|{}|} f = uncompressArray f
 205 gUncompress{|{!}|} f = uncompressArray f
 206 gUncompress{|String|} = uncompressArray uncompressChar
 207
 208
 209 //-------------------------------------------------------------------------------------
 210
 211 uncompress :: (BitVector -> Maybe a) | gUncompress{|*|} a
 212 uncompress = fst o gUncompress{|*|} o mkCompressSt
 213
 214 compress :: !a -> BitVector | gCompressedSize{|*|} a & gCompress{|*|} a
 215 compress x
 216         #! compressed_size = gCompressedSize{|*|} x
 217         #! arr_size = (compressed_size + (IF_INT_64_OR_32 63 31)) >> (IF_INT_64_OR_32 6 5)
 218         #! bits = createArray arr_size 0
 219         = (gCompress{|*|} x (mkCompressSt bits)).cs_bits
 220
 221 //-------------------------------------------------------------------------------------
 222
 223 /*
 224 :: Tree a b = Tip a | Bin b (Tree a b) (Tree a b)
 225 :: Color = Red | Green | Blue
 226
 227 derive bimap (,), (,,), Maybe
 228 derive gCompress Tree, Color
 229 derive gUncompress Tree, Color
 230 derive gCompressedSize Tree, Color
 231
 232 //Start :: Maybe (Tree Color Color)
 233 //Start = uncompress (compress (Bin Red (Bin Green (Tip Blue) (Tip Red)) (Tip Green)))
 234 //Start = gCompressedSize{|*|} (Bin Red (Bin Green (Tip Blue) (Tip Red)) (Tip Green))
 235
 236 Start
 237         = gCompressedSize{|*|} xs
 238 */