Bytes and Folds / Traversals

Byte.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE RankNTypes #-}

module Byte where

import Data.Bool (bool)
import Data.Functor.Const (Const(Const, getConst))
import Data.Bits ((.&.), (.|.), xor)
import Prelude hiding (sum)

type Bit = Bool

data Byte
  = Byte
      Bit
      Bit
      Bit
      Bit
      Bit
      Bit
      Bit
      Bit
  deriving (Show, Eq)

type Fold s a = forall m. Monoid m => (a -> Const m a) -> s -> Const m s

toList :: Fold s a -> s -> [a]
toList fold = getConst . fold (\a -> Const [a])

bits :: Fold Byte Bit
bits f (Byte _1 _2 _3 _4 _5 _6 _7 _8) =
  Byte <$> f _1 <*> f _2 <*> f _3 <*> f _4 <*> f _5 <*> f _6 <*> f _7 <*> f _8

toNum :: Num a => Byte -> a
toNum =
  foldr (\bit n -> bool 0 1 bit + n * 2) 0 . toList bits

halfAdder :: Bit -> Bit -> (Bit, Bit)
halfAdder a b = (a .&. b, a `xor` b)

fullAdder :: Bit -> Bit -> Bit -> (Bit, Bit)
fullAdder carry a b =
  let (carry' , sum ) = halfAdder a b
      (carry'', sum') = halfAdder sum carry
  in  (carry' .|. carry'', sum')

addBytes :: Byte -> Byte -> Byte
addBytes (Byte _1 _2 _3 _4 _5 _6 _7 _8) (Byte _1' _2' _3' _4' _5' _6' _7' _8')
  = let (c      , _1'') = halfAdder _1 _1'
        (c'     , _2'') = fullAdder c _2 _2'
        (c''    , _3'') = fullAdder c' _3 _3'
        (c'''   , _4'') = fullAdder c'' _4 _4'
        (c''''  , _5'') = fullAdder c''' _5 _5'
        (c''''' , _6'') = fullAdder c'''' _6 _6'
        (c'''''', _7'') = fullAdder c''''' _7 _7'
        (_      , _8'') = fullAdder c'''''' _8 _8'
    in  Byte _1'' _2'' _3'' _4'' _5'' _6'' _7'' _8''

byteFromIntegral :: (Integral a, Eq a) => a -> Byte
byteFromIntegral n =
  let (n1, _1) = divMod n 2
      (n2, _2) = divMod n1 2
      (n3, _3) = divMod n2 2
      (n4, _4) = divMod n3 2
      (n5, _5) = divMod n4 2
      (n6, _6) = divMod n5 2
      (n7, _7) = divMod n6 2
      (_ , _8) = divMod n7 2
  in  Byte (_1 /= 0)
           (_2 /= 0)
           (_3 /= 0)
           (_4 /= 0)
           (_5 /= 0)
           (_6 /= 0)
           (_7 /= 0)
           (_8 /= 0)