+++ /dev/null
-implementation module GenCompress\r
-\r
-import StdGeneric, StdEnv, StdMaybe, _Array\r
-\r
-//--------------------------------------------------\r
-// uncompressor monad\r
-\r
-ret :: !.a !u:CompressSt -> (!Maybe .a,!u:CompressSt)\r
-ret a st = (Just a, st)\r
-(>>=) infixl 5 \r
-(>>=) pa pb = bind pa pb\r
-where\r
- bind pa pb st \r
- #! (ma, st) = pa st\r
- = case ma of\r
- Nothing -> (Nothing, st)\r
- Just x -> pb x st\r
-\r
-//--------------------------------------------------\r
-\r
-:: BitVector :== {#Int}\r
-:: BitPos :== Int\r
-\r
-:: CompressSt = { cs_pos :: !Int, cs_bits :: !.{#Int} }\r
-mkCompressSt arr = { cs_pos = 0, cs_bits = arr}\r
-\r
-\r
-:: Compress a :== a -> *CompressSt -> *CompressSt\r
-:: Uncompress a :== .CompressSt -> .(.(Maybe a), .CompressSt)\r
-\r
-compressBool :: !Bool !*CompressSt -> *CompressSt\r
-compressBool bit {cs_pos = pos, cs_bits = bits}\r
- #! s = size bits\r
- #! int_pos = pos >> (IF_INT_64_OR_32 6 5)\r
- #! bit_pos = pos bitand (IF_INT_64_OR_32 63 31)\r
- | s == int_pos\r
- = abort "reallocate" \r
- #! int = bits.[int_pos]\r
- #! bit_mask = 1 << bit_pos\r
- #! new_int = if bit (int bitor bit_mask) (int bitand (bitnot bit_mask))\r
- = {cs_pos = inc pos, cs_bits = {bits & [int_pos] = new_int}}\r
-\r
-uncompressBool :: !u:CompressSt -> (.(Maybe Bool),v:CompressSt), [u <= v]\r
-uncompressBool cs=:{cs_pos = pos, cs_bits = bits}\r
- #! s = size bits\r
- #! int_pos = pos >> (IF_INT_64_OR_32 6 5)\r
- #! bit_pos = pos bitand (IF_INT_64_OR_32 63 31)\r
- | s == int_pos\r
- = (Nothing, cs) \r
- #! int = bits.[int_pos]\r
- #! bit_mask = 1 << bit_pos\r
- #! bit = (bit_mask bitand int) <> 0\r
- = (Just bit, {cs & cs_pos = inc pos})\r
-\r
-compressIntB :: !.Int !.Int -> .(*CompressSt -> .CompressSt)\r
-compressIntB num_bits int\r
- = compress 0 num_bits int\r
-where\r
- compress i n int\r
- | i == n\r
- = id\r
- | otherwise\r
- = compress (inc i) n (int >> 1) \r
- o compressBool ((int bitand 1) == 1)\r
-\r
-\r
-compressInt = compressIntB (IF_INT_64_OR_32 64 32)\r
-compressChar c = compressIntB 8 (toInt c)\r
-\r
-uncompressIntB :: !.Int -> u:CompressSt -> (.(Maybe Int),v:CompressSt), [u <= v]\r
-uncompressIntB num_bits\r
- = uncompress 0 num_bits 0\r
-where\r
- uncompress i n int\r
- | i == n\r
- = ret int\r
- | otherwise\r
- = uncompressBool\r
- >>= \bit -> uncompress (inc i) n int \r
- >>= \x -> ret ((if bit 1 0) + (x << 1))\r
-\r
-uncompressInt :: (u:CompressSt -> (.(Maybe Int),v:CompressSt)), [u <= v]\r
-uncompressInt = uncompressIntB (IF_INT_64_OR_32 64 32)\r
-\r
-uncompressChar :: (u:CompressSt -> (.(Maybe Char),v:CompressSt)), [u <= v]\r
-uncompressChar = uncompressIntB 8 >>= ret o toChar \r
-\r
-realToBinary32 :: !Real -> (!Int,!Int);\r
-realToBinary32 _ = code {\r
- pop_b 0\r
- };\r
-\r
-realToBinary64 :: !Real -> Int;\r
-realToBinary64 _ = code {\r
- pop_b 0\r
- };\r
-\r
-binaryToReal32 :: !(!Int,!Int) -> Real;\r
-binaryToReal32 _ = code {\r
- pop_b 0\r
- };\r
-\r
-binaryToReal64 :: !Int -> Real;\r
-binaryToReal64 _ = code {\r
- pop_b 0\r
- };\r
-\r
-compressReal real\r
- = IF_INT_64_OR_32\r
- (compressInt (realToBinary64 real))\r
- (let (i1, i2) = realToBinary32 real in compressInt i2 o compressInt i1)\r
-\r
-uncompressReal :: (u:CompressSt -> (.(Maybe Real),v:CompressSt)), [u <= v]\r
-uncompressReal\r
- = IF_INT_64_OR_32\r
- (uncompressInt\r
- >>= \i -> ret (binaryToReal64 i))\r
- (uncompressInt \r
- >>= \i1 -> uncompressInt \r
- >>= \i2 -> ret (binaryToReal32 (i1,i2)))\r
-\r
-compressArray :: (a -> u:(v:CompressSt -> w:CompressSt)) !.(b a) -> x:(*CompressSt -> y:CompressSt) | Array b a, [x <= u,w <= v,w <= y]\r
-compressArray f xs \r
- = foldSt f [x \\ x <-: xs] o compressInt (size xs)\r
-\r
-foldSt f [] = id\r
-foldSt f [x:xs] = foldSt f xs o f x\r
-\r
-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]\r
-uncompressArray f \r
- = uncompressInt >>= \s -> uncompress_array 0 s (createArrayUnsafe s) \r
-where \r
- uncompress_array i s arr\r
- | i == s\r
- = ret arr\r
- = f >>= \x -> uncompress_array (inc i) s {arr & [i] = x} \r
-\r
-compressList :: (a *CompressSt -> *CompressSt) ![a] -> *CompressSt -> *CompressSt\r
-compressList c xs = compressArray c (list_to_arr xs)\r
-where\r
- list_to_arr :: [b] -> {b} | Array {} b\r
- list_to_arr xs = {x \\ x <- xs}\r
-\r
-\r
-uncompressList xs = uncompressArray xs >>= ret o arr_to_list\r
-where\r
- arr_to_list :: {b} -> [b] | Array {} b\r
- arr_to_list xs = [x \\ x <-: xs] \r
- \r
-//--------------------------------------------------------------------------------------\r
-\r
-generic gCompress a :: !a -> *CompressSt -> *CompressSt\r
-gCompress{|Int|} x = compressInt x \r
-gCompress{|Real|} x = compressReal x \r
-gCompress{|Char|} x = compressChar x\r
-gCompress{|Bool|} x = compressBool x\r
-gCompress{|UNIT|} x = id\r
-gCompress{|PAIR|} cx cy (PAIR x y) = cy y o cx x\r
-gCompress{|EITHER|} cl cr (LEFT x) = cl x o compressBool False\r
-gCompress{|EITHER|} cl cr (RIGHT x) = cr x o compressBool True\r
-gCompress{|CONS|} c (CONS x) = c x\r
-gCompress{|FIELD|} c (FIELD x) = c x\r
-gCompress{|OBJECT|} c (OBJECT x) = c x\r
-gCompress{|{}|} c xs = compressArray c xs\r
-gCompress{|{!}|} c xs = compressArray c xs\r
-gCompress{|String|} xs = compressArray compressChar xs\r
-gCompress{|[]|} c xs = compressList c xs\r
-\r
-\r
-generic gCompressedSize a :: a -> Int\r
-gCompressedSize{|Int|} _ = IF_INT_64_OR_32 64 32\r
-gCompressedSize{|Real|} _ = 64\r
-gCompressedSize{|Char|} _ = 8\r
-gCompressedSize{|Bool|} _ = 1\r
-gCompressedSize{|UNIT|} _ = 0\r
-gCompressedSize{|PAIR|} cx cy (PAIR x y) = cx x + cy y\r
-gCompressedSize{|EITHER|} cl cr (LEFT x) = 1 + cl x\r
-gCompressedSize{|EITHER|} cl cr (RIGHT x) = 1 + cr x\r
-gCompressedSize{|CONS|} c (CONS x) = c x\r
-gCompressedSize{|FIELD|} c (FIELD x) = c x\r
-gCompressedSize{|OBJECT|} c (OBJECT x) = c x\r
-gCompressedSize{|[]|} c xs = foldSt (\x st -> c x + st) xs (IF_INT_64_OR_32 64 32) \r
-gCompressedSize{|{}|} c xs = foldSt (\x st -> c x + st) [x\\x<-:xs] (IF_INT_64_OR_32 64 32) \r
-gCompressedSize{|{!}|} c xs = foldSt (\x st -> c x + st) [x\\x<-:xs] (IF_INT_64_OR_32 64 32) \r
-gCompressedSize{|String|} xs = (IF_INT_64_OR_32 64 32) + size xs * 8\r
-\r
-generic gUncompress a :: (u:CompressSt -> ((Maybe a),u:CompressSt))\r
-gUncompress{|Int|} = uncompressInt\r
-gUncompress{|Real|} = uncompressReal\r
-gUncompress{|Char|} = uncompressChar\r
-gUncompress{|Bool|} = uncompressBool\r
-gUncompress{|UNIT|} = ret UNIT\r
-gUncompress{|PAIR|} fx fy = fx >>= \x -> fy >>= \y -> ret (PAIR x y)\r
-gUncompress{|EITHER|} fl fr = uncompressBool >>= either\r
-where\r
- either is_right \r
- | is_right\r
- = fr >>= ret o RIGHT\r
- = fl >>= ret o LEFT\r
-gUncompress{|CONS|} f = f >>= ret o CONS\r
-gUncompress{|FIELD|} f = f >>= ret o FIELD\r
-gUncompress{|OBJECT|} f = f >>= ret o OBJECT\r
-gUncompress{|[]|} f = uncompressList f \r
-gUncompress{|{}|} f = uncompressArray f \r
-gUncompress{|{!}|} f = uncompressArray f \r
-gUncompress{|String|} = uncompressArray uncompressChar \r
-\r
-\r
-//-------------------------------------------------------------------------------------\r
-\r
-uncompress :: (BitVector -> Maybe a) | gUncompress{|*|} a\r
-uncompress = fst o gUncompress{|*|} o mkCompressSt\r
-\r
-compress :: !a -> BitVector | gCompressedSize{|*|} a & gCompress{|*|} a\r
-compress x \r
- #! compressed_size = gCompressedSize{|*|} x\r
- #! arr_size = (compressed_size + (IF_INT_64_OR_32 63 31)) >> (IF_INT_64_OR_32 6 5)\r
- #! bits = createArray arr_size 0\r
- = (gCompress{|*|} x (mkCompressSt bits)).cs_bits\r
- \r
-//-------------------------------------------------------------------------------------\r
-\r
-/*\r
-:: Tree a b = Tip a | Bin b (Tree a b) (Tree a b)\r
-:: Color = Red | Green | Blue\r
-\r
-derive bimap (,), (,,), Maybe\r
-derive gCompress Tree, Color\r
-derive gUncompress Tree, Color\r
-derive gCompressedSize Tree, Color\r
- \r
-//Start :: Maybe (Tree Color Color)\r
-//Start = uncompress (compress (Bin Red (Bin Green (Tip Blue) (Tip Red)) (Tip Green)))\r
-//Start = gCompressedSize{|*|} (Bin Red (Bin Green (Tip Blue) (Tip Red)) (Tip Green))\r
-\r
-Start \r
- = gCompressedSize{|*|} xs\r
-*/
\ No newline at end of file
repositories / tt2015.git / blobdiff