Section Fix.
Variable Σ : finType.
Variable retr_stack : Retract (sigList (sigPair sigHClos sigNat)) Σ.
Variable retr_heap : Retract sigHeap Σ.
Definition retr_clos : Retract sigHClos Σ := ComposeRetract retr_stack _.
Definition retr_pro : Retract sigPro Σ := ComposeRetract retr_clos _.
Definition retr_com : Retract sigCom Σ := ComposeRetract retr_pro _.
Definition retr_nat_clos_ad' : Retract sigNat sigHClos := Retract_sigPair_X _ _.
Definition retr_nat_clos_ad : Retract sigNat Σ := ComposeRetract retr_clos retr_nat_clos_ad'.
Definition retr_nat_clos_var' : Retract sigNat sigHClos := Retract_sigPair_Y _ _.
Definition retr_nat_clos_var : Retract sigNat Σ := ComposeRetract retr_clos retr_nat_clos_var'.
Definition retr_stackEl : Retract (sigPair sigHClos sigNat) Σ :=
(ComposeRetract retr_stack _).
Definition retr_nat_stack : Retract sigNat Σ :=
ComposeRetract retr_stackEl
(Retract_sigPair_Y _ _) .
(* Instance of the [Lookup] and [JumpTarget] machine *)
Local Definition Lookup := Lookup retr_clos retr_heap.
Local Notation i_H := Fin0 (only parsing).
Local Notation i_a := Fin1 (only parsing).
Local Notation i_P := Fin2 (only parsing).
Local Notation i_k := Fin3 (only parsing).
Local Notation i_stack' := Fin4 (only parsing).
Local Notation i_res := Fin5 (only parsing).
Local Notation i_aux1 := Fin6 (only parsing).
Local Notation i_aux2 := Fin7 (only parsing).
Local Notation i_aux3 := Fin8 (only parsing).
Local Notation i_aux4 := Fin9 (only parsing).
(* Print unfoldTailRecStep. *)
(* Definition unfoldTailRecStep '(stack,res) : (list (HClos*nat) * Pro) + option Pro := match stack with | ((a,P),k)::stack => match P with c::P => match c with varT n => if ( k <=? n) then match lookup H a (n-k) with | Some (b,Q) => inl (((b,Q),1)::(a,retT::P,S k)::stack,lamT::res) | None => inr None end else inl ((a,P,k)::stack,varT n::res) | appT => inl ((a,P,k)::stack,appT::res) | lamT => inl ((a,P,S k)::stack,lamT::res) | retT => inl ((a,P,pred k)::stack,retT::res) end | [] => inl (stack,res) end | [] => inr (Some res) end. *)
Definition M__step : pTM (Σ) ^+ (option unit) 10 :=
If
(CaseList _ ⇑ retr_pro @ [| i_P;i_aux1|])
(Switch (CaseCom ⇑ retr_com @ [|i_aux1|])
(fun i : option ACom=> match i with
| Some c =>
Cons_constant.M (ACom2Com c)⇑ retr_pro @ [| i_res|];;
Return
match c return match c with _ => _ end with
| retAT => (CaseNat ⇑ retr_nat_clos_var @ [|i_k|];;Return Nop tt)
| lamAT => Constr_S  ⇑ retr_nat_clos_var @ [|i_k|]
| appAT => Nop
end
None
| None (*var*) =>
CopyValue _  @ [| i_k;i_aux2|];;
CopyValue _  @ [| i_aux1;i_aux3|];;
If (Subtract ⇑ retr_nat_clos_var @ [|i_aux3;i_aux2|])
(Reset _ @ [|i_aux1|];;
CopyValue _  @ [| i_a;i_aux4|];;
If (Lookup @ [|i_H;i_aux4;i_aux3;i_aux1;i_aux2|])
(Cons_constant.M lamT⇑ retr_pro @ [| i_res|];;
Cons_constant.M retT⇑ retr_pro @ [| i_P|];;
Constr_S  ⇑ retr_nat_clos_var @ [|i_k|];;
Constr_pair _ _ ⇑ retr_clos @ [|i_a;i_P|];;
Reset _ @ [|i_a|];;
Translate retr_nat_clos_var retr_nat_stack @[|i_k|];;
Constr_pair _ _ ⇑ retr_stackEl @ [|i_P;i_k|];;
MoveValue _ @ [|i_aux1;i_P|];;
Constr_cons _ ⇑ retr_stack @ [| i_stack';i_k|];;
Reset _ @ [|i_k|];;
CasePair _ _ ⇑ retr_clos @ [|i_P;i_a|];;
Return (WriteValue ( 1) ⇑ retr_nat_clos_var @ [|i_k|]) None
)
(Return Diverge (Some tt))
)
(Return
(Constr_varT ⇑ retr_com @ [|i_aux1|];;
Constr_cons _ ⇑ retr_pro @ [| i_res;i_aux1|];;
Reset _  @ [|i_aux1|];;
Reset _ @ [|i_aux3|])
None)
end)
)
( Reset _ @ [|i_P|];;
Reset _ @ [|i_a|];;
Reset _ @ [|i_k|];;
If
(CaseList _ ⇑ retr_stack @ [| i_stack';i_k|])
(CasePair _ _ ⇑ retr_stackEl @ [|i_k;i_P|];;
CasePair _ _ ⇑ retr_clos @ [|i_P;i_a|];;
Translate retr_nat_stack retr_nat_clos_var @[|i_k|];;
Return Nop None
)
(Reset _ @ [|i_stack'|];;Return Nop (Some tt))
).
Local Arguments "+"%nat : simpl never.
Local Arguments "*"%nat : simpl never.
Local Arguments UpToC.f__UpToC {_ _} _ _.
(* This function is copied from the end of the proof of SpecT__step' and not written by hand*)
Definition steps_step H (stack : list (HAdd * list Tok * nat)) :=
match stack with
(a,P,k)::stack' =>
1 + CaseList_steps P +
(if match P with
| [] => false
| _ :: _ => true
end
then
match P with
| [] => 0
| t :: P0 =>
match t with
| varT n =>
1 + CaseCom_steps +
(1 + CopyValue_steps k +
(1 + CopyValue_steps n +
(1 + UpToC.f__UpToC (projT1 Subtract_SpecT) k +
(if k <=? n
then
1 + Reset_steps n +
(1 + CopyValue_steps a +
match lookup H a (n - k) with
| Some h =>
let (_, _) := h in
Lookup_steps H a (n - k) + Cons_constant.time lamT +
Cons_constant.time retT + Constr_S_steps +
Constr_pair_steps a + Reset_steps a +
Translate_steps (1 + k) +
Constr_pair_steps (a, retT :: P0) +
MoveValue_steps h (a, retT :: P0) +
Constr_cons_steps (a, retT :: P0, 1 + k) +
Reset_steps (a, retT :: P0, 1 + k) +
CasePair_steps (fst h) + WriteValue_steps 2 +
Pos.to_nat 11 + 1
| None => 0
end)
else
Constr_varT_steps + Constr_cons_steps t + Reset_steps t +
Reset_steps (n - k) + Pos.to_nat 3))))
| _ => 1 + CaseCom_steps + 16
end
end
else
1 + Reset_steps P +
(1 + Reset_steps a +
(1 + Reset_steps k +
(1 + CaseList_steps stack' +
(if match stack' with
| [] => false
| _ :: _ => true
end
then
match stack' with
| [] => 0
| p :: _ =>
let (p0, _) := p in
let (_, _) := p0 in
1 + CasePair_steps (fst p) +
(1 + CasePair_steps (fst p0) + (1 + Translate_steps (snd p) + 0))
end
else
match stack' with
| [] => 1 + Reset_steps stack' + 0
| _ :: _ => 0
end)))))
| _ => 0
end.
Arguments steps_step : simpl never.
Definition M__loop := While M__step.
Local Arguments unfoldTailRecStep : simpl never.

(*TODO: remove, already copied *)
Lemma tspec_revertPure (sig: finType) (n : nat) (P0:Prop) P (Ps : SpecV sig n) Q:
P0
-> Entails (tspec (P0::P,Ps)) Q
-> Entails (tspec (P,Ps)) Q.