You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

Encoding.hs 3.7KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148
  1. {-# OPTIONS -fglasgow-exts #-}
  2. module Encoding (Trit(..), Encode(..), Stream(..), encode, decode, decodeStrict, toTrit, fromTrit) where
  3. import Control.Monad
  4. data Trit = T0 | T1 | T2 deriving (Enum, Eq)
  5. instance Show Trit where
  6. show = show . fromEnum
  7. instance Read Trit where
  8. readsPrec _ "0" = [(T0, "")]
  9. readsPrec _ "1" = [(T1, "")]
  10. readsPrec _ "2" = [(T2, "")]
  11. instance Num Trit where
  12. (+) = liftToTrit (+)
  13. (*) = liftToTrit (*)
  14. (-) = liftToTrit (-)
  15. abs = id
  16. signum = const 0
  17. fromInteger 0 = T0
  18. fromInteger 1 = T1
  19. fromInteger 2 = T2
  20. liftToTrit :: (Int -> Int -> Int) -> Trit -> Trit -> Trit
  21. liftToTrit f x y = toEnum $ (fromEnum x `f` fromEnum y) `mod` 3
  22. toTrit :: Int -> Trit
  23. toTrit = toEnum
  24. fromTrit :: Integral i => Trit -> i
  25. fromTrit = fromIntegral . fromEnum
  26. class Stream a where
  27. streamread :: a -> [Trit]
  28. streamwrite :: [Trit] -> a
  29. instance Stream [Trit] where
  30. streamread = id
  31. streamwrite = id
  32. instance Stream [Int] where
  33. streamread = map toEnum
  34. streamwrite = map fromEnum
  35. instance Stream String where
  36. streamread = map (toEnum . read . (:[]))
  37. streamwrite = concat . map (show . fromEnum)
  38. data Decoder i o = Decoder { doDecode :: [i] -> ([i], o) }
  39. type Encoder o i = i -> [o]
  40. type DR a = Decoder Trit a
  41. instance Monad (Decoder i) where
  42. f >>= g = Decoder $ \x -> let (x0, r0) = doDecode f x in doDecode (g r0) x0
  43. f >> g = Decoder $ \x -> let (x0, r0) = doDecode f x in doDecode g x0
  44. return a = Decoder $ \x -> (x, a)
  45. fail = error
  46. class Encode a where
  47. sdecode :: DR a
  48. sencode :: Encoder Trit a
  49. encode :: (Stream s, Encode a) => a -> s
  50. encode = streamwrite . sencode
  51. decode :: (Stream s, Encode a) => s -> a
  52. decode = snd . (doDecode sdecode) . streamread
  53. decodeStrict :: (Stream s, Encode a) => s -> a
  54. decodeStrict x = case (doDecode sdecode $ streamread x) of
  55. ([], a) -> a
  56. (_, _) -> error "Expected end of input"
  57. getTrit :: Decoder Trit Trit
  58. getTrit = Decoder $ \xs -> case xs of
  59. [] -> error "Unexpected end of stream"
  60. (i:xs) -> (xs, i)
  61. instance Encode Bool where
  62. sdecode = do
  63. i <- sdecode :: DR Int
  64. case i of
  65. 0 -> return False
  66. 1 -> return True
  67. _ -> fail "Expected 0 or 1"
  68. sencode True = [1]
  69. sencode False = [0]
  70. instance Encode Trit where
  71. sdecode = getTrit
  72. sencode t = [t]
  73. instance Encode a => Encode [a] where
  74. sdecode = do
  75. i <- getTrit
  76. case i of
  77. T0 -> return []
  78. T1 -> sdecode >>= (\x -> return [x])
  79. T2 -> do
  80. i <- getTrit
  81. case i of
  82. T2 -> do
  83. n <- sdecode :: DR Int
  84. replicateM (n+2) sdecode
  85. _ -> fail "Unexpected end of stream"
  86. sencode [] = [T0]
  87. sencode [x] = T1:sencode x
  88. sencode xs = T2:T2:(sencode $ length xs - 2) ++ concat (map sencode xs)
  89. instance Encode Int where
  90. sdecode = do
  91. n <- sdecode :: DR Integer
  92. return $ fromIntegral n
  93. sencode i = sencode (fromIntegral i :: Integer)
  94. instance Encode Integer where
  95. sdecode = do
  96. digits <- sdecode :: DR [Trit]
  97. return $ decodeTern digits + (3^(length digits - 1) `div` 2)
  98. sencode n
  99. | n < 0 = error "Can't encode negative numbers"
  100. | n == 0 = [0]
  101. | n > 0 = let len = log3 n in sencode (encodeTern len (n - base len)) where
  102. base len = (3^len - 1) `div` 2
  103. log3 n = (head $ filter (\len -> n < base len) [0..]) - 1
  104. instance (Encode a, Encode z) => Encode (a, z) where
  105. sdecode = do
  106. a <- sdecode
  107. z <- sdecode
  108. return (a, z)
  109. sencode (a, z) = sencode a ++ sencode z
  110. instance (Encode (a, b), Encode z) => Encode (a, b, z) where
  111. sdecode = do
  112. (a, b) <- sdecode
  113. z <- sdecode
  114. return (a, b, z)
  115. sencode (a, b, z) = sencode (a, b) ++ sencode z
  116. decodeTern :: Integral i => [Trit] -> i
  117. decodeTern digits = dec 0 digits where
  118. dec s [] = s
  119. dec s (i:xs) = dec (3*s + (fromTrit i)) xs
  120. encodeTern :: Integral i => Int -> i -> [Trit]
  121. encodeTern 0 0 = []
  122. encodeTern k x = (encodeTern (k-1) (x `div` 3)) ++ [toTrit $ fromIntegral (x `mod` 3)]