(* * Multiplication of [positive] numbers *)
Local Open Scope positive_scope.
(* ** Tail-recursive multiplication function *)
(* The function [Pos.mult] isn't tail-recursive. *)
Fixpoint mult_TR_cont (a : positive) (x y : positive) {struct x} : positive :=
match x with
| x'~1 => mult_TR_cont (a+y) x' (y~0)
| x'~0 => mult_TR_cont (a  ) x' (y~0)
| 1 => a
end.
Definition mult_TR (x y : positive) : positive := mult_TR_cont (shift_left y (pos_size x)) x y.
(* Check eq_refl : let x := 13 in let y := 3 in mult_TR x y = x * y. *)
(* Check eq_refl : let x := 5 in let y := 1 in mult_TR x y = x * y. *)
(* Check eq_refl : let x := 4234 in let y := 2132 in mult_TR x y = x * y. *)
(* Check eq_refl : let x := 43 in let y := 23 in mult_TR x y = x * y. *)
(* Check eq_refl : let x := 43 in let y := 24 in mult_TR x y = x * y. *)
(* All test passed! *)
(* (* NB: Haskell extraction is fun! *)
From Coq From Undecidability Require Extraction.
Extraction Language Haskell.
Recursive Extraction mult_TR Pos.mul.
*)
(* Compute eq_refl: let a := 3 in let x := 4 in let y := 5 in mult_TR_cont (a~0) x (y~0) = (mult_TR_cont a x y)~0. *)
(* Compute eq_refl: let a := 8 in let x := 232 in let y := 123 in mult_TR_cont (a~0) x (y~0) = (mult_TR_cont a x y)~0. *)
Definition Mult_Rel : pRel sigPos^+ unit 3 :=
fun tin '(yout, tout) =>
forall (x y : positive),
tin[@Fin0] ≃ x ->
tin[@Fin1] ≃ y ->
isVoid tin[@Fin2] ->
tout[@Fin0] ≃ x /\
tout[@Fin1] ≃ y /\
tout[@Fin2] ≃ x*y.
(* Initialise [a = shift_left y (pos_size x)];; go to LSB of [x];; call [Mult_Loop];; go to [START] for [x];; Undo shift [y = shift_right y (pos_size x)] *)
Definition Mult : pTM sigPos^+ unit 3 :=
CopyValue _ @[|Fin1; Fin2|];;
ShiftLeft_num @[|Fin0; Fin2|];;
GoToLSB_start @[|Fin0|];;
Mult_Loop;;
Move Lmove @[|Fin0|];;
ShiftRight_num @[|Fin0; Fin1|].

Lemma pos_size_shift_left (p : positive) (n : nat) :
(pos_size (shift_left p n) = pos_size p + n) % nat.