(*** Framework.v: Abstract framework where we prove non interference from unwindings lemmas *)
Require Export Wf_nat.
Require Export Omega.
Require Export Max.
Require Export Level.
Require Export cdr.
Require Export Axioms.
Require Export Tactics.
Require Import Setoid.

 Import L.

Section A.
Variable observable : L.t.

Variable PC : Set.
Variable Method : Type.
Variable Kind: Set.
Variable step : Method -> PC -> option PC -> Prop.
Variable PM : Method -> Prop.
Variable cdr : forall m, PM m -> CDR (step m).
Implicit Arguments region.

Variable Reg : Set.

Variable Sign : Set.

Record SignedMethod : Type := SM {unSign:Method; sign:Sign}.
Coercion unSign :  SignedMethod >-> Method.

Variable istate rstate : Type.
Variable exec : Method -> istate -> istate+rstate -> Prop.

Variable pc : istate -> PC.

Notation "m |- p1 => p2" := (step m p1 (Some p2)) (at level 30).
Notation "m |- p1 => " := (step m p1 None) (at level 30).
Variable exec_step_some : forall m s s',
  PM m -> exec m (* kd *) s (inl _ s')-> m |- (pc s) => (pc s').
Variable exec_step_none : forall m s s',
  PM m -> exec m (* kd *) s (inr _ s')-> m |- (pc s) =>.

Variable registertypes : Type.

Variable texec : forall m, PM m ->
      Sign -> (PC->L.t) -> PC ->
      registertypes -> option registertypes -> Prop.
Variable high_reg : registertypes -> Reg -> Prop.
Variable indist_reg_val : istate -> istate -> Reg -> Prop.
Variable indist_reg_val_trans : forall s1 s2 s3 r,
  indist_reg_val s1 s2 r -> indist_reg_val s2 s3 r -> indist_reg_val s1 s3 r.
Variable indist_reg_val_sym : forall s1 s2 r,
  indist_reg_val s1 s2 r -> indist_reg_val s2 s1 r.
Inductive indist_reg : registertypes -> registertypes -> istate -> istate -> Reg -> Prop :=
  | high_indist_reg : forall rt1 rt2 s1 s2 r,
      high_reg rt1 r -> high_reg rt2 r -> indist_reg rt1 rt2 s1 s2 r
  | low_indist_reg : forall rt1 rt2 s1 s2 r, indist_reg_val s1 s2 r -> indist_reg rt1 rt2 s1 s2 r.
Variable indist : Sign -> registertypes -> registertypes -> istate -> istate -> Prop.
Variable indist_from_reg : forall sgn rt1 rt2 s1 s2,
  (forall r, indist_reg rt1 rt2 s1 s2 r) -> indist sgn rt1 rt2 s1 s2.
Variable indist_reg_from_indist : forall sgn rt1 rt2 s1 s2,
  indist sgn rt1 rt2 s1 s2 ->
  forall r,
    (high_reg rt1 r -> high_reg rt2 r -> indist_reg rt1 rt2 s1 s2 r) /\
    ((~high_reg rt1 r /\ ~high_reg rt2 r) \/
      (high_reg rt1 r /\ ~high_reg rt2 r) \/
      (~high_reg rt1 r /\ high_reg rt2 r) ->
    indist_reg_val s1 s2 r).
Variable rindist : Sign -> rstate -> rstate -> Prop.
Variable indist_sym : forall m rt1 rt2 s1 s2,
 indist m rt1 rt2 s1 s2 -> indist m rt2 rt1 s2 s1.
Variable rindist_sym : forall m s1 s2,
 rindist m s1 s2 -> rindist m s2 s1.

Variable high_result : Sign -> rstate -> Prop.

Variable rt0 : Method-> Sign -> registertypes.
Variable init_pc : Method -> PC -> Prop.

Inductive evalsto (m:Method) : nat -> istate -> rstate -> Prop :=
  | evalsto_res : forall (* k *) s res,
      exec m (* k *) s (inr _ res) -> evalsto m 1 s res
  | evalsto_intra : forall (* k *) n s1 s2 res,
     exec m (* k *) s1 (inl _ s2) ->
     evalsto m n s2 res ->
     evalsto m (S n) s1 res.

Variable P : SignedMethod -> Prop.

Variable PM_P : forall m, P m -> PM m.

Definition ni :=
  forall m p p' sgn s s' r r',
  P (SM m sgn) ->
(*   rt0 m sgn rt -> *)
  indist sgn (rt0 m sgn) (rt0 m sgn) s s' ->
  pc s = pc s' ->
  init_pc m (pc s) ->
  init_pc m (pc s') ->
  evalsto m p s r ->
  evalsto m p' s' r' ->
  rindist sgn r r'.

(* seems weird to have same rt *)
Variable indist2_intra : forall m sgn se rt ut ut' s s' u u',
  forall H0:P (SM m sgn),
  indist sgn rt rt s s' ->
  pc s = pc s' ->
  exec m s (inl _ u) ->
  exec m s' (inl _ u') ->
  texec m (PM_P _ H0) sgn se (pc s) rt (Some ut) ->
  texec m (PM_P _ H0) sgn se (pc s) rt (Some ut') ->
    indist sgn ut ut' u u'.

Variable indist2_return : forall m sgn se rt s s' u u',
  forall H0:P (SM m sgn),
  indist sgn rt rt s s' ->
  pc s = pc s' ->
  exec m s (inr _ u) ->
  exec m s' (inr _ u')->
  texec m (PM_P _ H0) sgn se (pc s) rt None ->
  texec m (PM_P _ H0) sgn se (pc s) rt None ->
    rindist sgn u u'.

(* high branching *)
Variable soap2_basic_intra : forall m sgn se rt ut ut' s s' u u',
  forall (h:P (SM m sgn)),
  indist sgn rt rt s s' ->
  pc s = pc s' ->
  exec m s (inl _ u) ->
  exec m s' (inl _ u') ->
  texec m (PM_P _ h) sgn se (pc s) rt (Some ut) ->
  texec m (PM_P _ h) sgn se (pc s) rt (Some ut') ->
  pc u <> pc u' ->
    (forall j:PC, (region (cdr m (PM_P _ h)) (pc s) j) -> ~ leql (se j) observable).

Variable sub : registertypes -> registertypes -> Prop.
Variable sub_simple : forall sgn rt rt' rt0 s s0,
  indist sgn rt0 rt s0 s ->
  sub rt rt' ->
  indist sgn rt0 rt' s0 s.

Inductive typed_exec (m:Method) (H:PM m) (sgn:Sign) (se:PC->L.t) (RT:PC->registertypes)
: istate -> istate + rstate -> Prop :=
  typed_exec_def1 : forall s1 s2 rt',
   exec m s1 (inl _ s2) ->
   sub rt' (RT (pc s2)) ->
   texec m H sgn se (pc s1) (RT (pc s1)) (Some rt') ->
   typed_exec m H sgn se RT s1 (inl _ s2)
| big_exec_def2 : forall s1 s2,
   exec m s1 (inr _ s2) ->
   texec m H sgn se (pc s1) (RT (pc s1)) None ->
   typed_exec m H sgn se RT s1 (inr _ s2).

Inductive tevalsto (m:Method) (H:PM m) (sgn:Sign) (se:PC->L.t) (RT:PC->registertypes) : nat -> istate -> rstate -> Prop :=
  | tevalsto_res : forall s res,
      typed_exec m H sgn se RT s (inr _ res) -> tevalsto m H sgn se RT 1 s res
  | tevalsto_intra : forall n s1 s2 res,
     typed_exec m H sgn se RT s1 (inl _ s2) ->
     tevalsto m H sgn se RT n s2 res ->
     tevalsto m H sgn se RT (S n) s1 res.

(* Hendra additional *)
Variable tevalsto_high_result' : forall m sgn (H:PM m) se s RT res,
  ~L.leql (se m sgn (pc s)) observable ->
  exec m s (inr res) ->
  texec m H sgn (se m sgn) (pc s) (RT m sgn (pc s)) None -> high_result sgn res.

Variable tevalsto_diff_high_result : forall se RT m sgn s s' p res res' (H:PM m),
  pc s = pc s' -> 1 < p ->
  tevalsto m H sgn (se m sgn) (RT m sgn) 1 s res -> tevalsto m H sgn (se m sgn) (RT m sgn) p s' res' ->
  high_result sgn res /\ high_result sgn res'.

Variable high_result_indist : forall sgn res res0,
  high_result sgn res -> high_result sgn res0 -> rindist sgn res res0.

Variable eq_map : registertypes -> registertypes -> Prop.
Variable eq_map_refl : reflexive registertypes eq_map.
Variable eq_map_sym : symmetric registertypes eq_map.
Variable eq_map_trans : transitive registertypes eq_map.
Theorem map_setoid: Setoid_Theory registertypes eq_map.
 split.
 exact eq_map_refl.
 exact eq_map_sym.
 exact eq_map_trans.
Qed.
Add Setoid registertypes eq_map map_setoid as eq_map_rel.

Variable indist_morphism_proof : forall (y : Sign) (x y0 : registertypes),
eq_map x y0 ->
forall x0 y1 : registertypes,
eq_map x0 y1 -> forall y2 y3 : istate, indist y x x0 y2 y3 <-> indist y y0 y1 y2 y3.
Add Morphism indist : indist_morphism. Proof. exact indist_morphism_proof. Qed.

Definition Typable (m:Method) (H:PM m) (sgn:Sign) (se:Method->Sign->PC->L.t) (RT:Method->Sign->PC->registertypes) : Prop :=
  (forall i, init_pc m i -> eq_map (RT m sgn i) (rt0 m sgn)) /\
  (forall i,
     m |- i => ->
     texec m H sgn (se m sgn) i (RT m sgn i) None) /\
  (forall i j,
    m |- i =>j ->
    exists rt,
      texec m H sgn (se m sgn) i (RT m sgn i) (Some rt)
      /\ sub rt (RT m sgn j)).

Definition TypableProg se S :=
  forall m sgn (H:P (SM m sgn)), Typable m (PM_P _ H) sgn se S.

Lemma typable_evalsto : forall se RT m sgn n s r
  (H:PM m),
  Typable m H sgn se RT ->
  evalsto m n s r ->
  tevalsto m H sgn (se m sgn) (RT m sgn) n s r.
Proof.
  intros until r; intros HP H.
  destruct H as [_ [H0 H1]].
  induction 1.
  (* ret *)
  constructor 1; auto.
  constructor; auto.
  apply H0; auto.
  eapply exec_step_none; eauto.
  (* next *)
  constructor 2 with s2; auto.
  elim H1 with (pc s1) (pc s2).
  intros st (HT,Hs).
  constructor 1 with st; auto.
  eapply exec_step_some; eauto.
Qed.

Lemma tevalsto_evalsto : forall se RT m sgn p s r
  (h:PM m),
  tevalsto m h sgn (se m sgn) (RT m sgn) p s r ->
  evalsto m p s r.
Proof.
  induction 1.
  inversion H.
  constructor 1; auto.
  inversion H.
  constructor 2 with s2; auto.
Qed.

Lemma tevalsto_high_result : forall m sgn (H:PM m) se RT s res,
  ~L.leql (se m sgn (pc s)) observable ->
  tevalsto m H sgn (se m sgn) (RT m sgn) 1 s res -> high_result sgn res.
Proof.
  intros.
  apply tevalsto_high_result' with (m:=m) (H:=H) (sgn:=sgn) (se:=se) (s:=s) (RT:=RT); auto.
  apply tevalsto_evalsto in H1. inversion H1; auto. inversion H4.
  inversion H1; auto. inversion H2; auto. inversion H4.
Qed.

Implicit Arguments tevalsto_evalsto.

Hint Resolve PM_P.

Section TypableProg.
Variable se : Method -> Sign -> PC -> L.t.
Variable RT : Method -> Sign -> PC -> registertypes.
Variable T : TypableProg se RT.

Definition high_region m (h:PM m) sgn (i:PC) :=
  forall j:PC, region (cdr m h) i j ->
    ~ leql (se m sgn j) observable.

Hint Immediate indist_sym rindist_sym.
Hint Resolve exec_step_some exec_step_none.

Lemma final_bighighstep_aux : forall m sgn i p s res (H: P (SM m sgn)),
  tevalsto m (PM_P _ H) sgn (se m sgn) (RT m sgn) p s res ->
  region (cdr m (PM_P _ H)) i (pc s) ->
  (forall jun, ~junc (cdr m (PM_P _ H)) i jun) ->
  high_region m (PM_P _ H) sgn i ->
  high_result sgn res.
Proof.
  intros.
  induction H0.
  apply tevalsto_high_result with (m:=m) (H:=(PM_P _ H)) (se:=se) (RT:=RT) (s:=s); auto.
    constructor 1; auto.
  apply IHtevalsto; auto.
  inversion H0.
    eapply exec_step_some with (1:=PM_P _ H) in H6; eauto.
    elim (soap2 (cdr m (PM_P _ H))) with i (pc s1) (pc s2); auto.
    intros. unfold not in H2. apply H2 in H10. contradiction.
Qed.

Lemma final_bighighstep : forall m sgn p i s0 s res res0
  (H:P (SM m sgn)),
  pc s = pc s0 ->
  evalsto m p s res->
  evalsto m 1 s0 res0 ->
  region (cdr m (PM_P _ H)) i (pc s)->
  indist sgn (RT m sgn (pc s)) (RT m sgn (pc s0)) s s0 ->
  high_region m (PM_P _ H) sgn i ->
    rindist sgn res res0.
Proof.
  intros.
  inversion H2; try (inversion H8).
  destruct (T m sgn H). inversion_mine H11.
  apply high_result_indist.
  (* high result res *)
    apply final_bighighstep_aux with (m:=m) (i:=i) (p:=p) (s:=s) (H:=H); auto.
    apply typable_evalsto; auto.
    intros.
    apply soap3 with (j:=pc s0).
    rewrite <- H0; auto.
    apply exec_step_none with (1:=PM_P _ H) in H6.
    unfold result; eauto.
  (* high result res0 *)
    apply tevalsto_high_result with (m:=m) (H:=(PM_P _ H)) (se:=se) (RT:=RT) (s:=s0).
        rewrite <- H0; auto.
      apply typable_evalsto; auto.
Qed.

Lemma my_double_ind:forall P:(nat->nat->Prop),
   (forall n m:nat, (forall p q:nat, lt p n -> lt q m -> P p q) -> P n m) ->
   forall p q:nat, P p q.
Proof.
  intros P0 H.
  apply lt_wf_double_ind.
  intros.
  apply H.
  intros.
  apply H0.
  assumption.
Qed.

Lemma execution_reach_junction_or_return_1 : forall m sgn ns i s res (H: P (SM m sgn)),
  region (cdr m (PM_P _ H)) i (pc s) ->
  evalsto m ns s res ->
  (exists u, exists ps,
    evalsto m ps u res /\ ps < ns /\
    junc (cdr m (PM_P _ H)) i (pc u))
  \/ (forall jun, ~junc (cdr m (PM_P _ H)) i jun).
Proof.
  intros m sgn ns.
  pattern ns. apply lt_wf_ind.
  clear ns; intros ns Hind; intros.
  inversion H1; auto.
  right.
  apply exec_step_none with (1:=PM_P _ H) in H2.
  intros; apply soap3 with (k:=jun) in H0; auto.
  elim (soap2 (cdr m (PM_P _ H))) with i (pc s) (pc s2); auto.
  intros.
  elim Hind with (m0:=n) (i:=i) (s:=s2) (res:=res) (H:=H); auto; try omega.
  intros [U [ps [sH1 [sH2 sH3]]]].
  left. exists U. exists ps. repeat (split; auto).
  intros.
  left. exists s2. exists n. repeat (split; auto).
  apply exec_step_some with (1:=PM_P _ H) in H2; auto.
Qed.

Lemma execution_reach_junction_or_return_2 : forall m sgn ns ns' i s s' res res' (H: P (SM m sgn)),
  region (cdr m (PM_P _ H)) i (pc s) ->
  region (cdr m (PM_P _ H)) i (pc s') ->
  evalsto m ns s res ->
  evalsto m ns' s' res' ->
  (exists u, exists u', exists ps, exists ps',
    evalsto m ps u res /\ ps < ns /\
    evalsto m ps' u' res' /\ ps' < ns' /\
    junc (cdr m (PM_P _ H)) i (pc u) /\ junc (cdr m (PM_P _ H)) i (pc u'))
  \/ (forall jun, ~junc (cdr m (PM_P _ H)) i jun).
Proof.
    intros.
  apply execution_reach_junction_or_return_1 with (sgn:=sgn) (i:=i) (H:=H) in H2; auto.
  apply execution_reach_junction_or_return_1 with (sgn:=sgn) (i:=i) (H:=H) in H3; auto.
  inversion H2; inversion H3; auto.
  left.
  inversion H4; inversion H6; inversion H5; inversion H8.
  exists x; exists x1; exists x0; exists x2; auto.
  Cleanexand.
  repeat (split; auto).
Qed.

Lemma execution_reach_junction_or_return : forall m sgn ns ns' s s' u u' res res' (H: P (SM m sgn)),
  pc s = pc s' ->
  exec m s (inl u) -> exec m s' (inl u') ->
  pc u <> pc u' ->
  evalsto m ns u res ->
  evalsto m ns' u' res' ->
  (exists v, exists v', exists ps, exists ps',
    evalsto m ps v res /\ ps <= ns /\
    evalsto m ps' v' res' /\ ps' <= ns' /\
    junc (cdr m (PM_P _ H)) (pc s) (pc v) /\ junc (cdr m (PM_P _ H)) (pc s') (pc v'))
  \/ (forall jun, ~junc (cdr m (PM_P _ H)) (pc s) jun /\ forall jun, ~junc (cdr m (PM_P _ H)) (pc s') jun).
Proof.
  intros.
  apply exec_step_some with (1:=PM_P _ H) in H1; apply exec_step_some with (1:=PM_P _ H) in H2; auto.
  elim (soap1 (cdr m (PM_P _ H))) with (pc s) (pc u) (pc u'); try (rewrite H0; auto; fail); auto; intros.
  elim (soap1 (cdr m (PM_P _ H))) with (pc s) (pc u') (pc u); try (rewrite H0; auto; fail); auto; intros.
  (* both are in the region *)
  apply execution_reach_junction_or_return_2 with (ns:=ns) (ns':=ns') (s:=u) (s':=u') (res:=res) (res':=res') in H6; auto.
  inversion H6.
  left.
  Cleanexand.
  exists x; exists x0; exists x1; exists x2. repeat (split; auto).
  omega. omega.
  rewrite H0 in H13; auto.
  right. split; auto. rewrite H0 in H8; auto.
  (* one is in the region *)
  apply execution_reach_junction_or_return_1 with (ns:=ns') (s:=u') (res:=res') in H6; auto.
  inversion H6; Cleanexand.
  left.
  exists u; exists x; exists ns; exists x0; repeat (split; auto).
  omega. rewrite H0 in H10; auto.
  right. split; auto. rewrite H0 in H8; auto.
  (* *)
  elim (soap1 (cdr m (PM_P _ H))) with (pc s) (pc u') (pc u); try (rewrite H0; auto; fail); auto; intros.
  (* one is in the region *)
  apply execution_reach_junction_or_return_1 with (ns:=ns) (s:=u) (res:=res) in H7; auto.
  inversion H7; Cleanexand.
  left.
  exists x; exists u'; exists x0; exists ns'; repeat (split; auto).
  omega. rewrite H0 in H6; auto.
  right. split; auto. rewrite H0 in H8; auto.
  (* both are junction point *)
  left.
  exists u; exists u'; exists ns; exists ns'; repeat (split;auto).
  rewrite H0 in H6; auto.
Qed.

Inductive path (m:Method) (i:istate) : istate -> Type :=
  | path_base : forall j, exec m i (inl j) -> path m i j
  | path_step : forall j k, path m k j -> exec m i (inl k) -> path m i j.

Inductive path_prop (m:Method) (i j:istate) (p:path m i j) : Prop := path_prop_cons : path_prop m i j p.

Inductive path_in_region (m:Method) (cdr: CDR (step m)) (s:PC) (i j:istate) : (path m i j) -> Prop :=
  | path_in_reg_base : forall (Hexec:exec m i (inl j)), region cdr s (pc i) ->
      path_in_region m cdr s i j (path_base m i j Hexec)
  | path_in_reg_ind : forall k (Hexec:exec m i (inl k)) (p:path m k j), region cdr s (pc i) ->
      path_in_region m cdr s k j p -> path_in_region m cdr s i j (path_step m i j k p Hexec).

Lemma evalsto_path : forall m sgn n s i res (H: P (SM m sgn)),
  region (cdr m (PM_P _ H)) s (pc i) ->
  evalsto m n i res ->
  (exists j p, junc (cdr m (PM_P _ H)) s (pc j) /\ path_prop m i j p /\
    path_in_region m (cdr m (PM_P _ H)) s i j p /\
    (exists n', evalsto m n' j res /\ n' < n))
  \/ (forall jun, ~junc (cdr m (PM_P _ H)) s jun).
Proof.
  intros m sgn n. pattern n. apply lt_wf_ind.
  clear n. intros n IH.
  intros s i res H Hreg Hevalsto.
  inversion Hevalsto.
  (* the case where i is immediately a return point *)
  apply exec_step_none with (1:=PM_P _ H) in H0.
  right. intros. apply soap3 with (j:=pc i); auto.
  (* inductive case *)
  elim soap2 with PC (step m) (cdr m (PM_P _ H)) s (pc i) (pc s2); intros; auto.
  (* path stays in region *)
  elim IH with (H:=H) (s:=s) (m0:=n0) (i:=s2) (res:=res); simpl; intros; auto.
  Cleanexand.
  left.
  exists x. exists (path_step m i x s2 x0 H0).
  repeat (split; auto).
  constructor 2; auto.
  exists x1. split; auto.
  omega.

  (* path is the junction *)
  left. exists s2. exists (path_base m i s2 H0).
  repeat (split; auto).
  constructor 1; auto.

  (* final case *)
  exists n0; repeat (split; auto).
  apply exec_step_some with (1:=PM_P _ H); auto.
Qed.

Variable changed : forall (m:Method) (i j:istate), path m i j -> Reg -> Prop.
Variable changed_high : forall m sgn s i j r (H:P (SM m sgn)) (Hpath: path m i j),
  (forall k:PC, region (cdr m (PM_P _ H)) s k -> ~ L.leql (se m sgn k) observable) ->
  path_in_region m (cdr m (PM_P _ H)) s i j Hpath ->
  region (cdr m (PM_P _ H)) s (pc i) ->
  junc (cdr m (PM_P _ H)) s (pc j) ->
  changed m i j Hpath r ->
    high_reg (RT m sgn (pc j)) r.
Variable not_changed_same : forall m sgn i j (Hpath: path m i j) r (H: P (SM m sgn)) ,
  ~changed m i j Hpath r ->
  (indist_reg_val i j r) /\ (high_reg (RT m sgn (pc i)) r ->
    high_reg (RT m sgn (pc j)) r).
Variable high_reg_dec : forall rt r, high_reg rt r \/ ~high_reg rt r.
Variable changed_dec : forall m i j r (p:path m i j),
  changed m i j (p) r \/ ~changed m i j (p) r.

Lemma junction_indist : forall m sgn ns ns' s s' u u' res res' i (H: P (SM m sgn)),
  indist sgn (RT m sgn (pc s)) (RT m sgn (pc s')) s s' ->
  exec m s (inl u) -> exec m s' (inl u') ->
  region (cdr m (PM_P _ H)) i (pc u) ->
  region (cdr m (PM_P _ H)) i (pc u') ->
  high_region m (PM_P _ H) sgn i ->
  evalsto m ns u res ->
  evalsto m ns' u' res' ->
  indist sgn (RT m sgn (pc u)) (RT m sgn (pc u')) u u' ->
  (exists v, exists v', exists ps, exists ps',
    evalsto m ps v res /\ ps <= ns /\
    evalsto m ps' v' res' /\ ps' <= ns' /\
    junc (cdr m (PM_P _ H)) i (pc v) /\
    junc (cdr m (PM_P _ H)) i (pc v') /\
    indist sgn (RT m sgn (pc v)) (RT m sgn (pc v')) v v')
  \/ (high_result sgn res /\ high_result sgn res').
Proof.
  intros.
  elim evalsto_path with (1:=H3) (2:=H6);
  elim evalsto_path with (1:=H4) (2:=H7); intros.
  left. destruct H10 as [v H10]; destruct H10 as [path H10]; destruct H9 as [v' H9]; destruct H9 as [path' H9].
    exists v; exists v'.
    Cleanexand.
    exists x; exists x0.
    repeat (split; auto).
    omega. omega.
    apply indist_from_reg.
    intros.
    elim changed_dec with (m:=m) (i:=u) (j:=v) (p:=path) (r:=r);
    elim changed_dec with (m:=m) (i:=u') (j:=v') (p:=path') (r:=r); intros; auto.
    apply changed_high with (m:=m) (sgn:=sgn) (s:=i) (H:=H) in H19;
    apply changed_high with (m:=m) (sgn:=sgn) (s:=i) (H:=H) in H20; auto.
    constructor; auto.
    constructor 1; auto.
    apply changed_high with (m:=m) (sgn:=sgn) (s:=i) (H:=H) in H20; auto.
    apply changed_high with (m:=m) (sgn:=sgn) (s:=i) (H:=H) in H20; auto.
    elim junc_func with (PC:=PC) (step:=step m) (c:=cdr m (PM_P _ H)) (i:=i)
      (j1:=pc v) (j2:=pc v'); auto.
    constructor 1; auto.
    apply changed_high with (m:=m) (sgn:=sgn) (s:=i) (H:=H) in H19; auto.
    elim junc_func with (PC:=PC) (step:=step m) (c:=cdr m (PM_P _ H)) (i:=i)
      (j1:=pc v') (j2:=pc v); auto.
    apply changed_high with (m:=m) (sgn:=sgn) (s:=i) (H:=H) in H19; auto.
    apply not_changed_same with (m:=m) (sgn:=sgn) (i:=u') (j:=v') in H19; auto.
    apply not_changed_same with (m:=m) (sgn:=sgn) (i:=u) (j:=v) in H20; auto.
    inversion H19; inversion H20.
    destruct high_reg_dec with (rt:=RT m sgn (pc u)) (r:=r);
    destruct high_reg_dec with (rt:=RT m sgn (pc u')) (r:=r).
    specialize H22 with (1:=H26); specialize H24 with (1:=H25).
    constructor 1; auto.
    specialize H24 with (1:=H25).
    constructor 1; auto.
    elim junc_func with (PC:=PC) (step:=step m) (c:=cdr m (PM_P _ H)) (i:=i)
      (j1:=pc v) (j2:=pc v'); auto.
    specialize H22 with (1:=H26).
    elim junc_func with (PC:=PC) (step:=step m) (c:=cdr m (PM_P _ H)) (i:=i)
      (j1:=pc v') (j2:=pc v); auto.
    constructor 1; auto.
    constructor 2; auto.
    apply indist_reg_val_trans with (s2:=u).
    apply indist_reg_val_sym; auto.
    apply indist_reg_val_trans with (s2:=u'); auto.
    apply indist_reg_from_indist with (r:=r) in H8.
    Cleanexand.
    apply H29; auto.
  (* one of them doesn't have a junction point *)
  Cleanexand. specialize H9 with (pc x). contradiction.
  Cleanexand. specialize H10 with (pc x). contradiction.
  (* both are junction points *)
  right.
  split.
  apply typable_evalsto with (1:=T m sgn H) (se:=se) (RT:=RT) in H6.
  apply final_bighighstep_aux with (m:=m) (sgn:=sgn) (H:=H)
    (s:=u) (i:=i) (p:=ns); auto.
  (* the other high result *)
  apply typable_evalsto with (1:=T m sgn H) (se:=se) (RT:=RT) in H7.
  apply final_bighighstep_aux with (m:=m) (sgn:=sgn) (H:=H)
    (s:=u') (i:=i) (p:=ns'); auto.
Qed.

Lemma junction_indist_2 : forall m sgn ns ns' s s' u u' res res' i (H: P (SM m sgn)),
  indist sgn (RT m sgn (pc s)) (RT m sgn (pc s')) s s' ->
  exec m s (inl u) -> exec m s' (inl u') ->
  region (cdr m (PM_P _ H)) i (pc u) ->
  junc (cdr m (PM_P _ H)) i (pc u') ->
  high_region m (PM_P _ H) sgn i ->
  evalsto m ns u res ->
  evalsto m ns' u' res' ->
  indist sgn (RT m sgn (pc u)) (RT m sgn (pc u')) u u' ->
  (exists v, exists ps,
    evalsto m ps v res /\ ps <= ns /\
    junc (cdr m (PM_P _ H)) i (pc v) /\
    indist sgn (RT m sgn (pc v)) (RT m sgn (pc u')) v u').
Proof.
  intros.
  elim evalsto_path with (1:=H3) (2:=H6); intros.
  destruct H9 as [v [Hpath H9]].
  exists v.
  Cleanexand.
  exists x. repeat (split; auto).
  omega.
  apply indist_from_reg.
  intro r.
  elim changed_dec with (m:=m) (i:=u) (j:=v) (r:=r) (p:=Hpath); intros; auto.
  constructor 1.
  apply changed_high with (m:=m) (sgn:=sgn) (H:=H) (s:=i) in H14; auto.
  apply changed_high with (m:=m) (sgn:=sgn) (H:=H) (s:=i) in H14; auto.
  elim junc_func with (PC:=PC) (step:=step m) (c:=cdr m (PM_P _ H)) (i:=i)
      (j1:=pc v) (j2:=pc u'); auto.
  (* dealing with the value when it is not changed *)
  apply not_changed_same with (m:=m) (sgn:=sgn) (i:=u) (j:=v) in H14; auto.
  Cleanexand.
  destruct high_reg_dec with (rt:=RT m sgn (pc u)) (r:=r);
  destruct high_reg_dec with (rt:=RT m sgn (pc u')) (r:=r).
  specialize H15 with (1:=H16).
  constructor 1; auto.
  constructor 1; auto.
  elim junc_func with (PC:=PC) (step:=step m) (c:=cdr m (PM_P _ H)) (i:=i)
    (j1:=pc v) (j2:=pc u'); auto.
  constructor 1; auto.
  elim junc_func with (PC:=PC) (step:=step m) (c:=cdr m (PM_P _ H)) (i:=i)
    (j1:=pc u') (j2:=pc v); auto.
  constructor 2; auto.
  apply indist_reg_val_sym; auto.
  apply indist_reg_val_trans with (s2:=u).
  apply indist_reg_from_indist with (r:=r) in H8.
  Cleanexand. apply indist_reg_val_sym. apply H18; auto.
  apply H14; auto.
  specialize H9 with (pc u'); contradiction.
Qed.

Definition tni :=
  forall m sgn p p' s s' r r' (H:P (SM m sgn)),
  pc s = pc s' ->
  indist sgn (RT m sgn (pc s)) (RT m sgn (pc s)) s s' ->
  tevalsto m (PM_P _ H) sgn (se m sgn) (RT m sgn) p s r ->
  tevalsto m (PM_P _ H) sgn (se m sgn) (RT m sgn) p' s' r' ->
  rindist sgn r r'.

Lemma tni_ni : tni -> ni.
Proof.
  unfold tni, ni; intros.
  destruct (T _ _ H0) as [T1 [T2 T3]].
  apply H with m p p' s s' H0; auto.
  rewrite T1; auto.
  apply typable_evalsto; auto.
  apply typable_evalsto; auto.
Qed.

Variable branch_indist : forall m sgn s s' u u' (H:P (SM m sgn)),
  pc s = pc s' ->
  indist sgn (RT m sgn (pc s)) (RT m sgn (pc s')) s s' ->
  exec m s (inl u) ->
  exec m s' (inl u') ->
  pc u <> pc u' ->
  indist sgn (RT m sgn (pc u)) (RT m sgn (pc u')) u u'.

Lemma ni_ind : tni.
Proof.
  intros m sgn.
  intros ns ns'. pattern ns, ns'. apply my_double_ind.
  clear ns ns'; intros ns ns' Hind.
  intros s s' r r' H Hpc Hindist Htevalsto Htevalsto'.
  set (HM:=PM_P _ H).
  inversion Htevalsto; inversion Htevalsto'.
  (* *)
  inversion H0; inversion H4.
  subst.
  rewrite <- Hpc in H15.
  eapply indist2_return with (1:=Hindist) (5:=H11) (6:=H15); auto.

  (* *)
  subst.
  apply tevalsto_diff_high_result with (s:=s) (res:=r) in Htevalsto'; auto.
  inversion Htevalsto'; apply high_result_indist; auto.
  destruct n; auto. inversion H5. omega.
  (* *)
  subst.
  apply tevalsto_diff_high_result with (s:=s') (res:=r') in Htevalsto; auto.
  inversion Htevalsto; apply high_result_indist; auto.
  destruct n; auto. inversion H1. omega.
  (* *)
  inversion H0; inversion H5; subst.
  elim eq_excluded_middle with PC (pc s2) (pc s3); intros.
  (* pc s = pc s' *)
  rewrite <- Hpc in H19.
  assert (H11':=H11).
  apply indist2_intra with (1:=Hindist) (2:=Hpc) (4:=H16) (5:=H14) (6:=H19) in H11;
    try (auto); try (rewrite <- Hpc; auto; fail).
  apply Hind with (q:=n0) (p:=n) (s:=s2) (s':=s3) (r:=r) (r':=r') (H:=H); auto; try omega.
  apply sub_simple with (rt:=rt'0).
  apply indist_sym. apply sub_simple with (rt:=rt'); auto.
  rewrite H2; auto.

  (* pc s <> pc s' *)
  elim (soap1 (cdr m (PM_P _ H))) with (pc s) (pc s2) (pc s3); try (rewrite Hpc; auto; fail); auto; intros.
  elim (soap1 (cdr m (PM_P _ H))) with (pc s) (pc s3) (pc s2); try (rewrite Hpc; auto; fail); auto; intros.
  (* both are still in the region *)
  elim junction_indist with (m:=m) (sgn:=sgn) (ns:=n) (ns':=n0) (s:=s) (s':=s')
    (u:=s2) (u':=s3) (res:=r) (res':=r') (i:=pc s) (H:=H); auto.
  intros. Cleanexand.
  assert (pc x = pc x0) as Hpcx. apply junc_func with (step:=step m) (c:=cdr m (PM_P _ H)) (i:=pc s); auto.
  apply Hind with (p:=x1) (q:=x2) (s:=x) (s':=x0) (r:=r) (r':=r') (H:=H); auto; try omega.
  rewrite <- Hpcx in H18; auto.
  apply typable_evalsto; auto.
  apply typable_evalsto; auto.
  intros. inversion H7; apply high_result_indist; auto.
  rewrite <- Hpc; auto.
  assert ((forall j:PC, (region (cdr m (PM_P _ H)) (pc s) j) -> ~ leql (se m sgn j) observable)).
    intros. apply soap2_basic_intra with (m:=m) (sgn:=sgn) (rt:=RT m sgn (pc s))
      (ut:=rt') (ut':=rt'0) (s:=s) (s':=s') (u:=s2) (u':=s3) (h:=H); auto.
    rewrite Hpc; auto.
    unfold high_region. auto.
  apply tevalsto_evalsto with (se:=se) (RT:=RT) (sgn:=sgn) (h:=PM_P _ H); auto.
  apply tevalsto_evalsto with (se:=se) (RT:=RT) (sgn:=sgn) (h:=PM_P _ H); auto.
  apply branch_indist with (s:=s) (s':=s'); auto. rewrite <- Hpc; auto.
  (* one region one junction *)
  elim junction_indist_2 with (m:=m) (sgn:=sgn) (ns:=n0) (ns':=n) (s:=s') (s':=s)
    (u:=s3) (u':=s2) (res:=r') (res':=r) (i:=pc s) (H:=H); auto.
  intros. Cleanexand.
  assert (pc x = pc s2) as Hpcx. apply junc_func with (step:=step m) (c:=cdr m (PM_P _ H)) (i:=pc s); auto.
  apply Hind with (p:=n) (q:=x0) (s:=s2) (s':=x) (r:=r) (r':=r') (H:=H); auto; try omega.
  apply indist_sym; rewrite Hpcx in H10; auto.
  apply typable_evalsto; auto.
  apply indist_sym; rewrite <- Hpc; auto.
  assert ((forall j:PC, (region (cdr m (PM_P _ H)) (pc s) j) -> ~ leql (se m sgn j) observable)).
    intros. apply soap2_basic_intra with (m:=m) (sgn:=sgn) (rt:=RT m sgn (pc s))
      (ut:=rt') (ut':=rt'0) (s:=s) (s':=s') (u:=s2) (u':=s3) (h:=H); auto.
    rewrite Hpc; auto.
    unfold high_region; auto.
  apply tevalsto_evalsto with (se:=se) (RT:=RT) (sgn:=sgn) (h:=PM_P _ H); auto.
  apply tevalsto_evalsto with (se:=se) (RT:=RT) (sgn:=sgn) (h:=PM_P _ H); auto.
  apply branch_indist with (s:=s') (s':=s); auto.
  apply indist_sym. rewrite <- Hpc; auto.
  elim (soap1 (cdr m (PM_P _ H))) with (pc s) (pc s3) (pc s2); try (rewrite H0; auto; fail); auto; intros.
  (* one junction one region *)
  elim junction_indist_2 with (m:=m) (sgn:=sgn) (ns:=n) (ns':=n0) (s:=s) (s':=s')
    (u:=s2) (u':=s3) (res:=r) (res':=r') (i:=pc s) (H:=H); auto.
  intros. Cleanexand.
  assert (pc x = pc s3) as Hpcx. apply junc_func with (step:=step m) (c:=cdr m (PM_P _ H)) (i:=pc s); auto.
  apply Hind with (p:=x0) (q:=n0) (s:=x) (s':=s3) (r:=r) (r':=r') (H:=H); auto; try omega.
  rewrite <- Hpcx in H10; auto.
  apply typable_evalsto; auto.
  rewrite <- Hpc; auto.
  assert ((forall j:PC, (region (cdr m (PM_P _ H)) (pc s) j) -> ~ leql (se m sgn j) observable)).
    intros. apply soap2_basic_intra with (m:=m) (sgn:=sgn) (rt:=RT m sgn (pc s))
      (ut:=rt') (ut':=rt'0) (s:=s) (s':=s') (u:=s2) (u':=s3) (h:=H); auto.
    rewrite Hpc; auto.
    unfold high_region; auto.
  apply tevalsto_evalsto with (se:=se) (RT:=RT) (sgn:=sgn) (h:=PM_P _ H); auto.
  apply tevalsto_evalsto with (se:=se) (RT:=RT) (sgn:=sgn) (h:=PM_P _ H); auto.
  apply branch_indist with (s:=s) (s':=s'); auto.
  rewrite <- Hpc; auto.
  (* both are junctions *)
  apply junc_func with (step:=step m) (c:=cdr m (PM_P _ H)) (i:=pc s) (j1:=pc s2) in H3; auto.
  contradiction.
  apply exec_step_some with (1:=PM_P _ H) in H16. rewrite Hpc; auto.
Qed.

Theorem safe_ni : forall m sgn p p' s s' r r',
  P (SM m sgn) ->
  init_pc m (pc s) ->
  init_pc m (pc s') ->
  indist sgn (rt0 m sgn) (rt0 m sgn) s s' ->
  pc s = pc s' ->
  evalsto m p s r ->
  evalsto m p' s' r' ->
    rindist sgn r r'.
Proof.
  intros.
  apply (@ni_ind m sgn p p' s s' r r' H); auto.
  destruct (T _ _ H) as [T1 _]. rewrite T1; auto.
  apply typable_evalsto; auto.
  apply typable_evalsto; auto.
Qed.

End TypableProg.
End A.


Require Import type.

Fixpoint word_eq_dec ws w1 : forall w2 : word ws, {w1 = w2} + {w1 <> w2}.
Proof. repeat decide equality. Abort.


Require Import Terms.
Require Import LNaVSyntax.
Require Import LThrowDBigStep. (* reusing helpers *)

(** * Continuations and partial configurations *)

Inductive Frame : Type :=
| RLet : Var -> Tm -> Frame
| RRet : Env -> Frame
| RBrk : Lab -> Lab -> Frame (* final label + original pc *)
| RCatch : Var -> Tm -> Frame.

Definition Cont := list Frame.

Definition PCfg := prod (prod Lab Env) Cont.

Inductive RCfg : Type :=
| CR : Tm -> RCfg    (* term to be reduced *)
| CA : Atom -> RCfg  (* return atom *)
| CT : Excp -> RCfg. (* thrown exception *)

Definition Cfg := prod PCfg RCfg.

Notation "v @ L" := (v,L) (at level 5).

Notation "<< pc , r , k , X >>" := (((pc, r), k), X) (at level 5).

Definition result_to_rcfg r :=
  match r with
  | Suc a => CA a
  | Throw e => CT e
  end.

(** * Small-step semantics defined as a total(!) function *)

Definition step (c : Cfg) : Cfg :=
  match c with
  (* s_var *)
  | << pc, rho, k, CR (TVar x) >> =>
    match get rho x with
    | Some a =>
      << pc, rho, k, CA a >>
    | None =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_const *)
  | << pc, rho, k, CR (TConst c) >> =>
    << pc, rho, k, CA (V (VConst c))@bot>>
  (* s_let_start *)
  | << pc, rho, k, CR (TLet x t1 t2) >> =>
    << pc, rho, RLet x t2 :: k, CR t1 >>
  (* s_let_bind *)
  | << pc, rho, RLet x t :: k, CA a >> =>
    << pc, (x,a) :: rho, RRet rho :: k, CR t >>
  (* s_let_unwind *)
  | << pc, rho, RLet x t :: k, CT e >> =>
    << pc, rho, k, CT e >>
  (* s_abs *)
  | << pc, rho, k, CR (TAbs x t) >> =>
    << pc, rho, k, CA (V (VClos rho x t))@bot >>
  (* s_app *)
  | << pc, rho, k, CR (TApp x1 x2) >> =>
    match get rho x1, get rho x2 with
    | Some ((V (VClos rho' x t))@L), Some a =>
      << pc\_/L, (x,a) :: rho', RRet rho :: k, CR t >>
    | Some (b,L), Some a =>
      << pc\_/L, rho, k, CT (propagate_d b) >>
    | _, _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_return *)
  | << pc, rho, RRet rho' :: k, CA a >> =>
    << pc, rho', k, CA a >>
  (* s_return_unwind *)
  | << pc, rho, RRet rho' :: k, CT e >> =>
    << pc, rho', k, CT e >>
  (* s_inx *)
  | << pc, rho, k, CR (TInx d x) >> =>
    match get rho x with
    | Some a =>
      << pc, rho, k, CA (V (VInx d a))@bot >>
    | _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_match *)
  | << pc, rho, k, CR (TMatch x x' t1 t2) >> =>
    match get rho x with
    | Some (V (VInx DLeft a), l) =>
      << pc\_/l, (x',a) :: rho, RRet rho :: k, CR t1 >>
    | Some (V (VInx DRight a), l) =>
      << pc\_/l, (x',a) :: rho, RRet rho :: k, CR t2 >>
    | Some (V _, l) =>
      << pc\_/l, rho, k, CT eType >>
    | Some (D e, l) =>
      << pc\_/l, rho, k, CT e >>
    | _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_tag *)
  | << pc, rho, k, CR (TTag x) >> =>
    match get rho x with
    | Some (b,l) =>
      << pc\_/l, rho, k, result_to_rcfg (tag_res b) >>
    | _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_bop *)
  | << pc, rho, k, CR (TBOp bo x' x'') >> =>
    match get rho x', get rho x'' with
    | Some (b', l0'), Some (b'', l0'') =>
      << pc\_/l0' \_/ l0'', rho, k, result_to_rcfg (bop_res bo b' b'') >>
    | _, _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_bracket_start *)
  | << pc, rho, k, CR (TBracket x t) >> =>
    match get rho x with
    | Some ((V (VConst (CLab L)))@L') =>
      << pc\_/L', rho, RBrk L (pc\_/L') :: k, CR t >>
    | Some (b,L') =>
      << pc\_/L', rho, k, CT (propagate_d b) >>
    | None =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_bracket_end *)
  | << pc, rho, RBrk L' pc' :: k, CA b@L >> =>
    << pc', rho, k, CA (bracket_box (Suc b@L) pc (L' \_/ pc'))@L' >>
  | << pc, rho, RBrk L' pc' :: k, CT e >> =>
    << pc', rho, k, CA (bracket_box (Throw e) pc (L' \_/ pc'))@L' >>
  (* s_label_of *)
  | << pc, rho, k, CR (TLabelOf x) >> =>
    match get rho x with
    | Some (_,l) =>
      << pc, rho, k, CA (V (VConst (CLab l)))@bot >>
    | _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_get_pc *)
  | << pc, rho, k, CR TGetPc >> =>
    << pc, rho, k, CA (V (VConst (CLab pc)))@bot >>
  (* s_throw *)
  | << pc, rho, k, CR (TThrow x) >> =>
    match get rho x with
    | Some (b,l) =>
      << pc\_/l, rho, k, CT (throw_excp b) >>
    | _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* s_catch *)
  | << pc, rho, k, CR (TCatch t x t') >> =>
    << pc, rho, RCatch x t' :: k, CR t >>
  (* s_catch_no_excp *)
  | << pc, rho, RCatch x t' :: k, CA a >> =>
    << pc, rho, k, CA a >>
  (* s_catch_excp *)
  | << pc, rho, RCatch x t' :: k, CT e >> =>
    << pc, (x,((V (vExcp e))@bot)) :: rho, RRet rho :: k, CR t' >>
  (* s_to_sum *)
  | << pc, rho, k, CR (TToSum x) >> =>
    match get rho x with
    | Some (b,l) =>
      << pc, rho, k, CA (to_sum_box b)@l >>
    | _ =>
      << pc, rho, k, CT eUnbound >>
    end
  (* stack underflow (you're already done?) *)
  | << pc, rho, nil, CA _ >> =>
      << pc, rho, nil, CT eStack >>
  | << pc, rho, nil, CT e >> =>
      << pc, rho, nil, CT e >>
  (* terms not from this language *)
  (* s_mk_nav *)
  | << pc, rho, k, CR (TMkNav _) >> =>
      << pc, rho, k, CT eLanguage >>
  end.

Definition final (c : Cfg) : bool :=
  match c with
  | << pc, rho, nil, CA _ >> => true
  | << pc, rho, nil, CT _ >> => true
  | _ => false
  end.

Fixpoint nstep (n : nat) (cm : Cfg*nat) : Cfg*nat :=
  match n with
  | S n' =>
    match cm with
    | (c,m) => if final c then (c,m) else nstep n' (step c, m+1)
    end
  | O => cm
  end.

Definition mstep (n : nat) (t : Tm) : Cfg*nat :=
  nstep n (<< bot, nil, nil, CR t >>, 0).

Definition sstep (n : nat) (t : Tm) : option ((Result*Lab)*nat) :=
  match mstep n t with
  | (<< pc, rho, nil, CA a >>, m) => Some ((Suc a,pc),m)
  | (<< pc, rho, nil, CT e >>, m) => Some ((Throw e,pc),m)
  | _ => None (* looping or need more steps *)
  end.


From stdpp Require Import namespaces.
From iris.algebra Require Import excl auth list.
From iris.heap_lang Require Export lifting notation.
From iris.base_logic.lib Require Import invariants.
From iris.program_logic Require Import atomic.
From iris.heap_lang Require Import proofmode atomic_heap.
From iris_examples.logatom.elimination_stack Require spec.
Set Default Proof Using "Type".

Module logatom := elimination_stack.spec.

(** A general HoCAP-style interface for a stack, modeled after the spec in
[hocap/abstract_bag.v].  There are two differences:
- We split [bag_contents] into an authoritative part and a fragment as this
  slightly strnegthens the spec: The logically atomic spec only requires
  [stack_content ∗ stack_content] to derive a contradiction, the abstract bag
  spec requires to get *three* pieces which is only possible when actually
  calling a bag operation.
- We also slightly weaken the spec by adding [make_laterable], which is needed
  because logical atomicity can only capture laterable resources, which is
  needed when implementing e.g. the elimination stack on top of an abstract
  logically atomic heap. *)
Record hocap_stack {Σ} `{!heapG Σ} := AtomicStack {
  (* -- operations -- *)
  new_stack : val;
  push : val;
  pop : val;
  (* -- other data -- *)
  name : Type;
  name_eqdec : EqDecision name;
  name_countable : Countable name;
  (* -- predicates -- *)
  is_stack (N : namespace) (γs : name) (v : val) : iProp Σ;
  stack_content_frag (γs : name) (l : list val) : iProp Σ;
  stack_content_auth (γs : name) (l : list val) : iProp Σ;
  (* -- predicate properties -- *)
  is_stack_persistent N γs v : Persistent (is_stack N γs v);
  stack_content_frag_timeless γs l : Timeless (stack_content_frag γs l);
  stack_content_auth_timeless γs l : Timeless (stack_content_auth γs l);
  stack_content_frag_exclusive γs l1 l2 :
    stack_content_frag γs l1 -∗ stack_content_frag γs l2 -∗ False;
  stack_content_auth_exclusive γs l1 l2 :
    stack_content_auth γs l1 -∗ stack_content_auth γs l2 -∗ False;
  stack_content_agree γs l1 l2 :
    stack_content_frag γs l1 -∗ stack_content_auth γs l2 -∗ ⌜l1 = l2⌝;
  stack_content_update γs l l' :
    stack_content_frag γs l -∗
    stack_content_auth γs l -∗
    |==> stack_content_frag γs l' ∗ stack_content_auth γs l';
  (* -- operation specs -- *)
  new_stack_spec N :
    {{{ True }}} new_stack #() {{{ γs s, RET s; is_stack N γs s ∗ stack_content_frag γs [] }}};
  push_spec N γs s (v : val) (Φ : val → iProp Σ) :
    is_stack N γs s -∗
    make_laterable (∀ l, stack_content_auth γs l ={⊤∖↑N}=∗ stack_content_auth γs (v::l) ∗ Φ #()) -∗
    WP push s v {{ Φ }};
  pop_spec N γs s (Φ : val → iProp Σ) :
    is_stack N γs s -∗
    make_laterable (∀ l, stack_content_auth γs l ={⊤∖↑N}=∗
          match l with [] => stack_content_auth γs [] ∗ Φ NONEV
                | v :: l' => stack_content_auth γs l' ∗ Φ (SOMEV v) end) -∗
    WP pop s {{ Φ }};
}.
Arguments hocap_stack _ {_}.

Existing Instances
  is_stack_persistent stack_content_frag_timeless stack_content_auth_timeless
  name_eqdec name_countable.

(** Show that our way of writing the [pop_spec] is equivalent to what is done in
[concurrent_stack.spec].  IOW, the conjunction-vs-match doesn't matter.  Fixing
the postcondition (the [Q] in [concurrent_stack.spec]) still matters. *)
Section pop_equiv.
  Context `{invG Σ} (T : Type).

  Lemma pop_equiv E (I : list T → iProp Σ) (Φemp : iProp Σ) (Φret : T → iProp Σ) :
    (∀ l, I l ={E}=∗
       match l with [] => I [] ∗ Φemp | v :: l' => I l' ∗ Φret v end)
    ⊣⊢
    (∀ v vs, I (v :: vs) ={E}=∗ Φret v ∗ I vs)
    ∧ (I [] ={E}=∗ Φemp ∗ I []).
  Proof.
    iSplit.
    - iIntros "HΦ". iSplit.
      + iIntros (??) "HI". iMod ("HΦ" with "HI") as "[$ $]". done.
      + iIntros "HI". iMod ("HΦ" with "HI") as "[$ $]". done.
    - iIntros "HΦ" (l) "HI". destruct l; rewrite [(I _ ∗ _)%I]bi.sep_comm; by iApply "HΦ".
  Qed.
End pop_equiv.

(** From a HoCAP stack we can directly implement the logically atomic
interface. *)
Section hocap_logatom.
  Context `{!heapG Σ} (stack: hocap_stack Σ).

  Lemma logatom_push N γs s (v : val) :
    stack.(is_stack) N γs s -∗
    <<< ∀ l : list val, stack.(stack_content_frag) γs l >>>
      stack.(push) s v @ ⊤∖↑N
    <<< stack.(stack_content_frag) γs (v::l), RET #() >>>.
  Proof.
    iIntros "Hstack". iIntros (Φ) "HΦ".
    iApply (push_spec with "Hstack").
    iApply (make_laterable_intro with "[] HΦ"). iIntros "!# >HΦ" (l) "Hauth".
    iMod "HΦ" as (l') "[Hfrag [_ Hclose]]".
    iDestruct (stack_content_agree with "Hfrag Hauth") as %->.
    iMod (stack_content_update with "Hfrag Hauth") as "[Hfrag $]".
    iMod ("Hclose" with "Hfrag") as "HΦ". done.
  Qed.

  Lemma logatom_pop N γs (s : val) :
    stack.(is_stack) N γs s -∗
    <<< ∀ l : list val, stack.(stack_content_frag) γs l >>>
      stack.(pop) s @ ⊤∖↑N
    <<< stack.(stack_content_frag) γs (tail l),
        RET match l with [] => NONEV | v :: _ => SOMEV v end >>>.
  Proof.
    iIntros "Hstack". iIntros (Φ) "HΦ".
    iApply (pop_spec with "Hstack").
    iApply (make_laterable_intro with "[] HΦ"). iIntros "!# >HΦ" (l) "Hauth".
    iMod "HΦ" as (l') "[Hfrag [_ Hclose]]".
    iDestruct (stack_content_agree with "Hfrag Hauth") as %->.
    destruct l;
    iMod (stack_content_update with "Hfrag Hauth") as "[Hfrag $]";
    iMod ("Hclose" with "Hfrag") as "HΦ"; done.
  Qed.

  Definition hocap_logatom : logatom.atomic_stack Σ :=
    {| logatom.new_stack_spec := stack.(new_stack_spec);
       logatom.push_spec := logatom_push;
       logatom.pop_spec := logatom_pop;
       logatom.stack_content_exclusive := stack.(stack_content_frag_exclusive) |}.

End hocap_logatom.

(** From a logically atomic stack, we can implement a HoCAP stack by adding an
auth invariant. *)

(** The CMRA & functor we need. *)
Class hocapG Σ := HocapG {
  hocap_stateG :> inG Σ (authR (optionUR $ exclR (listO valO)));
}.
Definition hocapΣ : gFunctors :=
  #[GFunctor (exclR unitO); GFunctor (authR (optionUR $ exclR (listO valO)))].

Instance subG_hocapΣ {Σ} : subG hocapΣ Σ → hocapG Σ.
Proof. solve_inG. Qed.

Section logatom_hocap.
  Context `{!heapG Σ} `{!hocapG Σ} (stack: logatom.atomic_stack Σ).

  Definition hocap_name : Type := stack.(logatom.name) * gname.
  Implicit Types γs : hocap_name.

  Definition hocap_stack_content_auth γs l : iProp Σ := own γs.2 (● Excl' l).
  Definition hocap_stack_content_frag γs l : iProp Σ := own γs.2 (◯ Excl' l).

  Definition hocap_is_stack N γs v : iProp Σ :=
    (stack.(logatom.is_stack) (N .@ "stack") γs.1 v ∗
     inv (N .@ "wrapper") (∃ l, stack.(logatom.stack_content) γs.1 l ∗ hocap_stack_content_auth γs l))%I.

  Lemma hocap_new_stack N :
    {{{ True }}}
      stack.(logatom.new_stack) #()
    {{{ γs s, RET s; hocap_is_stack N γs s ∗ hocap_stack_content_frag γs [] }}}.
  Proof.
    iIntros (Φ) "_ HΦ". iApply wp_fupd. iApply logatom.new_stack_spec; first done.
    iIntros "!>" (γs s) "[Hstack Hcont]".
    iMod (own_alloc (● Excl' [] ⋅ ◯ Excl' [])) as (γw) "[Hs● Hs◯]".
    { apply auth_both_valid. split; done. }
    iApply ("HΦ" $! (γs, γw)). rewrite /hocap_is_stack. iFrame.
    iApply inv_alloc. eauto with iFrame.
  Qed.

  Lemma hocap_push N γs s (v : val) (Φ : val → iProp Σ) :
    hocap_is_stack N γs s -∗
    make_laterable (∀ l, hocap_stack_content_auth γs l ={⊤∖↑N}=∗ hocap_stack_content_auth γs (v::l) ∗ Φ #()) -∗
    WP stack.(logatom.push) s v {{ Φ }}.
  Proof using Type*.
    iIntros "#[Hstack Hwrap] Hupd". awp_apply (logatom.push_spec with "Hstack").
    iInv "Hwrap" as (l) "[>Hcont >H●]".
    iAaccIntro with "Hcont"; first by eauto 10 with iFrame.
    iIntros "Hcont".
    iMod fupd_intro_mask' as "Hclose";
      last iMod (make_laterable_elim with "Hupd H●") as "[H● HΦ]"; first solve_ndisj.
    iMod "Hclose" as "_". iIntros "!>".
    eauto with iFrame.
  Qed.

  Lemma hocap_pop N γs s (Φ : val → iProp Σ) :
    hocap_is_stack N γs s -∗
    make_laterable (∀ l, hocap_stack_content_auth γs l ={⊤∖↑N}=∗
          match l with [] => hocap_stack_content_auth γs [] ∗ Φ NONEV
                | v :: l' => hocap_stack_content_auth γs l' ∗ Φ (SOMEV v) end) -∗
    WP stack.(logatom.pop) s {{ Φ }}.
  Proof using Type*.
    iIntros "#[Hstack Hwrap] Hupd". awp_apply (logatom.pop_spec with "Hstack").
    iInv "Hwrap" as (l) "[>Hcont >H●]".
    iAaccIntro with "Hcont"; first by eauto 10 with iFrame.
    iIntros "Hcont". destruct l.
    - iMod fupd_intro_mask' as "Hclose";
        last iMod (make_laterable_elim with "Hupd H●") as "[H● HΦ]"; first solve_ndisj.
       iMod "Hclose" as "_". iIntros "!>"; eauto with iFrame.
    - iMod fupd_intro_mask' as "Hclose";
        last iMod (make_laterable_elim with "Hupd H●") as "[H● HΦ]"; first solve_ndisj.
       iMod "Hclose" as "_". iIntros "!>"; eauto with iFrame.
  Qed.

  Program Definition logatom_hocap : hocap_stack Σ :=
    {| new_stack_spec := hocap_new_stack;
       push_spec := hocap_push;
       pop_spec := hocap_pop |}.
  Next Obligation.
    iIntros (???) "Hf1 Hf2". iDestruct (own_valid_2 with "Hf1 Hf2") as %[].
  Qed.
  Next Obligation.
    iIntros (???) "Ha1 Ha2". by iDestruct (own_valid_2 with "Ha1 Ha2") as %[].
  Qed.
  Next Obligation.
    iIntros (???) "Hf Ha". iDestruct (own_valid_2 with "Ha Hf") as
      %[->%Excl_included%leibniz_equiv _]%auth_both_valid. done.
  Qed.
  Next Obligation.
    iIntros (???) "Hf Ha". iMod (own_update_2 with "Ha Hf") as "[? ?]".
    { eapply auth_update, option_local_update, (exclusive_local_update _ (Excl _)). done. }
    by iFrame.
  Qed.

End logatom_hocap.


(* Distributed under the terms of the MIT license. *)
From Coq Require Import ProofIrrelevance ssreflect ssrbool.
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import config uGraph.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTactics
     PCUICReflect PCUICLiftSubst PCUICUnivSubst PCUICTyping PCUICGlobalEnv
     PCUICCumulativity PCUICEquality PCUICWfUniverses
     PCUICInduction.

Require Import Equations.Prop.DepElim.
From Equations Require Import Equations.

Local Set Keyed Unification.

Set Default Goal Selector "!".

(* TODO move*)

Lemma consistent_instance_wf_universe `{checker_flags} Σ uctx u :
  consistent_instance_ext Σ uctx u ->
  Forall (wf_universe Σ) (map Universe.make u).
Proof.
  move => /consistent_instance_ext_wf /wf_universe_instanceP.
  rewrite -wf_universeb_instance_forall.
  move => /forallb_Forall ?.
  eapply Forall_impl ; tea.
  move => ? /wf_universe_reflect //.
Qed.

Lemma ctx_inst_on_universes Σ Γ ts Ts :
  ctx_inst (fun Σ' _ t' _ => wf_universes Σ' t') Σ Γ ts Ts ->
  Forall (wf_universes Σ) ts.
Proof.
  induction 1.
  - constructor.
  - now constructor.
  - assumption.
Qed.

(** ** Boolean of equality **  *)

Definition compare_universe_variance (equ lequ : Universe.t -> Universe.t -> bool) v u u' :=
  match v with
  | Variance.Irrelevant => true
  | Variance.Covariant => lequ (Universe.make u) (Universe.make u')
  | Variance.Invariant => equ (Universe.make u) (Universe.make u')
  end.

Definition compare_universe_instance equ u u' :=
  forallb2 equ (map Universe.make u) (map Universe.make u').

Fixpoint compare_universe_instance_variance equ lequ v u u' :=
  match u, u' with
  | u :: us, u' :: us' =>
    match v with
    | [] => compare_universe_instance_variance equ lequ v us us'
      (* Missing variance stands for irrelevance *)
    | v :: vs => compare_universe_variance equ lequ v u u' &&
        compare_universe_instance_variance equ lequ vs us us'
    end
  | [], [] => true
  | _, _ => false
  end.

Definition compare_global_instance lookup equ lequ gr napp :=
  match global_variance_gen lookup gr napp with
  | Some v => compare_universe_instance_variance equ lequ v
  | None => compare_universe_instance equ
  end.

Definition eqb_binder_annots (x y : list aname) : bool :=
  forallb2 eqb_binder_annot x y.

Fixpoint eqb_term_upto_univ_napp
  (equ lequ : Universe.t -> Universe.t -> bool)
  (gen_compare_global_instance : (Universe.t -> Universe.t -> bool) -> global_reference -> nat -> list Level.t -> list Level.t -> bool)
  napp (u v : term) : bool :=
  match u, v with
  | tRel n, tRel m =>
    eqb n m

  | tEvar e args, tEvar e' args' =>
    eqb e e' &&
    forallb2 (eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0) args args'

  | tVar id, tVar id' =>
    eqb id id'

  | tSort u, tSort u' =>
    lequ u u'

  | tApp u v, tApp u' v' =>
    eqb_term_upto_univ_napp equ lequ gen_compare_global_instance (S napp) u u' &&
    eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 v v'

  | tConst c u, tConst c' u' =>
    eqb c c' &&
    forallb2 equ (map Universe.make u) (map Universe.make u')

  | tInd i u, tInd i' u' =>
    eqb i i' &&
    gen_compare_global_instance lequ (IndRef i) napp u u'

  | tConstruct i k u, tConstruct i' k' u' =>
    eqb i i' &&
    eqb k k' &&
    gen_compare_global_instance lequ (ConstructRef i k) napp u u'

  | tLambda na A t, tLambda na' A' t' =>
    eqb_binder_annot na na' &&
    eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 A A' &&
    eqb_term_upto_univ_napp equ lequ gen_compare_global_instance 0 t t'

  | tProd na A B, tProd na' A' B' =>
    eqb_binder_annot na na' &&
    eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 A A' &&
    eqb_term_upto_univ_napp equ lequ gen_compare_global_instance 0 B B'

  | tLetIn na B b u, tLetIn na' B' b' u' =>
    eqb_binder_annot na na' &&
    eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 B B' &&
    eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 b b' &&
    eqb_term_upto_univ_napp equ lequ gen_compare_global_instance 0 u u'

  | tCase indp p c brs, tCase indp' p' c' brs' =>
    eqb indp indp' &&
    eqb_predicate_gen
      (fun u u' => forallb2 equ (map Universe.make u) (map Universe.make u'))
      (bcompare_decls eqb eqb)
      (eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0) p p' &&
    eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 c c' &&
    forallb2 (fun x y =>
      forallb2
        (bcompare_decls eqb eqb)
        x.(bcontext) y.(bcontext) &&
      eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 (bbody x) (bbody y)
    ) brs brs'

  | tProj p c, tProj p' c' =>
    eqb p p' &&
    eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 c c'

  | tFix mfix idx, tFix mfix' idx' =>
    eqb idx idx' &&
    forallb2 (fun x y =>
      eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 x.(dtype) y.(dtype) &&
      eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 x.(dbody) y.(dbody) &&
      eqb x.(rarg) y.(rarg) &&
      eqb_binder_annot x.(dname) y.(dname)
    ) mfix mfix'

  | tCoFix mfix idx, tCoFix mfix' idx' =>
    eqb idx idx' &&
    forallb2 (fun x y =>
      eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 x.(dtype) y.(dtype) &&
      eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0 x.(dbody) y.(dbody) &&
      eqb x.(rarg) y.(rarg) &&
      eqb_binder_annot x.(dname) y.(dname)
    ) mfix mfix'

  | tPrim p, tPrim p' => eqb p p'

  | _, _ => false
  end.

Notation eqb_term_upto_univ eq leq gen_compare_global_instance :=
  (eqb_term_upto_univ_napp eq leq gen_compare_global_instance 0).

Definition conv_pb_relb_gen pb (eq leq : Universe.t -> Universe.t -> bool) :=
    match pb with
    | Conv => eq
    | Cumul => leq
    end.

Definition eqb_termp_napp_gen pb eq leq compare_global_instance_gen napp :=
      eqb_term_upto_univ_napp eq (conv_pb_relb_gen pb eq leq)
                compare_global_instance_gen napp.

Ltac eqspec :=
  lazymatch goal with
  | |- context [ eqb ?u ?v ] =>
    destruct (eqb_specT u v) ; nodec ; subst
  end.

Ltac eqspecs :=
  repeat eqspec.

Local Ltac equspec equ h :=
  repeat lazymatch goal with
  | |- context [ equ ?x ?y ] =>
    destruct (h x y) ; nodec ; subst
  end.

Local Ltac ih :=
  repeat lazymatch goal with
  | ih : forall lequ Rle napp hle t' ht ht', reflectT (eq_term_upto_univ_napp _ _ _ napp ?t _) _,
    hle : forall u u' hu hu', reflect (?Rle u u') (?lequ u u') ,
    hcompare : forall R leq H ref n l l' _ _ , _ <-> _
    |- context [ eqb_term_upto_univ _ ?lequ _ ?t ?t' ] =>
    destruct (ih lequ Rle 0 hle t')
       ; nodec ; subst
  end.

(* Lemma compare_global_instance_impl (equ lequ : _ -> _ -> bool) Σ Re Rle gr napp :
  RelationClasses.subrelation equ Re ->
  RelationClasses.subrelation lequ Rle ->
  subrelation (compare_global_instance Σ equ lequ gr napp) (R_global_instance Σ Re Rle gr napp).
Proof.
  intros hre hrle x y.
  unfold compare_global_instance, R_global_instance, R_opt_variance.
  destruct global_variance as [v|].
  - induction x in v, y |- *; destruct v, y; simpl; auto.
    rtoProp. intros [Hat Hxy]. split; auto.
    destruct t; simpl in *; auto.
  - intro. eapply forallb2_Forall2 in H.
    eapply Forall2_impl; tea; eauto.
Qed. *)

Lemma Forall2_forallb2:
  forall (A : Type) (p : A -> A -> bool) (l l' : list A),
  Forall2 (fun x y : A => p x y) l l' -> forallb2 p l l'.
Proof.
  induction 1; simpl; auto.
Qed.

Lemma eqb_annot_spec {A} na na' : eqb_binder_annot na na' <-> @eq_binder_annot A A na na'.
Proof.
  unfold eqb_binder_annot, eq_binder_annot.
  now destruct Classes.eq_dec.
Qed.

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.

Lemma eqb_annot_refl {A} n : @eqb_binder_annot A n n.
Proof.
  apply eqb_annot_spec. reflexivity.
Qed.

Lemma eqb_annots_spec nas nas' : eqb_binder_annots nas nas' <-> Forall2 (on_rel eq binder_relevance) nas nas'.
Proof.
  unfold eqb_binder_annots, eq_binder_annot.
  split; intros.
  - eapply forallb2_Forall2 in H.
    eapply (Forall2_impl H). unfold on_rel. apply eqb_annot_spec.
  - eapply Forall2_forallb2, (Forall2_impl H); apply eqb_annot_spec.
Qed.

Lemma eqb_annots_reflect nas nas' : reflectT (All2 (on_rel eq binder_relevance) nas nas') (eqb_binder_annots nas nas').
Proof.
  unfold eqb_binder_annots, eq_binder_annot.
  destruct forallb2 eqn:H; constructor.
  - eapply Forall2_All2. now apply eqb_annots_spec.
  - intros H'; apply All2_Forall2, eqb_annots_spec in H'.
    red in H'. unfold eqb_binder_annots in H'. congruence.
Qed.

Lemma forallb2_bcompare_decl_All2_fold
  (P : term -> term -> bool) Γ Δ :
  forallb2 (bcompare_decls P P) Γ Δ ->
  All2_fold (fun _ _ => bcompare_decls P P) Γ Δ.
Proof.
  induction Γ as [|[na [b|] ty] Γ] in Δ |- *; destruct Δ as [|[na' [b'|] ty'] Δ]; simpl => //; constructor; auto;
  now move/andb_and: H => [].
Qed.

Lemma reflect_eq_context_IH {Σ equ lequ}
  {Re Rle : Universe.t -> Universe.t -> Prop}
  {gen_compare_global_instance : (Universe.t -> Universe.t -> Prop) -> global_reference -> nat -> list Level.t -> list Level.t -> bool }:
  (forall u u', reflect (Re u u') (equ u u')) ->
  (forall u u', reflect (Rle u u') (lequ u u')) ->
  forall ctx ctx',
  onctx
      (fun t : term =>
       forall (lequ : Universe.t -> Universe.t -> bool)
         (Rle : Universe.t -> Universe.t -> Prop)
         (napp : nat),
       (forall u u' : Universe.t, reflect (Rle u u') (lequ u u')) ->
       forall t' : term,
       reflectT (eq_term_upto_univ_napp Σ Re Rle napp t t')
         (eqb_term_upto_univ_napp equ lequ gen_compare_global_instance napp t t'))
      ctx ->
  reflectT
    (eq_context_gen (eq_term_upto_univ Σ Re Re) (eq_term_upto_univ Σ Re Re) ctx ctx')
    (forallb2 (bcompare_decls (eqb_term_upto_univ equ equ gen_compare_global_instance)
      (eqb_term_upto_univ equ equ gen_compare_global_instance)) ctx ctx').
Proof.
  intros hRe hRle ctx ctx' onc.
  eapply equiv_reflectT.
  - intros hcc'.
    eapply All2_fold_forallb2, All2_fold_impl_onctx; tea.
    unfold ondecl; intuition auto.
    depelim X0; cbn in * => //;
    intuition auto.
    + destruct (eqb_annot_reflect na na') => //.
      destruct (a equ Re 0 hRe T') => //.
    + destruct (eqb_annot_reflect na na') => //.
      destruct (b0 equ Re 0 hRe b') => //.
      destruct (a equ Re 0 hRe T') => //.
  - intros hcc'.
    eapply forallb2_bcompare_decl_All2_fold in hcc'; tea.
    eapply All2_fold_impl_onctx in onc; tea; simpl; intuition eauto.
    destruct X0.
    move: H.
    destruct d as [na [bod|] ty], d' as [na' [bod'|] ty']; cbn in * => //.
    + destruct (eqb_annot_reflect na na') => //.
      destruct (r equ Re 0 hRe ty') => //.
      2: now rewrite andb_false_r.
      destruct (o equ Re 0 hRe bod') => //.
      now constructor.
    + destruct (eqb_annot_reflect na na') => //.
      destruct (r equ Re 0 hRe ty') => //.
      now constructor.
Qed.

Definition eqb_univ_reflect : forall u u' : Universe.t, reflectProp (u = u') (eqb u u').
Proof.
  intros u u'.
  destruct (eqb_spec u u'); constructor; auto.
Qed.

Lemma eq_dec_to_bool_refl {A} {ea : Classes.EqDec A} (x : A) :
  eq_dec_to_bool x x.
Proof.
  unfold eq_dec_to_bool.
  now destruct (Classes.eq_dec x x).
Qed.

Lemma reflect_eq_ctx ctx ctx' :
  reflectT
    (eq_context_gen eq eq ctx ctx')
    (forallb2 (bcompare_decls eqb eqb) ctx ctx').
Proof.
  eapply equiv_reflectT.
  - intros hcc'.
    eapply All2_fold_forallb2; tea.
    unfold ondecl; intuition auto.
    eapply All2_fold_impl; tea. intros.
    destruct X; cbn ; subst.
    all: destruct (eqb_annot_reflect na na') => /= //.
    2: apply/andb_and; split.
    all: eapply eqb_refl.
  - intros hcc'.
    eapply forallb2_bcompare_decl_All2_fold in hcc'; tea.
    eapply All2_fold_impl in hcc'; tea; simpl; intuition eauto.
    move: H.
    destruct d as [na [bod|] ty], d' as [na' [bod'|] ty']; cbn in * => //.
    + destruct (eqb_annot_reflect na na') => // /=.
      repeat case: eqb_specT => //; intros; subst; cbn; auto; constructor; auto.
    + destruct (eqb_annot_reflect na na') => //.
      repeat case: eqb_specT => //; intros; subst; cbn; auto; constructor; auto.
Qed.

Lemma forallb_true {A : Type} (l : list A) : forallb xpredT l.
Proof.
  now induction l.
Qed.

Lemma on_universes_true (t : term) : on_universes xpredT (fun _ => xpredT) t.
Proof.
  induction t using term_forall_list_ind => //=.
  - now apply All_forallb.
  - now rewrite IHt1 IHt2.
  - now rewrite IHt1 IHt2.
  - now rewrite IHt1 IHt2 IHt3.
  - now rewrite IHt1 IHt2.
  - now apply forallb_true.
  - now apply forallb_true.
  - now apply forallb_true.
  - rewrite forallb_true IHt /=.
    destruct X as [? [? ->]].
    rewrite All_forallb //=.
    apply/andP ; split.
    + clear.
      induction (pcontext p) as [|[? [] ?]] => //=.
      all: now intuition.
    + apply All_forallb.
      eapply All_impl ; tea.
      cbn.
      move => [] /= bcontext ? [? ?].
      apply /andP ; split => //=.
      clear.
      induction bcontext as [|[? [] ?]] => //=.
      all: now intuition.

  - apply All_forallb.
    eapply All_impl ; tea.
    move => ? [? ?].
    now apply /andP.
  - apply All_forallb.
    eapply All_impl ; tea.
    move => ? [? ?].
    now apply /andP.
Qed.

Definition reflect_eq_predicate {Σ equ lequ}
  {gen_compare_global_instance : (Universe.t -> Universe.t -> bool) -> global_reference -> nat -> list Level.t -> list Level.t -> bool}
  {Re Rle : Universe.t -> Universe.t -> Prop}
  {p : Universe.t -> bool}
  {q : nat -> term -> bool} :
  (forall u u', p u -> p u' -> reflect (Re u u') (equ u u')) ->
  (forall u u', p u -> p u' -> reflect (Rle u u') (lequ u u')) ->
  (forall R leq,
        (forall u u', p u -> p u' -> reflect (R u u') (leq u u')) ->
        forall ref n l l',
        forallb p (map Universe.make l) ->
        forallb p (map Universe.make l') ->
        R_global_instance Σ Re R ref n l l' <->
        gen_compare_global_instance leq ref n l l') ->
  forall pr pr',
  Forall p (map Universe.make pr.(puinst)) ->
  Forall (on_universes p q) pr.(pparams) ->
  on_universes p q pr.(preturn) ->
  Forall p (map Universe.make pr'.(puinst)) ->
  Forall (on_universes p q) pr'.(pparams) ->
  on_universes p q pr'.(preturn) ->
  tCasePredProp
  (fun t : term =>
   forall (lequ : Universe.t -> Universe.t -> bool) (Rle : Universe.t -> Universe.t -> Prop) (napp : nat),
   (forall u u' : Universe.t, p u -> p u' -> reflect (Rle u u') (lequ u u')) ->
  forall t' : term,
   on_universes p q t ->
   on_universes p q t' ->
   reflectT (eq_term_upto_univ_napp Σ Re Rle napp t t') (eqb_term_upto_univ_napp equ lequ gen_compare_global_instance napp t t'))
  (fun t : term =>
   forall (lequ : Universe.t -> Universe.t -> bool) (Rle : Universe.t -> Universe.t -> Prop) (napp : nat),
   (forall u u' : Universe.t, p u -> p u' -> reflect (Rle u u') (lequ u u')) ->
  forall t' : term,
   on_universes p q t ->
   on_universes p q t' ->
   reflectT (eq_term_upto_univ_napp Σ Re Rle napp t t') (eqb_term_upto_univ_napp equ lequ gen_compare_global_instance napp t t')) pr ->
  reflectT (eq_predicate (eq_term_upto_univ_napp Σ Re Re 0) Re pr pr')
    (eqb_predicate_gen (fun u u' => forallb2 equ (map Universe.make u) (map Universe.make u'))
      (bcompare_decls eqb eqb)
      (eqb_term_upto_univ_napp equ equ gen_compare_global_instance 0) pr pr').
Proof.
  intros.
  solve_all. unfold eq_predicate, eqb_predicate, eqb_predicate_gen.
  cbn -[eqb]; apply equiv_reflectT.
  - intros Hp; rtoProp.
    destruct Hp as [onpars [onuinst [pctx pret]]].
    intuition auto; rtoProp; intuition auto.
    * solve_all. destruct (b1 _ Re 0 X y); auto; try contradiction.
    * red in onuinst.
      solve_all.
      eapply All2_impl.
      1: eapply (All2_All_mix_left H0), (All2_All_mix_right H3), All2_map_inv ;
        eassumption.
      now move=> x y [? []] /X.
    * destruct (reflect_eq_ctx (pcontext pr) (pcontext pr')) => //.
    * now destruct (r equ Re 0 X (preturn pr')) ; nodec ; subst.
  - move/andb_and => [/andb_and [/andb_and [ppars pinst] pctx] pret].
    intuition auto.
    * solve_all.
      now destruct (b1 _ _ 0 X y).
    * red.
      solve_all.
      eapply All2_impl.
      1: eapply (All2_All_mix_left H0), (All2_All_mix_right H3), All2_map_inv;
        eassumption.
      now move=> x y [? []] /X.
    * now destruct (reflect_eq_ctx (pcontext pr) (pcontext pr')).
    * now destruct (r _ _ 0 X (preturn pr')).
Qed.

Arguments eqb : simpl never.

Lemma reflect_R_global_instance' lookup equ lequ  (p : Universe.t -> bool)
  (Re Rle : Universe.t -> Universe.t -> Prop) gr napp ui ui' :
  (forall u u', p u -> p u' -> reflect (Re u u') (equ u u')) ->
  (forall u u', p u -> p u' -> reflect (Rle u u') (lequ u u')) ->
  forallb p (map Universe.make ui) ->
  forallb p (map Universe.make ui') ->
  reflect (R_global_instance_gen lookup Re Rle gr napp ui ui')
    (compare_global_instance lookup equ lequ gr napp ui ui').
Proof.
  intros he hle hui hui'.
  rewrite /compare_global_instance /R_global_instance_gen.
  destruct (global_variance_gen _ gr napp) as [v|].
  - induction ui as [|u ui IHui] in ui', v, hui, hui' |- * ; cbn in *.
    all: destruct ui' as [|u' ui'].
    1-3: by constructor.
    move: hui => /andP [? ?].
    move: hui' => /andP [? ?].
    destruct v as [|hv v]; cbn in *.
    1: now apply IHui.
    apply: (iffP andP) => [] [?] /IHui H.
    all: split.
    2,4: now apply H.
    all: destruct hv => //=.
    + apply /hle => //.
    + apply /he => //.
    + edestruct (hle (Universe.make u) (Universe.make u')) => //.
    + edestruct (he (Universe.make u) (Universe.make u')) => //.
  - cbn.
    unfold R_universe_instance, compare_universe_instance.
    apply (iffP idP).
    + solve_all.
      eapply All2_impl.
      1: eapply (All2_All_mix_left hui), (All2_All_mix_right hui'), All2_map_inv ;
      eassumption.
      now move => u u' [? []] /he.
    + solve_all.
      eapply All2_impl.
      1: eapply (All2_All_mix_left hui), (All2_All_mix_right hui'), All2_map_inv ;
      eassumption.
      now move => u u' [? []] /he.
Qed.

Lemma reflect_R_global_instance Σ lookup equ lequ  (p : Universe.t -> bool)
  (Re Rle : Universe.t -> Universe.t -> Prop) gr napp ui ui' :
  (forall u u', p u -> p u' -> reflect (Re u u') (equ u u')) ->
  (forall u u', p u -> p u' -> reflect (Rle u u') (lequ u u')) ->
  (forall kn, lookup_env Σ kn = lookup kn) ->
  forallb p (map Universe.make ui) ->
  forallb p (map Universe.make ui') ->
  reflect (R_global_instance Σ Re Rle gr napp ui ui')
    (compare_global_instance lookup equ lequ gr napp ui ui').
Proof.
  intros he hleh hlookup hui hui'.
  pose proof (Hglobal := reflect_R_global_instance' lookup equ lequ p
        Re Rle gr napp ui ui' he hleh hui hui').
  rewrite /R_global_instance_gen /compare_global_instance /R_opt_variance.
  rewrite /global_variance_gen /lookup_constructor_gen /lookup_inductive_gen /lookup_minductive_gen.
  destruct gr; auto; now repeat rewrite hlookup.
Qed.

Lemma reflect_eq_term_upto_univ Σ equ lequ
  (p : Universe.t -> bool) (q : nat -> term -> bool)
  (Re Rle : Universe.t -> Universe.t -> Prop)
  (gen_compare_global_instance : (Universe.t -> Universe.t -> bool) -> global_reference -> nat -> list Level.t -> list Level.t -> bool)
  napp :
  (forall u u', p u -> p u' -> reflect (Re u u') (equ u u')) ->
  (forall u u', p u -> p u' -> reflect (Rle u u') (lequ u u')) ->
  (forall R leq,
        (forall u u', p u -> p u' -> reflect (R u u') (leq u u')) ->
        forall ref n l l' ,
        forallb p (map Universe.make l) ->
        forallb p (map Universe.make l') ->
        R_global_instance Σ Re R ref n l l' <->
        gen_compare_global_instance leq ref n l l') ->
  forall t t',
    on_universes p q t ->
    on_universes p q t' ->
    reflectT (eq_term_upto_univ_napp Σ Re Rle napp t t')
             (eqb_term_upto_univ_napp equ lequ gen_compare_global_instance napp t t').
Proof.
  intros he hle hcompare t t' ht ht'.
  induction t in t', napp, lequ, Rle, hle, ht, ht' |- * using term_forall_list_ind.
  all: destruct t' ; nodec.
  all: move: ht => /= ; (repeat move => /andP [?]) ; move => ht.
  all: move: ht' => /= ; (repeat move => /andP [?]) ; move => ht'.

  - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. ih.
    constructor. constructor ; assumption.
  - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. ih.
    constructor. constructor ; assumption.
  - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. ih.
    cbn.
    induction X in l0, ht, ht' |- *.
    + destruct l0.
      * constructor. constructor. constructor.
      * constructor. intro bot. inversion bot. inversion X.
    + destruct l0.
      * constructor. intro bot. inversion bot. subst. inversion X0.
      * move: ht => /= /andP [? ?].
        move: ht' => /= /andP [? ?].
        destruct (p0 _ _ 0 he t) => //.
        -- cbn.  destruct (IHX l0) => //.
           ++ compute. constructor. constructor. constructor ; try assumption.
              inversion e0. subst. assumption.
           ++ constructor. intro bot. inversion bot. subst.
              inversion X0. subst.
              apply f. constructor. assumption.
        -- constructor. intro bot. apply f.
           inversion bot. subst. inversion X0. subst. assumption.
  - cbn - [eqb]. equspec lequ hle.
    all: auto.
    ih.
    constructor. constructor. assumption.
  - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle.
    destruct (eqb_annot_reflect n na); ih => //=.
    constructor. constructor; assumption.
  - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle.
    destruct (eqb_annot_reflect n na); ih => //.
    constructor. constructor ; assumption.
  - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle.
    destruct (eqb_annot_reflect n na); ih => //.
    constructor. constructor ; assumption.
  - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. ih => //.
    + destruct (IHt1 lequ Rle (S napp) hle t'1) => //.
      * constructor. constructor ; assumption.
      * constructor. intros H. now inv H.
    + destruct (IHt1 lequ Rle (S napp) hle t'1) => //.
      * constructor; auto.
        intros H; now inv H.
      * constructor. intros H; now inv H.
  - cbn - [eqb].
    destruct (eqb_specT s k) ; nodec. subst.
    induction u in ui, ht, ht' |- *.
    + destruct ui.
      * constructor. constructor. constructor.
      * constructor. intro bot. inversion bot. subst. inversion H0.
    + destruct ui.
      * constructor. intro bot. inversion bot. subst. inversion H0.
      * move: ht => /= /andP [? ?].
        move: ht' => /= /andP [? ?].
        cbn in *. equspec equ he => //=.
        -- destruct (IHu ui) => //=.
           ++ constructor. constructor.
              inversion e. subst.
              constructor ; assumption.
           ++ constructor. intro bot. apply f.
              inversion bot. subst. constructor. inversion H0.
              subst. assumption.
        -- constructor. intro bot. apply n.
           inversion bot. subst. inversion H0. subst.
           assumption.
  - cbn - [eqb]. eqspecs.
    apply equiv_reflectT.
    + inversion 1; subst. now eapply hcompare.
    + intros H.
      constructor.
      now rewrite hcompare.
  - cbn - [eqb]. eqspecs.
    apply equiv_reflectT.
    + inversion 1; subst. now eapply hcompare.
    + intros H.
      constructor. now eapply hcompare.
  - cbn - [eqb]. eqspecs => /=.
    unshelve epose proof (Hr := (reflect_eq_predicate he hle hcompare p0 p1 _ _ _ _ _ _ X)).
    7: ih.
    1-8: solve_all.
    2:{ rewrite andb_false_r /=.
        constructor. intros bot; inv bot; contradiction.
    }
    destruct Hr => /=.
    2:{
      constructor. intro bot. inversion bot. subst.
      auto.
    }
    clear X. rename X0 into X.
    induction l in brs, X, ht, ht' |- *.
    + destruct brs.
      * constructor. constructor ; try assumption.
        constructor.
      * constructor. intro bot. inversion bot. subst. inversion X2.
    + destruct brs.
      * constructor. intro bot. inversion bot. subst. inversion X2.
      * move: ht; rewrite /= /test_branch /= => /andP [] /andP [? ?] ?.
        move: ht'; rewrite /= /test_branch /= => /andP [] /andP [? ?] ?.
        cbn - [eqb]. inversion X. subst.
        destruct a, b. cbn - [eqb eqb_binder_annots].
        destruct X0 as [onc onbod].
        destruct (reflect_eq_ctx bcontext bcontext0) => // /=.
        2:{ constructor. intro bot. inversion bot. subst.
          inversion X3. subst. destruct X4. cbn in e1. subst.
          contradiction.
        }
        cbn - [eqb].
        pose proof (onbod equ Re 0 he bbody0) as hh. cbn in hh.
        destruct hh => //=.
        2:{ constructor. intro bot. apply f. inversion bot. subst.
          inversion X3. subst. destruct X4. assumption. }
        cbn -[eqb eqb_binder_annots] in *. destruct (IHl X1 brs) => //.
        2:{ constructor. intro bot. apply f. inversion bot. subst.
        inversion X3. subst. constructor; auto. }
        constructor. inversion e2. subst.
        constructor ; auto.

  - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. ih => //.
    constructor. constructor ; assumption.

  - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. ih.
    cbn - [eqb].
    induction m in X, mfix, ht, ht' |- *.
    + destruct mfix.
      * constructor. constructor. constructor.
      * constructor. intro bot. inversion bot. subst. inversion X0.
    + destruct mfix.
      * constructor. intro bot. inversion bot. subst. inversion X0.
      * cbn - [eqb].
        move: ht => /= /andP [] /andP [? ?] ?.
        move: ht' => /= /andP [] /andP [? ?] ?.
        inversion X. subst.
        destruct X0 as [h1 h2].
        destruct (h1 equ Re 0 he (dtype d)) => //.
        2:{ constructor. intro bot. apply f.
          inversion bot. subst. inversion X0. subst. apply X2. }
        destruct (h2 equ Re 0 he (dbody d)) => //.
        2:{
          constructor. intro bot. apply f.
          inversion bot. subst. inversion X0. subst.
          apply X2.
        }
        cbn - [eqb]. eqspecs.
        2:{ constructor. intro bot. inversion bot. subst.
          apply n. inversion X0. subst. destruct X2 as [[? ?] ?].
          assumption.
        }
        destruct (eqb_annot_reflect (dname a) (dname d)).
        2:{ constructor. intro bot; inversion bot. subst.
          apply n. inversion X0. subst. destruct X2 as [[? ?] ?].
          assumption.
        }
        cbn - [eqb]. destruct (IHm X1 mfix) => //.
        2:{ constructor. intro bot. apply f.
          inversion bot. subst. constructor.
          inversion X0. subst. assumption. }
        constructor. constructor. constructor ; try easy.
        now inversion e3.

  - cbn - [eqb]. eqspecs. equspec equ he. equspec lequ hle. ih.
    cbn - [eqb].
    induction m in X, mfix, ht, ht' |- *.
    + destruct mfix.
      * constructor. constructor. constructor.
      * constructor. intro bot. inversion bot. subst. inversion X0.
    + destruct mfix.
      * constructor. intro bot. inversion bot. subst. inversion X0.
      * cbn - [eqb].
        move: ht => /= /andP [] /andP [? ?] ?.
        move: ht' => /= /andP [] /andP [? ?] ?.
        inversion X. subst.
        destruct X0 as [h1 h2].
        destruct (h1 equ Re 0 he (dtype d)) => //.
        2:{ constructor. intro bot. apply f.
          inversion bot. subst. inversion X0. subst. apply X2. }
        destruct (h2 equ Re 0 he (dbody d)) => //.
        2:{
          constructor. intro bot. apply f.
          inversion bot. subst. inversion X0. subst.
          apply X2.
        }
        cbn - [eqb]. eqspecs.
        2:{ constructor. intro bot. inversion bot. subst.
          apply n. inversion X0. subst. destruct X2 as [[? ?] ?].
          assumption.
        }
        destruct (eqb_annot_reflect (dname a) (dname d)).
        2:{ constructor. intro bot; inversion bot. subst.
          apply n. inversion X0. subst. destruct X2 as [[? ?] ?].
          assumption.
        }
        cbn - [eqb]. destruct (IHm X1 mfix) => //.
        2:{ constructor. intro bot. apply f.
          inversion bot. subst. constructor.
          inversion X0. subst. assumption. }
        constructor. constructor. constructor ; try easy.
        now inversion e3.

 - cbn - [eqb]. eqspecs. do 2 constructor.
Qed.

 Lemma eqb_term_upto_univ_impl (equ lequ : _ -> _ -> bool)
  (gen_compare_global_instance : (Universe.t -> Universe.t -> bool) -> global_reference -> nat -> list Level.t -> list Level.t -> bool)
  (p : Universe.t -> bool) (q : nat -> term -> bool) Σ Re Rle napp:
  (forall u u', p u -> p u' -> reflect (Re u u') (equ u u')) ->
  (forall u u', p u -> p u' -> reflect (Rle u u') (lequ u u')) ->
  (forall R leq,
    (forall u u', p u -> p u' -> reflect (R u u') (leq u u')) ->
    forall ref n l l' ,
    forallb p (map Universe.make l) ->
    forallb p (map Universe.make l') ->
    R_global_instance Σ Re R ref n l l' <->
    gen_compare_global_instance leq ref n l l') ->
  forall t t', on_universes p q t -> on_universes p q t' ->
    eqb_term_upto_univ_napp equ lequ (gen_compare_global_instance) napp t t' ->
    eq_term_upto_univ_napp Σ Re Rle napp t t'.
Proof.
  intros he hle Hcompare t t' ht ht'.
  case: (reflect_eq_term_upto_univ Σ equ lequ p q Re Rle) => //; eauto.
Qed.

Definition compare_global_instance_proper Σ equ equ' eqlu eqlu' :
    (forall u u', equ u u' = equ' u u') ->
    (forall u u', eqlu u u' = eqlu' u u') ->
    forall ref n l l',
        compare_global_instance Σ equ eqlu ref n l l' =
        compare_global_instance Σ equ' eqlu' ref n l l'.
Proof.
  intros Hequ Heqlu ref n l l'.
  apply eq_true_iff_eq. etransitivity.
  - symmetry. eapply reflect_iff.
    eapply reflect_R_global_instance' with (p := xpredT); intros; eauto.
    1-2: apply idP.
    1-2: apply forallb_true.
  - eapply reflect_iff.
    eapply reflect_R_global_instance' with (p := xpredT); intros; eauto.
    3-4: apply forallb_true.
    + rewrite Hequ. destruct equ'; constructor; eauto.
    + rewrite Heqlu. destruct eqlu'; constructor; eauto.
Defined.

Definition eqb_term_upto_univ_proper Σ equ equ' eqlu eqlu'
(gen_compare_global_instance gen_compare_global_instance' : (Universe.t -> Universe.t -> bool) -> global_reference -> nat -> list Level.t -> list Level.t -> bool)
napp (t u : term) :
(forall u u', wf_universe Σ u -> wf_universe Σ u' -> equ u u' = equ' u u') ->
(forall u u', wf_universe Σ u -> wf_universe Σ u' -> eqlu u u' = eqlu' u u') ->
(forall leq ref n l l', compare_global_instance (lookup_env Σ) equ leq ref n l l' =
                        gen_compare_global_instance leq ref n l l') ->
(forall leq ref n l l', gen_compare_global_instance leq ref n l l' =
                        gen_compare_global_instance' leq ref n l l') ->
wf_universes Σ t -> wf_universes Σ u ->
eqb_term_upto_univ_napp equ eqlu gen_compare_global_instance napp t u =
eqb_term_upto_univ_napp equ' eqlu' gen_compare_global_instance' napp t u.
Proof.
intros Hequ Heqlu Hcompare Hgen_compare Ht Hu. apply eq_true_iff_eq. split; intros.
- eapply introT.
  * eapply reflect_eq_term_upto_univ; intros.
    1-2: apply idP.
    + apply reflect_iff. rewrite <- Hgen_compare, <- Hcompare.
      eapply reflect_R_global_instance with (p := wf_universeb Σ); eauto.
      1: intros; rewrite <- Hequ; eauto.  all: try apply idP.
      ++ revert H2. eapply reflect_iff; eapply wf_universe_reflect.
      ++ revert H3. eapply reflect_iff; eapply wf_universe_reflect.
    + eassumption.
    + eassumption.
  * eapply elimT. 2: exact H.
    eapply reflect_eq_term_upto_univ; intros; try assumption.
    1: intros; rewrite <- Hequ; try apply idP.
    1: revert H0; eapply reflect_iff; eapply wf_universe_reflect.
    1: revert H1; eapply reflect_iff; eapply wf_universe_reflect.
    1: intros; rewrite <- Heqlu; try apply idP.
    1: revert H0; eapply reflect_iff; eapply wf_universe_reflect.
    1: revert H1; eapply reflect_iff; eapply wf_universe_reflect.
    2-3: eassumption.
    + apply reflect_iff. rewrite <- Hcompare.
      eapply reflect_R_global_instance; eauto.
      1: intros; rewrite <- Hequ; try apply idP.
      1: revert H2; eapply reflect_iff; eapply wf_universe_reflect.
      1: revert H3; eapply reflect_iff; eapply wf_universe_reflect.
  - eapply introT.
  * eapply reflect_eq_term_upto_univ; intros.
  1-2: apply idP.
  2-3: eassumption.
  + apply reflect_iff. rewrite <- Hcompare.
    eapply reflect_R_global_instance; eauto.
    intros; rewrite Hequ; try apply idP.
    1: revert H2; eapply reflect_iff; eapply wf_universe_reflect.
    1: revert H3; eapply reflect_iff; eapply wf_universe_reflect.
    * eapply elimT. 2: exact H.
    eapply reflect_eq_term_upto_univ; intros; try eassumption.
    1: intros; rewrite <- Hequ; try apply idP.
    1: revert H0; eapply reflect_iff; eapply wf_universe_reflect.
    1: revert H1; eapply reflect_iff; eapply wf_universe_reflect.
    1: intros; rewrite <- Heqlu; try apply idP.
    1: revert H0; eapply reflect_iff; eapply wf_universe_reflect.
    1: revert H1; eapply reflect_iff; eapply wf_universe_reflect.
    + apply reflect_iff. rewrite <- Hgen_compare, <- Hcompare.
      eapply reflect_R_global_instance; eauto.
      intros; rewrite  Hequ; try apply idP.
      1: revert H2; eapply reflect_iff; eapply wf_universe_reflect.
      1: revert H3; eapply reflect_iff; eapply wf_universe_reflect.
Defined.

Lemma compare_global_instance_refl :
  forall Σ (eqb leqb : Universe.t -> Universe.t -> bool) gr napp u,
    (forall u, eqb u u) ->
    (forall u, leqb u u) ->
    compare_global_instance Σ eqb leqb gr napp u u.
Proof.
  intros Σ eqb leqb gr napp u eqb_refl leqb_refl.
  rewrite /compare_global_instance.
  destruct global_variance_gen as [v|].
  - induction u in v |- *; destruct v; simpl; auto.
    rtoProp. split; auto.
    destruct t; simpl; auto.
  - rewrite /compare_universe_instance.
    rewrite forallb2_map; eapply forallb2_refl; intro; apply eqb_refl.
Qed.

Lemma All_All2_diag {A} {P : A -> A -> Prop} {l} :
  All (fun x => P x x) l -> All2 P l l.
Proof.
  induction 1; constructor; auto.
Qed.

Lemma Forall_Forall2_diag {A} {P : A -> A -> Prop} {l} :
  Forall (fun x => P x x) l -> Forall2 P l l.
Proof.
  induction 1; constructor; auto.
Qed.

Lemma R_global_instance_refl_wf Σ (Re Rle : Universe.t -> Universe.t -> Prop) gr napp l :
(forall u, wf_universe Σ u -> Re u u) ->
(forall u, wf_universe Σ u -> Rle u u) ->
forallb (wf_universeb Σ) (map Universe.make l)  ->
R_global_instance Σ Re Rle gr napp l l.
Proof.
  intros rRE rRle Hl.
  rewrite /R_global_instance_gen.
  destruct global_variance_gen as [v|] eqn:lookup.
  - induction l in v , Hl |- *; simpl; auto.
    apply andb_and in Hl as [? Hl]. revert a H. move => ? /wf_universe_reflect ?.
    unfold R_opt_variance in IHl; destruct v; simpl; auto.
    split; auto.
    destruct t; simpl; eauto.
  - eapply Forall_Forall2_diag. eapply forallb_Forall in Hl.
    eapply Forall_impl; eauto.
    move => ? /wf_universe_reflect ?; eauto.
Qed.

Definition eq_term_upto_univ_refl_wf Σ (Re Rle : Universe.t -> Universe.t -> Prop) napp :
  (forall u, wf_universe Σ u -> Re u u) ->
  (forall u, wf_universe Σ u -> Rle u u) ->
  forall t, wf_universes Σ t -> eq_term_upto_univ_napp Σ Re Rle napp t t.
Proof.
  intros hRe hRle t wt.
  induction t in napp, Rle, hRle, wt |- * using term_forall_list_ind.
  all: repeat (apply andb_and in wt as [? wt]).
  all: try constructor. all: eauto.
  - apply forallb_All in wt; eapply All_mix in wt; try exact X; eapply All_All2 ; try exact wt;
    intros ? [? ?]; eauto.
  - revert s wt; move => ? /wf_universe_reflect ?; eauto.
  - apply forallb_All in wt. apply All2_Forall2. induction u; eauto; cbn.
    + eapply All2_nil.
    + cbn in wt. inversion wt; subst.  eapply All2_cons; eauto.
    clear -a H0 hRe; revert a H0; move => ? /wf_universe_reflect ?; eauto.
  - apply R_global_instance_refl_wf; auto.
  - apply R_global_instance_refl_wf; auto.
  - destruct X as [? [? ?]].
    unfold eq_predicate. repeat split; eauto.
    + eapply forallb_All in H0. eapply All_mix in H0; try apply a. clear a. eapply All_All2; eauto.
      clear H0. cbn; intros x [Hx Hclose]. apply Hx; eauto.
    + unfold R_universe_instance. clear - H hRe. apply Forall_Forall2_diag.
      apply forallb_Forall in H. eapply Forall_impl; eauto.
      move => ? /wf_universe_reflect ?; eauto.
    + eapply onctx_eq_ctx in a0; eauto.
  - eapply forallb_All in wt; eapply All_mix in X0; try apply wt.
    clear wt. eapply All_All2; eauto; simpl; intuition eauto.
    + eapply onctx_eq_ctx in a0; eauto.
    + eapply b0; eauto. apply andb_and in a as [? a]. exact a.
  - eapply forallb_All in wt; eapply All_mix in X; try apply wt; clear wt.
    eapply All_All2; eauto; simpl; intuition eauto;
    apply andb_and in a as [? ?]; eauto.
  - eapply forallb_All in wt; eapply All_mix in X; try apply wt; clear wt.
    eapply All_All2; eauto; simpl; intuition eauto;
    apply andb_and in a as [? ?]; eauto.
Defined.

Lemma eqb_term_upto_univ_refl Σ (eqb leqb : Universe.t -> Universe.t -> bool) (Re : Universe.t -> Universe.t -> Prop)
  (gen_compare_global_instance : (Universe.t -> Universe.t -> bool) -> global_reference -> nat -> list Level.t -> list Level.t -> bool)
    napp t :
    (forall u, wf_universe Σ u -> eqb u u) ->
    (forall u, wf_universe Σ u -> leqb u u) ->
    (forall u u', wf_universe Σ u -> wf_universe Σ u' -> reflect (Re u u') (eqb u u')) ->
    (forall R leq ,
  (forall u u', wf_universe Σ u -> wf_universe Σ u' ->  reflect (R u u') (leq u u')) ->
    forall ref n l l' ,
    forallb (wf_universeb Σ) (map Universe.make l) ->
    forallb (wf_universeb Σ) (map Universe.make l') ->
    R_global_instance Σ Re R ref n l l' <->
    gen_compare_global_instance leq ref n l l') ->
    wf_universes Σ t ->
    eqb_term_upto_univ_napp eqb leqb gen_compare_global_instance napp t t.
Proof.
  intros eqb_refl leqb_refl eqRe Hcompare Ht.
  case: (reflect_eq_term_upto_univ Σ eqb leqb (wf_universeb Σ) closedu Re leqb gen_compare_global_instance napp _ _ _ t t) => //; eauto.
  - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. now apply eqRe.
  - intros; apply/idP.
  - intros; apply Hcompare; eauto. move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; now apply X.
  - unshelve epose proof (eq_term_upto_univ_refl_wf Σ Re leqb napp _ _ t); eauto.
    + intros u Hu; pose proof (eqb_refl u Hu) as H. revert H. apply reflect_iff; eauto.
    + intro H. destruct (H (X Ht)).
Qed.

(* genereic equality for contexts *)

Fixpoint eqb_ctx_gen equ gen_compare_global_instance
    (Γ Δ : context) : bool :=
    match Γ, Δ with
    | [], [] => true
    | {| decl_name := na1 ; decl_body := None ; decl_type := t1 |} :: Γ,
      {| decl_name := na2 ; decl_body := None ; decl_type := t2 |} :: Δ =>
      eqb_binder_annot na1 na2 && eqb_term_upto_univ equ equ gen_compare_global_instance t1 t2  && eqb_ctx_gen equ gen_compare_global_instance Γ Δ
    | {| decl_name := na1 ; decl_body := Some b1 ; decl_type := t1 |} :: Γ,
      {| decl_name := na2 ; decl_body := Some b2 ; decl_type := t2 |} :: Δ =>
      eqb_binder_annot na1 na2 && eqb_term_upto_univ equ equ gen_compare_global_instance b1 b2 && eqb_term_upto_univ equ equ gen_compare_global_instance t1 t2 && eqb_ctx_gen equ gen_compare_global_instance Γ Δ
    | _, _ => false
    end.

  Lemma eqb_binder_annot_spec {A} na na' : eqb_binder_annot (A:=A) na na' -> eq_binder_annot (A:=A) na na'.
  Proof. case: eqb_annot_reflect => //. Qed.

  Lemma reflect_eqb_ctx_gen Σ equ
    (p : Universe.t -> bool) (q : nat -> term -> bool)
    (Re : Universe.t -> Universe.t -> Prop)
    (gen_compare_global_instance : (Universe.t -> Universe.t -> bool) -> global_reference -> nat -> list Level.t -> list Level.t -> bool) :
    (forall u u', p u -> p u' -> reflect (Re u u') (equ u u')) ->
    (forall R leq,
          (forall u u', p u -> p u' -> reflect (R u u') (leq u u')) ->
          forall ref n l l' ,
          forallb p (map Universe.make l) ->
          forallb p (map Universe.make l') ->
          R_global_instance Σ Re R ref n l l' <->
          gen_compare_global_instance leq ref n l l') ->
    forall Γ Δ,
      on_ctx_universes p q Γ ->
      on_ctx_universes p q Δ ->
      eqb_ctx_gen equ gen_compare_global_instance Γ Δ ->
      eq_context_upto Σ Re Re Γ Δ.
  Proof.
    intros Hequ Hcompare Γ Δ hΓ hΔ h.
    induction Γ as [| [na [b|] A] Γ ih ] in Δ, hΓ, hΔ, h |- *.
    all: destruct Δ as [| [na' [b'|] A'] Δ].
    all: try discriminate.
    - constructor.
    - simpl in h. apply andb_andI in h as [[[h1 h2]%andb_and h3]%andb_and h4].
      simpl in hΓ. apply andb_andI in hΓ as [[hΓ1 hΓ2]%andb_and hΓ].
      simpl in hΔ. apply andb_andI in hΔ as [[hΔ1 hΔ2]%andb_and hΔ]. cbn in *.
      constructor; auto. constructor; auto.
      + now apply eqb_binder_annot_spec in h1.
      + eapply eqb_term_upto_univ_impl; eauto.
      + eapply eqb_term_upto_univ_impl; eauto.
    - simpl in h. apply andb_and in h as [[h1 h2]%andb_and h3].
      simpl in hΓ. apply andb_andI in hΓ as [[hΓ1 hΓ2]%andb_and hΓ].
      simpl in hΔ. apply andb_andI in hΔ as [[hΔ1 hΔ2]%andb_and hΔ]. cbn in *.
      constructor; auto; constructor.
      + now apply eqb_binder_annot_spec.
      + eapply eqb_term_upto_univ_impl; eauto.
  Qed.

  Definition eqb_ctx_gen_proper (Σ:global_env_ext) equ equ' gen_compare_global_instance
  gen_compare_global_instance' (Γ Δ : context) :
    (forall u u', wf_universe Σ u -> wf_universe Σ u' -> equ u u' = equ' u u') ->
    (forall leq ref n l l', compare_global_instance (lookup_env Σ) equ leq ref n l l' =
                            gen_compare_global_instance leq ref n l l') ->
    (forall leq ref n l l', compare_global_instance (lookup_env Σ) equ' leq ref n l l' =
                            gen_compare_global_instance' leq ref n l l') ->
    (forall leq ref n l l', gen_compare_global_instance' leq ref n l l' =
                            gen_compare_global_instance leq ref n l l') ->
    wf_ctx_universes Σ Γ -> wf_ctx_universes Σ Δ ->
    eqb_ctx_gen equ gen_compare_global_instance Γ Δ =
    eqb_ctx_gen equ' gen_compare_global_instance' Γ Δ.
  Proof.
    revert Δ; induction Γ; destruct Δ; simpl; eauto.
    intros Hequ Hcompare Hcompare' Hgen_compare HΓ HΔ.
    destruct a. destruct decl_body.
    all: destruct c; destruct decl_body; eauto; cbn in *;
         apply eq_true_iff_eq; split; intros.
    all: repeat (let foo := fresh "H" in apply andb_and in H; destruct H as [H foo]);
         repeat (let foo := fresh "HΓ" in apply andb_and in HΓ; destruct HΓ as [HΓ foo]);
         repeat (let foo := fresh "HΔ" in apply andb_and in HΔ; destruct HΔ as [HΔ foo]);
         repeat (apply andb_and; split; eauto);
         try first[ rewrite <- IHΓ | rewrite IHΓ]; eauto.
    all: erewrite <- eqb_term_upto_univ_proper; eauto.
    all: intros; symmetry; eapply Hequ; eauto.
 Defined.

(** Checking equality *)

Lemma wf_gc_of_uctx {cf:checker_flags} {Σ : global_env} (HΣ : ∥ wf Σ ∥)
: ∑ uctx', gc_of_uctx (global_uctx Σ) = Some uctx'.
Proof.
assert (consistent (global_uctx Σ).2) as HC.
{ sq; apply (wf_consistent _ HΣ). }
unfold gc_of_uctx; simpl in *.
apply gc_consistent_iff in HC.
destruct (gc_of_constraints (global_constraints Σ)).
- eexists; reflexivity.
- contradiction HC.
Defined.

Lemma graph_of_wf {cf:checker_flags} {Σ : global_env} (HΣ : ∥ wf Σ ∥)
: ∑ G, is_graph_of_uctx G (global_uctx Σ).
Proof.
destruct (wf_gc_of_uctx HΣ) as [uctx Huctx].
exists (make_graph uctx). unfold is_graph_of_uctx. now rewrite Huctx.
Defined.

Lemma wf_ext_gc_of_uctx {cf:checker_flags} {Σ : global_env_ext} (HΣ : ∥ wf_ext Σ ∥)
: ∑ uctx', gc_of_uctx (global_ext_uctx Σ) = Some uctx'.
Proof.
assert (consistent (global_ext_uctx Σ).2) as HC.
  { sq; apply (global_ext_uctx_consistent _ HΣ). }
destruct Σ as [Σ φ].
simpl in HC.
unfold gc_of_uctx; simpl in *.
apply gc_consistent_iff in HC.
destruct (gc_of_constraints (global_ext_constraints (Σ, φ))).
- eexists; reflexivity.
- contradiction HC.
Defined.

Lemma wf_ext_gc_of_uctx_irr {cf:checker_flags} {Σ : global_env_ext} (HΣ HΣ' : ∥ wf_ext Σ ∥) :
  wf_ext_gc_of_uctx HΣ = wf_ext_gc_of_uctx HΣ'.
Proof.
  unfold wf_ext_gc_of_uctx. Opaque gc_of_constraints.
  destruct Σ; cbn.
  match goal with | |- _ ?X = _ ?Y => set (prf := X) ; set (prf' := Y) end.
  clearbody prf prf'. cbn in *. revert prf prf'.
  set (gc_of_constraints ((g, u):global_env_ext)) in *.
  now destruct o.
Qed.

Lemma graph_of_wf_ext {cf:checker_flags} {Σ : global_env_ext} (HΣ : ∥ wf_ext Σ ∥)
: ∑ G, is_graph_of_uctx G (global_ext_uctx Σ).
Proof.
destruct (wf_ext_gc_of_uctx HΣ) as [uctx Huctx].
exists (make_graph uctx). unfold is_graph_of_uctx. now rewrite Huctx.
Defined.

Lemma uctx'_eq {cf:checker_flags} {Σ} (wfΣ : ∥ wf_ext Σ ∥) :
  let G := graph_of_wf_ext wfΣ in
  (wf_ext_gc_of_uctx wfΣ).π1 = uctx' G.π1 (global_ext_uctx Σ) G.π2.
Proof.
  sq. Opaque gc_of_constraints.
  unfold wf_ext_gc_of_uctx, uctx'. destruct Σ. cbn.
  match goal with | |- (_ ?X).π1 = _ ?Y => set (prf := X) ; set (prf' := Y) end.
  clearbody prf prf'. cbn in *. revert prf prf'.
  set (G := graph_of_wf_ext _). destruct G as [G HG].
  unfold is_graph_of_uctx in *. cbn in *.
  Transparent gc_of_constraints.
  set (gc_of_constraints ((g, u):global_env_ext)) in *.
  now destruct o.
Qed.

Section EqualityDecGen.
  Context {cf : checker_flags}.
  Context (Σ : global_env_ext).
  Context (hΣ : ∥ wf_ext Σ ∥).

  Let uctx := global_ext_uctx Σ.

  Let G := (graph_of_wf_ext hΣ).π1.

  Let HG := (graph_of_wf_ext hΣ).π2.

  Let uctx' : VSet.t × GoodConstraintSet.t.
    fold G uctx in HG. clearbody G HG. cbn in *.
    unfold is_graph_of_uctx, gc_of_uctx in HG.
    destruct (gc_of_constraints uctx.2) as [ctrs|].
    - exact (uctx.1, ctrs).
    - contradiction HG.
  Defined.

  Lemma eq_universeP_gen leqb_level_n_gen
    (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen)
    u u' :
    wf_universe Σ u ->
    wf_universe Σ u' ->
    reflect (eq_universe Σ u u') (check_eqb_universe_gen leqb_level_n_gen u u').
  Proof using hΣ.
    intros. destruct Σ as [Σ' φ].
    apply (equivP idP); split; sq.
    all: pose proof hΣ as hΣ' ; sq.
    - intros e.
      eapply check_eqb_universe_spec_gen'
         with (uctx := global_ext_uctx (Σ', φ)) in e ; eauto.
      + now eapply wf_ext_global_uctx_invariants.
      + now eapply global_ext_uctx_consistent.
    - intros e.
      eapply check_eqb_universe_complete_gen
        with (uctx := global_ext_uctx (Σ', φ)); eauto.
      + now eapply wf_ext_global_uctx_invariants.
      + now eapply global_ext_uctx_consistent.
  Qed.

  Lemma leq_universeP_gen leqb_level_n_gen
  (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) u u' :
  wf_universe Σ u ->
  wf_universe Σ u' ->
  reflect (leq_universe Σ u u') (check_leqb_universe_gen leqb_level_n_gen u u').
  Proof using hΣ.
    intros.
    apply (equivP idP) ; split.
    all: pose proof hΣ as hΣ' ; sq.
    - intros e.
      eapply check_leqb_universe_spec_gen'
        with (uctx := global_ext_uctx Σ) in e ; eauto.
      + now eapply wf_ext_global_uctx_invariants.
      + now eapply global_ext_uctx_consistent.
    - intros e.
      eapply check_leqb_universe_complete_gen
        with (uctx := global_ext_uctx Σ); eauto.
      + now eapply wf_ext_global_uctx_invariants.
      + now eapply global_ext_uctx_consistent.
  Qed.

  Definition eqb_ctx leqb_level_n_gen := eqb_ctx_gen (check_eqb_universe_gen leqb_level_n_gen) (compare_global_instance (lookup_env Σ) (check_eqb_universe_gen leqb_level_n_gen)).

  Definition eqb_termp_napp pb leqb_level_n_gen :=
    eqb_termp_napp_gen pb (check_eqb_universe_gen leqb_level_n_gen) (check_leqb_universe_gen leqb_level_n_gen)
          (compare_global_instance (lookup_env Σ) (check_eqb_universe_gen leqb_level_n_gen)).

  Lemma reflect_eqb_termp_napp pb leqb_level_n_gen
    (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) napp t u :
    wf_universes Σ t ->
    wf_universes Σ u ->
    reflectT (eq_termp_napp pb Σ napp t u) (eqb_termp_napp pb leqb_level_n_gen napp t u).
  Proof using hΣ.
    apply reflect_eq_term_upto_univ.
    - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?.
      now apply eq_universeP_gen.
    - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?.
      destruct pb.
      + now apply eq_universeP_gen.
      + now eapply leq_universeP_gen.
    - intros. apply reflect_iff.
      eapply reflect_R_global_instance with (p := wf_universeb Σ); eauto.
      move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; now apply eq_universeP_gen; eauto.
  Qed.

  Lemma eqb_termp_napp_spec pb leqb_level_n_gen
  (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) napp t u :
    wf_universes Σ t ->
    wf_universes Σ u ->
    eqb_termp_napp pb leqb_level_n_gen napp t u ->
    eq_termp_napp pb Σ napp t u.
  Proof using hΣ.
    pose proof hΣ.
    eapply eqb_term_upto_univ_impl.
    - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; now apply eq_universeP_gen; eauto.
    - destruct pb.
      + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; now apply eq_universeP_gen; eauto.
      + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; now apply leq_universeP_gen; eauto.
    - intros. apply reflect_iff. eapply reflect_R_global_instance; eauto.
      move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; now apply eq_universeP_gen; eauto.
  Qed.

  Definition eqb_termp pb leq := (eqb_termp_napp pb leq 0).
  Definition eqb_term := (eqb_termp Conv).
  Definition leqb_term := (eqb_termp Cumul).

  Lemma eqb_term_spec leqb_level_n_gen
    (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) t u :
    wf_universes Σ t -> wf_universes Σ u ->
    eqb_term leqb_level_n_gen t u ->
    eq_term Σ Σ t u.
  Proof using hΣ.
    intros.
    eapply (eqb_termp_napp_spec Conv) ; tea.
  Qed.

  Lemma leqb_term_spec leqb_level_n_gen
    (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen)
    t u :
    wf_universes Σ t -> wf_universes Σ u ->
    leqb_term leqb_level_n_gen t u ->
    leq_term Σ Σ t u.
  Proof using hΣ.
    intros.
    eapply (eqb_termp_napp_spec Cumul) ; tea.
  Qed.

  Lemma reflect_leq_term leqb_level_n_gen
    (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) t u :
    wf_universes Σ t ->
    wf_universes Σ u ->
    reflectT (leq_term Σ Σ t u) (leqb_term leqb_level_n_gen t u).
  Proof using hΣ.
    intros.
    now eapply (reflect_eqb_termp_napp Cumul).
  Qed.

  Notation eq_term Σ t u := (eq_term Σ Σ t u).

  Lemma reflect_eq_term leqb_level_n_gen
  (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) t u :
    wf_universes Σ t ->
    wf_universes Σ u ->
    reflectT (eq_term Σ t u) (eqb_term leqb_level_n_gen t u).
  Proof using hΣ.
    intros.
    now eapply (reflect_eqb_termp_napp Conv).
  Qed.

  Lemma eqb_term_refl leqb_level_n_gen
  (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) :
    forall t, wf_universes Σ t -> eqb_term leqb_level_n_gen t t.
  Proof using hΣ.
    intro t. eapply eqb_term_upto_univ_refl with (Re := eq_universe Σ).
    all: intros; try eapply check_eqb_universe_refl_gen; eauto.
    - eapply eq_universeP_gen; eauto.
    - apply reflect_iff. eapply reflect_R_global_instance; eauto.
      + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; apply eq_universeP_gen; eauto.
      + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; apply X; eauto.
  Qed.

  Lemma eqb_ctx_spec leqb_level_n_gen
  (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) :
    forall Γ Δ,
      wf_ctx_universes Σ Γ ->
      wf_ctx_universes Σ Δ ->
      eqb_ctx leqb_level_n_gen Γ Δ ->
      eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) Γ Δ.
  Proof using hΣ.
    intros Γ Δ hΓ hΔ h. eapply reflect_eqb_ctx_gen; eauto.
    - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; now apply eq_universeP_gen; eauto.
    - intros. apply reflect_iff. eapply reflect_R_global_instance; eauto.
      move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?; now apply eq_universeP_gen; eauto.
  Qed.

  (*
  Definition eqb_opt_term leq (t u : option term) :=
    match t, u with
    | Some t, Some u => eqb_term leq t u
    | None, None => true
    | _, _ => false
    end.

  Lemma eqb_opt_term_spec t u
    : eqb_opt_term t u -> compare_opt_term Conv Σ (global_ext_constraints Σ) t u.
  Proof.
    destruct t, u; try discriminate; cbn => //.
    apply eqb_term_spec; tea.
  Qed.

  Definition eqb_decl (d d' : context_decl) :=
    eqb_binder_annot d.(decl_name) d'.(decl_name) &&
    eqb_opt_term d.(decl_body) d'.(decl_body) && eqb_term d.(decl_type) d'.(decl_type).

  Lemma eqb_decl_spec d d'
    : eqb_decl d d' -> eq_decl Σ (global_ext_constraints Σ) d d'.
  Proof.
    unfold eqb_decl, eq_decl.
    intro H. rtoProp. apply eqb_opt_term_spec in H1.
    eapply eqb_term_spec in H0; tea.
    eapply eqb_binder_annot_spec in H.
    destruct d as [na [b|] ty], d' as [na' [b'|] ty']; simpl in * => //;
    repeat constructor; eauto.
  Qed.

  Definition eqb_context (Γ Δ : context) := forallb2 eqb_decl Γ Δ.

  Lemma eqb_context_spec Γ Δ
    : eqb_context Γ Δ -> eq_context Σ (global_ext_constraints Σ) Γ Δ.
  Proof.
    unfold eqb_context, eq_context.
    intro HH. apply forallb2_All2 in HH.
    eapply All2_fold_All2.
    eapply All2_impl; try eassumption.
    cbn. apply eqb_decl_spec.
  Qed. *)

End EqualityDecGen.