From 61a2808d7171e90445b7e965c73d647b756b5154 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Stefan=20B=C3=BChler?= Date: Wed, 23 Jun 2010 13:48:17 +0200 Subject: [PATCH] Use Monad for decoding --- CircuitBase.hs | 6 ++-- Encoding.hs | 80 ++++++++++++++++++++++++++++++++++---------------- 2 files changed, 58 insertions(+), 28 deletions(-) diff --git a/CircuitBase.hs b/CircuitBase.hs index bbdfe9a..c68cb6d 100644 --- a/CircuitBase.hs +++ b/CircuitBase.hs @@ -10,11 +10,13 @@ data Chamber = Chamber { upperPipe :: [Int], mainChamber :: Bool, lowerPipe :: [ data Car = Car { chambers :: [Chamber] } instance Encode Chamber where - sdecode xs = let (x0, (a,b,c)) = sdecode xs in (x0, Chamber a (not b) c) + sdecode = do + (a, b, c) <- sdecode + return $ Chamber a (not b) c sencode (Chamber a b c) = sencode (a, not b, c) instance Encode Car where - sdecode xs = let (x0, a) = sdecode xs in (x0, Car a) + sdecode = sdecode >>= (return . Car) sencode (Car a) = sencode a server_input = "01202101210201202" diff --git a/Encoding.hs b/Encoding.hs index da4bee3..ae9529b 100644 --- a/Encoding.hs +++ b/Encoding.hs @@ -2,6 +2,8 @@ module Encoding (Trit(..), Encode(..), Stream(..), encode, decode, decodeStrict, toTrit, fromTrit) where +import Control.Monad + data Trit = T0 | T1 | T2 deriving (Enum, Eq) instance Show Trit where @@ -30,8 +32,6 @@ toTrit = toEnum fromTrit :: Integral i => Trit -> i fromTrit = fromIntegral . fromEnum -type DR a = ([Trit], a) - class Stream a where streamread :: a -> [Trit] streamwrite :: [Trit] -> a @@ -48,50 +48,75 @@ instance Stream String where streamread = map (toEnum . read . (:[])) streamwrite = concat . map (show . fromEnum) +data Decoder i o = Decoder { doDecode :: [i] -> ([i], o) } +type Encoder o i = i -> [o] +type DR a = Decoder Trit a + +instance Monad (Decoder i) where + f >>= g = Decoder $ \x -> let (x0, r0) = doDecode f x in doDecode (g r0) x0 + f >> g = Decoder $ \x -> let (x0, r0) = doDecode f x in doDecode g x0 + return a = Decoder $ \x -> (x, a) + fail = error + class Encode a where - sdecode :: [Trit] -> ([Trit], a) - sencode :: a -> [Trit] + sdecode :: DR a + sencode :: Encoder Trit a encode :: (Stream s, Encode a) => a -> s encode = streamwrite . sencode decode :: (Stream s, Encode a) => s -> a -decode = snd . sdecode . streamread +decode = snd . (doDecode sdecode) . streamread decodeStrict :: (Stream s, Encode a) => s -> a -decodeStrict x = case (sdecode $ streamread x) of +decodeStrict x = case (doDecode sdecode $ streamread x) of ([], a) -> a (_, _) -> error "Expected end of input" +getTrit :: Decoder Trit Trit +getTrit = Decoder $ \xs -> case xs of + [] -> error "Unexpected end of stream" + (i:xs) -> (xs, i) + instance Encode Bool where - sdecode xs = case sdecode xs :: DR Int of - (x0, 0) -> (x0, False) - (x0, 1) -> (x0, True) - (x0, i) -> error "Expected 0 or 1" + sdecode = do + i <- sdecode :: DR Int + case i of + 0 -> return False + 1 -> return True + _ -> fail "Expected 0 or 1" sencode True = [1] sencode False = [0] instance Encode Trit where - sdecode [] = error "Unexpected end of stream" - sdecode (i:xs) = (xs, i) + sdecode = getTrit sencode t = [t] instance Encode a => Encode [a] where - sdecode [] = error "Unexpected end of stream" - sdecode (T0:xs) = (xs, []) - sdecode (T1:xs) = let (x0, a) = sdecode xs in (x0, [a]) - sdecode (T2:T2:xs) = let (x0, a) = sdecode xs :: DR Int in get [] (a+2) x0 where - get r 0 x = (x, r) - get r k x | k > 0 = let (xn, e) = sdecode x in get (r ++ e) (k-1) xn + sdecode = do + i <- getTrit + case i of + T0 -> return [] + T1 -> sdecode >>= (\x -> return [x]) + T2 -> do + i <- getTrit + case i of + T2 -> do + n <- sdecode :: DR Int + replicateM (n+2) sdecode + _ -> fail "Unexpected end of stream" sencode [] = [T0] sencode [x] = T1:sencode x sencode xs = (sencode $ length xs - 2) ++ concat (map sencode xs) instance Encode Int where - sdecode xs = let (x0, i) = sdecode xs :: DR Integer in (x0, fromIntegral i) + sdecode = do + n <- sdecode :: DR Integer + return $ fromIntegral n sencode i = sencode (fromIntegral i :: Integer) instance Encode Integer where - sdecode xs = let (x0, digits) = sdecode xs :: DR [Trit] in - let sum = decodeTern digits in (x0, (3^(length digits - 1) `div` 2) + sum) + sdecode = do + digits <- sdecode :: DR [Trit] + return $ decodeTern digits + (3^(length digits - 1) `div` 2) sencode n | n < 0 = error "Can't encode negative numbers" | n == 0 = [0] @@ -100,11 +125,17 @@ instance Encode Integer where log3 n = (head $ filter (\len -> n < base len) [0..]) - 1 instance (Encode a, Encode z) => Encode (a, z) where - sdecode xs = let (x0, a) = sdecode xs in let (x1, z) = sdecode x0 in (x1, (a, z)) + sdecode = do + a <- sdecode + z <- sdecode + return (a, z) sencode (a, z) = sencode a ++ sencode z instance (Encode (a, b), Encode z) => Encode (a, b, z) where - sdecode xs = let (x0, (a, b)) = sdecode xs in let (x1, z) = sdecode x0 in (x1, (a, b, z)) + sdecode = do + (a, b) <- sdecode + z <- sdecode + return (a, b, z) sencode (a, b, z) = sencode (a, b) ++ sencode z decodeTern :: Integral i => [Trit] -> i @@ -115,6 +146,3 @@ decodeTern digits = dec 0 digits where encodeTern :: Integral i => Int -> i -> [Trit] encodeTern 0 0 = [] encodeTern k x = (encodeTern (k-1) (x `div` 3)) ++ [toTrit $ fromIntegral (x `mod` 3)] - --- cartanks :: Car -> Nat --- cartanks = (1+) . maximum . concat . map (\(upper, _, lower) -> upper ++ lower)