Addition

Posted on 2014-06-01 by nbloomf

Tags: arithmetic-made-difficult, literate-haskell

$\newcommand{\hyp}[2]{\stackrel{\tiny\text{hyp}}{#2}}$

$\newcommand{\let}[2]{\stackrel{\tiny\text{let}}{#2}}$

$\newcommand{\a}{a}$

$\newcommand{\b}{b}$

$\newcommand{\c}{c}$

$\newcommand{\p}{p}$

$\newcommand{\q}{q}$

$\newcommand{\r}{r}$

$\newcommand{\s}{s}$

$\newcommand{\x}{x}$

$\newcommand{\y}{y}$

$\newcommand{\z}{z}$

$\newcommand{\bool}{\mathbb{B}}$

$\newcommand{\btrue}{\mathsf{true}}$

$\newcommand{\bfalse}{\mathsf{false}}$

$\newcommand{\bnot}{\mathsf{not}}$

$\newcommand{\band}{\mathbin{\mathsf{and}}}$

$\newcommand{\bor}{\mathbin{\mathsf{or}}}$

$\newcommand{\bimpl}{\mathbin{\mathsf{impl}}}$

$\newcommand{\beq}{\mathsf{eq}}$

$\newcommand{\bif}[3]{\mathsf{if}\left(#1,#2,#3\right)}$

$\newcommand{\id}{\mathsf{id}}$

$\newcommand{\compose}{\mathsf{compose}}$

$\newcommand{\const}{\mathsf{const}}$

$\newcommand{\apply}{\mathsf{apply}}$

$\newcommand{\flip}{\mathsf{flip}}$

$\newcommand{\flipB}{\mathsf{flip2}}$

$\newcommand{\flipC}{\mathsf{flip3}}$

$\newcommand{\flipD}{\mathsf{flip4}}$

$\newcommand{\flipE}{\mathsf{flip5}}$

$\newcommand{\clone}{\mathsf{clone}}$

$\newcommand{\cloneC}{\mathsf{clone3}}$

$\newcommand{\composeAonB}{\mathsf{compose1on2}}$

$\newcommand{\composeAonC}{\mathsf{compose1on3}}$

$\newcommand{\composeAonD}{\mathsf{compose1on4}}$

$\newcommand{\composeBonA}{\mathsf{compose2on1}}$

$\newcommand{\composeBonB}{\mathsf{compose2on2}}$

$\newcommand{\composeConA}{\mathsf{compose3on1}}$

$\newcommand{\ptrue}{\mathsf{ptrue}}$

$\newcommand{\pfalse}{\mathsf{pfalse}}$

$\newcommand{\pnot}{\mathsf{pnot}}$

$\newcommand{\pand}{\mathbin{\mathsf{pand}}}$

$\newcommand{\por}{\mathbin{\mathsf{por}}}$

$\newcommand{\pimpl}{\mathbin{\mathsf{pimpl}}}$

$\newcommand{\fst}{\mathsf{first}}$

$\newcommand{\snd}{\mathsf{second}}$

$\newcommand{\dup}{\mathsf{dup}}$

$\newcommand{\tup}{\mathsf{tup}}$

$\newcommand{\tSwap}{\mathsf{swap}_{\times}}$

$\newcommand{\tPair}{\mathsf{pair}_{\times}}$

$\newcommand{\tAssocL}{\mathsf{assocL}_{\times}}$

$\newcommand{\tAssocR}{\mathsf{assocR}_{\times}}$

$\newcommand{\tupL}{\mathsf{tupL}}$

$\newcommand{\tupR}{\mathsf{tupR}}$

$\newcommand{\uncurry}{\mathsf{uncurry}}$

$\newcommand{\curry}{\mathsf{curry}}$

$\newcommand{\lft}{\mathsf{left}}$

$\newcommand{\rgt}{\mathsf{right}}$

$\newcommand{\either}{\mathsf{either}}$

$\newcommand{\uSwap}{\mathsf{swap}_{+}}$

$\newcommand{\uPair}{\mathsf{pair}_{+}}$

$\newcommand{\uAssocL}{\mathsf{assocL}_{+}}$

$\newcommand{\uAssocR}{\mathsf{assocR}_{+}}$

$\newcommand{\isLft}{\mathsf{isLeft}}$

$\newcommand{\isRgt}{\mathsf{isRight}}$

$\newcommand{\nats}{\mathbb{N}}$

$\newcommand{\zero}{\mathsf{0}}$

$\newcommand{\next}{\mathsf{next}}$

$\newcommand{\unnext}{\mathsf{unnext}}$

$\newcommand{\iszero}{\mathsf{isZero}}$

$\newcommand{\prev}{\mathsf{prev}}$

$\newcommand{\natrec}{\mathsf{natrec}}$

$\newcommand{\simprec}{\mathsf{simprec}}$

$\newcommand{\bailrec}{\mathsf{bailrec}}$

$\newcommand{\mutrec}{\mathsf{mutrec}}$

$\newcommand{\dnatrec}{\mathsf{dnatrec}}$

$\newcommand{\normrec}{\mathsf{normrec}}$

$\newcommand{\findsmallest}{\mathsf{findsmallest}}$

$\newcommand{\mnormrec}{\mathsf{mnormrec}}$

$\newcommand{\nequal}{\mathsf{eq}}$

$\newcommand{\nplus}{\mathsf{plus}}$

$\newcommand{\ntimes}{\mathsf{times}}$

$\newcommand{\nleq}{\mathsf{leq}}$

$\newcommand{\ngeq}{\mathsf{geq}}$

$\newcommand{\nminus}{\mathsf{minus}}$

$\newcommand{\nmax}{\mathsf{max}}$

$\newcommand{\nmin}{\mathsf{min}}$

$\newcommand{\ndivalg}{\mathsf{divalg}}$

$\newcommand{\nquo}{\mathsf{quo}}$

$\newcommand{\nrem}{\mathsf{rem}}$

$\newcommand{\ndiv}{\mathsf{div}}$

$\newcommand{\ngcd}{\mathsf{gcd}}$

$\newcommand{\ncoprime}{\mathsf{coprime}}$

$\newcommand{\nlcm}{\mathsf{lcm}}$

$\newcommand{\nmindiv}{\mathsf{mindiv}}$

$\newcommand{\nisprime}{\mathsf{isPrime}}$

$\newcommand{\npower}{\mathsf{power}}$

$\newcommand{\nchoose}{\mathsf{choose}}$

$\newcommand{\dom}{\mathsf{dom}}$

$\newcommand{\cod}{\mathsf{cod}}$

$\newcommand{\lists}[1]{\mathsf{List}(#1)}$

$\newcommand{\nil}{\mathsf{nil}}$

$\newcommand{\cons}{\mathsf{cons}}$

$\newcommand{\uncons}{\mathsf{uncons}}$

$\newcommand{\isnil}{\mathsf{isNil}}$

$\newcommand{\tail}{\mathsf{tail}}$

$\newcommand{\head}{\mathsf{head}}$

$\newcommand{\foldr}{\mathsf{foldr}}$

$\newcommand{\foldl}{\mathsf{foldl}}$

$\newcommand{\tacunfoldN}{\mathsf{tacunfoldN}}$

$\newcommand{\unfoldN}{\mathsf{unfoldN}}$

$\newcommand{\dfoldr}{\mathsf{dfoldr}}$

$\newcommand{\cfoldr}{\mathsf{cfoldr}}$

$\newcommand{\bfoldr}{\mathsf{bfoldr}}$

$\newcommand{\dbfoldr}{\mathsf{dbfoldr}}$

$\newcommand{\lfoldr}{\mathsf{lfoldr}}$

$\newcommand{\snoc}{\mathsf{snoc}}$

$\newcommand{\revcat}{\mathsf{revcat}}$

$\newcommand{\rev}{\mathsf{rev}}$

$\newcommand{\last}{\mathsf{last}}$

$\newcommand{\cat}{\mathsf{cat}}$

$\newcommand{\addlength}{\mathsf{addlength}}$

$\newcommand{\length}{\mathsf{length}}$

$\newcommand{\head}{\mathsf{head}}$

$\newcommand{\at}{\mathsf{at}}$

$\newcommand{\map}{\mathsf{map}}$

$\newcommand{\range}{\mathsf{range}}$

$\newcommand{\zip}{\mathsf{zip}}$

$\newcommand{\zipPad}{\mathsf{zipPad}}$

$\newcommand{\unzip}{\mathsf{unzip}}$

$\newcommand{\prefix}{\mathsf{prefix}}$

$\newcommand{\suffix}{\mathsf{suffix}}$

$\newcommand{\lcp}{\mathsf{lcp}}$

$\newcommand{\lcs}{\mathsf{lcs}}$

$\newcommand{\all}{\mathsf{all}}$

$\newcommand{\any}{\mathsf{any}}$

$\newcommand{\tails}{\mathsf{tails}}$

$\newcommand{\inits}{\mathsf{inits}}$

$\newcommand{\filter}{\mathsf{filter}}$

$\newcommand{\elt}{\mathsf{elt}}$

$\newcommand{\addcount}{\mathsf{addcount}}$

$\newcommand{\count}{\mathsf{count}}$

$\newcommand{\repeat}{\mathsf{repeat}}$

$\newcommand{\sublist}{\mathsf{sublist}}$

$\newcommand{\infix}{\mathsf{infix}}$

$\newcommand{\select}{\mathsf{select}}$

$\newcommand{\unique}{\mathsf{unique}}$

$\newcommand{\delete}{\mathsf{delete}}$

$\newcommand{\dedupeL}{\mathsf{dedupeL}}$

$\newcommand{\dedupeR}{\mathsf{dedupeR}}$

$\newcommand{\common}{\mathsf{common}}$

$\newcommand{\disjoint}{\mathsf{disjoint}}$

$\newcommand{\sublists}{\mathsf{sublists}}$

$\newcommand{\take}{\mathsf{take}}$

$\newcommand{\drop}{\mathsf{drop}}$

$\newcommand{\takeBut}{\mathsf{takeBut}}$

$\newcommand{\dropBut}{\mathsf{dropBut}}$

$\newcommand{\takeWhile}{\mathsf{takeWhile}}$

$\newcommand{\dropWhile}{\mathsf{dropWhile}}$

This page is part of a series on Arithmetic Made Difficult.

This post is literate Haskell; you can load the source into GHCi and play along.

{-# LANGUAGE NoImplicitPrelude #-}
module Plus
  ( plus, _test_plus, main_plus
  ) where

import Testing
import Functions
import Booleans
import NaturalNumbers
import SimpleRecursion

So far we’ve characterized the natural numbers via a unique mapping $\natrec(\ast)(\ast) : \nats \rightarrow A,$ and we defined another parameterized mapping $\simprec(\ast)(\ast) : \nats \times A \rightarrow B.$ From now on, when we want to define a mapping with one of these signatures, these prepackaged recursive maps may come in handy. What’s more, we can use the universal properties of these maps to define them in terms of desired behavior.

Natural number addition has signature $\nats \times \nats \rightarrow \nats$ , so we might hope to define addition in terms of $\simprec(\ast)(\ast)$ . To do this, we need to find mappings $\varphi : \nats \rightarrow \nats$ and $\mu : \nats \times \nats \times \nats \rightarrow \nats$ that make $\simprec(\varphi)(\mu)$ act like addition. For example, we want $\next$ to act like $+1$ , and $n = \zero + n = \simprec(\varphi)(\mu)(\zero,n) = \varphi(n),$ and

$\begin{eqnarray*} (m+n)+1 & = & (m+1)+n \\ & = & \simprec(\varphi)(\mu)(\next(m),n) \\ & \href{/posts/arithmetic-made-difficult/SimpleRecursion.html#def-simprec-next} = & \mu(m,n,\simprec(\varphi)(\mu)(m,n)) \\ & = & \mu(m,n,m+n). \end{eqnarray*}$

With this in mind, we define a binary operation $\nplus$ on $\nats$ as follows.

Let $\mu : \nats \times \nats \times \nats \rightarrow \nats$ be given by $\mu(k,a,b) = \next(b)$ . We then define $\nplus : \nats \times \nats \rightarrow \nats$ by $\nplus = \simprec(\id)(\mu).$

In Haskell:

plus :: (Natural n) => n -> n -> n
plus = simpleRec id mu
  where mu _ _ b = next b

Since $\nplus$ is defined in terms of simple recursion, it is the unique solution to a set of functional equations.

$\nplus$ is the unique map $f : \nats \times \nats \rightarrow \nats$ with the property that for all $a,b \in \nats$ , we have $\left\{\begin{array}{l} f(\zero,b) = b \\ f(\next(a),b) = \next(f(a,b)). \end{array}\right.$

_test_plus_zero_left :: (Natural n, Equal n)
  => Proxy n -> (n -> n -> n) -> Test (n -> Bool)
_test_plus_zero_left _ f =
  testName "f(0,b) == b" $
  \b -> eq (f zero b) b


_test_plus_next_left :: (Natural n, Equal n)
  => Proxy n -> (n -> n -> n) -> Test (n -> n -> Bool)
_test_plus_next_left _ f =
  testName "f(next(a),b) == next(f(a,b))" $
  \a b -> eq (f (next a) b) (next (f a b))

Next we establish a version of the universal property of $\nplus$ with the arguments reversed.

The following hold for all natural numbers $a$ and $b$ .

$\nplus(a,\zero) = a$ .
$\nplus(a,\next(b)) = \next(\nplus(a,b))$ .

We proceed by induction on $a$ . For the base case, we have $\nplus(\zero,\zero) = \zero$ by the universal property of $\nplus$ . For the inductive step, suppose we have $\nplus(a,\zero) = a$ for some $a \in \nats$ . Then $\begin{eqnarray*} & & \nplus(\next(a),\zero) \\ & \href{/posts/arithmetic-made-difficult/Plus.html#cor-plus-up-next} = & \next(\nplus(a,\zero)) \\ & \hyp{\nplus(a,\zero) = a} = & \next(a) \end{eqnarray*}$ as needed.
We proceed by induction on $a$ . For the base case, note that $\nplus(\zero,\next(b)) = \next(b).$ For the inductive step, suppose we have $\next(\nplus(a,b)) = \nplus(a,\next(b))$ for all $b$ for some $a$ . Then $\begin{eqnarray*} & & \nplus(\next(a),\next(b)) \\ & \href{/posts/arithmetic-made-difficult/Plus.html#cor-plus-up-next} = & \next(\nplus(a,\next(b))) \\ & \hyp{\next(\nplus(a,b)) = \nplus(a,\next(b))} = & \next(\next(\nplus(a,b))) \\ & \href{/posts/arithmetic-made-difficult/Plus.html#cor-plus-up-next} = & \next(\nplus(\next(a),b)) \end{eqnarray*}$ as needed.

_test_plus_zero_right :: (Natural n, Equal n)
  => Proxy n -> (n -> n -> n) -> Test (n -> Bool)
_test_plus_zero_right _ f =
  testName "plus(a,0) == a" $
  \a -> eq (f a zero) a


_test_plus_next_right :: (Natural n, Equal n)
  => Proxy n -> (n -> n -> n) -> Test (n -> n -> Bool)
_test_plus_next_right _ f =
  testName "next(plus(a,b)) == plus(a,next(b))" $
  \a b -> eq (f a (next b)) (next (f a b))

$\nplus$ is associative and commutative.

The following hold for all natural numbers $a$ , $b$ , and $c$ .

$\nplus(\nplus(a,b),c) = \nplus(a,\nplus(b,c))$ .
$\nplus(a,b) = \nplus(b,a)$ .

We will show this by induction on $a$ . For the base case, note that $\nplus(\nplus(\zero,b),c) = \nplus(b,c) = \nplus(\zero,\nplus(b,c)).$ For the inductive step, suppose the result holds for some $a$ . Then $\begin{eqnarray*} & & \nplus(\nplus(\next(a),b),c) \\ & \href{/posts/arithmetic-made-difficult/Plus.html#cor-plus-up-next} = & \nplus(\next(\nplus(a,b)),c) \\ & \href{/posts/arithmetic-made-difficult/Plus.html#cor-plus-up-next} = & \next(\nplus(\nplus(a,b),c)) \\ & \hyp{\nplus(a,\nplus(b,c)) = \nplus(\nplus(a,b),c)} = & \next(\nplus(a,\nplus(b,c))) \\ & \href{/posts/arithmetic-made-difficult/Plus.html#cor-plus-up-next} = & \nplus(\next(a),\nplus(b,c)) \end{eqnarray*}$ as needed.
We proceed by induction on $a$ . For the base case, note that $\nplus(\zero,b) = b = \nplus(b,\zero).$ For the inductive step, suppose the result holds for some $a$ . Then we have $\begin{eqnarray*} & & \nplus(\next(a),b) \\ & \href{/posts/arithmetic-made-difficult/Plus.html#cor-plus-up-next} = & \next(\nplus(a,b)) \\ & \hyp{\nplus(a,b) = \nplus(b,a)} = & \next(\nplus(b,a)) \\ & \href{/posts/arithmetic-made-difficult/Plus.html#thm-plus-next-right} = & \nplus(b,\next(a)) \end{eqnarray*}$ as needed.

_test_plus_associative :: (Natural n, Equal n)
  => Proxy n -> (n -> n -> n) -> Test (n -> n -> n -> Bool)
_test_plus_associative _ f =
  testName "plus(plus(a,b),c) == plus(a,plus(b,c))" $
  \a b c -> eq (f (f a b) c) (f a (f b c))


_test_plus_commutative :: (Natural n, Equal n)
  => Proxy n -> (n -> n -> n) -> Test (n -> n -> Bool)
_test_plus_commutative _ f =
  testName "plus(a,b) == plus(b,a)" $
  \a b -> eq (f a b) (f b a)

And $\nplus$ is cancellative.

The following hold for all natural numbers $a$ , $b$ , and $c$ .

If $\nplus(c,a) = \nplus(c,b)$ then $a = b$ .
If $\nplus(a,c) = \nplus(b,c)$ then $a = b$ .

We proceed by induction on $c$ . For the base case, note that if $\nplus(\zero,a) = \nplus(\zero,b)$ , then we have $a = \nplus(\zero,a) = \nplus(\zero,b) = b.$ For the inductive step, suppose the result holds for some $c$ . Now if $\nplus(\next(c),a) = \nplus(\next(c),b),$ then $\next(\nplus(c,a)) = \next(\nplus(c,b))$ so that $\nplus(c,a) = \nplus(c,b)$ and thus $a = b$ as needed.
If $\nplus(a,c) = \nplus(b,c),$ then $\nplus(c,a) = \nplus(c,b),$ and so $a = b$ as claimed.

_test_plus_cancellative_left :: (Natural n, Equal n)
  => Proxy n -> (n -> n -> n) -> Test (n -> n -> n -> Bool)
_test_plus_cancellative_left _ f =
  testName "if plus(c,a) == plus(c,b) then a == b" $
  \a b c -> if eq (f c a) (f c b)
    then eq a b
    else true


_test_plus_cancellative_right :: (Natural n, Equal n)
  => Proxy n -> (n -> n -> n) -> Test (n -> n -> n -> Bool)
_test_plus_cancellative_right _ f =
  testName "if plus(a,c) == plus(b,c) then a == b" $
  \a b c -> if eq (f a c) (f b c)
    then eq a b
    else true

Of course we will eventually prefer to say $a + b$ instead of $\nplus(a,b)$ . But we’ll avoid the more familiar notation until we’re convinced that $\nplus$ really does act just like the usual $+$ , since familiar notation can easily lull us into using theorems we haven’t proven yet.

Testing

Suite:

_test_plus
  :: (Typeable n, Natural n, Equal n, Show n, Arbitrary n)
  => Int -> Int -> Proxy n -> (n -> n -> n) -> IO ()
_test_plus size cases pn f = do
  labelTestArgs1 "plus" pn
  let args = testArgs size cases

  runTest args (_test_plus_zero_left pn f)
  runTest args (_test_plus_next_left pn f)
  runTest args (_test_plus_zero_right pn f)
  runTest args (_test_plus_next_right pn f)
  runTest args (_test_plus_associative pn f)
  runTest args (_test_plus_commutative pn f)
  runTest args (_test_plus_cancellative_left pn f)
  runTest args (_test_plus_cancellative_right pn f)

Main:

main_plus :: IO ()
main_plus = do
  _test_plus 100 100 (Proxy :: Proxy Unary) plus