Register machine encoder/decoder

machine.hs

data Op = Inc Reg Label | Dec Reg Label Label | Halt deriving Eq
data Reg = Reg Integer deriving Eq
data Label = Label Integer deriving Eq

instance Show Op where
  show Halt         = "HALT"
  show (Inc r l)    = (show r) ++ "+ -> " ++ (show l)
  show (Dec r l l') = (show r) ++ "- -> " ++ (show l) ++ ", " ++ (show l')

instance Show Reg where
  show (Reg i)      = "R_" ++ (show i)

instance Show Label where
  show (Label i)    = "L_" ++ (show i)

-- Code = 2^46 × 20483
-- L_0 : R_1− → L_1 , L_3 
-- L_1 : R_0+ → L_2
-- L_2 : R_0+ → L_0
-- L_3 : HALT
tutorial :: [Op]
tutorial = [(Dec (Reg 1) (Label 1) (Label 3)),
            (Inc (Reg 0) (Label 2)),
            (Inc (Reg 0) (Label 0)),
            Halt
           ]

printEncode :: [Op] -> IO ()
printEncode ops
  = putStrLn $ "2^" ++ show e ++ " * " ++ show m
  where
    code = encode ops
    (e, m) = expMult 2 code

printDecode :: Integer -> IO ()
printDecode = mapM_ putStrLn . zipWith (\l instr -> l ++ show instr) labels . decode
  where
    labels = map (\i -> "L_" ++ (show i) ++ ": ") [0..]

encode :: [Op] -> Integer
encode [] 
  = 0
encode (op : ops) 
  = encodePPair (encodeOp op, encode ops)

encodeOp :: Op -> Integer
encodeOp Halt 
  = 0
encodeOp (Inc (Reg i) (Label j))
  = encodePPair (2*i, j)
encodeOp (Dec (Reg i) (Label j) (Label k))
  = encodePPair (2*i + 1, encodePair (j, k))

decode :: Integer -> [Op]
decode 0 = []
decode c
  = (decodeOp l) : decode l'
  where
    (l, l') = decodePPair c

decodeOp :: Integer -> Op
decodeOp 0 = Halt
decodeOp c
  | r == 0    = (Inc (Reg i) (Label b))
  | otherwise = (Dec (Reg i) (Label j) (Label k))
  where
    (a, b) = decodePPair c
    (i, r) = divMod a 2
    (j, k) = decodePair b
    
encodePair :: (Integer, Integer) -> Integer
encodePair (x, y)
  = 2^x * (2*y + 1) - 1

decodePair :: Integer -> (Integer, Integer)
-- Pre: c > 0
decodePair c
  = (x, (m - 1) `div` 2)
  where
    (x, m) = expMult 2 (c + 1)

encodePPair :: (Integer, Integer) -> Integer
encodePPair (x, y)
  = 2^x * (2*y + 1)

decodePPair :: Integer -> (Integer, Integer)
-- Pre: c > 1
decodePPair c
  = (x, (m - 1) `div` 2)
  where
    (x, m) = expMult 2 c

expMult :: Integer -> Integer -> (Integer, Integer)
-- Pre: b, x > 0
expMult b x
  | r == 0    = (e + 1, m)
  | otherwise = (0, x)
  where
    (q, r) = divMod x b
    (e, m) = expMult b q