(* Uncomputablity in the definition of R function *)
(* For convenience's sake, we focus on real numbers in [0,1] *)
(* All definitions are copied from Coq standard library Rdefinitions.v Rpow_def.v Raxioms.v*)
Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Logic.Classical.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
From Coq Require Import Classes.Morphisms.
From Coq Require Import Classes.RelationClasses.
From Coq Require Import Classes.Equivalence.
From Coq Require Export ZArith.ZArith_base.
From Coq Require Import QArith.QArith_base.
From Coq Require Import QArith.Qabs.
From Coq Require Import QArith.Qminmax.
From Coq Require Import QArith.Qround.
From Coq Require Import Logic.Classical.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Logic.PropExtensionality.
From Coq Require Import Logic.ProofIrrelevance.
From Coq Require Import setoid_ring.Ring_theory.
From Coq Require Import setoid_ring.Ring.
From Coq Require Import setoid_ring.Field.
From Coq Require Import omega.Omega.
From Coq Require Import micromega.Psatz.
Import ListNotations.
From CReal Require Import Countable.
From CReal Require Import QArith_base_ext.
From CReal Require Import Uncomputable.SingleLemmas.

Module Type VIR_R.
  Parameter R : Type.
  Delimit Scope R_scope with R.
  Bind Scope R_scope with R.
  Local Open Scope R_scope.
  Parameter R0 : R.
  Parameter R1 : R.
  Parameter Rplus : R -> R -> R.
  Parameter Rmult : R -> R -> R.
  Parameter Ropp : R -> R.
  Parameter Rinv : R -> R.
  Parameter Rlt : R -> R -> Prop.
  Parameter Req : R -> R -> Prop.

  Infix "==" := Req : R_scope.
  Infix "+" := Rplus : R_scope.
  Infix "*" := Rmult : R_scope.
  Notation "- x" := (Ropp x) : R_scope.
  Notation "/ x" := (Rinv x) : R_scope.
  Infix "<" := Rlt : R_scope.

  Definition Rgt (r1 r2:R) : Prop := r2 < r1.

  Definition Rle (r1 r2:R) : Prop := Rlt r1 r2 \/ r1 ==r2.

  Definition Rge (r1 r2:R) : Prop := Rgt r1 r2 \/ r1 == r2.

  Definition Rminus (r1 r2:R) : R := r1 + - r2.

  Definition Rdiv (r1 r2 :R) : R := r1 * / r2.

  Infix "-" := Rminus : R_scope.
  Infix "/" := Rdiv : R_scope.
  Infix "<=" := Rle : R_scope.
  Infix ">=" := Rge : R_scope.
  Infix ">"  := Rgt : R_scope.
  Notation "x <= y <= z" := (x <= y /\ y <= z) : R_scope.
  Notation "x <= y < z"  := (x <= y /\ y <  z) : R_scope.
  Notation "x < y < z"   := (x <  y /\ y <  z) : R_scope.
  Notation "x < y <= z"  := (x <  y /\ y <= z) : R_scope.
  Notation "0" := R0 : R_scope.
  Notation "1" := R1 : R_scope.
  Notation "2" := (1+1) : R_scope.

  (* Definitions copied from Rdefinitions.v *)
  (* Delete the definition of up *)

  Parameter Req_refl : forall x : R ,  x == x.

  Parameter Req_sym : forall x y : R , x == y -> y == x.

  Parameter Req_trans : forall x y z : R , x == y -> y == z -> x == z.

  Hint Immediate Req_sym : real.
  Hint Resolve Req_refl Req_trans : real.

  Instance R_Setoid : Equivalence Req.
  Proof. split; red; eauto with real. Qed.

  Axiom Rplus_comp : Proper (Req==>Req==>Req) Rplus.
  Existing Instance Rplus_comp .

  Axiom Ropp_comp : Proper (Req==>Req) Ropp.
  Existing Instance Ropp_comp .

  Axiom Rmult_comp : Proper (Req==>Req==>Req) Rmult.
  Existing Instance Rmult_comp .

  Axiom Rinv_comp : Proper (Req==>Req) Rinv.
  Existing Instance Rinv_comp .

  Axiom Rle_comp : Proper (Req==>Req==>iff) Rle.
  Existing Instance Rle_comp .

  Axiom Rlt_comp : Proper (Req==>Req==>iff) Rlt.
  Existing Instance Rlt_comp .

  Instance Rminus_comp : Proper (Req==>Req==>Req) Rminus.
  Proof. hnf ; red ; intros. unfold Rminus. rewrite H , H0. reflexivity. Qed.

  Instance Rdiv_comp : Proper (Req==>Req==>Req) Rdiv.
  Proof. hnf ; red ; intros. unfold Rdiv. rewrite H , H0. reflexivity. Qed.

  Instance Rgt_comp : Proper (Req==>Req==>iff) Rgt.
  Proof. hnf ; red ; intros. unfold Rgt. rewrite H , H0. reflexivity. Qed.

  Instance Rge_comp : Proper (Req==>Req==>iff) Rge.
  Proof. hnf ; red ; intros. unfold Rge. rewrite H , H0. reflexivity. Qed.

  (* Complementary definition of Real Equivalence. *)

  Fixpoint pow (r:R) (n:nat) : R :=
    match n with
      | O => 1
      | S n => Rmult r (pow r n)
    end.

  Instance Rpow_comp : Proper (Req ==> eq ==> Req) pow.
  Proof.
    hnf ; red; intros. rewrite H0. clear H0.
    induction y0.
    - simpl. reflexivity.
    - simpl. rewrite IHy0. rewrite H. reflexivity.
  Qed.

  (* Definition copied from Rpow_def.v *)

  Fixpoint IPR_2 (p:positive) : R :=
    match p with
    | xH => R1 + R1
    | xO p => (R1 + R1) * IPR_2 p
    | xI p => (R1 + R1) * (R1 + IPR_2 p)
    end.

  Definition IPR (p:positive) : R :=
    match p with
    | xH => R1
    | xO p => IPR_2 p
    | xI p => R1 + IPR_2 p
    end.
  Arguments IPR p%positive : simpl never.

  (**********)
  Definition IZR (z:Z) : R :=
    match z with
    | Z0 => R0
    | Zpos n => IPR n
    | Zneg n => - IPR n
    end.
  Arguments IZR z%Z : simpl never.

  (* Definitions copied from Rdefinitions.v *)

  Fixpoint INR (n:nat) : R :=
    match n with
    | O => 0
    | S O => 1
    | S n => INR n + 1
    end.
  Arguments INR n%nat.

  (* Definition copied from Raxioms.v *)

  Definition IQR(q : Q) : R :=
    match q with
    | p # q => IZR p / IPR q
    end.
  Arguments IQR q%Q.

  (* Complementary definition of Injection from Q to R. *)

  (* Definition of Vir_R *)

  Axiom Rplus_comm : forall r1 r2:R, r1 + r2 == r2 + r1.
  Hint Resolve Rplus_comm: real.
  Axiom Rplus_assoc : forall r1 r2 r3:R, r1 + r2 + r3 == r1 + (r2 + r3).
  Hint Resolve Rplus_assoc: real.
  Axiom Rplus_opp_r : forall r:R, r + - r == 0.
  Hint Resolve Rplus_opp_r: real.
  Axiom Rplus_0_l : forall r:R, 0 + r == r.
  Hint Resolve Rplus_0_l: real.
  Axiom Rmult_comm : forall r1 r2:R, r1 * r2 == r2 * r1.
  Hint Resolve Rmult_comm: real.
  Axiom Rmult_assoc : forall r1 r2 r3:R, r1 * r2 * r3 == r1 * (r2 * r3).
  Hint Resolve Rmult_assoc: real.
  Axiom Rinv_l : forall r:R, ~ r == 0 -> / r * r == 1.
  Hint Resolve Rinv_l: real.
  Axiom Rmult_1_l : forall r:R, 1 * r == r.
  Hint Resolve Rmult_1_l: real.
  Axiom
    Rmult_plus_distr_l : forall r1 r2 r3:R, r1 * (r2 + r3) == r1 * r2 + r1 * r3.
  Hint Resolve Rmult_plus_distr_l: real.

  Axiom total_order_T : forall r1 r2:R, r1 < r2 \/ r1 == r2 \/ r1 > r2.
  Axiom Rlt_asym : forall r1 r2:R, r1 < r2 -> ~ r2 < r1.
  Axiom Rlt_trans : forall r1 r2 r3:R, r1 < r2 -> r2 < r3 -> r1 < r3.
  Axiom R1_gt_R0 : 0 < 1.
  Hint Resolve R1_gt_R0: real.

  Axiom Rplus_lt_compat_l : forall r r1 r2:R, r1 < r2 -> r + r1 < r + r2.
  Axiom
    Rmult_lt_compat_l : forall r r1 r2:R, 0 < r -> r1 < r2 -> r * r1 < r * r2.
  Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real.
  (* Axioms copied from Raxioms.v *)
  (* Change { | } -> exists , sumbool to or *)
  (* Change eq -> Req *)

  (* Axioms of Vir_R *)
End VIR_R.

Module Type VIR_R_COMPLETE (VirR : VIR_R).
  Import VirR.
  Local Open Scope R_scope.
  Axiom archimed : forall r:R, exists z : Z , IZR z > r /\ IZR z - r <= 1.

  Definition is_upper_bound (E:R -> Prop) (m:R) := forall x:R, E x -> x <= m.

  Definition bound (E:R -> Prop) := exists m : R, is_upper_bound E m.

  Definition is_lub (E:R -> Prop) (m:R) :=
  is_upper_bound E m /\ (forall b:R, is_upper_bound E b -> m <= b).

  Axiom
  completeness :
    forall E:R -> Prop,
      bound E -> (exists x : R, E x) -> exists m:R , is_lub E m .

  (* Completeness axioms copied from Raxioms.v *)
  (* Change { | } -> exists , sumbool to or *)
End VIR_R_COMPLETE.

Module Type VIR_R_SINGLETON (VirR : VIR_R).
  Import VirR.
  Local Open Scope R_scope.
  Definition P_singlefun (X : R -> Prop) := (forall x1 x2, X x1 -> X x2 -> x1 == x2)
         /\ (exists x, X x) /\ Proper (Req ==> iff) X.
  Parameter Rsinglefun : {X: R -> Prop | P_singlefun X} -> R.
  Axiom Rsinglefun_correct: forall X H, X (Rsinglefun (exist _ X H)).
End VIR_R_SINGLETON.

Module VirRSingletonLemmas (VirR: VIR_R) (VirRSingleton: VIR_R_SINGLETON VirR).
  Import VirR.
  Import VirRSingleton.
  Local Open Scope R_scope.

  Module RSS <: R_SINGLE_SIMPLE.
    Definition R := VirR.R.
    Definition Req := VirR.Req.
    Definition R_Setoid := VirR.R_Setoid.
    Definition P_singlefun := VirRSingleton.P_singlefun.
    Definition Rsinglefun := VirRSingleton.Rsinglefun.
    Definition Rsinglefun_correct  := VirRSingleton.Rsinglefun_correct.
  End RSS.

  Module RL := RSignleLemmas RSS.

  Definition Rif: Prop -> R -> R -> R := RL.Rif.

  Instance Rif_comp : Proper (eq(A:=Prop) ==> Req ==> Req ==> Req) Rif :=
    RL.Rif_comp.

  Definition Rif_left : forall (P:Prop) (x y:R), P -> Rif P x y == x :=
    RL.Rif_left.

  Definition Rif_right : forall (P:Prop) (x y:R), ~ P -> Rif P x y == y :=
    RL.Rif_right.

  Definition Rif_rich: forall (P : Prop) (x: P -> R) (y: ~ P -> R)
                              {_: Proper ((fun _ _ : P => True) ==> Req) x}
                              {_: Proper ((fun _ _ : ~ P => True) ==> Req) y}, R :=
    RL.Rif_rich.

  Definition Rif_rich_left: forall (P : Prop) (x: P -> R) (y: ~ P -> R)
                              {Px: Proper ((fun _ _ : P => True) ==> Req) x}
                              {Py: Proper ((fun _ _ : ~ P => True) ==> Req) y},
    P -> exists H : P, @Rif_rich P x y Px Py == x H
  := RL.Rif_rich_left.

  Definition Rif_rich_right: forall (P : Prop) (x: P -> R) (y: ~ P -> R)
                              {Px: Proper ((fun _ _ : P => True) ==> Req) x}
                              {Py: Proper ((fun _ _ : ~ P => True) ==> Req) y},
    ~ P -> exists H : ~ P,Rif_rich P x y == y H
  := RL.Rif_rich_right.
End VirRSingletonLemmas.

Module Type VIR_R_ALL.

Include VIR_R.
Include VIR_R_SINGLETON.
Include VIR_R_COMPLETE.

End VIR_R_ALL.


Require Import ZArith.
Require Import divsteps_base.

Lemma example60 : ZMap.Empty (N.iter 60 (processDivstep 0x25f260) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.

Lemma example70 : ZMap.Empty (N.iter 70 (processDivstep 0x1b6e641) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.

Lemma example80 : ZMap.Empty (N.iter 80 (processDivstep 0x13ff9d11) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.

Lemma example90 : ZMap.Empty (N.iter 90 (processDivstep 0xe5ffa818) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.

Lemma example100 : ZMap.Empty (N.iter 100 (processDivstep 0xa83fbaca2) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.

Lemma example120 : ZMap.Empty (N.iter 120 (processDivstep 0x5815434ee53) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.

Lemma example140 : ZMap.Empty (N.iter 140 (processDivstep 0x2e1e235b5b050) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.

Lemma example160 : ZMap.Empty (N.iter 160 (processDivstep 0x182ad45d1c9ceb3) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.

Lemma example180 : ZMap.Empty (N.iter 180 (processDivstep 0xcb846e4b7123c2e6) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.

Lemma example200 : ZMap.Empty (N.iter 200 (processDivstep 0x6b3e8fa3a7bf045de8) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.

Lemma example250 : ZMap.Empty (N.iter 250 (processDivstep 0x15627f2692a0950931661a2) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.

Lemma example300 : ZMap.Empty (N.iter 300 (processDivstep 0x444ef1442ed062b8a839c3f73b7) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.

Lemma example350 : ZMap.Empty (N.iter 350 (processDivstep 0xdb25c1822a251f32e577049b3ae0534) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.

Lemma example400 : ZMap.Empty (N.iter 400 (processDivstep 0x2bfb19d6f6a3c2c9f7958b69b1c1b4599b89) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.

Lemma example450 : ZMap.Empty (N.iter 450 (processDivstep 0x8d398ceaaafb27cf5dee5af890ad7f76079d8d94) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.

Lemma example500 : ZMap.Empty (N.iter 500 (processDivstep 0x1c37b0f2a381c18fcb128b22b449e871a7b2e91dd4597) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.

Lemma example600 : ZMap.Empty (N.iter 600 (processDivstep 0x11f38fa0335f159c3a401217b46582758aa53084bfe4fe57a7dbd9) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.


Require Import VST.floyd.proofauto.
Require Import VST.progs.evenodd.
Local Open Scope logic.

Inductive repr : Z -> val -> Prop :=
| mk_repr : forall z, z >= 0 -> repr z (Vint (Int.repr z)).

Lemma repr0_not_odd z n :
  repr z (Vint n) -> Int.eq n (Int.repr 0) = true -> Z.odd z = false.
Proof.
inversion 1; subst; intros A.
symmetry in A; apply binop_lemmas.int_eq_true in A.
rewrite A in H; inv H.
rewrite Int.Z_mod_modulus_eq, Zmod_divides in H0.
destruct H0 as [c H0]; rewrite H0, Z.odd_mul; auto.
unfold Int.modulus; simpl; intro Contra; inv Contra.
Qed.

Lemma repr0_even z n :
  repr z (Vint n) -> Int.eq n (Int.repr 0) = true -> Z.even z = true.
Proof.
inversion 1; subst; intros A.
symmetry in A; apply binop_lemmas.int_eq_true in A.
rewrite A in H; inv H.
rewrite Int.Z_mod_modulus_eq, Zmod_divides in H0.
destruct H0 as [c H0]; rewrite H0, Z.even_mul; auto.
unfold Int.modulus; simpl; intro Contra; inv Contra.
Qed.

Lemma repr_eq0_not0 z :
  Int.eq (Int.repr z) (Int.repr 0) = false -> z <> 0.
Proof.
intros H; generalize (Int.eq_spec (Int.repr z) (Int.repr 0)); rewrite H.
intros H2 H3; rewrite H3 in H2; apply H2; auto.
Qed.

Definition odd_spec :=
 DECLARE _odd
  WITH sh : share, z : Z, v : val
  PRE [ _n OF tuint] PROP(repr z v) LOCAL (`(eq v) (eval_id _n)) SEP ()
  POST [ tint ] local (`(eq (Vint (if Z.odd z then Int.one else Int.zero))) retval).

Definition even_spec :=
 DECLARE _even
  WITH z : Z, v : val
  PRE [ _n OF tuint] PROP(repr z v) LOCAL (`(eq v) (eval_id _n)) SEP ()
  POST [ tint ] local (`(eq (Vint (if Z.even z then Int.one else Int.zero))) retval).

Definition main_spec :=
 DECLARE _main
  WITH z : Z, v : val
  PRE [ ] PROP(repr 42 v) LOCAL () SEP ()
  POST [ tint ] local (`(eq (Vint (if Z.even 42 then Int.one else Int.zero))) retval).

Definition Vprog : varspecs := nil.

Definition Gprog : funspecs :=
     ltac:(with_library prog [ odd_spec; even_spec; main_spec]).

Lemma body_odd : semax_body Vprog Gprog f_odd odd_spec.
Proof.
start_function.
name n _n.
forward_if (PROP (repr z v /\ z > 0) LOCAL (`(eq v) (eval_id _n)) SEP ()).
* forward; eapply repr0_not_odd in H0; eauto; rewrite H0; entailer.
* forward; entailer; inv H.
  assert (z <> 0) by (apply repr_eq0_not0; auto); entailer.
* forward_call (z-1,Vint (Int.sub (Int.repr z) (Int.repr 1))).
  entailer; inversion H; subst z0; rewrite <-H5 in H2; inversion H2; subst n.
  entailer.
  assert (repr (z - 1) (Vint (Int.repr (z - 1)))).
  { clear -H H1. inv H. constructor. lia. }
  entailer!.
  after_call; forward.
  rewrite Z.even_sub; simpl.
  case_eq (Z.odd z); rewrite Zodd_even_bool;
   destruct (Z.even z); simpl; congruence.
Qed.

Lemma body_even : semax_body Vprog Gprog f_even even_spec.
Proof.
start_function.
name n _n.
forward_if (PROP (repr z v /\ z > 0) LOCAL (`(eq v) (eval_id _n)) SEP ()).
* forward. eapply repr0_even in H0; eauto; rewrite H0; entailer.
* forward; entailer; inv H.
  assert (z <> 0) by (apply repr_eq0_not0; auto); entailer.
* forward_call (Share.top,z-1,Vint (Int.sub (Int.repr z) (Int.repr 1))).
  entailer; inversion H; subst z0; rewrite <-H5 in H2; inversion H2; subst n.
  entailer.
  assert (repr (z - 1) (Vint (Int.repr (z - 1)))).
  { clear -H H1. inv H. constructor. lia. }
  entailer!.
  after_call; forward.
  rewrite Z.odd_sub; simpl.
  case_eq (Z.odd z); rewrite Zodd_even_bool;
   destruct (Z.even z); simpl; congruence.
Qed.

Lemma body_main : semax_body Vprog Gprog f_main main_spec.
Proof with (try solve[entailer!|entailer!; constructor; lia]).
start_function.
forward_call (42,Vint (Int.repr 42))... after_call.
forward.
Qed.

Lemma prog_correct:
  semax_prog prog tt Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons body_odd.
semax_func_cons body_even.
semax_func_cons body_main.
Qed.


(* Distributed under the terms of the MIT license. *)
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import uGraph Reflect.
From MetaCoq.PCUIC Require Import PCUICAst PCUICSize.

Require Import ssreflect.
From Equations Require Import Equations.
Set Equations Transparent.

Lemma eqb_annot_reflect {A} na na' : reflect (@eq_binder_annot A A na na') (eqb_binder_annot na na').
Proof.
  unfold eqb_binder_annot, eq_binder_annot.
  destruct Classes.eq_dec; constructor; auto.
Qed.

Definition string_of_aname (b : binder_annot name) :=
  string_of_name b.(binder_name).

Fixpoint string_of_term (t : term) :=
  match t with
  | tRel n => "Rel(" ^ string_of_nat n ^ ")"
  | tVar n => "Var(" ^ n ^ ")"
  | tEvar ev args => "Evar(" ^ string_of_nat ev ^ "," ^ string_of_list string_of_term args ^ ")"
  | tSort s => "Sort(" ^ string_of_sort s ^ ")"
  | tProd na b t => "Prod(" ^ string_of_aname na ^ "," ^
                            string_of_term b ^ "," ^ string_of_term t ^ ")"
  | tLambda na b t => "Lambda(" ^ string_of_aname na ^ "," ^ string_of_term b
                                ^ "," ^ string_of_term t ^ ")"
  | tLetIn na b t' t => "LetIn(" ^ string_of_aname na ^ "," ^ string_of_term b
                                 ^ "," ^ string_of_term t' ^ "," ^ string_of_term t ^ ")"
  | tApp f l => "App(" ^ string_of_term f ^ "," ^ string_of_term l ^ ")"
  | tConst c u => "Const(" ^ string_of_kername c ^ "," ^ string_of_universe_instance u ^ ")"
  | tInd i u => "Ind(" ^ string_of_inductive i ^ "," ^ string_of_universe_instance u ^ ")"
  | tConstruct i n u => "Construct(" ^ string_of_inductive i ^ "," ^ string_of_nat n ^ ","
                                    ^ string_of_universe_instance u ^ ")"
  | tCase ci p t brs =>
    "Case(" ^ string_of_case_info ci ^ "," ^ string_of_term t ^ ","
            ^ string_of_predicate string_of_term p ^ "," ^ string_of_list (string_of_branch string_of_term) brs ^ ")"
  | tProj p c =>
    "Proj(" ^ string_of_inductive p.(proj_ind) ^ "," ^ string_of_nat p.(proj_npars) ^ "," ^ string_of_nat p.(proj_arg) ^ ","
            ^ string_of_term c ^ ")"
  | tFix l n => "Fix(" ^ (string_of_list (string_of_def string_of_term) l) ^ "," ^ string_of_nat n ^ ")"
  | tCoFix l n => "CoFix(" ^ (string_of_list (string_of_def string_of_term) l) ^ "," ^ string_of_nat n ^ ")"
  | tPrim i => "Int(" ^ string_of_prim string_of_term i ^ ")"
  end.

Ltac change_Sk :=
  repeat match goal with
    | |- context [S (?x + ?y)] => progress change (S (x + y)) with (S x + y)
    | |- context [#|?l| + (?x + ?y)] => progress replace (#|l| + (x + y)) with ((#|l| + x) + y) by now rewrite Nat.add_assoc
  end.

Ltac solve_all_one :=
  try lazymatch goal with
  | H: tCasePredProp _ _ _ |- _ => destruct H as [? [? ?]]
  end;
  unfold tCaseBrsProp, tFixProp in *;
  autorewrite with map;
  rtoProp;
  try (
    apply map_predicate_eq_spec ||
    apply map_predicate_k_eq_spec ||
    apply map_predicate_id_spec ||
    apply map_predicate_k_id_spec ||
    apply map_branch_k_eq_spec ||
    apply map_branch_k_id_spec ||
    apply map_def_eq_spec ||
    apply map_def_id_spec ||
    apply map_branch_eq_spec ||
    apply map_branch_id_spec ||
    (eapply All_forallb_eq_forallb; [eassumption|]) ||
    (eapply mapi_context_eqP_test_id_spec; [eassumption|eassumption|]) ||
    (eapply mapi_context_eqP_spec; [eassumption|]) ||
    (eapply mapi_context_eqP_id_spec; [eassumption|]) ||
    (eapply onctx_test; [eassumption|eassumption|]) ||
    (eapply test_context_k_eqP_id_spec; [eassumption|eassumption|]) ||
    (eapply test_context_k_eqP_eq_spec; [eassumption|]) ||
    (eapply map_context_eq_spec; [eassumption|]));
  repeat toAll; try All_map; try close_Forall;
  change_Sk; auto with all;
  intuition eauto 4 with all.

Ltac solve_all := repeat (progress solve_all_one).
#[global] Hint Extern 10 => rewrite !map_branch_map_branch : all.
#[global] Hint Extern 10 => rewrite !map_predicate_map_predicate : all.

Lemma lookup_env_nil c s : lookup_global [] c = Some s -> False.
Proof.
  induction c; simpl; auto => //.
Qed.

Lemma lookup_env_cons {kn d Σ kn' d'} : lookup_global ((kn, d) :: Σ) kn' = Some d' ->
  (kn = kn' /\ d = d') \/ (kn <> kn' /\ lookup_global Σ kn' = Some d').
Proof.
  simpl.
  epose proof (ReflectEq.eqb_spec (A:=kername) kn' kn). simpl in H.
  elim: H. intros -> [= <-]; intuition auto.
  intros diff look. intuition auto.
Qed.

Lemma lookup_env_cons_fresh {kn d Σ kn'} :
  kn <> kn' ->
  lookup_global ((kn, d) :: Σ) kn' = lookup_global Σ kn'.
Proof.
  simpl.
  epose proof (ReflectEq.eqb_spec (A:=kername) kn' kn). simpl in H.
  elim: H. intros -> => //. auto.
Qed.

Fixpoint decompose_app_rec (t : term) l :=
  match t with
  | tApp f a => decompose_app_rec f (a :: l)
  | _ => (t, l)
  end.

Definition decompose_app t := decompose_app_rec t [].

Lemma mkApps_tApp f a l : mkApps (tApp f a) l = mkApps f (a :: l).
Proof. reflexivity. Qed.

Lemma tApp_mkApps f a : tApp f a = mkApps f [a].
Proof. reflexivity. Qed.

Definition mkApps_decompose_app_rec t l :
  mkApps t l = mkApps (fst (decompose_app_rec t l)) (snd (decompose_app_rec t l)).
Proof.
  revert l; induction t; try reflexivity.
  intro l; cbn in *.
  transitivity (mkApps t1 ((t2 ::l))). reflexivity.
  now rewrite IHt1.
Qed.

Definition mkApps_decompose_app t :
  t = mkApps (fst (decompose_app t)) (snd (decompose_app t))
  := mkApps_decompose_app_rec t [].

Lemma decompose_app_rec_mkApps f l l' : decompose_app_rec (mkApps f l) l' =
                                    decompose_app_rec f (l ++ l').
Proof.
  induction l in f, l' |- *; simpl; auto; rewrite IHl ?app_nil_r; auto.
Qed.

Require Import ssrbool.

Lemma decompose_app_mkApps f l :
  ~~ isApp f -> decompose_app (mkApps f l) = (f, l).
Proof.
  intros Hf. rewrite /decompose_app decompose_app_rec_mkApps. rewrite app_nil_r.
  destruct f; simpl in *; (discriminate || reflexivity).
Qed.

Lemma mkApps_app f l l' : mkApps f (l ++ l') = mkApps (mkApps f l) l'.
Proof.
  induction l in f, l' |- *; destruct l'; simpl; rewrite ?app_nil_r; auto.
  rewrite IHl //.
Qed.

Lemma mkApps_tApp_inj fn args t u :
  ~~ isApp fn ->
  mkApps fn args = tApp t u ->
  t = mkApps fn (removelast args) /\ u = last args t.
Proof.
  intros napp eqapp.
  destruct args using rev_case => //.
  simpl in eqapp. subst fn => //.
  rewrite mkApps_app in eqapp. noconf eqapp.
  now rewrite removelast_app // last_app // /= app_nil_r.
Qed.

Lemma removelast_length {A} (args : list A) : #|removelast args| = Nat.pred #|args|.
Proof.
  induction args => //. destruct args => //.
  now rewrite (removelast_app [_]) // app_length IHargs /=.
Qed.

Lemma nth_error_removelast {A} {args : list A} {n arg} :
  nth_error (removelast args) n = Some arg ->
  nth_error args n = Some arg.
Proof.
  intros h. rewrite nth_error_removelast //.
  apply nth_error_Some_length in h.
  now rewrite removelast_length in h.
Qed.

Lemma mkApps_discr f args t :
  args <> [] ->
  mkApps f args = t ->
  ~~ isApp t -> False.
Proof.
  intros.
  destruct args using rev_case => //.
  rewrite mkApps_app in H0. destruct t => //.
Qed.

Fixpoint decompose_prod (t : term) : (list aname) * (list term) * term :=
  match t with
  | tProd n A B => let (nAs, B) := decompose_prod B in
                  let (ns, As) := nAs in
                  (n :: ns, A :: As, B)
  | _ => ([], [], t)
  end.

Fixpoint remove_arity (n : nat) (t : term) : term :=
  match n with
  | O => t
  | S n => match t with
          | tProd _ _ B => remove_arity n B
          | _ => t (* TODO *)
          end
  end.

Definition isConstruct_app t :=
  match fst (decompose_app t) with
  | tConstruct _ _ _ => true
  | _ => false
  end.

(* was mind_decl_to_entry *)
Definition mind_body_to_entry (decl : mutual_inductive_body)
  : mutual_inductive_entry.
Proof.
  refine {| mind_entry_record := None; (* not a record *)
            mind_entry_finite := Finite; (* inductive *)
            mind_entry_params := _;
            mind_entry_inds := _;
            mind_entry_universes := decl.(ind_universes);
            mind_entry_private := None |}.
  - refine (match List.hd_error decl.(ind_bodies) with
            | Some i0 => _
            | None => nil (* assert false: at least one inductive in a mutual block *)
            end).
    pose (typ := decompose_prod i0.(ind_type)).
    destruct typ as [[names types] _].
    apply (List.firstn decl.(ind_npars)) in names.
    apply (List.firstn decl.(ind_npars)) in types.
    refine (map (fun '(x, ty) => vass x ty) (combine names types)).
  - refine (List.map _ decl.(ind_bodies)).
    intros [].
    refine {| mind_entry_typename := ind_name0;
              mind_entry_arity := remove_arity decl.(ind_npars) ind_type0;
              mind_entry_template := false;
              mind_entry_consnames := _;
              mind_entry_lc := _;
            |}.
    refine (List.map (fun x => cstr_name x) ind_ctors0).
    refine (List.map (fun x => remove_arity decl.(ind_npars)
                                                (cstr_type x)) ind_ctors0).
Defined.

Fixpoint decompose_prod_assum (Γ : context) (t : term) : context * term :=
  match t with
  | tProd n A B => decompose_prod_assum (Γ ,, vass n A) B
  | tLetIn na b bty b' => decompose_prod_assum (Γ ,, vdef na b bty) b'
  | _ => (Γ, t)
  end.

Lemma decompose_prod_assum_ctx ctx t : decompose_prod_assum ctx t =
  let (ctx', t') := decompose_prod_assum [] t in
  (ctx ,,, ctx', t').
Proof.
  induction t in ctx |- *; simpl; auto.
  - simpl. rewrite IHt2.
    rewrite (IHt2 ([] ,, vass _ _)).
    destruct (decompose_prod_assum [] t2). simpl.
    unfold snoc. now rewrite app_context_assoc.
  - simpl. rewrite IHt3.
    rewrite (IHt3 ([] ,, vdef _ _ _)).
    destruct (decompose_prod_assum [] t3). simpl.
    unfold snoc. now rewrite app_context_assoc.
Qed.

Fixpoint decompose_prod_n_assum (Γ : context) n (t : term) : option (context * term) :=
  match n with
  | 0 => Some (Γ, t)
  | S n =>
    match t with
    | tProd na A B => decompose_prod_n_assum (Γ ,, vass na A) n B
    | tLetIn na b bty b' => decompose_prod_n_assum (Γ ,, vdef na b bty) n b'
    | _ => None
    end
  end.

(* TODO move *)
Lemma it_mkLambda_or_LetIn_app l l' t :
  it_mkLambda_or_LetIn (l ++ l') t = it_mkLambda_or_LetIn l' (it_mkLambda_or_LetIn l t).
Proof. induction l in l', t |- *; simpl; auto. Qed.

Lemma decompose_prod_n_assum_it_mkProd ctx ctx' ty :
  decompose_prod_n_assum ctx #|ctx'| (it_mkProd_or_LetIn ctx' ty) = Some (ctx' ++ ctx, ty).
Proof.
  revert ctx ty. induction ctx' using rev_ind; move=> // ctx ty.
  rewrite app_length /= it_mkProd_or_LetIn_app /=.
  destruct x as [na [body|] ty'] => /=;
  now rewrite !Nat.add_1_r /= IHctx' -app_assoc.
Qed.

Definition is_ind_app_head t :=
  let (f, l) := decompose_app t in
  match f with
  | tInd _ _ => true
  | _ => false
  end.

Lemma is_ind_app_head_mkApps ind u l : is_ind_app_head (mkApps (tInd ind u) l).
Proof.
  unfold is_ind_app_head.
  unfold decompose_app. rewrite decompose_app_rec_mkApps. now simpl; trivial.
Qed.

Lemma decompose_prod_assum_it_mkProd ctx ctx' ty :
  is_ind_app_head ty ->
  decompose_prod_assum ctx (it_mkProd_or_LetIn ctx' ty) = (ctx' ++ ctx, ty).
Proof.
  revert ctx ty. induction ctx' using rev_ind; move=> // ctx ty /=.
  destruct ty; unfold is_ind_app_head; simpl; try (congruence || reflexivity).
  move=> Hty. rewrite it_mkProd_or_LetIn_app /=.
  case: x => [na [body|] ty'] /=; by rewrite IHctx' // /snoc -app_assoc.
Qed.

Lemma reln_length Γ Γ' n : #|reln Γ n Γ'| = #|Γ| + context_assumptions Γ'.
Proof.
  induction Γ' in n, Γ |- *; simpl; auto.
  destruct a as [? [b|] ?]; simpl; auto.
  rewrite Nat.add_1_r. simpl. rewrite IHΓ' => /= //.
Qed.

Lemma to_extended_list_k_length Γ n : #|to_extended_list_k Γ n| = context_assumptions Γ.
Proof.
  now rewrite /to_extended_list_k reln_length.
Qed.

Lemma reln_list_lift_above l p Γ :
  Forall (fun x => exists n, x = tRel n /\ p <= n /\ n < p + length Γ) l ->
  Forall (fun x => exists n, x = tRel n /\ p <= n /\ n < p + length Γ) (reln l p Γ).
Proof.
  generalize (Nat.le_refl p).
  generalize p at 1 3 5.
  induction Γ in p, l |- *. simpl. auto.
  intros. destruct a. destruct decl_body. simpl.
  assert(p0 <= S p) by lia.
  specialize (IHΓ l (S p) p0 H1). rewrite <- Nat.add_succ_comm, Nat.add_1_r.
  simpl in *. rewrite <- Nat.add_succ_comm in H0. eauto.
  simpl in *.
  specialize (IHΓ (tRel p :: l) (S p) p0 ltac:(lia)). rewrite <- Nat.add_succ_comm, Nat.add_1_r.
  eapply IHΓ. simpl in *. rewrite <- Nat.add_succ_comm in H0. auto.
  simpl in *.
  constructor. exists p. intuition lia. auto.
Qed.

Lemma to_extended_list_k_spec Γ k :
  Forall (fun x => exists n, x = tRel n /\ k <= n /\ n < k + length Γ) (to_extended_list_k Γ k).
Proof.
  pose (reln_list_lift_above [] k Γ).
  unfold to_extended_list_k.
  forward f. constructor. apply f.
Qed.

Lemma to_extended_list_lift_above Γ :
  Forall (fun x => exists n, x = tRel n /\ n < length Γ) (to_extended_list Γ).
Proof.
  pose (reln_list_lift_above [] 0 Γ).
  unfold to_extended_list.
  forward f. constructor. eapply Forall_impl; eauto. intros.
  destruct H; eexists; intuition eauto.
Qed.

Fixpoint reln_alt p (Γ : context) :=
  match Γ with
  | [] => []
  | {| decl_body := Some _ |} :: Γ => reln_alt (p + 1) Γ
  | {| decl_body := None |} :: Γ => tRel p :: reln_alt (p + 1) Γ
  end.

Lemma reln_alt_eq l Γ k : reln l k Γ = List.rev (reln_alt k Γ) ++ l.
Proof.
  induction Γ in l, k |- *; simpl; auto.
  destruct a as [na [body|] ty]; simpl.
  now rewrite IHΓ.
  now rewrite IHΓ -app_assoc.
Qed.

Lemma to_extended_list_k_cons d Γ k :
  to_extended_list_k (d :: Γ) k =
  match d.(decl_body) with
  | None => to_extended_list_k Γ (S k) ++ [tRel k]
  | Some b => to_extended_list_k Γ (S k)
  end.
Proof.
  rewrite /to_extended_list_k reln_alt_eq. simpl.
  destruct d as [na [body|] ty]. simpl.
  now rewrite reln_alt_eq Nat.add_1_r.
  simpl. rewrite reln_alt_eq.
  now rewrite -app_assoc !app_nil_r Nat.add_1_r.
Qed.

Ltac merge_All :=
  unfold tFixProp, tCaseBrsProp in *;
  repeat toAll.

#[global]
Hint Rewrite @map_def_id @map_id : map.

(* TODO move *)
Ltac close_All :=
  match goal with
  | H : Forall _ _ |- Forall _ _ => apply (Forall_impl H); clear H; simpl
  | H : All _ _ |- All _ _ => apply (All_impl H); clear H; simpl
  | H : OnOne2 _ _ _ |- OnOne2 _ _ _ => apply (OnOne2_impl H); clear H; simpl
  | H : All2 _ _ _ |- All2 _ _ _ => apply (All2_impl H); clear H; simpl
  | H : Forall2 _ _ _ |- Forall2 _ _ _ => apply (Forall2_impl H); clear H; simpl
  | H : All _ _ |- All2 _ _ _ =>
    apply (All_All2 H); clear H; simpl
  | H : All2 _ _ _ |- All _ _ =>
    (apply (All2_All_left H) || apply (All2_All_right H)); clear H; simpl
  end.

Lemma mkApps_inj :
  forall u v l,
    mkApps u l = mkApps v l ->
    u = v.
Proof.
  intros u v l eq.
  revert u v eq.
  induction l ; intros u v eq.
  - cbn in eq. assumption.
  - cbn in eq. apply IHl in eq.
    inversion eq. reflexivity.
Qed.

Lemma isApp_mkApps :
  forall u l,
    isApp u ->
    isApp (mkApps u l).
Proof.
  intros u l h.
  induction l in u, h |- *.
  - cbn. assumption.
  - cbn. apply IHl. reflexivity.
Qed.

Lemma decompose_app_rec_notApp :
  forall t l u l',
    decompose_app_rec t l = (u, l') ->
    isApp u = false.
Proof.
  intros t l u l' e.
  induction t in l, u, l', e |- *.
  all: try (cbn in e ; inversion e ; reflexivity).
  cbn in e. eapply IHt1. eassumption.
Qed.

Lemma decompose_app_notApp :
  forall t u l,
    decompose_app t = (u, l) ->
    isApp u = false.
Proof.
  intros t u l e.
  eapply decompose_app_rec_notApp. eassumption.
Qed.

Lemma decompose_app_rec_inv {t l' f l} :
  decompose_app_rec t l' = (f, l) ->
  mkApps t l' = mkApps f l.
Proof.
  induction t in f, l', l |- *; try intros [= <- <-]; try reflexivity.
  simpl. apply/IHt1.
Qed.

Lemma decompose_app_inv {t f l} :
  decompose_app t = (f, l) -> t = mkApps f l.
Proof. by apply/decompose_app_rec_inv. Qed.

Lemma decompose_app_nonnil t f l :
  isApp t ->
  decompose_app t = (f, l) -> l <> [].
Proof.
  intros isApp.
  destruct t; simpl => //.
  intros da.
  pose proof (decompose_app_notApp _ _ _ da).
  apply decompose_app_inv in da.
  destruct l using rev_ind.
  unfold decompose_app => /=.
  destruct f => //.
  destruct l => //.
Qed.

Fixpoint nApp t :=
  match t with
  | tApp u _ => S (nApp u)
  | _ => 0
  end.

Lemma isApp_false_nApp :
  forall u,
    isApp u = false ->
    nApp u = 0.
Proof.
  intros u h.
  destruct u.
  all: try reflexivity.
  discriminate.
Qed.

Lemma nApp_mkApps :
  forall t l,
    nApp (mkApps t l) = nApp t + #|l|.
Proof.
  intros t l.
  induction l in t |- *.
  - simpl. lia.
  - simpl. rewrite IHl. cbn. lia.
Qed.

Lemma decompose_app_eq_mkApps :
  forall t u l l',
    decompose_app t = (mkApps u l', l) ->
    l' = [].
Proof.
  intros t u l l' e.
  apply decompose_app_notApp in e.
  apply isApp_false_nApp in e.
  rewrite nApp_mkApps in e.
  destruct l' ; cbn in e ; try lia.
  reflexivity.
Qed.

Lemma mkApps_nApp_inj :
  forall u u' l l',
    nApp u = nApp u' ->
    mkApps u l = mkApps u' l' ->
    u = u' /\ l = l'.
Proof.
  intros u u' l l' h e.
  induction l in u, u', l', h, e |- *.
  - cbn in e. subst.
    destruct l' ; auto.
    exfalso.
    rewrite nApp_mkApps in h. cbn in h. lia.
  - destruct l'.
    + cbn in e. subst. exfalso.
      rewrite nApp_mkApps in h. cbn in h. lia.
    + cbn in e. apply IHl in e.
      * destruct e as [e1 e2].
        inversion e1. subst. auto.
      * cbn. f_equal. auto.
Qed.

Lemma mkApps_notApp_inj :
  forall u u' l l',
    isApp u = false ->
    isApp u' = false ->
    mkApps u l = mkApps u' l' ->
    u = u' /\ l = l'.
Proof.
  intros u u' l l' h h' e.
  eapply mkApps_nApp_inj.
  - rewrite -> 2!isApp_false_nApp by assumption. reflexivity.
  - assumption.
Qed.

Definition head x := (decompose_app x).1.
Definition arguments x := (decompose_app x).2.

Lemma head_arguments x : mkApps (head x) (arguments x) = x.
Proof.
  unfold head, arguments, decompose_app.
  remember (decompose_app_rec x []).
  destruct p as [f l].
  symmetry in Heqp.
  eapply decompose_app_rec_inv in Heqp.
  now simpl in *.
Qed.

Lemma fst_decompose_app_rec t l : fst (decompose_app_rec t l) = fst (decompose_app t).
Proof.
  induction t in l |- *; simpl; auto. rewrite IHt1.
  unfold decompose_app. simpl. now rewrite (IHt1 [t2]).
Qed.

Lemma decompose_app_rec_head t l f : fst (decompose_app_rec t l) = f ->
  negb (isApp f).
Proof.
  induction t; unfold isApp; simpl; try intros [= <-]; auto.
  intros. apply IHt1. now rewrite !fst_decompose_app_rec.
Qed.

Lemma head_nApp x : negb (isApp (head x)).
Proof.
  unfold head.
  eapply decompose_app_rec_head. reflexivity.
Qed.

Lemma head_tapp t1 t2 : head (tApp t1 t2) = head t1.
Proof. rewrite /head /decompose_app /= fst_decompose_app_rec //. Qed.

Lemma mkApps_Fix_spec mfix idx args t : mkApps (tFix mfix idx) args = t ->
                                        match decompose_app t with
                                        | (tFix mfix idx, args') => args' = args
                                        | _ => False
                                        end.
Proof.
  intros H; apply (f_equal decompose_app) in H.
  rewrite decompose_app_mkApps in H. reflexivity.
  destruct t; noconf H. rewrite <- H. reflexivity.
  simpl. reflexivity.
Qed.

Lemma decompose_app_rec_tFix mfix idx args t l :
  decompose_app_rec t l = (tFix mfix idx, args) -> mkApps t l = mkApps (tFix mfix idx) args.
Proof.
  unfold decompose_app.
  revert l args.
  induction t; intros args l' H; noconf H. simpl in H.
  now specialize (IHt1 _ _ H).
  reflexivity.
Qed.

Lemma decompose_app_tFix mfix idx args t :
  decompose_app t = (tFix mfix idx, args) -> t = mkApps (tFix mfix idx) args.
Proof. apply decompose_app_rec_tFix. Qed.

Lemma mkApps_eq_head {x l} : mkApps x l = x -> l = [].
Proof.
  assert (WF : WellFounded (precompose lt PCUICSize.size))
    by apply wf_precompose, lt_wf.
  induction l. simpl. constructor.
  apply apply_noCycle_right. simpl. red. rewrite size_mkApps. simpl. lia.
Qed.

Lemma mkApps_eq_inv {x y l} : x = mkApps y l -> size y <= size x.
Proof.
  assert (WF : WellFounded (precompose lt size))
    by apply wf_precompose, lt_wf.
  induction l in x, y |- *. simpl. intros -> ; constructor.
  simpl. intros. specialize (IHl _ _ H). simpl in IHl. lia.
Qed.

Lemma mkApps_eq_left x y l : mkApps x l = mkApps y l -> x = y.
Proof.
  induction l in x, y |- *; simpl. auto.
  intros. simpl in *. specialize (IHl _ _ H). now noconf IHl.
Qed.

Lemma decompose_app_eq_right t l l' : decompose_app_rec t l = decompose_app_rec t l' -> l = l'.
Proof.
  induction t in l, l' |- *; simpl; intros [=]; auto.
  specialize (IHt1 _ _ H0). now noconf IHt1.
Qed.

Lemma mkApps_eq_right t l l' : mkApps t l = mkApps t l' -> l = l'.
Proof.
  intros. eapply (f_equal decompose_app) in H. unfold decompose_app in H.
  rewrite !decompose_app_rec_mkApps in H. apply decompose_app_eq_right in H.
  now rewrite !app_nil_r in H.
Qed.

Lemma atom_decompose_app t l : ~~ isApp t -> decompose_app_rec t l = pair t l.
Proof. destruct t; simpl; congruence. Qed.

Lemma mkApps_eq_inj {t t' l l'} :
  mkApps t l = mkApps t' l' ->
  ~~ isApp t -> ~~ isApp t' -> t = t' /\ l = l'.
Proof.
  intros Happ Ht Ht'. eapply (f_equal decompose_app) in Happ. unfold decompose_app in Happ.
  rewrite !decompose_app_rec_mkApps in Happ. rewrite !atom_decompose_app in Happ; auto.
  rewrite !app_nil_r in Happ. intuition congruence.
Qed.

Ltac solve_discr' :=
  match goal with
    H : mkApps _ _ = mkApps ?f ?l |- _ =>
    eapply mkApps_eq_inj in H as [? ?]; [|easy|easy]; subst; try intuition congruence
  | H : ?t = mkApps ?f ?l |- _ =>
    change t with (mkApps t []) in H ;
    eapply mkApps_eq_inj in H as [? ?]; [|easy|easy]; subst; try intuition congruence
  | H : mkApps ?f ?l = ?t |- _ =>
    change t with (mkApps t []) in H ;
    eapply mkApps_eq_inj in H as [? ?]; [|easy|easy]; subst; try intuition congruence
  end.

Lemma mkApps_eq_decompose_app {t t' l l'} :
  mkApps t l = mkApps t' l' ->
  decompose_app_rec t l = decompose_app_rec t' l'.
Proof.
  induction l in t, t', l' |- *; simpl.
  - intros ->. rewrite !decompose_app_rec_mkApps.
    now rewrite app_nil_r.
  - intros H. apply (IHl _ _ _ H).
Qed.

Lemma mkApps_eq_decompose {f args t} :
  mkApps f args = t ->
  ~~ isApp f ->
  fst (decompose_app t) = f.
Proof.
  intros H Happ; apply (f_equal decompose_app) in H.
  rewrite decompose_app_mkApps in H. auto. rewrite <- H. reflexivity.
Qed.

Ltac finish_discr :=
  repeat match goal with
         | [ H : ?x = ?x |- _ ] => clear H
         | [ H : mkApps _ _ = mkApps _ _ |- _ ] =>
           let H0 := fresh in let H1 := fresh in
                              specialize (mkApps_eq_inj H eq_refl eq_refl) as [H0 H1];
                              clear H;
                              try (congruence || (noconf H0; noconf H1))
         | [ H : mkApps _ _ = _ |- _ ] => apply mkApps_eq_head in H
         end.

Ltac prepare_discr :=
  repeat match goal with
         | [ H : mkApps ?f ?l = tApp ?y ?r |- _ ] => change (mkApps f l = mkApps y [r]) in H
         | [ H : tApp ?f ?l = mkApps ?y ?r |- _ ] => change (mkApps f [l] = mkApps y r) in H
         | [ H : mkApps ?x ?l = ?y |- _ ] =>
           match y with
           | mkApps _ _ => fail 1
           | _ => change (mkApps x l = mkApps y []) in H
           end
         | [ H : ?x = mkApps ?y ?l |- _ ] =>
           match x with
           | mkApps _ _ => fail 1
           | _ => change (mkApps x [] = mkApps y l) in H
           end
         end.

Inductive mkApps_spec : term -> list term -> term -> list term -> term -> Type :=
| mkApps_intro f l n :
    ~~ isApp f ->
    mkApps_spec f l (mkApps f (firstn n l)) (skipn n l) (mkApps f l).

Lemma decompose_app_rec_eq f l :
  ~~ isApp f ->
  decompose_app_rec f l = (f, l).
Proof.
  destruct f; simpl; try discriminate; congruence.
Qed.

Lemma decompose_app_rec_inv' f l hd args :
  decompose_app_rec f l = (hd, args) ->
  ∑ n, ~~ isApp hd /\ l = skipn n args /\ f = mkApps hd (firstn n args).
Proof.
  destruct (isApp f) eqn:Heq.
  revert l args hd.
  induction f; try discriminate. intros.
  simpl in H.
  destruct (isApp f1) eqn:Hf1.
  2:{ rewrite decompose_app_rec_eq in H => //. now apply negbT.
      revert Hf1.
      inv H. exists 1. simpl. intuition auto. now eapply negbT. }
  destruct (IHf1 eq_refl _ _ _ H).
  clear IHf1.
  exists (S x); intuition auto. eapply (f_equal (skipn 1)) in H2.
  rewrite [l]H2. now rewrite skipn_skipn Nat.add_1_r.
  rewrite -Nat.add_1_r firstn_add H3 -H2.
  now rewrite -[tApp _ _](mkApps_app hd _ [f2]).
  rewrite decompose_app_rec_eq; auto. now apply negbT.
  move=> [] H ->. subst f. exists 0. intuition auto.
  now apply negbT.
Qed.

Lemma mkApps_elim_rec t l l' :
  let app' := decompose_app_rec (mkApps t l) l' in
  mkApps_spec app'.1 app'.2 t (l ++ l') (mkApps t (l ++ l')).
Proof.
  destruct app' as [hd args] eqn:Heq.
  subst app'.
  rewrite decompose_app_rec_mkApps in Heq.
  have H := decompose_app_rec_inv' _ _ _ _ Heq.
  destruct H. simpl. destruct a as [isapp [Hl' Hl]].
  subst t.
  have H' := mkApps_intro hd args x. rewrite Hl'.
  rewrite -mkApps_app. now rewrite firstn_skipn.
Qed.

Lemma mkApps_elim t l  :
  let app' := decompose_app (mkApps t l) in
  mkApps_spec app'.1 app'.2 t l (mkApps t l).
Proof.
  have H := @mkApps_elim_rec t l [].
  now rewrite app_nil_r in H.
Qed.

Lemma nisApp_mkApps {t l} : ~~ isApp (mkApps t l) -> ~~ isApp t /\ l = [].
Proof.
  induction l in t |- *; simpl; auto.
  intros. destruct (IHl _ H). discriminate.
Qed.

Lemma mkApps_nisApp {t t' l} : mkApps t l = t' -> ~~ isApp t' -> t = t' /\ l = [].
Proof.
  induction l in t |- *; simpl; auto.
  intros. destruct (IHl _ H). auto. subst. simpl in H0. discriminate.
Qed.

Lemma tApp_mkApps_inj f a f' l :
  tApp f a = mkApps f' l -> l <> [] ->
  f = mkApps f' (removelast l) /\ (a = last l a).
Proof.
  induction l in f' |- *; simpl; intros H. noconf H. intros Hf. congruence.
  intros . destruct l; simpl in *. now noconf H.
  specialize (IHl _ H). forward IHl by congruence.
  apply IHl.
Qed.

Definition application_atom t :=
  match t with
  | tVar _
  | tSort _
  | tInd _ _
  | tConstruct _ _ _
  | tLambda _ _ _ => true
  | _ => false
  end.

Lemma application_atom_mkApps {t l} : application_atom (mkApps t l) -> application_atom t /\ l = [].
Proof.
  induction l in t |- *; simpl; auto.
  intros. destruct (IHl _ H). discriminate.
Qed.

Ltac solve_discr :=
  (try (progress (prepare_discr; finish_discr; cbn [mkApps] in * )));
  (try (match goal with
        | [ H : is_true (application_atom _) |- _ ] => discriminate
        | [ H : is_true (application_atom (mkApps _ _)) |- _ ] =>
          destruct (application_atom_mkApps H); subst; try discriminate
        end)).

(** Use a coercion for this common projection of the global context. *)
Definition fst_ctx : global_env_ext -> global_env := fst.
Coercion fst_ctx : global_env_ext >-> global_env.

Definition empty_ext (Σ : global_env) : global_env_ext
  := (Σ, Monomorphic_ctx).

Lemma destArity_app_aux {Γ Γ' t}
  : destArity (Γ ,,, Γ') t = option_map (fun '(ctx, s) => (Γ ,,, ctx, s))
                                        (destArity Γ' t).
Proof.
  revert Γ'.
  induction t; cbn; intro Γ'; try reflexivity.
  - rewrite <- app_context_cons. now eapply IHt2.
  - rewrite <- app_context_cons. now eapply IHt3.
Qed.

Lemma destArity_app {Γ t}
  : destArity Γ t = option_map (fun '(ctx, s) => (Γ ,,, ctx, s))
                               (destArity [] t).
Proof.
  exact (@destArity_app_aux Γ [] t).
Qed.

Lemma destArity_app_Some {Γ t ctx s}
  : destArity Γ t = Some (ctx, s)
    -> ∑ ctx', destArity [] t = Some (ctx', s) /\ ctx = Γ ,,, ctx'.
Proof.
  intros H. rewrite destArity_app in H.
  destruct (destArity [] t) as [[ctx' s']|]; cbn in *.
  exists ctx'. inversion H. now subst.
  discriminate H.
Qed.

Lemma destArity_it_mkProd_or_LetIn ctx ctx' t :
  destArity ctx (it_mkProd_or_LetIn ctx' t) =
  destArity (ctx ,,, ctx') t.
Proof.
  induction ctx' in ctx, t |- *; simpl; auto.
  rewrite IHctx'. destruct a as [na [b|] ty]; reflexivity.
Qed.

Lemma mkApps_nonempty f l :
  l <> [] -> mkApps f l = tApp (mkApps f (removelast l)) (last l f).
Proof.
  destruct l using rev_ind. intros; congruence.
  intros. rewrite mkApps_app. simpl. f_equal.
  rewrite removelast_app. congruence. simpl. now rewrite app_nil_r.
  rewrite last_app. congruence.
  reflexivity.
Qed.

Lemma destArity_tFix {mfix idx args} :
  destArity [] (mkApps (tFix mfix idx) args) = None.
Proof.
  induction args. reflexivity.
  rewrite mkApps_nonempty.
  intros e; discriminate e.
  reflexivity.
Qed.

Lemma destArity_tApp {t u l} :
  destArity [] (mkApps (tApp t u) l) = None.
Proof.
  induction l. reflexivity.
  rewrite mkApps_nonempty.
  intros e; discriminate e.
  reflexivity.
Qed.

Lemma destArity_tInd {t u l} :
  destArity [] (mkApps (tInd t u) l) = None.
Proof.
  induction l. reflexivity.
  rewrite mkApps_nonempty.
  intros e; discriminate e.
  reflexivity.
Qed.

Lemma destArity_mkApps_None ctx t l :
  destArity ctx t = None -> destArity ctx (mkApps t l) = None.
Proof.
  induction l in t |- *. trivial.
  intros H. cbn. apply IHl. reflexivity.
Qed.

Lemma destArity_mkApps_Ind ctx ind u l :
  destArity ctx (mkApps (tInd ind u) l) = None.
Proof.
  apply destArity_mkApps_None. reflexivity.
Qed.

(* Helper for nested recursive functions on well-typed terms *)

Section MapInP.
  Context {A B : Type}.
  Context {P : A -> Type}.
  Context (f : forall (x : A), P x -> B).

  Equations map_InP (l : list A) (H : forall x, In x l -> P x) : list B :=
  map_InP nil _ := nil;
  map_InP (cons x xs) H := cons (f x (H x (or_introl eq_refl))) (map_InP xs (fun x inx => H x _)).
End MapInP.

Lemma map_InP_spec {A B : Type} {P : A -> Type} (f : A -> B) (l : list A) (H : forall x, In x l -> P x) :
  map_InP (fun (x : A) (_ : P x) => f x) l H = List.map f l.
Proof.
  remember (fun (x : A) (_ : P x) => f x) as g.
  funelim (map_InP g l H) => //; simpl. f_equal.
  now rewrite H0.
Qed.

Lemma nth_error_map_InP {A B : Type} {P : A -> Type} (f : forall x : A, P x -> B) (l : list A) (H : forall x, In x l -> P x) n x :
  nth_error (map_InP f l H) n = Some x ->
  ∑ a, (nth_error l n = Some a) *
  ∑ p : P a, x = f a p.
Proof.
  induction l in n, H |- *. simpl. rewrite nth_error_nil => //.
  destruct n; simpl; intros [=].
  subst x.
  eexists; intuition eauto.
  eapply IHl. eapply H1.
Qed.

Lemma map_InP_length {A B : Type} {P : A -> Type} (f : forall x : A, P x -> B) (l : list A) (H : forall x, In x l -> P x) :
  #|map_InP f l H| = #|l|.
Proof.
  induction l; simpl; auto.
Qed.
#[global]
Hint Rewrite @map_InP_length : len.

(** Views *)

Definition isSort T :=
  match T with
  | tSort u => true
  | _ => false
  end.

Inductive view_sort : term -> Type :=
| view_sort_sort s : view_sort (tSort s)
| view_sort_other t : ~ isSort t -> view_sort t.

Equations view_sortc (t : term) : view_sort t :=
  view_sortc (tSort s) := view_sort_sort s;
  view_sortc t := view_sort_other t _.

Definition isProd t :=
  match t with
  | tProd na A B => true
  | _ => false
  end.

Inductive view_prod : term -> Type :=
| view_prod_prod na A b : view_prod (tProd na A b)
| view_prod_other t : ~ isProd t -> view_prod t.

Equations view_prodc (t : term) : view_prod t :=
  view_prodc (tProd na A b) := view_prod_prod na A b;
  view_prodc t := view_prod_other t _.

Definition isInd (t : term) : bool :=
  match t with
  | tInd _ _ => true
  | _ => false
  end.

Inductive view_ind : term -> Type :=
| view_ind_tInd ind u : view_ind (tInd ind u)
| view_ind_other t : negb (isInd t) -> view_ind t.

Equations view_indc (t : term) : view_ind t :=
  view_indc (tInd ind u) => view_ind_tInd ind u;
  view_indc t => view_ind_other t _.

Inductive view_prod_sort : term -> Type :=
| view_prod_sort_prod na A B : view_prod_sort (tProd na A B)
| view_prod_sort_sort u : view_prod_sort (tSort u)
| view_prod_sort_other t :
    ~isProd t ->
    ~isSort t ->
    view_prod_sort t.

Equations view_prod_sortc (t : term) : view_prod_sort t := {
  | tProd na A B => view_prod_sort_prod na A B;
  | tSort u => view_prod_sort_sort u;
  | t => view_prod_sort_other t _ _
  }.

Lemma nth_error_ass_subst_context s k Γ :
  (forall n d, nth_error Γ n = Some d -> decl_body d = None) ->
  forall n d, nth_error (subst_context s k Γ) n = Some d -> decl_body d = None.
Proof.
  induction Γ as [|[? [] ?] ?] in |- *; simpl; auto;
  intros; destruct n; simpl in *; rewrite ?subst_context_snoc in H0; simpl in H0.
  - noconf H0; simpl.
    specialize (H 0 _ eq_refl). simpl in H; discriminate.
  - specialize (H 0 _ eq_refl). simpl in H; discriminate.
  - noconf H0; simpl. auto.
  - eapply IHΓ; intros; eauto.
    now specialize (H (S n0) d0 H1).
Qed.

Lemma nth_error_smash_context Γ Δ :
  (forall n d, nth_error Δ n = Some d -> decl_body d = None) ->
  forall n d, nth_error (smash_context Δ Γ) n = Some d -> decl_body d = None.
Proof.
  induction Γ as [|[? [] ?] ?] in Δ |- *; simpl; auto.
  - intros. eapply (IHΓ (subst_context [t] 0 Δ)); tea.
    now apply nth_error_ass_subst_context.
  - intros. eapply IHΓ. 2:eauto.
    intros.
    pose proof (nth_error_Some_length H1). autorewrite with len in H2. simpl in H2.
    destruct (eq_dec n0 #|Δ|).
    * subst.
      rewrite nth_error_app_ge in H1; try lia.
      rewrite Nat.sub_diag /= in H1. noconf H1.
      reflexivity.
    * rewrite nth_error_app_lt in H1; try lia. eauto.
Qed.

Lemma context_assumptions_smash_context Δ Γ :
  context_assumptions (smash_context Δ Γ) =
  context_assumptions Δ + context_assumptions Γ.
Proof.
  induction Γ as [|[? [] ?] ?] in Δ |- *; simpl; auto;
  rewrite IHΓ.
  - now rewrite context_assumptions_fold.
  - rewrite context_assumptions_app /=. lia.
Qed.

Lemma context_assumptions_expand_lets_ctx Γ Δ :
  context_assumptions (expand_lets_ctx Γ Δ) = context_assumptions Δ.
Proof. now rewrite /expand_lets_ctx /expand_lets_k_ctx; len. Qed.
#[global]
Hint Rewrite context_assumptions_expand_lets_ctx : len.


Require Import TM.Prelim TM.TM.

(** * 0-tape Turing machine that does nothing. *)

Section Mono_Nop.

  Variable sig : finType.

  Definition NullTM : mTM sig 0 :=
    {|
      trans := fun '(q, s) => (q, Vector.nil _);
      start := tt;
      halt _ := true;
    |}.

  Definition Null : pTM sig unit 0 := (NullTM; fun _ => tt).

  Definition Null_Rel : pRel sig unit 0 :=
    ignoreParam (fun t t' => True).

  Lemma Null_Sem: Null ⊨c(0) Null_Rel.
  Proof. intros t. cbn. unfold initc; cbn. eexists (mk_mconfig _ _); cbn; eauto. Qed.

End Mono_Nop.

Arguments Null : simpl never.
Arguments Null {sig}.
Arguments Null_Rel { sig } x y / : rename.

(** ** Tactic Support *)

Ltac smpl_TM_Null :=
  lazymatch goal with
  | [ |- Null ⊨ _] => eapply RealiseIn_Realise; eapply Null_Sem
  | [ |- Null ⊨c(_) _] => eapply Null_Sem
  | [ |- projT1 (Null) ↓ _] => eapply RealiseIn_TerminatesIn; eapply Null_Sem
  end.

Smpl Add smpl_TM_Null : TM_Correct.


(** * Leaves of an Interaction Tree *)

(* begin hide *)
From ITree Require Import
     Basics.Tacs
     Basics.HeterogeneousRelations
     ITree
     Eq.Shallow
     Eq.Eqit
     Interp.InterpFacts
     Events.State
     Events.StateFacts
     Props.HasPost.

From Paco Require Import paco.
From Coq Require Import Morphisms Basics Program.Equality.
Import ITree.
Import ITreeNotations.
(* end hide *)

(** ** Leaves of itrees *)

(** The [Leaf a t] predicate expresses that [t] has a [Ret] leaf with
    value [a].

    We provide the elementary structural lemmas to work with this
    predicate, and one main useful result relying on [Leaf]: the
    up-to bind closure [eqit_bind_clo] can be refined such that
    continuations need only be related over the leaves of the
    first operand of [bind].
    *)

Inductive Leaf {E} {A: Type} (a: A) : itree E A -> Prop :=
 | LeafRet: forall t,
   observe t = RetF a ->
   Leaf a t
 | LeafTau: forall t u,
   observe t = TauF u ->
   Leaf a u ->
   Leaf a t
 | LeafVis: forall {X} (e: E X) t k x,
   observe t = VisF e k ->
   Leaf a (k x) ->
   Leaf a t
.
#[global] Hint Constructors Leaf : itree.

Module LeafNotations.
  Notation "a ∈ t" := (Leaf a t) (at level 70).
End LeafNotations.

Import LeafNotations.

(** Smart constructors *)

Lemma Leaf_Ret : forall E R a,
  a ∈ (Ret a : itree E R).
Proof.
  intros; econstructor; reflexivity.
Qed.

Lemma Leaf_Tau : forall E R a t,
  a ∈ (t : itree E R) ->
  a ∈ Tau t.
Proof.
  intros; econstructor; [reflexivity | eauto].
Qed.

Lemma Leaf_Vis : forall E X Y (e : E X) (k : _ -> itree E Y) b x,
  b ∈ (k x) ->
  b ∈ (Vis e k).
Proof.
  intros * IN; econstructor 3; [reflexivity | eauto].
Qed.

(** Inversion lemmas *)
Lemma Leaf_Ret_inv : forall E R (a b : R),
  Leaf (E := E) b (Ret a) ->
  b = a.
Proof.
  intros * IN; inv IN; cbn in *; try congruence.
Qed.

Lemma Leaf_Tau_inv : forall E R (u : itree E R) b,
  b ∈ Tau u ->
  b ∈ u.
Proof.
  intros * IN; inv IN; cbn in *; try congruence.
Qed.

Lemma Leaf_Vis_inv : forall E X Y (e : E X) (k : _ -> itree E Y) b,
  b ∈ Vis e k ->
  exists x, b ∈ k x.
Proof.
  intros * IN *; inv IN; cbn in *; try congruence.
  revert x H0.
  refine (match H in _ = u return match u with VisF e0 k0 => _ | RetF _ | TauF _ => False end with eq_refl => _ end).
  eauto.
Qed.

(** Closure under [eutt]

  General asymmetric lemmas for [eutt R], where we naturally get
  a different point related by [R], and [Proper] instances for
  [eutt eq]. *)

Lemma Leaf_eutt_l {E A B R}:
  forall (t : itree E A) (u : itree E B) (a : A),
  eutt R t u ->
  a ∈ t ->
  exists b, b ∈ u /\ R a b.
Proof.
  intros * EQ FIN;
  revert u EQ.
  induction FIN; intros u2 EQ.
  - punfold EQ.
    red in EQ; rewrite H in EQ; clear H t.
    remember (RetF a); genobs u2 ou.
    hinduction EQ before R; intros; try now discriminate.
    + inv Heqi; eauto with itree.
    + edestruct IHEQ as (b & IN & HR); eauto with itree.
  - punfold EQ; red in EQ; rewrite H in EQ; clear H t.
    remember (TauF u); genobs u2 ou2.
    hinduction EQ before R; intros; try discriminate; pclearbot; inv Heqi.
    + edestruct IHFIN as (? & ? & ?); [ .. | eexists ]; eauto with itree.
    + eauto with itree.
    + edestruct IHEQ as (? & ? & ?); [ .. | eexists ]; eauto with itree.
  - punfold EQ; red in EQ; rewrite H in EQ; clear H t.
    remember (VisF e k); genobs u2 ou2.
    hinduction EQ before R; intros; try discriminate; pclearbot.
    + revert x FIN IHFIN.
      refine (match Heqi in _ = u return match u with VisF e0 k0 => _ | RetF _ | TauF _ => False end with eq_refl => _ end).
      intros. edestruct IHFIN as (? & ? & ?); [ | eexists ]; eauto with itree.
    + edestruct IHEQ as (? & ? & ?); [.. | exists x0 ]; eauto with itree.
Qed.

Lemma Leaf_eutt_r {E A B R}:
  forall (t : itree E A) (u : itree E B) (b : B),
  eutt R t u ->
  b ∈ u ->
  exists a, a ∈ t /\ R a b.
Proof.
  intros * EQ FIN.
  apply eqit_flip in EQ.
  revert EQ FIN.
  apply @Leaf_eutt_l.
Qed.

#[global] Instance Leaf_eutt {E A}:
  Proper (eq ==> eutt eq ==> iff) (@Leaf E A).
Proof.
  apply proper_sym_impl_iff_2; [ exact _ .. | ].
  unfold Proper, respectful, impl. intros; subst.
  edestruct @Leaf_eutt_l as [? []]; try eassumption; subst; assumption.
Qed.

(** Compatibility with [bind], forward and backward *)

Lemma Leaf_bind : forall {E R S}
  (t : itree E R) (k : R -> itree E S) a b,
  b ∈ t ->
  a ∈ k b ->
  a ∈ t >>= k.
Proof.
  intros * INt INk; induction INt.
  - rewrite (itree_eta t), H, bind_ret_l; auto.
  - rewrite (itree_eta t), H, tau_eutt; auto.
  - rewrite (itree_eta t), H, bind_vis.
    apply Leaf_Vis with x; auto.
Qed.

Lemma Leaf_bind_inv : forall {E R S}
  (t : itree E R) (k : R -> itree E S) a,
  a ∈ t >>= k ->
  exists b, b ∈ t /\ a ∈ k b.
Proof.
  intros * FIN;
  remember (ITree.bind t k) as u.
  revert t k Hequ.
  induction FIN; intros t' k' ->; rename t' into t.
  - unfold observe in H; cbn in H.
    desobs t EQ; cbn in *; try congruence.
    exists r; auto with itree.
  - unfold observe in H; cbn in H.
    desobs t EQ; cbn in *; try congruence; [ eexists; eauto with itree | ].
    inversion H; clear H; symmetry in H1.
    edestruct IHFIN as (? & ? & ?); [ eauto | eexists; eauto with itree ].
  - unfold observe in H; cbn in H.
    desobs t EQ; cbn in *; try congruence; [ eexists; eauto with itree | ].
    revert x FIN IHFIN.
    refine (match H in _ = u return match u with VisF e0 k0 => _ | RetF _ | TauF _ => False end with eq_refl => _ end).
    intros.
    edestruct IHFIN as (? & ? & ?); [ reflexivity | eexists; eauto with itree ].
Qed.

(** Leaf-aware up-to bind closure
    This construction generalizes [eqit_bind_clo]: one can
    indeed provide an arbitrary cut at the relational
    redicate [RU] of one's choice, but the continuations
    are only required to be related pointwise at the intersection
    of [RU] with the respective leaves of the prefixes.
  *)
Section LeafBind.

  Context {E : Type -> Type} {R S : Type}.

  Local Open Scope itree.

  Inductive eqit_Leaf_bind_clo b1 b2 (r : itree E R -> itree E S -> Prop) :
    itree E R -> itree E S -> Prop :=
  | pbc_intro_h U1 U2 (RU : U1 -> U2 -> Prop)
                (t1 : itree E U1) (t2 : itree E U2)
                 (k1 : U1 -> itree E R) (k2 : U2 -> itree E S)
                (EQV: eqit RU b1 b2 t1 t2)
                (REL: forall u1 u2,
                      u1 ∈ t1 -> u2 ∈ t2 -> RU u1 u2 ->
                      r (k1 u1) (k2 u2))
      : eqit_Leaf_bind_clo b1 b2 r
            (ITree.bind t1 k1) (ITree.bind t2 k2)
    .
  Hint Constructors eqit_Leaf_bind_clo : itree.

  Lemma eqit_Leaf_clo_bind  (RS : R -> S -> Prop) b1 b2 vclo
        (MON: monotone2 vclo)
        (CMP: compose (eqitC RS b1 b2) vclo <3= compose vclo (eqitC RS b1 b2))
        (ID: id <3= vclo):
    eqit_Leaf_bind_clo b1 b2 <3= gupaco2 (eqit_ RS b1 b2 vclo) (eqitC RS b1 b2).
  Proof.
    gcofix CIH. intros. destruct PR.
    guclo eqit_clo_trans.
    econstructor; auto_ctrans_eq; try (rewrite (itree_eta (x <- _;; _ x)), unfold_bind; reflexivity).
    punfold EQV. unfold_eqit.
    genobs t1 ot1.
    genobs t2 ot2.
    hinduction EQV before CIH; intros; pclearbot.
    - guclo eqit_clo_trans.
      econstructor; auto_ctrans_eq; try (rewrite <- !itree_eta; reflexivity).
      gbase; cbn.
      apply REL0; auto with itree.
    - gstep. econstructor.
      gbase.
      apply CIH.
      econstructor; eauto with itree.
    - gstep. econstructor.
      intros; apply ID; unfold id.
      gbase.
      apply CIH.
      econstructor; eauto with itree.
    - destruct b1; try discriminate.
      guclo eqit_clo_trans.
      econstructor.
      3:{ eapply IHEQV; eauto with itree. }
      3,4:auto_ctrans_eq.
      2: reflexivity.
      eapply eqit_Tau_l. rewrite unfold_bind, <-itree_eta. reflexivity.
    - destruct b2; try discriminate.
      guclo eqit_clo_trans.
      econstructor; auto_ctrans_eq; eauto with itree; try reflexivity.
      eapply eqit_Tau_l. rewrite unfold_bind, <-itree_eta. reflexivity.
  Qed.

End LeafBind.

(** General cut rule for [eqit]
    This result generalizes [eqit_clo_bind].  *)
Lemma eqit_clo_bind_gen :
  forall {E} {R1 R2} (RR : R1 -> R2 -> Prop) {U1 U2} {UU : U1 -> U2 -> Prop}
          b1 b2
           (t1 : itree E U1) (t2 : itree E U2)
          (k1 : U1 -> itree E R1) (k2 : U2 -> itree E R2),
    eqit UU b1 b2 t1 t2 ->
    (forall (u1 : U1) (u2 : U2),
      u1 ∈ t1 -> u2 ∈ t2 -> UU u1 u2 ->
      eqit RR b1 b2 (k1 u1) (k2 u2)) ->
    eqit RR b1 b2 (x <- t1;; k1 x) (x <- t2;; k2 x).
Proof.
    intros.
    ginit. guclo (@eqit_Leaf_clo_bind E R1 R2).
    econstructor; eauto.
    intros * IN1 IN2 HR.
    gfinal; right.
    apply H0; auto.
Qed.

(** Specialization of the cut rule to [eutt] *)
Lemma eutt_clo_bind_gen :
  forall {E} {R1 R2} (RR : R1 -> R2 -> Prop) {U1 U2} {UU : U1 -> U2 -> Prop}
           (t1 : itree E U1) (t2 : itree E U2)
          (k1 : U1 -> itree E R1) (k2 : U2 -> itree E R2),
    eutt UU t1 t2 ->
    (forall (u1 : U1) (u2 : U2),
      u1 ∈ t1 -> u2 ∈ t2 -> UU u1 u2 ->
      eutt RR (k1 u1) (k2 u2)) ->
    eutt RR (x <- t1;; k1 x) (x <- t2;; k2 x).
Proof.
  intros *; apply eqit_clo_bind_gen.
Qed.

(** Often useful particular case of identical prefixes *)
Lemma eutt_eq_bind_gen {E R S T} (RS : R -> S -> Prop)
      (t: itree E T) (k1: T -> itree E R) (k2 : T -> itree E S) :
    (forall u, u ∈ t -> eutt RS (k1 u) (k2 u)) ->
    eutt RS (t >>= k1) (t >>= k2).
Proof.
  intros; eapply eutt_clo_bind_gen.
  reflexivity.
  intros * IN _ <-; eauto.
Qed.

Lemma eqit_bind_Leaf_inv {E} {R S T} (RS : R -> S -> Prop)
      (t : itree E T)  (k1: T -> itree E R) (k2 : T -> itree E S) :
  (eutt RS  (ITree.bind t k1) (ITree.bind t k2)) ->
  (forall r, Leaf r t -> eutt RS (k1 r) (k2 r)).
Proof.
  intros EQIT r HRET.
  revert k1 k2 EQIT.
  induction HRET; intros;
    rewrite 2 unfold_bind, H in EQIT.
  - assumption.
  - rewrite 2 tau_eutt in EQIT. auto.
  - apply IHHRET. eapply eqit_inv_Vis in EQIT; eauto.
Qed.

(** Correspondence with has_post *)

Lemma has_post_Leaf {E R} (t: itree E R) Q r:
  has_post t Q -> r ∈ t -> Q r.
Proof.
  intros Hcond Himage.
  rewrite has_post_post_strong in Hcond.
  destruct (Leaf_eutt_l t t r Hcond Himage).
  intuition; now subst.
Qed.

Lemma has_post_Leaf_equiv {E R} (t: itree E R) Q:
  has_post t Q <-> (forall r, r ∈ t -> Q r).
Proof.
  intuition. eapply has_post_Leaf; eauto.
  revert t H. pcofix CIH; intros t Hpost. pstep; red.
  setoid_rewrite (itree_eta t) in Hpost.
  desobs t Ht; clear t Ht.
  - constructor. apply Hpost, Leaf_Ret.
  - constructor. right; apply CIH. intros. apply Hpost, Leaf_Tau, H.
  - constructor. intros. right. apply CIH. intros. eapply Hpost, Leaf_Vis, H.
Qed.

(** Leaf-based inversion principles for iter *)

(* Inverts [r ∈ ITree.iter body entry] into any post-condition on r which is
   satisfied by terminating iterations of the body. *)
Lemma Leaf_iter_inv {E R I}:
  forall (body: I -> itree E (I + R)) (entry: I) (Inv: I -> Prop) (Q: R -> Prop),
  (forall i r, Inv i -> r ∈ body i -> sum_pred Inv Q r) ->
  Inv entry ->
  forall r, r ∈ (ITree.iter body entry) -> Q r.
Proof.
  intros * Hinv Hentry.
  rewrite <- has_post_Leaf_equiv.
  eapply has_post_iter_strong; eauto.
  setoid_rewrite has_post_Leaf_equiv. eauto.
Qed.

Lemma Leaf_interp_iter_inv {E F R I} (h: E ~> itree F):
  forall (body: I -> itree E (I + R)) (entry: I) (Inv: I -> Prop) (Q: R -> Prop),
  (forall i r, Inv i -> r ∈ interp h (body i) -> sum_pred Inv Q r) ->
  Inv entry ->
  forall r, r ∈ interp h (ITree.iter body entry) -> Q r.
Proof.
  intros * Hbody Hentry r Hr.
  apply (Leaf_iter_inv (fun i => interp h (body i)) entry Inv); auto.
  rewrite (interp_iter'  _ _ (fun i => interp h (body i))) in Hr.
  apply Hr. reflexivity.
Qed.

(* Inverts [sr' ∈ interp_state h (ITree.iter body i)] into a post-condition on
   both retun value and state, like Leaf_iter_inv. *)
Lemma Leaf_interp_state_iter_inv {E F S R I}:
  forall (h: E ~> Monads.stateT S (itree F)) (body: I -> itree E (I + R))
         (RS: S -> Prop) (RI: I -> Prop) (RR: R -> Prop) (s: S) (i: I),
  (forall s i, RS s -> RI i -> (forall sx', sx' ∈ interp_state h (body i) s ->
                    prod_pred RS (sum_pred RI RR) sx')) ->
  RS s -> RI i ->
  forall sr', sr' ∈ interp_state h (ITree.iter body i) s -> prod_pred RS RR sr'.
Proof.
  setoid_rewrite <- has_post_Leaf_equiv.
  setoid_rewrite has_post_post_strong.
  intros * Hinv Hentrys Hentryi.
  set (eRI := fun (i1 i2: I) => i1 = i2 /\ RI i1).
  set (eRR := fun (r1 r2: R) => r1 = r2 /\ RR r1).
  set (eRS := fun (s1 s2: S) => s1 = s2 /\ RS s1).

  set (R1 := (fun x y : S * R => x = y /\ prod_pred RS RR x)).
  set (R2 := (fun a b : S * R => eRS (fst a) (fst b) /\ eRR (snd a) (snd b))).
  assert (HR1R2: eq_rel R1 R2) by (compute; intuition; subst; now try destruct y).
  unfold has_post_strong; fold R1; rewrite (eutt_equiv _ _ HR1R2).

  unshelve eapply (eutt_interp_state_iter eRI eRR eRS h body body _ i i s s _ _);
  [| subst eRS; intuition | subst eRI; intuition].
  intros i1 ? s1 ? [<- Hs1] [<- Hi1].

  set (R3 := (fun x y : S * (I + R) => x = y /\ prod_pred RS (sum_pred RI RR) x)).
  set (R4 := (prod_rel eRS (sum_rel eRI eRR))).
  assert (HR3R4: eq_rel R3 R4).
  { split; intros [? [|]] [? [|]]; compute.
    1-4: intros [[]]; dintuition; cbn; intuition.
    all: intros [[[=->] ?] HZ]; inversion HZ; intuition now subst. }

  rewrite <- (eutt_equiv _ _ HR3R4).
  now apply Hinv.
Qed.

(** Inversion of Leaf through interp.
    Since interp does not change leaves, we have [x ∈ interp h t -> x ∈ t].
    However this is not easy to see from the Leaf predicate; we must use t. *)

Module Subtree.

Inductive subtree {E R}: itree E R -> itree E R -> Prop :=
  | SubtreeRefl u t:
      u ≅ t -> subtree u t
  | SubtreeTau u t:
      subtree (Tau u) t -> subtree u t
  | SubtreeVis {T} u (e: E T) k x t:
      u ≅ k x -> subtree (Vis e k) t -> subtree u t.

#[global] Instance subtree_cong_eqitree {E R}:
  Proper (eq_itree eq ==> eq_itree eq ==> flip impl) (@subtree E R).
Proof.
  intros t t' Ht u u' Hu Hsub.
  revert t Ht u Hu; induction Hsub; intros.
  - apply SubtreeRefl. now rewrite Ht, Hu.
  - apply SubtreeTau, IHHsub; auto. apply eqit_Tau, Ht.
  - eapply SubtreeVis. now rewrite Ht, H. apply IHHsub; auto. reflexivity.
Qed.

Lemma subtree_image {E R} (t u: itree E R) x:
  subtree u t -> x ∈ u -> x ∈ t.
Proof.
  intros * Hsub. induction Hsub; intros.
  - intros. rewrite <- H; auto.
  - apply IHHsub, Leaf_Tau, H.
  - eapply IHHsub, Leaf_Vis. rewrite H in H0; eauto.
Qed.

Lemma Leaf_interp_subtree_inv {E F R} (h: E ~> itree F) (t u: itree E R):
  subtree u t -> has_post (interp h u) (fun x : R => x ∈ t).
Proof.
  revert t u. ginit. gcofix CIH; intros * Hsub.
  rewrite (itree_eta u) in Hsub.
  rewrite ! unfold_interp.
  desobs u Hu; clear u Hu; cbn.
  - gstep; red. constructor. eapply subtree_image; eauto. apply Leaf_Ret.
  - gstep; red. constructor. gfinal; left. apply CIH. apply SubtreeTau, Hsub.
  - guclo eqit_clo_bind; econstructor. reflexivity. intros u _ <-.
    gstep; red. constructor. gfinal; left. apply CIH. eapply SubtreeVis, Hsub.
    reflexivity.
Qed.

Lemma Leaf_interp_state_subtree_inv {E F S R} (h: E ~> Monads.stateT S (itree F))
  (t u: itree E R) (s: S):
  subtree u t -> has_post (interp_state h u s) (fun x => snd x ∈ t).
Proof.
  revert t u s. ginit. gcofix CIH; intros * Hsub.
  rewrite (itree_eta u) in Hsub.
  rewrite ! unfold_interp_state.
  desobs u Hu; clear u Hu; cbn.
  - gstep; red. constructor. eapply subtree_image; eauto. apply Leaf_Ret.
  - gstep; red. constructor. gfinal; left. apply CIH. apply SubtreeTau, Hsub.
  - guclo eqit_clo_bind; econstructor. reflexivity. intros [u1 u2] _ <-; cbn.
    gstep; red. constructor. gfinal; left. apply CIH. eapply SubtreeVis, Hsub.
    reflexivity.
Qed.

End Subtree.
Import Subtree.

Lemma Leaf_interp_inv {E F R} (h: E ~> itree F) (t: itree E R) x:
  x ∈ interp h t -> x ∈ t.
Proof.
  intros Hleaf. apply (has_post_Leaf (interp h t) (fun x => x ∈ t)); auto.
  apply Leaf_interp_subtree_inv. apply SubtreeRefl; reflexivity.
Qed.

Lemma Leaf_interp_state_inv {E F S R} (h: E ~> Monads.stateT S (itree F))
  (t: itree E R) s x:
  x ∈ interp_state h t s -> snd x ∈ t.
Proof.
  intros Hleaf.
  apply (has_post_Leaf (interp_state h t s) (fun x => snd x ∈ t)); auto.
  apply Leaf_interp_state_subtree_inv. apply SubtreeRefl; reflexivity.
Qed.

(** Inversion through translate. *)

Lemma Leaf_translate_inv {E F R} `{Inj: E -< F}: forall (t: itree E R) v,
  v ∈ translate (@subevent E F _) t -> v ∈ t.
Proof.
  intros. rewrite translate_to_interp in H.
  eapply Leaf_interp_inv; eauto.
Qed.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal86.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Succ (Succ Zero)).
Definition lfind_example_2  := ( Succ (Succ Zero)).
Definition lfind_example_3  := ( Succ (Succ (Succ (Succ Zero)))).
Definition lfind_example_4  := ( Succ (Succ (Succ Zero))).
Definition lfind_example_5  := ( Succ (Succ Zero)).
Definition lfind_example_6  := ( Succ Zero).
Definition lfind_example_7  := ( Succ (Succ (Succ Zero))).
Definition lfind_example_8  := ( Succ (Succ Zero)).
Definition lfind_example_9  := ( Succ Zero).
Definition lfind_example_10  := ( Succ (Succ (Succ Zero))).
Definition lfind_example_11  := ( Succ Zero).
Definition lfind_example_12  := ( Succ (Succ (Succ (Succ Zero)))).
Definition lfind_example_13  := ( Succ Zero).
Definition lfind_example_14  := ( Succ Zero).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal86_mult_commut_88_mult_succ/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 .