95 lines
2.4 KiB
Haskell
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
|