Type class

-- A bit can be zero or one
data Bit = Zero | One

-- Bit streams of any length
newtype Bits = Bits { getBits :: [Bit] }

Bits [One,Zero,One]

> show (Bits [One,Zero,One])
"101"

class Show a
  where
    show :: a -> String

-- Show bits
instance Show Bit 
  where
    show Zero = "0"
    show One = "1"

-- Show bit streams
instance Show Bits
  where
    show = concat . map show . getBits

class Eq a
  where 
    (==) :: a -> a -> Bool

-- Test bits for equality
instance Eq Bit
  where
    Zero == Zero = True
    Zero == One = False
    One == One = True
    One == Zero = False

-- Test bit streams for equality
instance Eq Bits
  where
    x == y =  length x' == length y'
           && and (map (uncurry (==)) (zip x' y'))
      where
        x' = trim (getBits x)
        y' = trim (getBits y)
        trim [] = []
        trim z@(One: ) = z
        trim (Zero:z) = trim z

-- Test bit streams for equality
> let b101 = read "101" :: Bits
> let b0101 = read "0101" :: Bits
> let b1101 = read "1101" :: Bits
> b101 == b0101
True
> b101 == b1101
False

class (Eq a, Show a) => Num a
  where
    (+) :: a -> a -> a
    (*) :: a -> a -> a
    (-) :: a -> a -> a
    negate :: a -> a
    abs :: a -> a
    signum :: a -> a
    fromInteger :: Integer -> a

-- Convert bits to an integer
bits2integral :: Integral a => Bits -> a
bits2integral = foldl f 0 . getBits 
  where
    f a b = a * 2 + (bit2int b)
    bit2int Zero = 0
    bit2int One = 1

-- Convert a (non-negative) integral to bits
integral2bits :: Integral a => a -> Bits
integral2bits i | i < 0 = error "Bits are unsigned"
integral2bits i = Bits (f [] i)
  where
    f xs 0 = xs
    f xs i = f (x:xs) (i `div` 2) 
      where
        x = if odd i then One else Zero

-- Bits as a Num type
instance Num Bits
  where
    x + y = integral2bits z'
      where
        x' = bits2integral x
        y' = bits2integral y
        z' = x' + y'
    x * y = integral2bits z'
      where
        x' = bits2integral x
        y' = bits2integral y
        z' = x' * y'
    x - y = integral2bits z'
      where
        x' = bits2integral x
        y' = bits2integral y
        z' = x' - y'
    abs = id
    signum = integral2bits
           . signum
           . bits2integral
    fromInteger = integral2bits

class ToInt a
  where
    toInt :: a -> Maybe Int

instance ToInt Int
  where
    toInt = Just

instance ToInt Float
  where
    toInt = Just . round

instance ToInt String
  where
    toInt s =
      case reads s of
        [(i, "")] -> Just i
        _ -> Nothing

*Main> toInt "5"
Just 5
*Main> toInt "foo"
Nothing
*Main> toInt (5::Int)
Just 5
*Main> toInt (5.5::Float)
Just 6

-- Notions of size for container types
class Size f
  where
    -- Number of constructors
    consSize :: f a -> Int
    -- Number of elements
    elemSize :: f a -> Int

instance Size []
  where
    consSize = (+1) . length
    elemSize = length

-- Node-labeled rose trees
data NLTree a = NLTree a [NLTree a]
  deriving (Eq, Show, Read)

instance Size NLTree
  where
    consSize (NLTree _ ts) =
        1
      + consSize ts
      + sum (map consSize ts)
    elemSize (NLTree _ ts) =
        1
      + sum (map elemSize ts)

-- Leaf-labeled rose trees
data LLTree a = Leaf a | Fork [LLTree a]
  deriving (Eq, Show, Read)

instance Size LLTree
  where
    consSize (Leaf _) = 1
    consSize (Fork ts) =
        consSize ts
      + sum (map consSize ts)
    elemSize (Leaf _) = 1
    elemSize (Fork ts) =
      sum (map elemSize ts)

*Main> let list = [1,2,3]
*Main> let nltree = NLTree 1 [NLTree 2 [], NLTree 3 []]
*Main> let lltree = Fork [Leaf 1, Fork [Leaf 2, Leaf 3]]
*Main> consSize list
4
*Main> elemSize list
3
*Main> consSize nltree 
8
*Main> elemSize nltree 
3
*Main> consSize lltree 
9
*Main> elemSize lltree 
3