(* ** Addition for [positive] numbers *)
Local Open Scope positive_scope.
(* ** Tail-recursive versions of [Pos.add] and [Pos.add_carry] *)
Fixpoint addTR_rec (a : list bool) (x y : positive) : list bool :=
match x, y with
| p~1, q~1 => addTR_rec_carry (false :: a) p q
| p~1, q~0 => addTR_rec (true :: a) p q
| p~1, 1 => pos_to_bits (Pos.succ p) ++ false :: a
| p~0, q~1 => addTR_rec (true :: a) p q
| p~0, q~0 => addTR_rec (false :: a) p q
| p~0, 1 => pos_to_bits p ++ true :: a
| 1, q~1 => pos_to_bits (Pos.succ q) ++ false :: a
| 1, q~0 => pos_to_bits q ++ true :: a
| 1, 1 => false :: a
end
with addTR_rec_carry (a : list bool) (x y : positive) : list bool :=
match x, y with
| p~1, q~1 => addTR_rec_carry (true :: a) p q
| p~1, q~0 => addTR_rec_carry (false :: a) p q
| p~1, 1 => pos_to_bits (Pos.succ p) ++ true :: a
| p~0, q~1 => addTR_rec_carry (false :: a) p q
| p~0, q~0 => addTR_rec (true :: a) p q
| p~0, 1 => pos_to_bits (Pos.succ p) ++ false :: a
| 1, q~1 => pos_to_bits (Pos.succ q) ++ true :: a
| 1, q~0 => pos_to_bits (Pos.succ q) ++ false :: a
| 1, 1 => true :: a
end.
Definition addTR_rec' (carry : bool) (a : list bool) (x y : positive) : list bool := if carry then addTR_rec_carry a x y else addTR_rec a x y.
Definition addTR (x y : positive) := bits_to_pos (addTR_rec nil x y).
(* Compute addTR 42 1. (* 43 *)
Compute addTR 1 1. (* 2 *)
Compute addTR 1 2. (* 3 *)
Compute addTR 1 3. (* 4 *)
Compute addTR 7 3. (* 10 *)
Compute addTR 7 3. (* 10 *)
Compute addTR 3 1. (* 4 *)
Compute addTR 10 11. (* 21 *)
Compute addTR 42 42. (* 84 *)
Compute addTR 42 8. (* 50 *)
*)
(* We use [StateWhile] to implement mutual recursion. The [bool] "state" corresponds to the carry. *)
(* This function is used in the base case: t0 contains [xH] and t1 contains [p ++ b :: bits] and the pointer is on [b]. In some cases, we need to increment [p]. *)
Definition add_baseCase (b carry : bool) (p : positive) :=
if (b || carry) then (Pos.succ p) ~~ (negb (xorb b carry))
else p ~~ (negb (xorb b carry)).
(* Compute add_baseCase true false 1. *)
(* This base case is complex enough that I write an auxilliary machine for this *)
Definition Add_BaseCase_Rel (carry : bool) (b : bool) : pRel sigPos^+ unit 1 :=
fun tin '(_, tout) =>
forall (p : positive) (bits : list bool),
atBit tin[@Fin0] p b bits ->
atHSB tout[@Fin0] (append_bits (add_baseCase b carry p) bits).
Definition Add_BaseCase (carry : bool) (b : bool) : pTM sigPos^+ unit 1 :=
if (b || carry)
then SetBitAndMoveLeft (negb (xorb b carry));; Increment_Loop
else SetBitAndMoveLeft (negb (xorb b carry));; GoToHSB.

Lemma Add_BaseCase_Realise (carry : bool) (b : bool) : Add_BaseCase carry b ⊨ Add_BaseCase_Rel carry b.