hamming/src/Hamming.hs

95 lines
2.4 KiB
Haskell

{-|
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
| not (oddParity c) = Nothing
| 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