This is the code from the paper "Functional Pearl: Explaining binomial
heaps" by Ralf Hinze, in Journal of Functional Programming, 9(1),
pp. 93-104, January 1999.

Note that the code conforms to Haskell 98 with one small exception:
deriving `Show' for `MinView' does not work since the instance
declaration requires a context of the form `Show (q a)'. This is,
however, not legal Haskell 98. Fortunately, both Hugs 98 (use `-98')
and GHC 4.0x (use `-fglasgow-exts') provide the necessary extension to
the class system. [Alternatively, delete `deriving (Show)' and use
Hugs' `-u' option to activate the built-in printing mechanism of Hugs.]

> module BinomialHeap ( module BinomialHeap )
> where
> import Prelude hiding ( sum )

NB. We hide the standard function `sum'.

%-------------------------------=  --------------------------------------------
2. Priority queues
%-------------------------------=  --------------------------------------------

The abstract data type `priority queue'.

> data MinView q a              =  Min a (q a) | Infty
>				   deriving (Show)

> class PriorityQueue q where
>     empty			:: (Ord a) => q a
>     single			:: (Ord a) => a -> q a
>     insert			:: (Ord a) => a -> q a -> q a
>     (\+/)			:: (Ord a) => q a -> q a -> q a
>     splitMin			:: (Ord a) => q a -> MinView q a
>
>     insert a q		=  single a \+/ q

NB. `PriorityQueue' is a constructor class; the class variable `q' ranges
over type constructors rather than types (`q' has kind `* -> *').

%-------------------------------=  --------------------------------------------
3. Tournament trees
%-------------------------------=  --------------------------------------------

Topped loser trees.

> newtype ToppedTree a		=  P (MinView BinTree a)
>				   deriving (Show)

NB. In the paper we employ `type' declarations as if they worked as
`newtype' declarations. Here, `P' is a short cut for `pennant'.

> data BinTree a		=  Bin a (BinTree a) (BinTree a) | Empty
>				   deriving (Show)

> instance PriorityQueue ToppedTree where
>     empty			=  P Infty
>     single a			=  P (Min a Empty)
>
>     P Infty \+/ u		=  u
>     t \+/ P Infty		=  t
>     P (Min a t) \+/ P (Min b u)
>         | a <= b		=  P (Min a (Bin b u t))
>         | otherwise		=  P (Min b (Bin a t u))
>
>     splitMin (P Infty)	=  Infty
>     splitMin (P (Min a t))	=  Min a (secondBest t)
>         where secondBest Empty	=  P Infty
>               secondBest (Bin a' l r)	=  P (Min a' l) \+/ secondBest r

Try `splitMin (foldr insert empty [9, 8 .. 1]) :: MinView ToppedTree Int'
 or `splitMin (foldr insert empty [1 .. 9]) :: MinView ToppedTree Int'.

%-------------------------------=  --------------------------------------------
4. Bottom-up tournament trees
%-------------------------------=  --------------------------------------------

Binary binomial heaps.

> newtype BinBinomialHeap a	=  BBH [ToppedTree a]
>				   deriving (Show)

Here, `BBH' is a short cut for `binary binomial heap'.

> bbh3, bbh6, bbh13	:: BinBinomialHeap Int
> bbh3			=  BBH [P (Min 1 Empty),
>			        P (Min 2 (Bin 3 Empty Empty))]
> bbh6			=  BBH [P Infty,
>			        P (Min 1 (Bin 2 Empty Empty)),
>			        P (Min 3 (Bin 5 (Bin 6 Empty Empty)
>			                        (Bin 4 Empty Empty)))]
> bbh13			=  BBH [P (Min 1 Empty),
>			        P Infty,
>			        P (Min 2 (Bin 4 (Bin 5 Empty Empty)
>			                        (Bin 3 Empty Empty))),
>			        P (Min 6 (Bin 10 (Bin 12 (Bin 13 Empty Empty)
>			                                 (Bin 11 Empty Empty))
>			                         (Bin 8 (Bin 9 Empty Empty)
>			                                (Bin 7 Empty Empty))))]

NB. `bbhx' equals `foldr insert empty [1..x] :: BinBinomialHeap Int'.

%-------------------------------=  --------------------------------------------
5. Digression: Binary addition
%-------------------------------=  --------------------------------------------

> class (Eq b) => BinaryDigit b where
>     zero			:: b
>     carry, sum		:: b -> b -> b

> fullAdder			:: (BinaryDigit b) => b -> b -> b -> (b, b)
> fullAdder c a b		=  (s2, sum c1 c2)
>     where (s1, c1)		=  halfAdder a b
>           (s2, c2)		=  halfAdder c s1
>
> halfAdder			:: (BinaryDigit b) => b -> b -> (b, b)
> halfAdder a b			=  (sum a b, carry a b)
>
> add				:: (BinaryDigit b) => [b] -> [b] -> [b]
> add x y			=  addWithCarry zero x y
>
> addWithCarry			:: (BinaryDigit b) => b -> [b] -> [b] -> [b]
> addWithCarry c [] y		=  addDigit c y
> addWithCarry c x []		=  addDigit c x
> addWithCarry c (a : x) (b : y)=  s : addWithCarry c' x y
>     where (s, c')		=  fullAdder c a b
>
> addDigit			:: (BinaryDigit b) => b -> [b] -> [b]
> addDigit c x | c == zero	=  x
> addDigit c []			=  [c]
> addDigit c (a : x)		=  s : addDigit c' x
>     where (s, c')		=  halfAdder c a

> instance BinaryDigit Int where
>     zero			=  0
>     carry m n			=  (m + n) `div` 2
>     sum m n			=  (m + n) `mod` 2

Try `add [1, 1] [0, 1, 1] :: [Int]'.

> instance (Ord a) => BinaryDigit (ToppedTree a) where
>     zero			=  P Infty
>
>     carry (P (Min a t)) (P (Min b u))
>         | a <= b		=  P (Min a (Bin b u t))
>         | otherwise		=  P (Min b (Bin a t u))
>     carry _ _			=  P Infty
>
>     sum (P Infty) u		=  u
>     sum t (P Infty)		=  t
>     sum (P (Min _ _)) (P (Min _ _))
>				=  P Infty

NB. The following instance declaration is omitted in the paper.

> instance (Eq a) => Eq (ToppedTree a) where
>     P Infty     == P Infty	=  True
>     P (Min a _) == P (Min b _)=  a == b
>     _           == _		=  False

%-------------------------------=  --------------------------------------------
6. Binary binomial heaps
%-------------------------------=  --------------------------------------------

> instance (Ord a) => Ord (ToppedTree a) where
>     t           <= P Infty	=  True
>     P Infty     <= u		=  False
>     P (Min a _) <= P (Min b _)=  a <= b

> extractMin			:: (Ord t, BinaryDigit t) => [t] -> MinView [] t
> extractMin []			=  Infty
> extractMin (a:x)		=  case extractMin x of
>     Infty			-> Min a []
>     Min b y | a <= b		-> Min a (zero : x)
>             | otherwise	-> Min b (a    : y)

> dismantle			:: BinTree a -> [ToppedTree a]
> dismantle Empty		=  []
> dismantle (Bin a l r)		=  P (Min a l) : dismantle r

> instance PriorityQueue BinBinomialHeap where
>     empty			=  BBH []
>     single a			=  BBH [P (Min a Empty)]
>     BBH q1 \+/ BBH q2		=  BBH (add q1 q2)
>     splitMin (BBH q)		=  case extractMin q of
>         Infty			-> Infty
>         Min (P (Min a t)) ts	-> Min a (BBH (reverse (dismantle t)) \+/ BBH ts)

Try `foldr insert empty [9, 8 .. 1] :: BinBinomialHeap Int'
 or `foldr insert empty [1..9] :: BinBinomialHeap Int'
 or `bbh3 \+/ bbh6'
 or `splitMin bbh6'.

%-------------------------------=  --------------------------------------------
7. Multiway binomial heaps
%-------------------------------=  --------------------------------------------

> data Tree a			=  Root a (Forest a) | Void
>				   deriving (Show)
> type Forest a			=  [Tree a]

> tree				:: ToppedTree a -> Tree a
> tree (P Infty)		=  Void
> tree (P (Min a t))		=  Root a (forest t)
 
> forest			:: BinTree a -> Forest a
> forest Empty			=  []
> forest (Bin a l r)		=  Root a (forest l) : forest r

Multiway binomial heaps.

> newtype BinomialHeap a	=  BH (Forest a)
>				   deriving (Show)

Here, `BH' is a short cut for `binomial heap'.

> bh3, bh6, bh13	:: BinomialHeap Int
> bh3			=  BH [Root 1 [],
>			       Root 2 [Root 3 []]]
> bh6			=  BH [Void,
>			       Root 1 [Root 2 []],
>			       Root 3 [Root 5 [Root 6 []], Root 4 []]]
> bh13			=  BH [Root 1 [],
>			       Void,
>			       Root 2 [Root 4 [Root 5 []], Root 3 []],
>			       Root 6 [Root 10 [Root 12 [Root 13 []], Root 11 []],
>			               Root 8 [Root 9 []],Root 7 []]]

NB. `bhx' equals `foldr insert empty [1..x] :: BinomialHeap Int'.

> instance (Ord a) => BinaryDigit (Tree a) where
>     zero			=  Void
>
>     carry t@(Root a ts) u@(Root b us)
>         | a <= b		=  Root a (u : ts)
>         | otherwise		=  Root b (t : us)
>     carry _ _			=  Void
>
>     sum Void u		=  u
>     sum t Void		=  t
>     sum (Root _ _) (Root _ _)	=  Void

NB. The following two instance declarations are omitted in the paper.

> instance (Eq a) => Eq (Tree a) where
>     Void     == Void		=  True
>     Root a _ == Root b _	=  a == b
>     _        == _		=  False
>
> instance (Ord a) => Ord (Tree a) where
>     Void     <= Void		=  True
>     Void     <= Root _ _	=  False
>     Root _ _ <= Void		=  True
>     Root a _ <= Root b _	=  a <= b

> instance PriorityQueue BinomialHeap where
>     empty			=  BH []
>     single a			=  BH [Root a []]
>     BH q1 \+/ BH q2		=  BH (add q1 q2)
>     splitMin (BH q)		=  case extractMin q of
>         Infty			-> Infty
>         Min (Root a ts) us	-> Min a (BH (reverse ts) \+/ BH us)

Try `foldr insert empty [9, 8 .. 1] :: BinomialHeap Int'
 or `foldr insert empty [1..9] :: BinomialHeap Int'
 or `bh3 \+/ bh6'
 or `splitMin bh6'.