Error Control Coding - Lecture 3: Hamming codes

F2.hs

module F2 where

import Data.Maybe
import Data.Function

-- The finite field F2
data F2 = Zero | One
  deriving Eq

instance Num F2 where
  (+) = add
  (*) = mul
  abs a = a
  signum a = case a of
    Zero -> 0
    One -> 1
  fromInteger a = tryFromInteger a & Data.Maybe.fromJust
  negate a = a

instance Show F2 where
  show a = show (F2.toInteger a)

tryFromInteger :: Integer -> Maybe F2
tryFromInteger 0 = Just Zero
tryFromInteger 1 = Just One
tryFromInteger _ = Nothing

fromBool :: Bool -> F2
fromBool False = Zero
fromBool True = One

toInteger :: F2 -> Int
toInteger Zero = 0
toInteger One = 1

toBool :: F2 -> Bool
toBool Zero = False
toBool One = True

fromIntegerVec :: [Integer] -> Maybe [F2]
fromIntegerVec [] = Just []
fromIntegerVec (h:t) =
  fromIntegerVec t >>= \f2_t -> (\f2_h -> f2_h : f2_t) <$> tryFromInteger h

toIntegerVec :: [F2] -> [Int]
toIntegerVec [] = []
toIntegerVec (h:t) =
  F2.toInteger h : toIntegerVec t

add :: F2 -> F2 -> F2
add Zero Zero = Zero
add Zero One = One
add One Zero = One
add One One = Zero

mul :: F2 -> F2 -> F2
mul One One = One
mul _ _ = Zero

innerprod :: [F2] -> [F2] -> F2
innerprod [] [] = Zero
innerprod (vh:vt) (wh:wt) =
  add (mul vh wh) (innerprod vt wt)

vecAdd :: [F2] -> [F2] -> [F2]
vecAdd [] [] = []
vecAdd (vh:vt) (wh:wt) =
  (vh + wh) : (vecAdd vt wt)

Lect3Game.hs

{-# LANGUAGE ScopedTypeVariables #-}

import System.Random
import Text.Printf
import Debug.Trace
import Data.Function
import Data.Maybe (fromJust)
import Data.Bits ((.|.), shift)

import F2 (F2(Zero, One), vecAdd, innerprod, toBool, tryFromInteger)

n :: Integer
n = 7

h0 :: [F2]
h0 = [Zero, Zero, Zero, One, One, One, One]
h1 :: [F2]
h1 = [Zero, One, One, Zero, Zero, One, One]
h2 :: [F2]
h2 = [One, Zero, One, Zero, One, Zero, One]

generateErrorVec :: Integer -> Integer -> [F2.F2]
generateErrorVec 0 _ = []
generateErrorVec len 0 =
  F2.One : generateErrorVec (len - 1) (-1)
generateErrorVec len pos  =
  F2.Zero : generateErrorVec (len - 1) (pos - 1)

randTransportVec :: Int -> IO [F2]
randTransportVec 0 =
  pure []
randTransportVec len = do
  val <- randomRIO (0, 1)
  let head = fromJust $ F2.tryFromInteger val
  tail <- randTransportVec $ len - 1
  return $ head : tail

(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)
(f2 .: f1) a b =
  f2 (f1 a b)

askQuery :: [F2] -> [F2] -> Bool
askQuery = F2.toBool .: F2.innerprod

askQueries :: [[F2]] -> [F2] -> [Bool]
askQueries queries target =
  map (\query -> askQuery query target) queries

syndrome :: [F2] -> [Bool]
syndrome =
  askQueries [h0, h1, h2]

_binListToInteger :: [Bool] -> (Int, Integer)
_binListToInteger [] = (0, 0)
_binListToInteger (h:t) =
  let
    (depth, t_int) = _binListToInteger t
    val = if h == True then 1 else 0
  in
    (
      depth + 1,
      (shift val depth) .|. t_int
    )

binListToInteger :: [Bool] -> Integer
binListToInteger = snd . _binListToInteger

generateTransmitDecode :: IO ()
generateTransmitDecode = do
  let txVec = [One, Zero, Zero, One, One, Zero, Zero]
  printf "Transport vec:           %s\n" $ show txVec

  errorPos <- randomRIO (0, n)
  printf "Error position:          %d\n" $ errorPos
  let errorVec = generateErrorVec n errorPos

  let rxVec = F2.vecAdd txVec errorVec
  printf "Received vec:            %s\n" $ show rxVec

  let detectedErrorPos = (binListToInteger $ syndrome rxVec) - 1
  if detectedErrorPos == -1 then
    putStrLn "No error detected"
  else
    printf "Detected error position: %d\n" detectedErrorPos

  let correctionVec = generateErrorVec n $ detectedErrorPos
  let decodeVec = F2.vecAdd rxVec correctionVec
  printf "Decoded vec:             %s\n" $ show decodeVec


_possibleVecs :: Integer -> Integer -> [[F2]]
_possibleVecs len 1 = [[Zero], [One]]
_possibleVecs len depth =
  let
    next = _possibleVecs len (depth - 1)
  in
    (map (\t -> Zero : t) next) ++ (map (\t -> One : t) next)

possibleVecs :: Integer -> [[F2]]
possibleVecs len =
  _possibleVecs len len

bruteforceKernel :: IO ()
bruteforceKernel = do
  printf "Generating and bruteforcing %d possible vectors\n" (2^n :: Integer)
  let vecs = possibleVecs n

  putStrLn "Checking if the vectors are codewords (syndrome is zero / in the nullspace)"
  let filtered = filter ((==) [False, False, False] . syndrome) vecs

  printf "Available codewords (%d):\n%s\n" (length filtered) (show filtered)

main :: IO ()
main = do
  putStrLn "-- Generate, transmit, detect and decode"
  generateTransmitDecode
  putStrLn ""
  putStrLn "-- Calculate available codewords (bruteforce kernel of parity check matrix)"
  bruteforceKernel