{-|

Module      : Hamming
Description : Utilities for working with Hamming codes
Copyright   : (C) Jonathan Lamothe
License     : AGPL-3.0-or-later
Maintainer  : jonathan@jlamothe.net
Stability   : experimental
Portability : POSIX

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as
published by the Free Software Foundation, either version 3 of the
License, or (at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Affero General Public License for more details.

You should have received a copy of the GNU Affero General Public
License along with this program.  If not, see
<https://www.gnu.org/licenses/>.

|-}

module Hamming (Hamming (..)) where

import Data.Bits
  ( Bits
  , complement
  , shiftL
  , shiftR
  , xor
  , (.&.)
  , (.|.)
  )
import Data.Word (Word16)

-- | An implementation of a Hamming code
class Hamming h where
  -- | Sets the check bits (overwriting previous values)
  setCheckBits :: h -> h
  -- | Determines whether or not the code is valid
  isValid :: h -> Bool
  -- | Attempts to correct a single bit error
  correctErrors :: h -> Maybe h

instance Hamming Word16 where
  setCheckBits c = foldl setCheckBit c
    [ ( 0x0002, 0xaaa8 )
    , ( 0x0004, 0xccc8 )
    , ( 0x0010, 0xf0e0 )
    , ( 0x0100, 0xfe00 )
    , ( 0x0001, 0xfffe )
    ]

  isValid code = not $ any (\mask -> oddParity $ code .&. mask)
    [ 0xaaaa
    , 0xcccc
    , 0xf0f0
    , 0xff00
    , 0xffff
    ]

  correctErrors c
    | isValid c = Just c
    | otherwise = let
      errorFlags = map (oddParity . (c .&.))
        [0xaaaa, 0xcccc, 0xf0f0, 0xff00]
      flipAddr = foldl
        ( \a (mask, err) -> if err
          then let
            in a .|. mask
          else a
        ) 0 $ zip [1, 2, 4, 8] errorFlags
      flipBit = 1 `shiftL` flipAddr
      in Just $ c `xor` flipBit

setCheckBit :: (Num a, Bits a) => a -> (a, a) -> a
setCheckBit a (pBit, chkMask) =
  if oddParity (a .&. chkMask)
    then a .|. pBit
    else a .&. complement pBit

oddParity :: (Bits a, Num a) => a -> Bool
oddParity = f False where
  f p x
    | x == 0       = p
    | x .&. 1 == 1 = f (not p) (shiftR x 1)
    | otherwise    = f p (shiftR x 1)

--jl