(* * Machines that compte natural functions *)
(* Don't simplify [skipn (S n) xs]; only, if the number and the lists are constructors *)
Local Arguments skipn { A } !n !l.
Local Arguments Encode_nat : simpl never.
(* Lemma nat_encode_length (n : nat) : | encode n : list bool | = S n.  Lemma max_max_le (m n : nat) : max (max m n) n = max m n. *)
(* ** Addition *)
(* * Step machine * * if (b--) { *   a++; *   continue; * } else { *   break; * } * * Tapes: * t0: a * t1: b *)
Definition Add_Step : pTM sigNat^+ (option unit) 2 :=
If (LiftTapes CaseNat [|Fin1|])
(Return (LiftTapes Constr_S [|Fin0|]) None)
(Return Nop (Some tt)).
Definition Add_Loop : pTM sigNat^+ unit 2 := While Add_Step.
(* * Full machine in pseudocode: * a := n * b := m * while (b--) { // Loop *   a++; * } * reset b; * return a; * * Tapes: * INP t0: m * INP t1: n * OUT t2: a * INT t3: b *)
(* Everything, but not reset *)
Definition Add_Main : pTM sigNat^+ unit 4 :=
LiftTapes (CopyValue _) [|Fin1; Fin2|];; (* copy n to a *)
LiftTapes (CopyValue _) [|Fin0; Fin3|];; (* copy m to b *)
LiftTapes Add_Loop [|Fin2; Fin3|]. (* Main loop *)
(* * Finally, reset tape b. * For technical reasons, it is convienient to define the machine for this last step seperately, * because it makes prooving the termination easier. *)
Definition Add :=
Add_Main;; (* Initialisation and main loop *)
LiftTapes (Reset _) [|Fin3|]. (* Reset b *)
(* *** Correctness of [Add] *)
Definition Add_Step_Rel : pRel sigNat^+ (option unit) 2 :=
fun tin '(yout, tout) =>
forall a b sa sb,
tin [@Fin0] ≃(;sa) a ->
tin [@Fin1] ≃(;sb) b ->
match yout, b with
| Some tt, O => (* break *)
tout[@Fin0] ≃(;sa) a /\
tout[@Fin1] ≃(;sb) b
| None, S b' =>
tout[@Fin0] ≃(;pred sa) S a /\
tout[@Fin1] ≃(;S sb) b'
| _, _ => False
end.
Definition Add_Loop_Rel : pRel sigNat^+ unit 2 :=
ignoreParam (
fun tin tout =>
forall a b sa sb,
tin [@Fin0] ≃(;sa) a ->
tin [@Fin1] ≃(;sb) b ->
tout[@Fin0] ≃(;sa-b) b + a /\
tout[@Fin1] ≃(;sb+b) 0
).
(* Everything, but reset *)
Definition Add_Main_Rel : pRel sigNat^+ unit 4 :=
ignoreParam (
fun tin tout =>
forall m n sm sn s2 s3,
tin [@Fin0] ≃(;sm) m ->
tin [@Fin1] ≃(;sn) n ->
isVoid_size tin[@Fin2] s2 ->
isVoid_size tin[@Fin3] s3 ->
tout[@Fin0] ≃(;sm) m /\
tout[@Fin1] ≃(;sn) n /\
tout[@Fin2] ≃(; s2 - (S (size n)) - m) m + n /\
tout[@Fin3] ≃(; s3 - (2 + m) + m) 0
).
Goal forall (x m : nat), x - m + m >= x. intros. lia. Qed.
Definition Add_space2 (m n : nat) (so : nat) := so + m - n - 2.
Definition Add_space3 (m : nat) (s3 : nat) := 2 + (s3 - (2 + m) + m).
Definition Add_Rel : pRel sigNat^+ unit 4 :=
ignoreParam
(fun tin tout =>
forall (m : nat) (n : nat) (sx sy so s3 : nat),
tin[@Fin0] ≃(;sx) m ->
tin[@Fin1] ≃(;sy) n ->
isVoid_size tin[@Fin2] so ->
isVoid_size tin[@Fin3] s3 ->
tout[@Fin0] ≃(;sx) m /\ (* First input value stayes unchanged *)
tout[@Fin1] ≃(;sy) n /\ (* Second input value stayes unchanged *)
tout[@Fin2] ≃(;Add_space2 m n so) (m + n) /\
isVoid_size tout[@Fin3] (Add_space3 m s3)
).
(* *** Termination of [Add] *)
Local Arguments plus : simpl never.
Local Arguments mult : simpl never.
Definition Add_Loop_steps b := 9 + 10 * b.
Definition Add_Main_steps m n := 85 + 12 * n + 22 * m.
(* [37 + 12 * n] for [CopyValue] (n) *)
(* [37 + 12 * m] for [CopyValue] (m) *)
(* [9 + 10 * m] for [Add_Loop] *)
Definition Add_Main_T : tRel sigNat^+ 4 := fun tin k => exists m n, tin[@Fin0] ≃ m /\ tin[@Fin1] ≃ n /\ isVoid tin[@Fin2] /\ isVoid tin[@Fin3] /\ Add_Main_steps m n <= k.
Definition Add_steps m n := 98 + 12 * n + 22 * m.
(* Additional [12] steps for [Reset], and [1] for [Seq] *)
Definition Add_T : tRel sigNat^+ 4 := fun tin k => exists m n, tin[@Fin0] ≃ m /\ tin[@Fin1] ≃ n /\ isVoid tin[@Fin2] /\ isVoid tin[@Fin3] /\ Add_steps m n <= k.
(* ** Multiplication *)
(* * Complete Machine: * * INP t0: m * INP t1: n  (for Add: INP t0) * OUT t2: c  (for Add: INP t1) * INT t3: c' (for Add: OUT t2) * INT t4:    (for Add: INT t3) * INT t5: m' (copy of m) * * Pseudocode: * c := 0 * while (m--) { *   ADD(n, c, c') *   Reset c *   c := c' *   Reset c' * } * Reset m' *)
(* * Step-Machine: * (Note that it only accesses the copy of m) * * t0: m' (counter) * t1: n  (for Add: INP t0) * t2: c  (for Add: INP t1) * t3: c' (for Add: OUT t2) * t4:    (for Add: INT t3) * * if (m'--) { *   Add(n, c, c') *   c := c *   reset c' *   continue * } else { *   break * } *)
Definition Mult_Step : pTM sigNat^+ (option unit) 5 :=
If (LiftTapes CaseNat [|Fin0|])
(Return (
LiftTapes Add [|Fin1; Fin2; Fin3; Fin4|];; (* Add(n, c, c') *)
LiftTapes (MoveValue _) [|Fin3; Fin2|]
) (None)) (* continue *)
(Return Nop (Some tt)). (* break *)
Definition Mult_Loop := While Mult_Step.
(* * INP t0: m * INP t1: n  (for Mult_Loop: t1) * OUT t2: c  (for Mult_Loop: t2) * INT t3: c' (for Mult_Loop: t3) * INT t4:    (for Mult_Loop: t4) * INT t5: m' (for Mult_Loop: t0) *)
Definition Mult_Main : pTM sigNat^+ unit 6 :=
LiftTapes (CopyValue _) [|Fin0; Fin5|];; (* m' := m *)
LiftTapes (Constr_O) [|Fin2|];; (* c := 0 *)
LiftTapes Mult_Loop [|Fin5; Fin1; Fin2; Fin3; Fin4|]. (* Main loop *)
Definition Mult : pTM sigNat^+ unit 6 :=
Mult_Main;;
LiftTapes (Reset _) [|Fin5|]. (* Reset m' *)
(* *** Correctness of [Mult] *)
Definition Mult_Step_Rel : pRel sigNat^+ (option unit) 5 :=
fun tin '(yout, tout) =>
forall (c m' n : nat) (sm sn sc s3 s4 : nat),
tin[@Fin0] ≃(;sm) m' ->
tin[@Fin1] ≃(;sn) n ->
tin[@Fin2] ≃(;sc) c ->
isVoid_size tin[@Fin3] s3 ->
isVoid_size tin[@Fin4] s4 ->
match yout, m' with
| (Some tt), O => (* return *)
tout[@Fin0] ≃(;sm) m' /\
tout[@Fin1] ≃(;sn) n /\
tout[@Fin2] ≃(;sc) c /\
isVoid_size tout[@Fin3] s3 /\
isVoid_size tout[@Fin4] s4
| None, S m'' => (* continue *)
tout[@Fin0] ≃(;S sm) m'' /\
tout[@Fin1] ≃(;sn) n /\
tout[@Fin2] ≃(;sc-n) n + c /\
isVoid_size tout[@Fin3] (2 + n + c + Add_space2 n c s3)  /\
isVoid_size tout[@Fin4] (Add_space3 n s4)
| _, _ => False
end.
Fixpoint Mult_Loop_space34 (m' n c : nat) (s3 s4 : nat) { struct m' } : Vector.t nat 2 :=
match m' with
| 0 => [| s3; s4 |]
| S m'' => Mult_Loop_space34 m'' n (n + c) (2 + n + c + Add_space2 n c s3) (Add_space3 n s4)
end.
Definition Mult_Loop_Rel : pRel sigNat^+ unit 5 :=
ignoreParam (
fun tin tout =>
forall c m' n sm sn sc s3 s4,
tin[@Fin0] ≃(;sm) m' ->
tin[@Fin1] ≃(;sn) n ->
tin[@Fin2] ≃(;sc) c ->
isVoid_size tin[@Fin3] s3 ->
isVoid_size tin[@Fin4] s4 ->
tout[@Fin0] ≃(;sm+m') 0 /\
tout[@Fin1] ≃(;sn) n /\
tout[@Fin2] ≃(;sc-m'*n) m' * n + c /\
isVoid_size tout[@Fin3] (Mult_Loop_space34 m' n c s3 s4)[@Fin0] /\
isVoid_size tout[@Fin4] (Mult_Loop_space34 m' n c s3 s4)[@Fin1]
).
(* * Complete Machine: * * INP t0: m * INP t1: n  (from Add: INP t0) * OUT t2: c  (from Add: INP t1) * INT t3: c' (from Add: OUT t2) * INT t4:    (from Add: INT t3) * INT t5: m' (copy of m) * * Pseudocode: * c := 0 * m' := m * while (m--) { *   ADD(n, c, c') *   c := c' *   reset c' * } * reset m' *)
Definition Mult_Main_Rel : pRel sigNat^+ unit 6 :=
ignoreParam (
fun tin tout =>
forall (m n : nat) (sm sn so s3 s4 s5 : nat),
tin[@Fin0] ≃(;sm) m ->
tin[@Fin1] ≃(;sn) n ->
isVoid_size tin[@Fin2] so ->
isVoid_size tin[@Fin3] s3 ->
isVoid_size tin[@Fin4] s4 ->
isVoid_size tin[@Fin5] s5 ->
tout[@Fin0] ≃(;sm) m /\
tout[@Fin1] ≃(;sn) n /\
tout[@Fin2] ≃(;so-m*n) m * n /\
isVoid_size tout[@Fin3] ((Mult_Loop_space34 m n 0 s3 s4)[@Fin0]) /\
isVoid_size tout[@Fin4] ((Mult_Loop_space34 m n 0 s3 s4)[@Fin1]) /\
tout[@Fin5] ≃(;s5+m) 0
).
Definition Mult_Rel : pRel sigNat^+ unit 6 :=
ignoreParam
(fun tin tout =>
forall (m : nat) (n : nat) (sm sn so s3 s4 s5 : nat),
tin[@Fin0] ≃(;sm) m ->
tin[@Fin1] ≃(;sn) n ->
isVoid_size tin[@Fin2] so ->
isVoid_size tin[@Fin3] s3 ->
isVoid_size tin[@Fin4] s4 ->
isVoid_size tin[@Fin5] s5 ->
tout[@Fin0] ≃(;sm) m /\
tout[@Fin1] ≃(;sn) n /\
tout[@Fin2] ≃(;so-m*n) m * n /\
isVoid_size tout[@Fin3] ((Mult_Loop_space34 m n 0 s3 s4)[@Fin0]) /\
isVoid_size tout[@Fin4] ((Mult_Loop_space34 m n 0 s3 s4)[@Fin1]) /\
isVoid_size tout[@Fin5] (S (S (m + s5)))
).
(* *** Termination of Mult *)
Definition Mult_Step_steps m' n c :=
match m' with
| O => 6
| _ => 168 + 33 * c + 39 * n
end.
(* [5] for [If] and [1] for [CaseNat] *)
(* [98+12*n+22*c] for [Add] *)
(* [12+c] for [Reset] (c) *)
(* [36+12*(c+n)] for [CopyValue] (c' = c + n) *)
(* [12 + (c+n)] for [Reset] (c' = c + n) *)
Fixpoint Mult_Loop_steps m' n c :=
match m' with
| O => S (Mult_Step_steps m' n c)
| S m'' => S (Mult_Step_steps m' n c) + Mult_Loop_steps m'' n (n + c)
end.

Lemma Mult_Loop_Terminates :
projT1 Mult_Loop ↓
(fun tin i => exists m' n c,
tin[@Fin0] ≃ m' /\
tin[@Fin1] ≃ n /\
tin[@Fin2] ≃ c /\
isVoid tin[@Fin3] /\
isVoid tin[@Fin4] /\
Mult_Loop_steps m' n c <= i).