Section StepMachine.
Implicit Types H : Heap.
Implicit Types T V : list HClos.
Implicit Types a b c : HAdd.
Implicit Types g : HClos.
Implicit Types (P Q : Pro).
(* The machine operates on lists of closures and on a heap, so we need a closure-list alphabet and a heap alphabet. *)
Variable sigStep : finType.
Variable retr_closures_step : Retract (sigList sigHClos) sigStep.
Variable retr_heap_step : Retract sigHeap sigStep.
Set Default Proof Using "Type".
(* Retracts *)
(* Closures *)
Local Definition retr_clos_step : Retract sigHClos sigStep := ComposeRetract retr_closures_step _.
(* Closure addresses *)
Definition retr_pro_clos : Retract sigPro sigHClos := _.
Local Definition retr_pro_step : Retract sigPro sigStep := ComposeRetract retr_clos_step retr_pro_clos.
Local Definition retr_tok_step : Retract sigCom sigStep := ComposeRetract retr_pro_step _.
Local Definition retr_nat_clos_ad : Retract sigNat sigHClos := Retract_sigPair_X _ (Retract_id _).
Local Definition retr_nat_step_clos_ad : Retract sigNat sigStep := ComposeRetract retr_clos_step retr_nat_clos_ad.
Local Definition retr_nat_clos_var : Retract sigNat sigHClos := Retract_sigPair_Y _ _.
Local Definition retr_nat_step_clos_var : Retract sigNat sigStep := ComposeRetract retr_clos_step retr_nat_clos_var.
(* Instance of the [Lookup] and [JumpTarget] machine *)
Local Definition Step_Lookup := Lookup retr_clos_step retr_heap_step.
(* Cons a closure to a closure list, if the programm of the closure is not empty, and reset the program but not the address of the closure *)
Definition TailRec_size (T : list HClos) (P : Pro) (a : HAdd) : Vector.t (nat->nat) 3 :=
match P with
| nil => [| id; Reset_size P; id|]
| c :: P' => [| (*0*) Constr_cons_size (a,P); (*1*) Constr_pair_size a >> Reset_size (a,P); (*2*) id |]
end.
Definition TailRec_Rel : pRel sigStep^+ unit 3 :=
ignoreParam (
fun tin tout =>
forall T P a (s0 s1 s2 : nat),
tin[@Fin0] ≃(;s0) T ->
tin[@Fin1] ≃(retr_pro_step;s1) P ->
tin[@Fin2] ≃(retr_nat_step_clos_ad;s2) a ->
tout[@Fin0] ≃(;TailRec_size T P a @>Fin0 s0) tailRecursion (a, P) T /\
isVoid_size tout[@Fin1] (TailRec_size T P a @>Fin1 s1) /\
tout[@Fin2] ≃(retr_nat_step_clos_ad; TailRec_size T P a @>Fin2 s2) a
).
Definition TailRec : pTM sigStep^+ unit 3 :=
If (IsNil sigCom_fin ⇑ retr_pro_step @ [|Fin1|])
(Reset _ @ [|Fin1|])
(Constr_pair sigHAdd_fin sigPro_fin ⇑ retr_clos_step @ [|Fin2; Fin1|];;
Constr_cons sigHClos_fin ⇑ _ @ [|Fin0; Fin1|];;
Reset _ @ [|Fin1|]).
Local Arguments TailRec_size : simpl never.
Local Arguments tailRecursion : simpl never.
Definition TailRec_steps P a :=
match P with
| nil => 1 + IsNil_steps + Reset_steps nil
| t::P => 1 + IsNil_steps + 1 + Constr_pair_steps a + 1 + Constr_cons_steps (a,t::P) + Reset_steps (a, t :: P)
end.
Definition TailRec_T : tRel sigStep^+ 3 :=
fun tin k =>
exists T P a, tin[@Fin0] ≃ T /\
tin[@Fin1] ≃(retr_pro_step) P /\
tin[@Fin2] ≃(retr_nat_step_clos_ad) a /\
TailRec_steps P a <= k.
(* Like [TailRec], but doesn't check whether the program is empty, and resets [a] and [Q] *)
Definition ConsClos_size (T : list HClos) (Q : Pro) (a : HAdd) : Vector.t (nat->nat) 3 :=
[| Constr_cons_size (a,Q); Reset_size a; Constr_pair_size a >> Reset_size (a, Q) |].
Definition ConsClos_Rel : pRel sigStep^+ unit 3 :=
ignoreParam (
fun tin tout =>
forall T Q a (s0 s1 s2 : nat),
tin[@Fin0] ≃(;s0) T ->
tin[@Fin1] ≃(retr_nat_step_clos_ad;s1) a ->
tin[@Fin2] ≃(retr_pro_step;s2) Q ->
tout[@Fin0] ≃(;ConsClos_size T Q a @>Fin0 s0) (a, Q) :: T /\
isVoid_size tout[@Fin1] (ConsClos_size T Q a @>Fin1 s1) /\
isVoid_size tout[@Fin2] (ConsClos_size T Q a @>Fin2 s2)
).
Definition ConsClos : pTM sigStep^+ unit 3 :=
Constr_pair sigHAdd_fin sigPro_fin ⇑ retr_clos_step @ [|Fin1; Fin2|];;
Constr_cons sigHClos_fin ⇑ _ @ [|Fin0; Fin2|];;
Reset _ @ [|Fin2|];;
Reset _ @ [|Fin1|].
Local Arguments ConsClos_size : simpl never.
Definition ConsClos_steps Q a :=
3 + Constr_pair_steps a + Constr_cons_steps (a,Q) + Reset_steps (a,Q) + Reset_steps a.
Definition ConsClos_T : tRel sigStep^+ 3 :=
fun tin k =>
exists T Q a,
tin[@Fin0] ≃ T /\
tin[@Fin1] ≃(retr_nat_step_clos_ad) a /\
tin[@Fin2] ≃(retr_pro_step) Q /\
ConsClos_steps Q a <= k.
Definition Step_lam_size (T V : list HClos) (H : Heap) (a : HAdd) (P : Pro) : Vector.t (nat->nat) 10 :=
match jumpTarget 0 [] P with
| Some (Q, P') =>
(JumpTarget_size P @>> [|Fin3; Fin6; Fin7; Fin8; Fin9|]) >>> (TailRec_size T P' a @>> [|Fin0; Fin3; Fin4|]) >>> (ConsClos_size V Q a @>> [|Fin1; Fin4; Fin6|])
| _ => default
end.
Definition Step_lam_Rel : pRel sigStep^+ bool 10 :=
fun tin '(yout, tout) =>
forall (T V : list HClos) (H : Heap) (a : HAdd) (P : Pro) (s0 s1 s2 s3 s4 : nat) (sr : Vector.t nat 5),
let size := Step_lam_size T V H a P in
tin[@Fin0] ≃(;s0) T ->
tin[@Fin1] ≃(;s1) V ->
tin[@Fin2] ≃(;s2) H ->
tin[@Fin3] ≃(retr_pro_step;s3) P ->
tin[@Fin4] ≃(retr_nat_step_clos_ad;s4) a ->
(forall i : Fin.t 5, isVoid_size tin[@FinR 5 i] sr[@i]) ->
match yout with
| true =>
exists (P' Q : Pro),
jumpTarget 0 [] P = Some (Q, P') /\
tout[@Fin0] ≃(;size@>Fin0 s0) tailRecursion (a, P') T /\
tout[@Fin1] ≃(;size@>Fin1 s1) (a, Q) :: V /\
tout[@Fin2] ≃(;size@>Fin2 s2) H /\
(forall i : Fin.t 7, isVoid_size tout[@FinR 3 i] (size@>(FinR 3 i) (s3:::s4:::sr)[@i]))
| false => jumpTarget 0 [] P = None
end.
Definition Step_lam : pTM sigStep^+ bool 10 :=
If (JumpTarget ⇑ retr_pro_step @ [|Fin3; Fin6; Fin7; Fin8; Fin9|])
(Return (TailRec @ [|Fin0; Fin3; Fin4|];;
ConsClos @ [|Fin1; Fin4; Fin6|])
true)
(Return Nop false).
(* Steps depending on the result of [JumpTarget] *)
Definition Step_lam_steps_JumpTarget P a :=
match jumpTarget 0 [] P with
| Some (Q', P') =>
1 + TailRec_steps P' a + ConsClos_steps Q' a
| None => 0
end.
Definition Step_lam_steps P a := 1 + JumpTarget_steps P + Step_lam_steps_JumpTarget P a.
Definition Step_lam_T : tRel sigStep^+ 10 :=
fun tin k =>
exists (T V : list HClos) (H : Heap) (a : HAdd) (P : Pro),
tin[@Fin0] ≃ T /\
tin[@Fin1] ≃ V /\
tin[@Fin2] ≃ H /\
tin[@Fin3] ≃(retr_pro_step) P /\
tin[@Fin4] ≃(retr_nat_step_clos_ad) a /\
(forall i : Fin.t 5, isVoid tin[@FinR 5 i]) /\
Step_lam_steps P a <= k.
Definition Put_size (H : Heap) (g : HClos) (b : HAdd) : Vector.t (nat->nat) 6 :=
(* (Length_size H @>> [|Fin0; Fin3; Fin4; Fin5|]) >>> ([|pred|] @>> [|Fin4|]) >>> (* nil *)
([|Constr_pair_size g >> pred|] @>>[|Fin2|]) >>> (* pair and [Some] on tape 2 *)
...
*)
[| (*0*) Length_size H @>Fin0 >> MoveValue_size_y (H++[Some(g,b)]) H;
(*1*) Reset_size g; (*2*) Constr_pair_size g >> pred >> Reset_size (Some(g,b)); (*3*) Length_size H @>Fin1; (*4*) Length_size H @>Fin2 >> pred >> Constr_cons_size (Some(g,b)) >> App'_size H >> MoveValue_size_x (H++[Some(g,b)]); (* nil and cons *)
(*5*) Length_size H @>Fin3 |].   Definition Put_Rel : pRel sigStep^+ unit 6 := ignoreParam ( fun tin tout => forall (H : Heap) (g : HClos) (b : HAdd) (s0 s1 s2 s3 s4 s5 : nat), let size := Put_size H g b in tin[@Fin0] ≃(;s0) H -> tin[@Fin1] ≃(retr_clos_step;s1) g -> tin[@Fin2] ≃(retr_nat_step_clos_ad;s2) b -> isVoid_size tin[@Fin3] s3 -> isVoid_size tin[@Fin4] s4 -> isVoid_size tin[@Fin5] s5 -> tout[@Fin0] ≃(;size @>Fin0 s0) H ++ [Some (g,b)] /\ isVoid_size tout[@Fin1] (size @>Fin1 s1) /\ isVoid_size tout[@Fin2] (size @>Fin2 s2) /\ tout[@Fin3] ≃(retr_nat_step_clos_ad; size @>Fin3 s3) length H /\ isVoid_size tout[@Fin4] (size @>Fin4 s4) /\ isVoid_size tout[@Fin5] (size @>Fin5 s5) ).    Local Definition retr_nat_step_hent : Retract sigNat sigStep := ComposeRetract retr_heap_step retr_nat_heap_entry.  Local Definition retr_clos_step_hent : Retract sigHClos sigStep := ComposeRetract retr_heap_step retr_clos_heap.  Local Definition retr_hent'_step : Retract sigHEntr' sigStep := ComposeRetract retr_heap_step retr_hent'_heap.  Local Definition retr_hent_step : Retract sigHEntr sigStep := ComposeRetract retr_heap_step retr_hent_heap.  Definition Put : pTM sigStep^+ unit 6 := Length retr_heap_step retr_nat_step_clos_ad @ [|Fin0; Fin3; Fin4; Fin5|];; Constr_nil HEntr ⇑ _ @ [|Fin4|];; Translate retr_nat_step_clos_ad retr_nat_step_hent @ [|Fin2|];; Translate retr_clos_step retr_clos_step_hent @ [|Fin1|];; Constr_pair sigHClos_fin sigHAdd_fin ⇑ retr_hent'_step @ [|Fin1; Fin2|];; Constr_Some sigHEntr'_fin ⇑ retr_hent_step @ [|Fin2|];; Constr_cons sigHEntr_fin ⇑ _ @ [|Fin4; Fin2|];; App' sigHEntr_fin ⇑ _ @ [|Fin0; Fin4|];; MoveValue _ @ [|Fin4; Fin0|];; Reset _ @ [|Fin2|];; Reset _ @ [|Fin1|].   Lemma Put_Realise : Put ⊨ Put_Rel.  Local Arguments Put_size : simpl never.  Definition Put_steps H g b := 10 + Length_steps H + Constr_nil_steps + Translate_steps b + Translate_steps g + Constr_pair_steps g + Constr_Some_steps + Constr_cons_steps (Some (g, b)) + App'_steps H + MoveValue_steps (H++[Some(g,b)]) H + Reset_steps (Some (g, b)) + Reset_steps g.  Definition Put_T : tRel sigStep ^+ 6 := fun tin k => exists (H : Heap) (g : HClos) (b : HAdd), tin[@Fin0] ≃ H /\ tin[@Fin1] ≃(retr_clos_step) g /\ tin[@Fin2] ≃(retr_nat_step_clos_ad) b /\ isVoid tin[@Fin3] /\ isVoid tin[@Fin4] /\ isVoid tin[@Fin5] /\ Put_steps H g b <= k.  Lemma Put_Terminates : projT1 Put ↓ Put_T.   (* This time I write the size function column-wise *)
Definition Step_app_size (T V : list HClos) (H : Heap) (a : HAdd) (P : Pro) : Vector.t (nat->nat) 11 :=
match V with
| g :: (b, Q) :: V' =>
([|CaseList_size0 g; CaseList_size1 g|] @>> [|Fin1;Fin5|]) >>>
([|CaseList_size0 (b,Q); CaseList_size1 (b,Q)|] @>> [|Fin1;Fin6|]) >>>
([|CasePair_size0 b; CasePair_size1 b|] @>> [|Fin6;Fin7|]) >>>
(TailRec_size T P a @>> [|Fin0; Fin3; Fin4|]) >>>
([|Reset_size a|] @>> [|Fin4|]) >>>
(Put_size H g b @>> [|Fin2; Fin5; Fin7; Fin8; Fin9; Fin10|]) >>>
(ConsClos_size (tailRecursion (a,P) T) Q (length H) @>> [|Fin0; Fin8; Fin6|])
| _ => default (* not specified *)
end.
Definition Step_app_Rel : pRel sigStep^+ bool 11 :=
fun tin '(yout, tout) =>
forall (T V : list HClos) (H : Heap) (a : HAdd) (P : Pro) (s0 s1 s2 s3 s4 : nat) (sr : Vector.t nat 6),
let size := Step_app_size T V H a P in
tin[@Fin0] ≃(;s0) T ->
tin[@Fin1] ≃(;s1) V ->
tin[@Fin2] ≃(;s2) H ->
tin[@Fin3] ≃(retr_pro_step;s3) P ->
tin[@Fin4] ≃(retr_nat_step_clos_ad;s4) a ->
(forall i : Fin.t 6, isVoid_size tin[@FinR 5 i] sr[@i]) ->
match yout, V with
| true, g :: (b, Q) :: V =>
let (c, H') := put H (Some (g, b)) in (* This simplifys immediatly by computation *)
tout[@Fin0] ≃(;size@>Fin0 s0) (c, Q) :: tailRecursion (a, P) T /\
tout[@Fin1] ≃(;size@>Fin1 s1) V /\
tout[@Fin2] ≃(;size@>Fin2 s2) H' /\
(forall i : Fin.t 8, isVoid_size tout[@FinR 3 i] (size @>(FinR 3 i) (s3:::s4:::sr)[@i]))
| false, [] => True
| false, [_] => True
| _, _ => False
end.
Definition Step_app : pTM sigStep^+ bool 11 :=
If (CaseList sigHClos_fin ⇑ _ @ [|Fin1; Fin5|])
(If (CaseList sigHClos_fin ⇑ _ @ [|Fin1; Fin6|])
(Return (CasePair sigHAdd_fin sigPro_fin ⇑ retr_clos_step @ [|Fin6; Fin7|];;
TailRec @ [|Fin0; Fin3; Fin4|];;
Reset _ @ [|Fin4|];;
Put @ [|Fin2; Fin5; Fin7; Fin8; Fin9; Fin10|];;
ConsClos @ [|Fin0; Fin8; Fin6|])
(true))
(Return Nop false))
(Return Nop false)
.
Arguments Step_app_size : simpl never.
Arguments Step_app_size : simpl never.
Definition Step_app_steps_CaseList' g V' H P a :=
match V' with
| nil => 0 (* Nop *)
| (b, Q) :: V'' =>
4 + CasePair_steps b + TailRec_steps P a + Reset_steps a + Put_steps H g b + ConsClos_steps Q (length H)
end.
Definition Step_app_steps_CaseList V H P a :=
match V with
| nil => 0 (* Nop *)
| g :: V' => 1 + CaseList_steps V' + Step_app_steps_CaseList' g V' H P a
end.
Definition Step_app_steps V H a P := 1 + CaseList_steps V + Step_app_steps_CaseList V H P a.
Definition Step_app_T : tRel sigStep^+ 11 :=
fun tin k =>
exists (T V : list HClos) (H : Heap) (P : Pro) (a : HAdd),
tin[@Fin0] ≃ T /\
tin[@Fin1] ≃ V /\
tin[@Fin2] ≃ H /\
tin[@Fin3] ≃(retr_pro_step) P /\
tin[@Fin4] ≃(retr_nat_step_clos_ad) a /\
(forall i : Fin.t 6, isVoid tin[@FinR 5 i]) /\
Step_app_steps V H a P <= k.

Lemma Step_app_Terminates : projT1 Step_app ↓ Step_app_T.