Use Monad for decoding

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"

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)
+	sdecode :: DR  a
-	sencode :: a -> [Trit]
+	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
+	sdecode = do
-		(x0, 0) -> (x0, False)
+		i <- sdecode :: DR Int
-		(x0, 1) -> (x0, True)
+		case i of
-		(x0, i) -> error "Expected 0 or 1"
+			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 = getTrit
-	sdecode (i:xs) = (xs, i)
 	sencode t = [t]
 
 instance Encode a => Encode [a] where
-	sdecode [] = error "Unexpected end of stream"
+	sdecode = do
-	sdecode (T0:xs) = (xs, [])
+		i <- getTrit
-	sdecode (T1:xs) = let (x0, a) = sdecode xs in (x0, [a])
+		case i of
-	sdecode (T2:T2:xs) = let (x0, a) = sdecode xs :: DR Int in get [] (a+2) x0  where
+			T0 -> return []
-		get r 0 x = (x, r)
+			T1 -> sdecode >>= (\x -> return [x])
-		get r k x | k > 0 = let (xn, e) = sdecode x in get (r ++ e) (k-1) xn
+			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
+	sdecode = do
-		let sum = decodeTern digits in (x0, (3^(length digits - 1) `div` 2) + sum)
+		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)