Require Import FcEtt.sigs.

Require Import FcEtt.imports.
Require Import FcEtt.tactics.
Require Import FcEtt.fset_facts.

Require Import FcEtt.ett_ott.
Require Import FcEtt.ett_inf.
Require Import FcEtt.ett_inf_cs.
Require Import FcEtt.ett_ind.

Require Import FcEtt.erase_syntax.
Require Export Metalib.CoqEqDec.
Require Import Coq.Logic.Decidable.
Require Import Metalib.Metatheory.
Require Import FcEtt.fc_unique.

Require Import FcEtt.fc_wf.
Require Import FcEtt.toplevel.
Require Import FcEtt.fc_context_fv.

Module fc_invert (wf : fc_wf_sig) (weak : fc_weak_sig) (subst : fc_subst_sig).
Import weak subst.

Module unique := fc_unique wf subst.
Import unique.

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

(* ------------------------------------------------------------- *)

Lemma AnnTyping_regularity :
  (forall G a A, AnnTyping G a A -> AnnTyping G A a_Star).
Proof.
  induction 1; eauto with ctx_wff.
  - eapply binds_to_AnnTyping; eauto.
  - inversion IHAnnTyping1. eapply AnnTyping_tm_subst_nondep; eauto.
  - inversion IHAnnTyping. eapply AnnTyping_co_subst_nondep; eauto.
  - eapply AnnTyping_weakening with (F:=nil)(G:=nil) in H1.
    simpl_env in H1.
    eauto.
    auto.
    simpl_env.
    auto.
  - eapply AnnTyping_weakening with (F:=nil)(G:=nil) in H1;
      simpl_env in H1; simpl_env; eauto.
Qed.

Lemma AnnPropWff_regularity :
  forall G A B A1, AnnPropWff G (Eq A B A1) -> exists B1 g,
      AnnTyping G A A1 /\ AnnTyping G B B1 /\ AnnDefEq G empty g A1 B1.
Proof.
  intros G A B A1 H.
  inversion H. subst.
  pose K := AnnTyping_regularity H4.
  pose L := AnnTyping_regularity H5.
  pose M := AnnTyping_regularity K.
  pose N := AnnTyping_regularity M.
  pose g := g_Refl2 A1 B0 (g_Refl a_Star).
  assert (DE : AnnDefEq G empty g A1 B0). eapply An_EraseEq; eauto.
  exists B0. eexists. eauto.
Qed.

(* -------------------------------------------------------------- *)

(*  Interlude: some lemmas about how erasure and typing interact. *)

(* -------------------------------------------------------------- *)

Lemma erase_pi : forall G AB0 rho A B S, erase AB0 = (a_Pi rho A B) -> AnnTyping G AB0 S ->
  exists A1 B0, erase AB0 = erase (a_Pi rho A1 B0) /\ erase A1 = A /\ erase B0 = B /\ AnnTyping G (a_Pi rho A1 B0) a_Star.
Proof.
  induction AB0; intros rho' A B S H; try solve [try destruct rho; simpl in H; inversion H].
  - simpl in H; inversion H.
    intros. exists AB0_1. exists AB0_2.
    repeat split. inversion H0. subst. auto.
  - simpl in H; inversion H.
    intros H0.  inversion H0. destruct (IHAB0 rho' A B A0 H) as [A2 [B2 [E1 [E2 [E3 AT]]]]]; auto.
    subst.
    exists A2. exists B2. simpl in *. subst. repeat split. auto.
    auto.
Qed.

Lemma erase_cpi : forall AB0 A B G S,
    erase AB0 = (a_CPi A B) -> AnnTyping G AB0 S ->
    exists A1 B0, erase AB0 = erase (a_CPi A1 B0) /\ erase_constraint A1 = A /\ erase B0 = B
             /\ AnnTyping G (a_CPi A1 B0) a_Star.
Proof.
  induction AB0; intros A B G S H; try destruct rho; simpl in H; inversion H.
  - intros J.
    inversion J. subst.
    destruct (IHAB0 A B G A0 H) as [A1 [B0 [E1 [E2 E3]]]]; auto.
    subst.
    exists A1. exists B0. simpl. subst. auto.
  - exists phi. exists AB0. inversion H0. subst.  auto.
Qed.

Lemma erase_app_Rel :
  forall AB0 A B C G, erase AB0 = (a_App A Rel B) -> AnnTyping G AB0 C ->
  exists A1 B0 g D, erase AB0 = erase (a_App A1 Rel B0) /\ erase A1 = A /\ erase B0 = B /\
          AnnTyping G (a_App A1 Rel B0) D /\ AnnDefEq G (dom G) g C D.
Proof.
  induction AB0;
    move=> A B C G H; try destruct rho;
            simpl in H;

    inversion H;
    eauto.
  - intros T.
    pose K := AnnTyping_regularity T.
    eexists. eexists. eexists. eexists.
    repeat split. eauto.  eauto.
  - intros T.
    inversion T. subst.
    destruct (IHAB0 _ _ _ _ H H3) as [A1 [B0 [g1 [D [E1 [E2 [E3 [T1 DE]]]]]]]].
    simpl in E1. inversion E1. subst.
    pose K := AnnTyping_regularity T. clearbody K.
    pose K2 := AnnTyping_regularity T1. clearbody K2.
    pose K3 := AnnTyping_regularity H3. clearbody K3.
    assert (AnnCtx G). eauto using AnnTyping_AnnCtx.
    exists A1, B0. eexists. exists D.
    repeat split. simpl. eauto. eauto.
    eapply An_Trans with (a1 := A0).
    eapply An_Sym; eauto. eauto. eauto. eauto.
    eapply An_Refl. eauto.
Qed.

Lemma erase_app_Irrel :
  forall AB0 A C G, erase AB0 = (a_App A Irrel a_Bullet) -> AnnTyping G AB0 C ->
  exists A1 B0 g D, erase AB0 = erase (a_App A1 Irrel B0) /\ erase A1 = A /\
          AnnTyping G (a_App A1 Irrel B0) D /\ AnnDefEq G (dom G) g C D.
Proof.
  induction AB0;
    move=> A C G H; try destruct rho;
            simpl in H;
    inversion H;
    eauto.
  - intros T.
    pose K := AnnTyping_regularity T.
    eexists. eexists. eexists. eexists.
    repeat split. eauto.  eauto.
  - intros T.
    inversion T. subst.
    destruct (IHAB0 _ _ _  H H3) as [A1 [B0 [g1 [D [E1 [E3 [T1 DE]]]]]]].
    simpl in E1. inversion E1. subst.
    pose K := AnnTyping_regularity T. clearbody K.
    pose K2 := AnnTyping_regularity T1. clearbody K2.
    pose K3 := AnnTyping_regularity H3. clearbody K3.
    assert (AnnCtx G). eauto using AnnTyping_AnnCtx.
    exists A1, B0. eexists. exists D.
    repeat split. simpl. eauto. eauto.
    eapply An_Trans with (a1 := A0).
    eapply An_Sym; eauto. eauto. eauto. eauto.
    eapply An_Refl. eauto.
Qed.

(*
Lemma erase_abs : forall AB0 rho B, erase AB0 = (a_UAbs rho B) ->
  exists A1 B0, erase AB0 = erase (a_Abs rho A1 B0) /\ erase B0 = B.
Proof.
  induction AB0;
    move=> rho' B H;
            try destruct rho;
    simpl in H;
    inversion H;
    eauto.
Qed.
*)
(*
Lemma erase_capp :
  forall AB0 A C G, erase AB0 = (a_CApp A g_Triv) -> AnnTyping G AB0 C ->
  exists A1 g0 g D, erase AB0 = erase (a_CApp A1 g0) /\ erase A1 = A /\
          AnnTyping G (a_CApp A1 g0) D /\ AnnDefEq G (dom G) g C D.
Proof.
  induction AB0;
    move=> A C G H;
    simpl in H;
    inversion H;
    eauto.
  - intros T.
    inversion T. subst.
    destruct (IHAB0 _  _ _ H H3) as [A1 [g0 [g1 [D [E1 [E3 [T1 DE]]]]]]].
    simpl in E1. inversion E1. subst.
    pose K := AnnTyping_regularity T. clearbody K.
    pose K2 := AnnTyping_regularity T1. clearbody K2.
    pose K3 := AnnTyping_regularity H3. clearbody K3.
    assert (AnnCtx G). eauto.
    exists A1, g0. eexists. eexists.
    repeat split. simpl. eauto. eauto. eapply An_Trans with (a1 := A0).
    eapply An_Sym; eauto. eauto. eauto. eauto.
    eapply An_Refl. eauto.
   -  intros T.
    pose K := AnnTyping_regularity T.
    eexists. eexists. eexists. eexists.
    repeat split. eauto.  eauto.
Qed.
*)

(* -------------------------------------------------------------- *)

Lemma erasure_compatible : forall G a A (H1 :AnnTyping G a A),
    forall b B (H2 : AnnTyping G b B)
      (E : erase a = erase b)
      (F : erase A = erase B),
    exists g1, AnnDefEq G (dom G) g1 a b.
Proof.
  intros.
  pose K1 := AnnTyping_regularity H1.
  pose K2 := AnnTyping_regularity H2.
  eexists.
  eapply An_EraseEq.
  eauto. eauto. eauto.
  eapply An_EraseEq; eauto using AnnTyping_AnnCtx.
Qed.

(* ------------------------------------------------------------- *)

(*
    Challenging lemma: coercible terms have coercible types.

     NOTE: this result for AnnDefEq is *not* AnnPropWff G (Eq A B).

 *)
Lemma AnnDefEqAnnIso_regularity :
  (forall G0 a A, AnnTyping G0 a A -> True ) /\
  (forall G0 phi,   AnnPropWff G0 phi -> True ) /\
  (forall G D g p1 p2, AnnIso G D g p1 p2 ->
                 AnnPropWff G p1 /\ AnnPropWff G p2) /\
  (forall G D g A B,   AnnDefEq G D g A B ->
           exists C1 C2 g', AnnTyping G A C1 /\ AnnTyping G B C2 /\ AnnDefEq G (dom G) g' C1 C2) /\
  (forall G0, AnnCtx G0 -> True).
Proof.
  apply ann_typing_wff_iso_defeq_mutual; eauto.
  { intros.
  destruct H as [C1 [C2 [g' [AT1 [AT2 DE]]]]].
  inversion AT1. inversion AT2. subst. split; auto. }
  all: intros.
  - destruct H. eauto.
  - pose K:= binds_to_AnnPropWff _ _ _ _ a0 b0.
    destruct (AnnPropWff_regularity K) as [B1 [g [TA [TB DE]]]].
    exists A, B1, g. split. auto. split. auto. eapply AnnDefEq_weaken_available. eauto.
  - exists A, A, (g_Refl A).
    pose N := AnnTyping_regularity a0.
    eauto.
  - pose N1 := AnnTyping_regularity a0.
    pose N2 := AnnTyping_regularity a1.
    exists A, B. eexists.
    repeat split.
    eauto. eauto. eauto.
  - exists A, B, (g_Sym g1).
    pose K1 := AnnTyping_regularity a0.
    pose K2 := AnnTyping_regularity a1.
    split. auto. split. auto.
    eapply An_Sym. eauto. eauto. eapply An_Refl. eapply An_Star.
    eauto using AnnTyping_AnnCtx.
    eapply AnnDefEq_weaken_available.
    eauto.
  - destruct H as [C1 [D1 [g1' [TbC1 [TaD1 EQ1]]]]]; auto.
    destruct H0 as [C2 [D2 [g2' [TbC2 [TaD2 EQ2]]]]]; auto.
    assert (D1 = C2). eapply AnnTyping_unique; eauto.
    subst.
    exists C1, D2. eexists.
    repeat split. auto. auto.
    eapply An_Trans. eauto. eauto.
    eapply AnnTyping_regularity. eauto.
    eapply AnnTyping_regularity. eauto.
    eapply An_Refl. eapply An_Star. eauto with ctx_wff.
  - exists B0, B1. eexists.
    pose N1 := AnnTyping_regularity a.
    pose N2 := AnnTyping_regularity a0.
    repeat split.
    eauto. eauto.
    eapply An_EraseEq; eauto with ctx_wff.
  - exists a_Star, a_Star. eexists.
    assert (HG : AnnCtx G); eauto with ctx_wff.
  - (* abs cong *)
    clear H1. clear H2. clear H3.

    assert (ANG : AnnCtx G). eauto with ctx_wff.
    pick fresh x1. assert (FR1 : x1 `notin` L). eauto.
    destruct (H0 x1 FR1) as [B1 [B2 [g' [Tb1 [Tb2 EqB1B2]]]]]. clear H0.
    assert (FRB1 : x1 `notin` fv_tm_tm_tm (close_tm_wrt_tm x1 B1)).
    autorewrite with lngen; eauto.
    assert (R1 : AnnTyping G (a_Abs rho A1 b1) (a_Pi rho A1 (close_tm_wrt_tm x1 B1))).
    { eapply (An_Abs_exists); eauto.
      rewrite open_tm_wrt_tm_close_tm_wrt_tm. eauto. }
    pick fresh x2. assert (FR2 : x2 `notin` L). eauto.
    pose N1 := (e x2 FR2). clearbody N1. clear e.
    assert (HSG : AnnDefEq G D (g_Sym g1) A2 A1). {
      assert (AnnDefEq G D (g_Refl a_Star) a_Star a_Star). eauto with ctx_wff.
      eapply An_Sym; eauto with ctx_wff.
      }
    remember (tm_subst_tm_tm (a_Conv (a_Var_f x2) (g_Sym g1)) x1 B2) as B3.
    assert (EQB : open_tm_wrt_tm (close_tm_wrt_tm x2 B3) (a_Var_f x2) =
                  open_tm_wrt_tm (close_tm_wrt_tm x1 B2) (a_Conv (a_Var_f x2) (g_Sym g1))).
    { rewrite HeqB3.
      rewrite (tm_subst_tm_tm_intro x1 (close_tm_wrt_tm x1 B2) (a_Conv (a_Var_f x2) (g_Sym g1))).
      rewrite (open_tm_wrt_tm_close_tm_wrt_tm B2 x1).
      rewrite (open_tm_wrt_tm_close_tm_wrt_tm).
      auto.
      autorewrite with lngen; auto.
    }
    assert (x2 `notin` fv_tm_tm_tm (close_tm_wrt_tm x2 B3)). {
      autorewrite with lngen; auto. }
    assert (R2 : AnnTyping G (a_Abs rho A2 b3) (a_Pi rho A2 (close_tm_wrt_tm x2 B3))).
    { eapply An_Abs_exists with (x := x2). eauto. eauto.
      rewrite N1.
      rewrite EQB.
      rewrite (tm_subst_tm_tm_intro x1); auto.
      rewrite (tm_subst_tm_tm_intro x1 (close_tm_wrt_tm x1 B2)).
      eapply (@AnnTyping_tm_subst ([(x2, Tm A2)] ++ G) x1 A1).
      rewrite open_tm_wrt_tm_close_tm_wrt_tm.
      eapply AnnTyping_weakening; eauto.
      eapply An_ConsTm; eauto with ctx_wff.
      eapply (AnnTyping_weakening a1 _ nil); simpl; eauto.
      eapply An_ConsTm; eauto with ctx_wff.
      eapply An_Conv. eauto.
      eapply AnnDefEq_weaken_available.
      eapply (AnnDefEq_weakening HSG _ nil); simpl; eauto.
      eapply An_ConsTm; eauto.
      eapply (AnnTyping_weakening a1 _ nil); simpl; eauto.
      eapply An_ConsTm; eauto.
      autorewrite with lngen. auto.
      move: (r0 x2 FR2) => r2'. auto.
    }
    exists (a_Pi rho A1 (close_tm_wrt_tm x1 B1)), (a_Pi rho A2 (close_tm_wrt_tm x2 B3)).
    exists (g_PiCong rho g1 (close_co_wrt_tm x1 g') ).
    repeat split. auto. auto.
    eapply An_PiCong_exists with (x1:=x1)(x2:=x2)(B2 := close_tm_wrt_tm x1 B2).
    autorewrite with lngen. auto.
    autorewrite with lngen. auto.
    eapply AnnDefEq_weaken_available. eauto.
    {
      rewrite (open_co_wrt_tm_close_co_wrt_tm g').
      rewrite (open_tm_wrt_tm_close_tm_wrt_tm).
      rewrite (open_tm_wrt_tm_close_tm_wrt_tm).
      eapply AnnDefEq_strengthen_available_tm; eauto.
      assert (x1 `notin` dom G). auto.
      simpl.  clear Fr0. clear Fr.
      fsetdec.
    }
    eauto.
    eapply AnnTyping_regularity. eauto.
    eapply AnnTyping_regularity. eauto.
    destruct (AnnDefEq_context_fv EqB1B2) as (_ & _ & _ & _ & h4 & _).
    simpl in h4.
    autorewrite with lngen.
    clear Fr0. assert (x1 `notin` dom G). auto. clear Fr.
    {
      eapply An_Pi_exists with (x:= x1); eauto 1.
      autorewrite with lngen.
      fsetdec.
      autorewrite with lngen.
      eapply AnnTyping_regularity; eauto.
    }
  - inversion a3.
    inversion a4.
    subst.
    destruct H as [P1 [P2 [g [AT1 [AT2 EP]]]]].
    destruct H0 as [Q1 [Q2 [g' [AU1 [AU2 EP']]]]].
    resolve_unique_subst.
    resolve_unique_subst.
    resolve_unique_subst.
    resolve_unique_subst.
    assert (HG : AnnCtx G); eauto with ctx_wff.
    eexists. eexists. eexists.
    split. eauto. split. eauto.
    eapply AnnDefEq_weaken_available; eauto.
  - destruct H as [C1 [C2 [g' [T1 [T2 E1]]]]].
    inversion T1. inversion T2. subst.
    exists a_Star. exists a_Star. exists (g_Refl a_Star).
    assert (HG : AnnCtx G); eauto with ctx_wff.
  - destruct H as [C1 [C2 [g [T1 [T2 E1]]]]].
    destruct H0 as [C1' [C2' [g' [T12 [T22 E2]]]]].
    inversion T1. inversion T2. subst.
    pick fresh x1. assert (FRL: x1 `notin` L). auto.
    pose N1 := H6 x1 FRL. clearbody N1. clear H6.
    pick fresh x2.
    assert (FRL0 : x2 `notin` L0). auto.
    pose N2 := H13 x2 FRL0. clearbody N2. clear H13.
    exists a_Star. exists a_Star. exists (g_Refl a_Star).
    repeat split.
    move: (AnnTyping_tm_subst N1 a3) => K1.
    simpl in K1.
    rewrite tm_subst_tm_tm_open_tm_wrt_tm in K1; auto.
    rewrite tm_subst_tm_tm_var in K1.
    rewrite tm_subst_tm_tm_fresh_eq in K1; auto.
    apply (AnnTyping_lc a3). clear Fr.
    pose K2 := AnnTyping_tm_subst N2 a4. clearbody K2.
    simpl in K2.
    rewrite tm_subst_tm_tm_open_tm_wrt_tm in K2; auto.
    rewrite tm_subst_tm_tm_var in K2.
    rewrite tm_subst_tm_tm_fresh_eq in K2; auto.
    apply (AnnTyping_lc a4). clear Fr0.
    assert (HG : AnnCtx G); eauto with ctx_wff.
  - exists a_Star. exists a_Star. eexists.
    assert (HG : AnnCtx G); eauto with ctx_wff.
  - (* cabs_cong *)
    exists (a_CPi phi1 B1), (a_CPi phi2 B2).
    exists g4.
    repeat split. auto. auto. auto.
  - clear H2. clear H3.
    destruct H as [C1 [D1 [g [T1 [T2 E1]]]]].
    destruct H0 as [C2 [D2 [g2' [T12 [T22 E2]]]]].
    destruct H1 as [C3 [D3 [g3' [T13 [T23 E3]]]]].
    inversion a5. inversion a6. subst.
    assert ((a_CPi (Eq a9 b A1) B0) = C1). eapply AnnTyping_unique; eauto.
    assert ((a_CPi (Eq a11 b0 A0) B1) = D1). eapply AnnTyping_unique; eauto.
    subst.
    eexists. eexists. eexists.
    eauto.
 -  destruct H as [C1 [D1 [g [T1 [T2 E1]]]]].
    destruct H0 as [C2 [D2 [g2' [T12 [T22 E2]]]]].
    destruct H1 as [C3 [D3 [g3' [T13 [T23 E3]]]]].
    inversion T1. inversion T2. subst.
    exists a_Star. exists a_Star. eexists.
    repeat split.
    eapply AnnTyping_co_subst_nondep; eauto.
    eapply AnnTyping_co_subst_nondep; eauto.
    eauto.
 - destruct H as [C1 [D1 [g [T1 [T2 E1]]]]].
   destruct H0 as [WF1 WF2].
   inversion WF1. inversion WF2.
   subst.
   assert (HG : AnnCtx G); eauto with ctx_wff.
   assert (U1 : AnnTyping G B a_Star). eapply AnnTyping_regularity; eauto.
   assert (U2 : AnnTyping G B1 a_Star). eapply AnnTyping_regularity; eauto.
   eexists. eexists. eexists.
   split. eauto. split.  eauto.
   eapply An_EraseEq; eauto.
 - split_hyp.
   inversion H. inversion H0. subst.
   assert (HG : AnnCtx G); eauto with ctx_wff.
   assert (U1 : AnnTyping G A a_Star). eapply AnnTyping_regularity; eauto.
   assert (U2 : AnnTyping G B a_Star). eapply AnnTyping_regularity; eauto.
   eexists. eexists. eexists.
   repeat split; eauto 1.
   eapply An_Refl; eauto 1.
   eapply An_Star. eauto.
 - assert (HG : AnnCtx G); eauto with ctx_wff.
   assert (U1 : AnnTyping G (a_Pi rho A B) a_Star).
   eapply AnnTyping_regularity; eauto.
   inversion U1.
   exists (a_Pi rho A B), (a_Pi rho A B). eexists.
   repeat split; eauto 1.
   pick fresh x and apply An_Abs; auto.
   + rewrite e; eauto. econstructor.
   eapply AnnTyping_weakening with (F:=nil); simpl; eauto.
   econstructor; eauto.
   econstructor; eauto.
   + rewrite e; eauto.
   destruct rho. econstructor; eauto. econstructor; eauto.
   simpl. autorewcs. apply union_notin_iff. split.
   eapply fv_tm_erase_tm. auto. auto.
(*   rewrite e; eauto.
   econstructor. eapply lc_erase. eauto using AnnTyping_lc1. *)
   + eapply An_Refl. eauto.
 - assert (HG : AnnCtx G); eauto with ctx_wff.
   assert (U1 : AnnTyping G (a_CPi phi B) a_Star).
   eapply AnnTyping_regularity; eauto.
   inversion U1. subst.
   exists (a_CPi phi B), (a_CPi phi B). eexists.
   repeat split; eauto 1.
   pick fresh x and apply An_CAbs; auto.
   inversion H3; subst.
   + rewrite e; eauto. econstructor.
     eapply AnnTyping_weakening with (F:=nil); simpl; eauto.
     econstructor; eauto. econstructor; eauto.
   + eapply An_Refl. eauto.
 (* Left/Right
 -  exists (a_Pi rho A B), (a_Pi rho A' B'), g2. repeat split; eauto 1.
 -  exists A, A'. eexists.  repeat split; eauto 1.
    eapply An_PiFst. eauto.
 - exists (a_CPi (Eq a1 a2 A0) B), (a_CPi (Eq a1' a2' A0') B'), g2. repeat split; eauto 1. *)
Qed.

Definition  AnnDefEq_regularity :
    (forall G D g A B,   AnnDefEq G D g A B ->
                    exists C1 C2 g', AnnTyping G A C1 /\ AnnTyping G B C2
                                /\ AnnDefEq G (dom G) g' C1 C2) :=
  fourth AnnDefEqAnnIso_regularity.

Definition AnnIso_regularity :
  forall G D g phi1 phi2, AnnIso G D g phi1 phi2 ->
                     AnnPropWff G phi1 /\ AnnPropWff G phi2 :=
  third AnnDefEqAnnIso_regularity.

(* --------------------------------------------------------- *)

(* Smart constructors for the annotated language *)

  Lemma An_Sym2
    : ∀ (G : context) (D : available_props) (g : co) (a b : tm),
      AnnDefEq G D g b a → AnnDefEq G D (g_Sym g) a b.
  Proof.
    intros.
    destruct (AnnDefEq_regularity H) as [A1 [A2 [g3 [T1 [T2 DE]]]]].
    eapply An_Sym ; eassumption.
  Qed.

Lemma An_Trans2
     : ∀ (G : context) (D : available_props) (g1 g2 : co)
       (a b a1 : tm),
       AnnDefEq G D g1 a a1
       → AnnDefEq G D g2 a1 b
       → AnnDefEq G D (g_Trans g1 g2) a b .
Proof.
  intros.
  destruct (AnnDefEq_regularity H) as [A1 [A2 [g3 [T1 [T2 DE]]]]].
    eapply An_Trans; eassumption.
Qed.

(* ---------------------------------------------- *)

Lemma erase_a_Const : forall G0 a0 A0 A1 T,
       erase a0 = a_Const T ->
       binds T (Cs A1) an_toplevel ->
       AnnTyping G0 a0 A0   ->
       exists g, AnnDefEq G0 (dom G0) g A0 A1.
   Proof.
     intros. dependent induction H1.
     all: try destruct rho; simpl in H; try done.
     + move: (IHAnnTyping1 H) => [? ?].
       eexists. eapply An_Trans2 with (a1 := A).
       eapply An_Sym2. eassumption.
       eassumption.
     + inversion H. subst.
       move: (binds_unique _ _ _ _ _ H0 H2 uniq_an_toplevel) => EQ. inversion EQ.
       subst.
       eexists. eapply An_Refl.
       move: (AnnTyping_weakening H3 G nil nil eq_refl) => h0.
       simpl_env in h0.
       eauto.
   Qed.

Lemma erase_capp :
  forall AB0 C G, AnnTyping G AB0 C -> forall A, erase AB0 = (a_CApp A g_Triv) ->
  exists a1 g0 g D, erase AB0 = erase (a_CApp a1 g0) /\ erase a1 = A /\
          AnnTyping G (a_CApp a1 g0) D /\ AnnDefEq G (dom G) g C D.
Proof.
  induction 1; intros a0 EQ; try destruct rho; inversion EQ; subst.
  - move: (IHAnnTyping1 _ H3) => [A1 [g0 [g1 [D hyp]]]]. split_hyp.
    subst.
    ann_invert_clear.
    exists A1.
    exists g0.
    eexists.
    eexists.
    repeat split.
    + simpl. simpl in *.  auto.
    + eapply An_CApp. eassumption. auto.
    + eapply An_Trans2 with (a1 := A). eapply An_Sym2; eauto.
      eauto.
  - exists a1. exists g. eexists. eexists.
    repeat split. eauto.
    eapply An_Refl.
    move: (AnnTyping_regularity H) => h0. inversion h0. subst.
    eapply AnnTyping_co_subst_nondep. eauto. eauto.
Qed.

Lemma An_AppCong2 : ∀ (G : context) (D : available_props) rho (g1 g2 : co)
       (a1 a2 b1 b2 A B : tm),
       AnnDefEq G D g1 a1 b1
       → AnnDefEq G D g2 a2 b2
         → AnnTyping G (a_App a1 rho a2) A
           → AnnTyping G (a_App b1 rho b2) B
           → AnnDefEq G D (g_AppCong g1 rho g2) (a_App a1 rho a2) (a_App b1 rho b2).
Proof.
  intros.
  assert (TMP: exists g3, AnnDefEq G (dom G) g3 A B).
  { destruct (AnnDefEq_regularity H) as (A1 & B1 & g4 & T1 & T2 & DE).
    destruct (AnnDefEq_regularity H0) as (A2 & B2 & g5 & T3 & T4 & DE2).
    inversion H1.
    inversion H2.
    resolve_unique_subst.
    resolve_unique_subst.
    resolve_unique_subst.
    resolve_unique_subst.
    eexists.
    eapply An_PiSnd; eauto 2. eapply AnnDefEq_weaken_available; eauto 1.
  } destruct TMP as [g3 EQ].
  eapply An_AppCong; eauto 1.
Qed.

(* ---------------------------------------------- *)

Lemma An_CAppCong2 :
      ∀ (G : context) (D : available_props) (g1 g2 g3 : co) (a1 b1 a2 b2 a3 b3 A B : tm),
       AnnDefEq G D g1 a1 b1
       → AnnDefEq G (dom G) g2 a2 b2
       → AnnDefEq G (dom G) g3 a3 b3
       → AnnTyping G (a_CApp a1 g2) A
       → AnnTyping G (a_CApp b1 g3) B
       → AnnDefEq G D (g_CAppCong g1 g2 g3) (a_CApp a1 g2) (a_CApp b1 g3).
Proof.
  intros.
  assert (TMP : exists g4, AnnDefEq G (dom G) g4 A B).
  {
    destruct (AnnDefEq_regularity H) as (A1 & B1 & g4 & T1 & T2 & DE).
    inversion H2.
    inversion H3.
    resolve_unique_subst.
    resolve_unique_subst.
    resolve_unique_subst.
    resolve_unique_subst.
    eexists.
    eapply An_CPiSnd; eauto 2.
  } destruct TMP as [g4 EQ].
  eapply An_CAppCong; eauto 1.
Qed.

Lemma An_Trans'
     : ∀ (G : context) (D : available_props) (g1 g2 : co)
       (a b a1 : tm),
       AnnDefEq G D g1 a a1
       → AnnDefEq G D g2 a1 b
       → exists g, AnnDefEq G D g a b .
Proof.
  intros.
  destruct (AnnDefEq_regularity H) as [A1 [A2 [g3 [T1 [T2 DE]]]]].
  eexists.
  eapply An_Trans; eassumption.
Qed.

Lemma An_Sym'
   : ∀ (G : context) (D : available_props) (g : co) (a b : tm),
       AnnDefEq G D g b a → exists g, AnnDefEq G D g a b.
Proof.
  intros.
  destruct (AnnDefEq_regularity H) as [A1 [A2 [g3 [T1 [T2 DE]]]]].
  eexists.
  eapply An_Sym ; eassumption.
Qed.

Lemma An_Refl_Star : forall G D a b A,
     erase a = erase b -> AnnTyping G b a_Star ->
     AnnTyping G a A -> erase A = a_Star ->
     exists g, AnnDefEq G D g a b.
  Proof.
    intros.
    eexists.
    eapply An_EraseEq. eauto. eauto. eauto.
    eapply An_EraseEq. eapply AnnTyping_regularity. eauto.
    eapply An_Star. eauto with ctx_wff.
    eauto. eapply An_Refl. eapply An_Star.
    eauto with ctx_wff.
  Qed.

Lemma An_IsoRefl2_derivable  : ∀ (G : context) (D : available_props) (phi1 phi2 : constraint),
       AnnPropWff G phi1
       → AnnPropWff G phi2
       → erase_constraint phi1 = erase_constraint phi2 →
       exists g,
       AnnIso G D g phi1 phi2.
Proof.
  intros G D phi1 phi2 H H0 H1.
  destruct phi1 as [a1 b1 A1].
  destruct phi2 as [a2 b2 B2].
  assert (AnnCtx G). eauto 2 with ctx_wff.
  inversion H. inversion H0. simpl in H1. inversion H1. clear H1. subst.
  eexists.
  eapply An_IsoConv; eauto 1.
  eapply An_EraseEq; eauto 1.
  eapply AnnTyping_regularity; eauto 1.
  eapply AnnTyping_regularity; eauto 1.
  eapply An_Refl; eauto.
Qed.

Lemma An_Pi_exists2
     : ∀ (x : atom) (G : list (atom * sort)) (rho : relflag) (A B : tm),
       x `notin` union (dom G) (fv_tm_tm_tm B)
       → AnnTyping ([(x, Tm A)] ++ G) (open_tm_wrt_tm B (a_Var_f x)) a_Star
       → AnnTyping G (a_Pi rho A B) a_Star.
Proof.
  intros.
  eapply An_Pi_exists; eauto.
  sort_inversion.
Qed.

Lemma An_Abs_exists2
  : ∀ (x : atom) (G : context) (rho : relflag) (A a B : tm),
    x `notin` union (dom G) (union (fv_tm_tm_tm a) (fv_tm_tm_tm B))
    → AnnTyping ([(x, Tm A)] ++ G) (open_tm_wrt_tm a (a_Var_f x)) (open_tm_wrt_tm B (a_Var_f x))
    → RhoCheck rho x (erase_tm (open_tm_wrt_tm a (a_Var_f x)))
    → AnnTyping G (a_Abs rho A a) (a_Pi rho A B).
Proof.
  intros.
  eapply An_Abs_exists; eauto.
  sort_inversion.
Qed.

Lemma An_CPi_exists2
  : ∀ (c : atom) (G : context) (phi : constraint) (B : tm),
       c `notin` union (dom G) (fv_co_co_tm B)
       → AnnTyping ([(c, Co phi)] ++ G) (open_tm_wrt_co B (g_Var_f c)) a_Star
       → AnnTyping G (a_CPi phi B) a_Star.
Proof.
  intros.
  eapply An_CPi_exists; eauto.
  sort_inversion.
Qed.

Lemma An_CAbs_exists2
   : ∀ (c : atom) (G : context) (phi : constraint) (a B : tm),
       c `notin` union (dom G) (union (fv_co_co_tm a) (fv_co_co_tm B))
       → AnnTyping ([(c, Co phi)] ++ G) (open_tm_wrt_co a (g_Var_f c)) (open_tm_wrt_co B (g_Var_f c))
       → AnnTyping G (a_CAbs phi a) (a_CPi phi B).
Proof.
  intros.
  eapply An_CAbs_exists; eauto.
  sort_inversion.
Qed.

Lemma An_Fam2 :  ∀ (G : context) (F : tyfam) (A a : tm),
       AnnCtx G
       → binds F (Ax a A) an_toplevel
       → AnnTyping G (a_Fam F) A.
Proof.
  intros.
  eapply An_Fam.
  eauto. eauto.
  move: (an_toplevel_closed H0) => h0.
  move: (AnnTyping_regularity h0) => h1.
  eauto.
Qed.

Lemma An_AbsCong_exists2
      : ∀ (x1 x2 : atom) (G : context) (D : available_props) (rho : relflag) (g1 g2 : co)
        (A1 b1 A2 b3 b2 B : tm),
        x1 `notin` union (dom G) (union (fv_tm_tm_tm b1) (union (fv_tm_tm_tm b2) (fv_tm_tm_co g2)))
        → x2 `notin` union (dom G) (union (fv_tm_tm_tm b2) (union (fv_tm_tm_tm b3) (fv_tm_tm_co g1)))
          → AnnDefEq G D g1 A1 A2
            → AnnDefEq ([(x1, Tm A1)]++ G) D (open_co_wrt_tm g2 (a_Var_f x1))
                (open_tm_wrt_tm b1 (a_Var_f x1)) (open_tm_wrt_tm b2 (a_Var_f x1))
              → open_tm_wrt_tm b3 (a_Var_f x2) = open_tm_wrt_tm b2 (a_Conv (a_Var_f x2) (g_Sym g1))
                  → AnnTyping G A2 a_Star
                    → RhoCheck rho x1 (erase_tm (open_tm_wrt_tm b1 (a_Var_f x1)))
                      → RhoCheck rho x2 (erase_tm (open_tm_wrt_tm b3 (a_Var_f x2)))
                        → AnnTyping G (a_Abs rho A1 b2) B
                          → AnnDefEq G D (g_AbsCong rho g1 g2) (a_Abs rho A1 b1) (a_Abs rho A2 b3).
 Proof.
   intros. eapply An_AbsCong_exists; eauto.
   inversion H7. auto.
 Qed.

 Lemma An_CPiCong_exists2
      : ∀ (c : atom) (G : context) (D : available_props)
        (g1 g3 : co) (phi1 : constraint) (B1 : tm)
        (phi2 : constraint) (B3 B2 : tm),
        AnnIso G D g1 phi1 phi2
        → c
          `notin` (union (dom G)
                   (union D
                    (union (fv_co_co_tm B2)
                       (union (fv_co_co_tm B1)
                          (union (fv_co_co_co g3)
                              (union (fv_co_co_co g1)
                                     (fv_co_co_tm B3)))))))
          → AnnDefEq ([(c, Co phi1)] ++ G) D
                     (open_co_wrt_co g3 (g_Var_f c))
                     (open_tm_wrt_co B1 (g_Var_f c))
                     (open_tm_wrt_co B2 (g_Var_f c))
          → open_tm_wrt_co B3 (g_Var_f c) =
            open_tm_wrt_co B2 (g_Cast (g_Var_f c) (g_Sym g1))
          → AnnTyping G (a_CPi phi1 B1) a_Star
          → AnnTyping G (a_CPi phi1 B2) a_Star
          → AnnDefEq G D (g_CPiCong g1 g3) (a_CPi phi1 B1) (a_CPi phi2 B3).
 Proof.
   intros. eapply An_CPiCong_exists with (B1 := B1) (B2 := B2) (B3:= B3); eauto.
   eapply An_CPi_exists2 with (c:= c).
   fsetdec.
   rewrite H2.
   move: (AnnIso_regularity H) => [h0 h1].
   move: (AnnIso_AnnCtx H) => h2.
   destruct phi1 as [a1 b1 A1].
   destruct phi2 as [a2 b2 A2].
   inversion h1. subst.
   inversion H4. subst.
   eapply AnnTyping_co_subst_nondep with (D := dom ([(c, Co (Eq a2 b2 A2))] ++ G))(L := L \u {{c}} \u dom G).
   eapply An_Cast.
   eapply An_Assn.
   eauto.
   eauto.
   simpl. eauto.
   eapply An_IsoSym.
   eapply AnnIso_weakening with (F := nil); simpl; eauto using AnnIso_weaken_available.
   eapply (third ann_weaken_available_mutual).
   eapply AnnIso_weaken_available. eauto. eauto.
   econstructor; eauto.
   intros c1 Fr.
   move: (H12 c1 ltac:(auto)) => h3.
   eapply AnnTyping_weakening with (F:= (c1 ~ Co (Eq a1 b1 A1))); eauto.
   econstructor; eauto.
   eapply AnnPropWff_weakening with (F:=nil); eauto.
   simpl. econstructor; eauto.
 Qed.

(* Left/Right
  Lemma An_Left2 :
      ∀ (G : context) (D : available_props) (g1 g2 : co)
       (a a' : tm) (T : ett_ott.const) (rho : relflag)
       (A B A' B' b b' : tm),
       Path T a
       → Path T a'
       → AnnTyping G a (a_Pi rho A B)
       → AnnTyping G a' (a_Pi rho A' B')
       → AnnDefEq G D g1 (a_App a rho b) (a_App a' rho b')
       → AnnDefEq G (dom G) g2 (a_Pi rho A B) (a_Pi rho A' B')
       → AnnDefEq G D (g_Left g1 g2) a a'.
  Proof.
    intros.
    move: (AnnDefEq_regularity H3) => [s1 [s2 [g4 hyp]]]. split_hyp.
    ann_invert_clear.
    ann_invert_clear.
    resolve_unique_subst.
    resolve_unique_subst.
    invert_syntactic_equality.
    eapply An_Left with (b:=b)(b':=b'); try eassumption.
  Qed.

  Lemma An_Right2 : ∀ (G : context) (D : available_props) (g1 g2 : co) (b b' : tm) (T : ett_ott.const) (a a' : tm) (A A' B B' : tm),
      Path T a
      → Path T a'
      → AnnTyping G a (a_Pi Rel A B)
      → AnnTyping G a' (a_Pi Rel A' B')
      → AnnDefEq G D g1 (a_App a Rel b) (a_App a' Rel b')
      → AnnDefEq G (dom G) g2 (a_Pi Rel A B) (a_Pi Rel A' B')
      → AnnDefEq G D (g_Right g1 g2) b b'.
  Proof.
    intros.
    move: (AnnDefEq_regularity H3) => [T1 [T2 [g hyp]]]. split_hyp.
    ann_invert_clear.
    ann_invert_clear.
    resolve_unique_subst.
    resolve_unique_subst.
    invert_syntactic_equality.
    eapply An_Right with (a:=a)(a':=a'); try eassumption.
  Qed.

  Lemma An_CLeft2 : ∀ (G : context) (D : available_props) (g1 g2 : co) (a a' : tm)
                      (T : const) phi B phi' B'
                      (g g': co),
      Path T a
      → Path T a'
      → AnnTyping G a (a_CPi phi B)
      → AnnTyping G a' (a_CPi phi' B')
      → AnnDefEq G D g1 (a_CApp a g) (a_CApp a' g')
      → AnnDefEq G (dom G) g2 (a_CPi phi B) (a_CPi phi' B')
      → AnnDefEq G D (g_Left g1 g2) a a'.
  Proof.
    intros.
    move: (AnnDefEq_regularity H3) => [T1 [T2 [s hyp]]]. split_hyp.
    inversion H5. inversion H6. subst.
    destruct phi as [a1 a2 A]. destruct phi' as [a1' a2' A'].
    resolve_unique_subst.
    resolve_unique_subst.
    inversion H8.
    inversion H9.
    subst.
    eapply An_CLeft with (g := g)(g':=g')(a1 := a0)(a2:=b)(A0:=A1)(a1':=a3)(a2':=b0)(A0':=A0); try eassumption.
  Qed.
*)

End fc_invert.


(* Generated by coq-of-rust *)
Require Import CoqOfRust.CoqOfRust.

Import Root.std.prelude.rust_2015.

Definition main (_ : unit) : unit :=
  _crate.io._print
    (_crate.fmt.ImplArguments.new_v1
      [ ""; " and "; " is "; "\n" ]
      match
        ("1i32 + 1 == 2i32",
          "2i32 * 2 == 4i32",
          andb (eqb (add 1 1) 2) (eqb (mul 2 2) 4))
      with
      | args =>
        [
          _crate.fmt.ImplArgumentV1.new_debug
            (IndexedField.get (index := 0) args);
          _crate.fmt.ImplArgumentV1.new_debug
            (IndexedField.get (index := 1) args);
          _crate.fmt.ImplArgumentV1.new_debug
            (IndexedField.get (index := 2) args)
        ]
      end) ;;
  tt ;;
  _crate.io._print
    (_crate.fmt.ImplArguments.new_v1
      [ ""; " or "; " is "; "\n" ]
      match ("true", "false", or true false) with
      | args =>
        [
          _crate.fmt.ImplArgumentV1.new_debug
            (IndexedField.get (index := 0) args);
          _crate.fmt.ImplArgumentV1.new_debug
            (IndexedField.get (index := 1) args);
          _crate.fmt.ImplArgumentV1.new_debug
            (IndexedField.get (index := 2) args)
        ]
      end) ;;
  tt ;;
  tt.


Require Import List.
Import ListNotations.

Require Import Undecidability.PCP.PCP.
Require Import Undecidability.PCP.Util.Facts.
Import PCPListNotation.
Require Import Undecidability.PCP.Util.PCP_facts.
Require Import Undecidability.Synthetic.Definitions.

#[local] Hint Resolve cons_incl : core.

Set Default Goal Selector "!".

(* ** BPCP reduces to iBPCP *)

Definition f (P : stack bool) (A : stack bool) := omap (fun x => pos card_eq x P) A.

Lemma itau_tau1 P A : A <<= P -> itau1 P (f P A) = tau1 A.
Proof.
  intros H. induction A as [ | (x,y) ].
  - reflexivity.
  - cbn. assert ((x, y) el P) as [n E] % (el_pos card_eq) by firstorder.
    rewrite E. cbn. unfold f in IHA. rewrite IHA; [|now eauto].
    now erewrite pos_nth; eauto.
Qed.

Lemma itau_tau2 P A : A <<= P -> itau2 P (f P A) = tau2 A.
Proof.
  intros H. induction A as [ | (x,y) ].
  - reflexivity.
  - cbn. assert ((x, y) el P) as [n E] % (el_pos card_eq) by firstorder.
    rewrite E. cbn. unfold f in IHA. rewrite IHA; eauto.
    now erewrite pos_nth; eauto.
Qed.

Definition g (P : stack bool) (A : list nat) := map (fun n => nth n P ( [], [] )) A.

Lemma tau_itau1 P A : (forall a : nat, a el A -> a < | P |) -> tau1 (g P A) = itau1 P A.
Proof.
  intros H. induction A.
  - reflexivity.
  - cbn. unfold g in *. rewrite IHA; firstorder. now destruct (nth a P ([], [])) eqn:E.
Qed.

Lemma tau_itau2 P A : (forall a : nat, a el A -> a < | P |) -> tau2 (g P A) = itau2 P A.
Proof.
  intros H. induction A.
  - reflexivity.
  - cbn. unfold g in *. rewrite IHA; firstorder. now destruct (nth a P ([], [])) eqn:E.
Qed.

Lemma PCPb_iff_iPCPb P : PCPb P <-> iPCPb P.
Proof.
  split.
  - intros (A & ? & ? & ?).
    exists (f P A). repeat split.
    + now intros ? (? & ? & ? % pos_length) % in_omap_iff.
    + destruct A as [ | c A ]; try congruence. cbn.
      assert (c el P) as [n ->] % (el_pos card_eq) by firstorder.
      congruence.
    + rewrite itau_tau1, H1, itau_tau2; eauto.
  - intros (A & ? & ? & ?).
    exists (g P A). repeat split.
    + unfold g. intros ? (? & <- & ?) % in_map_iff. eapply nth_In; firstorder.
    + destruct A; cbn; congruence.
    + now rewrite tau_itau1, H1, tau_itau2.
Qed.

Lemma reductionLR : PCPb ⪯ iPCPb.
Proof.
  exists id. exact PCPb_iff_iPCPb.
Qed.

Lemma reductionRL : iPCPb ⪯ PCPb.
Proof.
  exists id. intro x. now rewrite PCPb_iff_iPCPb.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

Require Export Ensembles.
Require Export Constructive_sets.
Require Export Relations_1.
Require Export Relations_1_facts.
Require Export Partial_Order.
Require Export Cpo.
Require Export Powerset.
Require Export Powerset_facts.
Require Export Classical.
Require Export Classical_sets.

Section Sets_as_an_algebra.

  Variable U : Type.

  Lemma sincl_add_x :
    forall (A B:Ensemble U) (x:U),
      ~ In U A x ->
      Strict_Included U (Add U A x) (Add U B x) -> Strict_Included U A B.
  Proof.
    intros A B x H' H'0; red.
    lapply (Strict_Included_inv U (Add U A x) (Add U B x)); auto with sets.
    clear H'0; intro H'0; split.
    apply incl_add_x with (x := x); tauto.
    elim H'0; intros H'1 H'2; elim H'2; clear H'0 H'2.
    intros x0 H'0.
    red; intro H'2.
    elim H'0; clear H'0.
    rewrite <- H'2; auto with sets.
  Qed.

  Lemma incl_soustr_in :
    forall (X:Ensemble U) (x:U), In U X x -> Included U (Subtract U X x) X.
  Proof.
    intros X x H'; red.
    intros x0 H'0; elim H'0; auto with sets.
  Qed.

  Lemma incl_soustr :
    forall (X Y:Ensemble U) (x:U),
      Included U X Y -> Included U (Subtract U X x) (Subtract U Y x).
  Proof.
    intros X Y x H'; red.
    intros x0 H'0; elim H'0.
    intros H'1 H'2.
    apply Subtract_intro; auto with sets.
  Qed.

  Lemma incl_soustr_add_l :
    forall (X:Ensemble U) (x:U), Included U (Subtract U (Add U X x) x) X.
  Proof.
    intros X x; red.
    intros x0 H'; elim H'; auto with sets.
    intro H'0; elim H'0; auto with sets.
    intros t H'1 H'2; elim H'2; auto with sets.
  Qed.

  Lemma incl_soustr_add_r :
    forall (X:Ensemble U) (x:U),
      ~ In U X x -> Included U X (Subtract U (Add U X x) x).
  Proof.
    intros X x H'; red.
    intros x0 H'0; try assumption.
    apply Subtract_intro; auto with sets.
    red; intro H'1; apply H'; rewrite H'1; auto with sets.
  Qed.
  Hint Resolve incl_soustr_add_r: sets.

  Lemma add_soustr_2 :
    forall (X:Ensemble U) (x:U),
      In U X x -> Included U X (Add U (Subtract U X x) x).
  Proof.
    intros X x H'; red.
    intros x0 H'0; try assumption.
    elim (classic (x = x0)); intro K; auto with sets.
    elim K; auto with sets.
  Qed.

  Lemma add_soustr_1 :
    forall (X:Ensemble U) (x:U),
      In U X x -> Included U (Add U (Subtract U X x) x) X.
  Proof.
    intros X x H'; red.
    intros x0 H'0; elim H'0; auto with sets.
    intros y H'1; elim H'1; auto with sets.
    intros t H'1; try assumption.
    rewrite <- (Singleton_inv U x t); auto with sets.
  Qed.

  Lemma add_soustr_xy :
    forall (X:Ensemble U) (x y:U),
      x <> y -> Subtract U (Add U X x) y = Add U (Subtract U X y) x.
  Proof.
    intros X x y H'; apply Extensionality_Ensembles.
    split; red.
    intros x0 H'0; elim H'0; auto with sets.
    intro H'1; elim H'1.
    intros u H'2 H'3; try assumption.
    apply Add_intro1.
    apply Subtract_intro; auto with sets.
    intros t H'2 H'3; try assumption.
    elim (Singleton_inv U x t); auto with sets.
    intros u H'2; try assumption.
    elim (Add_inv U (Subtract U X y) x u); auto with sets.
    intro H'0; elim H'0; auto with sets.
    intro H'0; rewrite <- H'0; auto with sets.
  Qed.

  Lemma incl_st_add_soustr :
    forall (X Y:Ensemble U) (x:U),
      ~ In U X x ->
      Strict_Included U (Add U X x) Y -> Strict_Included U X (Subtract U Y x).
  Proof.
    intros X Y x H' H'0; apply sincl_add_x with (x := x); auto using add_soustr_1 with sets.
    split.
    elim H'0.
    intros H'1 H'2.
    generalize (Inclusion_is_transitive U).
    intro H'4; red in H'4.
    apply H'4 with (y := Y); auto using add_soustr_2 with sets.
    red in H'0.
    elim H'0; intros H'1 H'2; try exact H'1; clear H'0. (* PB *)
    red; intro H'0; apply H'2.
    rewrite H'0; auto 8 using add_soustr_xy, add_soustr_1, add_soustr_2 with sets.
  Qed.

  Lemma Sub_Add_new :
    forall (X:Ensemble U) (x:U), ~ In U X x -> X = Subtract U (Add U X x) x.
  Proof.
    auto using incl_soustr_add_l with sets.
  Qed.

  Lemma Simplify_add :
    forall (X X0:Ensemble U) (x:U),
      ~ In U X x -> ~ In U X0 x -> Add U X x = Add U X0 x -> X = X0.
  Proof.
    intros X X0 x H' H'0 H'1; try assumption.
    rewrite (Sub_Add_new X x); auto with sets.
    rewrite (Sub_Add_new X0 x); auto with sets.
    rewrite H'1; auto with sets.
  Qed.

  Lemma Included_Add :
    forall (X A:Ensemble U) (x:U),
      Included U X (Add U A x) ->
      Included U X A \/ (exists A' : _, X = Add U A' x /\ Included U A' A).
  Proof.
    intros X A x H'0; try assumption.
    elim (classic (In U X x)).
    intro H'1; right; try assumption.
    exists (Subtract U X x).
    split; auto using incl_soustr_in, add_soustr_xy, add_soustr_1, add_soustr_2 with sets.
    red in H'0.
    red.
    intros x0 H'2; try assumption.
    lapply (Subtract_inv U X x x0); auto with sets.
    intro H'3; elim H'3; intros K K'; clear H'3.
    lapply (H'0 x0); auto with sets.
    intro H'3; try assumption.
    lapply (Add_inv U A x x0); auto with sets.
    intro H'4; elim H'4;
      [ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ].
    elim K'; auto with sets.
    intro H'1; left; try assumption.
    red in H'0.
    red.
    intros x0 H'2; try assumption.
    lapply (H'0 x0); auto with sets.
    intro H'3; try assumption.
    lapply (Add_inv U A x x0); auto with sets.
    intro H'4; elim H'4;
      [ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ].
    absurd (In U X x0); auto with sets.
    rewrite <- H'5; auto with sets.
  Qed.

  Lemma setcover_inv :
    forall A x y:Ensemble U,
      covers (Ensemble U) (Power_set_PO U A) y x ->
      Strict_Included U x y /\
      (forall z:Ensemble U, Included U x z -> Included U z y -> x = z \/ z = y).
  Proof.
    intros A x y H'; elim H'.
    unfold Strict_Rel_of; simpl.
    intros H'0 H'1; split; [ auto with sets | idtac ].
    intros z H'2 H'3; try assumption.
    elim (classic (x = z)); auto with sets.
    intro H'4; right; try assumption.
    elim (classic (z = y)); auto with sets.
    intro H'5; try assumption.
    elim H'1.
    exists z; auto with sets.
  Qed.

  Theorem Add_covers :
    forall A a:Ensemble U,
      Included U a A ->
      forall x:U,
	In U A x ->
	~ In U a x -> covers (Ensemble U) (Power_set_PO U A) (Add U a x) a.
  Proof.
    intros A a H' x H'0 H'1; try assumption.
    apply setcover_intro; auto with sets.
    red.
    split; [ idtac | red; intro H'2; try exact H'2 ]; auto with sets.
    apply H'1.
    rewrite H'2; auto with sets.
    red; intro H'2; elim H'2; clear H'2.
    intros z H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2.
    lapply (Strict_Included_inv U a z); auto with sets; clear H'3.
    intro H'2; elim H'2; intros H'3 H'5; elim H'5; clear H'2 H'5.
    intros x0 H'2; elim H'2.
    intros H'5 H'6; try assumption.
    generalize H'4; intro K.
    red in H'4.
    elim H'4; intros H'8 H'9; red in H'8; clear H'4.
    lapply (H'8 x0); auto with sets.
    intro H'7; try assumption.
    elim (Add_inv U a x x0); auto with sets.
    intro H'15.
    cut (Included U (Add U a x) z).
    intro H'10; try assumption.
    red in K.
    elim K; intros H'11 H'12; apply H'12; clear K; auto with sets.
    rewrite H'15.
    red.
    intros x1 H'10; elim H'10; auto with sets.
    intros x2 H'11; elim H'11; auto with sets.
  Qed.

  Theorem covers_Add :
    forall A a a':Ensemble U,
      Included U a A ->
      Included U a' A ->
      covers (Ensemble U) (Power_set_PO U A) a' a ->
      exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x.
  Proof.
    intros A a a' H' H'0 H'1; try assumption.
    elim (setcover_inv A a a'); auto with sets.
    intros H'6 H'7.
    clear H'1.
    elim (Strict_Included_inv U a a'); auto with sets.
    intros H'5 H'8; elim H'8.
    intros x H'1; elim H'1.
    intros H'2 H'3; try assumption.
    exists x.
    split; [ try assumption | idtac ].
    clear H'8 H'1.
    elim (H'7 (Add U a x)); auto with sets.
    intro H'1.
    absurd (a = Add U a x); auto with sets.
    red; intro H'8; try exact H'8.
    apply H'3.
    rewrite H'8; auto with sets.
    auto with sets.
    red.
    intros x0 H'1; elim H'1; auto with sets.
    intros x1 H'8; elim H'8; auto with sets.
    split; [ idtac | try assumption ].
    red in H'0; auto with sets.
  Qed.

  Theorem covers_is_Add :
    forall A a a':Ensemble U,
      Included U a A ->
      Included U a' A ->
      (covers (Ensemble U) (Power_set_PO U A) a' a <->
	(exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x)).
  Proof.
    intros A a a' H' H'0; split; intro K.
    apply covers_Add with (A := A); auto with sets.
    elim K.
    intros x H'1; elim H'1; intros H'2 H'3; rewrite H'2; clear H'1.
    apply Add_covers; intuition.
  Qed.

  Theorem Singleton_atomic :
    forall (x:U) (A:Ensemble U),
      In U A x ->
      covers (Ensemble U) (Power_set_PO U A) (Singleton U x) (Empty_set U).
  Proof.
    intros x A H'.
    rewrite <- (Empty_set_zero' U x).
    apply Add_covers; auto with sets.
  Qed.

  Lemma less_than_singleton :
    forall (X:Ensemble U) (x:U),
      Strict_Included U X (Singleton U x) -> X = Empty_set U.
  Proof.
    intros X x H'; try assumption.
    red in H'.
    lapply (Singleton_atomic x (Full_set U));
      [ intro H'2; try exact H'2 | apply Full_intro ].
    elim H'; intros H'0 H'1; try exact H'1; clear H'.
    elim (setcover_inv (Full_set U) (Empty_set U) (Singleton U x));
      [ intros H'6 H'7; try exact H'7 | idtac ]; auto with sets.
    elim (H'7 X); [ intro H'5; try exact H'5 | intro H'5 | idtac | idtac ];
      auto with sets.
    elim H'1; auto with sets.
  Qed.

End Sets_as_an_algebra.

Hint Resolve incl_soustr_in: sets.
Hint Resolve incl_soustr: sets.
Hint Resolve incl_soustr_add_l: sets.
Hint Resolve incl_soustr_add_r: sets.
Hint Resolve add_soustr_1 add_soustr_2: sets.
Hint Resolve add_soustr_xy: sets.


(*
Copyright 2017 IMDEA Software Institute
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)

From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat eqtype seq.
From pcm Require Import options pred prelude.
From pcm Require Export auto.
From pcm Require Import pcm unionmap natmap.

(**************************************************************************)
(**************************************************************************)
(* Canonical structure lemmas for automating three tasks:                 *)
(*                                                                        *)
(* 1. checking if implications of the form valid e1 -> valid e2 hold by   *)
(*    deciding if the terms in e2 are all contained in e1                 *)
(*                                                                        *)
(* 2. checking if dom_eq e1 e2 holds by cancelling the common terms, to   *)
(*    obtain residuals rs1 and rs2, and then issuing a subgoal dom_eq rs1 *)
(*    rs2.                                                                *)
(*                                                                        *)
(* 3. checking if the union e is undef, because it contains duplicate     *)
(*    pointers or an undef                                                *)
(*                                                                        *)
(**************************************************************************)
(**************************************************************************)

(* Context structure for reflection of unionmap expressions. We          *)
(* reflect the keys and the variables of the map expression. (The        *)
(* variables are all expressions that are not recognized as a key, or as *)
(* a disjoint union). We reflect disjoint union as a sequence.           *)
(*                                                                       *)
(* The context of keys is thus seq K. The context of vars is seq U.      *)

Section ReflectionContexts.
Variables (K : ordType) (C : pred K) (T : Type) (U : union_map_class C T).

Structure ctx := Context {keyx : seq K; varx : seq U}.

Definition empx := Context [::] [::].

(* because contexts grow during computation, *)
(* we need a notion of sub-context *)

Definition sub_ctx (i j : ctx) :=
  prefix (keyx i) (keyx j) /\ prefix (varx i) (varx j).

Lemma sc_refl i : sub_ctx i i.
Proof. by []. Qed.

Lemma sc_trans i j k : sub_ctx i j -> sub_ctx j k -> sub_ctx i k.
Proof.
by case=>K1 V1 [K2 V2]; split; [move: K2 | move: V2]; apply: prefix_trans.
Qed.

End ReflectionContexts.

(* Keys and map variables are syntactified as De Bruijn indices in the context. *)
(* Disjoint union is syntactified as concatenation of lists.                    *)
(*                                                                              *)
(* Pts n v : syntax for "key indexed the context under number n" \-> v          *)
(* Var n : syntax for "expression indexed in the context under number n"        *)

(* now for reflection *)

Section Reflection.
Variables (K : ordType) (C : pred K) (T : Type) (U : union_map_class C T).
Implicit Type i : ctx U.

Inductive term := Pts of nat & T | Var of nat.

(* interpretation function for elements *)
Definition interp' i t :=
  match t with
    Pts n v => if onth (keyx i) n is Some k then pts k v else undef
  | Var n => if onth (varx i) n is Some f then f else undef
  end.

(* main interpretation function *)
Notation fx i := (fun t f => interp' i t \+ f).
Definition interp i ts := foldr (fx i) Unit ts.

Lemma fE i ts x  : foldr (fx i) x ts = x \+ interp i ts.
Proof. by elim: ts x=>[|t ts IH] x; rewrite /= ?unitR // IH joinCA. Qed.

Lemma interp_rev i ts : interp i (rev ts) = interp i ts.
Proof.
elim: ts=>[|t ts IH] //=; rewrite rev_cons -cats1.
by rewrite /interp foldr_cat fE /= unitR IH.
Qed.

(* we also need a pretty-printer, which works the same as interp *)
(* but removes trailing Unit's *)

Fixpoint pprint i ts :=
  if ts is t :: ts' then
    if ts' is [::] then interp' i t else interp' i t \+ pprint i ts'
  else Unit.

Lemma pp_interp i ts : pprint i ts = interp i ts.
Proof. by elim: ts=>[|t ts /= <-] //; case: ts=>//; rewrite unitR. Qed.

Definition key n t := if t is Pts m _ then n == m else false.
Definition var n t := if t is Var m then n == m else false.

Definition kfree n t := rfilter (key n) t.
Definition vfree n t := rfilter (var n) t.
Arguments kfree /.
Arguments vfree /.

Lemma keyN i n ts : ~~ has (key n) ts -> interp i (kfree n ts) = interp i ts.
Proof. by elim: ts=>[|t ts IH] //=; case: ifP=>//= _ /IH ->. Qed.

Lemma varN i n ts : ~~ has (var n) ts -> interp i (vfree n ts) = interp i ts.
Proof. by elim: ts=>[|t ts IH] //=; case: ifP=>//= _ /IH ->. Qed.

Lemma keyP i n k ts :
        has (key n) ts -> onth (keyx i) n = Some k ->
        exists v, interp i ts = pts k v \+ interp i (kfree n ts).
Proof.
elim: ts=>[|t ts IH] //=; case: ifP=>[|_ H].
- by case: t=>//= _ v /eqP <- _ ->; exists v.
by case/(IH H)=>v ->; exists v; rewrite joinCA.
Qed.

Lemma varP i n u ts :
        has (var n) ts -> onth (varx i) n = Some u ->
        interp i ts = u \+ interp i (vfree n ts).
Proof.
elim: ts=>[|t ts IH] //=; case: ifP=>[|_ H].
- by case: t=>//= _ /eqP <- _ ->.
by move/(IH H)=>->; rewrite joinCA.
Qed.

(* interpretation is invariant under context weakening *)
(* under assumption that the interpreted term is well-formed *)

Definition wf i t :=
  match t with
    Pts n _ => n < size (keyx i)
  | Var n => n < size (varx i)
  end.

Lemma sc_wf i j ts : sub_ctx i j -> all (wf i) ts -> all (wf j) ts.
Proof.
case=>/prefix_size H1 /prefix_size H2; elim: ts=>[|t ts IH] //=.
case/andP=>H /IH ->; rewrite andbT.
by case: t H=>[n v|v] H; apply: leq_trans H _.
Qed.

Lemma sc_interp i j ts :
        sub_ctx i j -> all (wf i) ts -> interp i ts = interp j ts.
Proof.
case=>H1 H2; elim: ts=>[|t ts IH] //= /andP [H] /IH ->.
by case: t H=>[n v|n] /= /prefix_onth <-.
Qed.

Lemma valid_wf i ts : valid (interp i ts) -> all (wf i) ts.
Proof.
elim: ts=>[|t ts IH] //= V; rewrite (IH (validR V)) andbT.
case: t {V IH} (validL V)=>[n v|n] /=;
by case X : (onth _ _)=>[a|]; rewrite ?(onth_size X) // valid_undef.
Qed.

Lemma wf_kfree i n ts : all (wf i) ts -> all (wf i) (kfree n ts).
Proof. by elim: ts=>//= t ts IH; case: ifP=>_ /andP [] //= -> /IH ->. Qed.

Lemma wf_vfree i n ts : all (wf i) ts -> all (wf i) (vfree n ts).
Proof. by elim: ts=>//= t ts IH; case: ifP=>_ /andP [] //= -> /IH ->. Qed.

(* sometimes we want to get keys in a list, not in a predicate *)

Definition getkeys :=
  foldr (fun t ks => if t is Pts k _ then k :: ks else ks) [::].

Lemma has_getkeys ts n : n \in getkeys ts = has (key n) ts.
Proof. by elim: ts=>//= t ts IH; case: t=>[m v|m] //; rewrite inE IH. Qed.

End Reflection.

(**********************************************************************)
(**********************************************************************)
(* Purely functional decision procedures for the three tasks. Further *)
(* below, they will be embedded into the canonical programs validX    *)
(* and domeqX and invalidX respectively.                              *)
(**********************************************************************)
(**********************************************************************)

(* subterm is purely functional version of validX *)

Section Subterm.
Variables (K : ordType) (C : pred K) (T : Type) (U : union_map_class C T).
Implicit Types (i : ctx U) (ts : seq (term T)).

Fixpoint subterm ts1 ts2 :=
  match ts1 with
    Pts n _ :: tsx1 =>
      if has (key n) ts2 then subterm tsx1 (kfree n ts2) else false
  | Var n :: tsx1 =>
      if has (var n) ts2 then subterm tsx1 (vfree n ts2) else false
  | [::] => true
  end.

(* the procedure is sound for deciding wf subterms *)
Lemma subterm_sound i ts1 ts2 :
        all (wf i) ts1 -> all (wf i) ts2 -> subterm ts1 ts2 ->
        exists u, dom_eq (interp i ts1 \+ u) (interp i ts2).
Proof.
elim: ts1 ts2=>[|t ts1 IH] ts2 /= A1 A2.
- by exists (interp i ts2); rewrite unitL.
case/andP: A1; case: t=>[n v|n] /= /size_onth [k] X A1;
rewrite X; case: ifP=>Y //.
- case: (keyP Y X)=>w -> /(IH _ A1 (wf_kfree n A2)) [xs D].
  by exists xs; rewrite -joinA; apply: domeqUn D.
move: (varP Y X)=>-> /(IH _ A1 (wf_vfree n A2)) [xs D].
by exists xs; rewrite -joinA; apply: domeqUn D.
Qed.

End Subterm.

(* subtract is purely functional version of domeqX *)

Section Subtract.
Variables (K : ordType) (C : pred K) (T : Type) (U : union_map_class C T).
Implicit Types (i : ctx U) (ts : seq (term T)).

(* We need a subterm lemma that returns the uncancelled stuff from *)
(* both sides. xs accumulates uncancelled part of ts1, starting as nil *)

Fixpoint subtract ts1 ts2 xs :=
  match ts1 with
    Pts n v :: tsx1 =>
      if has (key n) ts2 then subtract tsx1 (kfree n ts2) xs
      else subtract tsx1 ts2 (Pts n v :: xs)
  | Var n :: tsx1 =>
      if has (var n) ts2 then subtract tsx1 (vfree n ts2) xs
      else subtract tsx1 ts2 (Var T n :: xs)
  | [::] => (xs, ts2)
  end.

(* below, the existentially quantified u is the cancelled part *)
Lemma subtract_sound i ts1 ts2 rs1 rs2 xs :
        all (wf i) ts1 -> all (wf i) ts2 ->
        subtract ts1 ts2 xs = (rs1, rs2) ->
        exists u, dom_eq (interp i ts1 \+ interp i xs) (interp i rs1 \+ u) /\
                  dom_eq (interp i ts2) (interp i rs2 \+ u).
Proof.
elim: ts1 ts2 xs=>[|t ts1 IH] ts2 xs /= A1 A2.
- by case=><-<-; exists Unit; rewrite unitL !unitR.
case/andP: A1; case: t=>[n v|n] /= /size_onth [x X] A1; rewrite X; case: ifP=>Y.
- case: (keyP Y X)=>w -> /(IH _ _ A1 (wf_kfree n A2)) [u][H1 H2].
  exists (pts x v \+ u); rewrite -joinA !(pull (pts x _)).
  by split=>//; apply: domeqUn.
- by case/(IH _ _ A1 A2)=>u [/= H1 H2]; rewrite X joinCA joinA in H1; exists u.
- move: (varP Y X)=>-> /(IH _ _ A1 (wf_vfree n A2)) [u][H1 H2].
  by exists (x \+ u); rewrite -joinA !(pull x); split=>//; apply: domeqUn.
by case/(IH _ _ A1 A2)=>u [/= H1 H2]; rewrite X joinCA joinA in H1; exists u.
Qed.

End Subtract.

(* invalid is a purely functional test of invalidX *)

Section Invalid.
Variables (K : ordType) (C : pred K) (T : Type) (U : union_map_class C T).
Implicit Types (i : ctx U) (t : term T) (ts : seq (term T)).

Definition undefx i t :=
  if t is Var n then
    if onth (varx i) n is Some x then undefb x else false
  else false.

Definition isundef i ts := ~~ uniq (getkeys ts) || has (undefx i) ts.

Lemma isundef_sound i ts :
        all (wf i) ts -> isundef i ts -> ~~ valid (interp i ts).
Proof.
elim: ts=>[|t ts IH] //= /andP [W A].
case: t W=>[n v|n] /= /size_onth [k] X; rewrite /isundef /= X; last first.
- rewrite orbCA=>H; case: validUn=>// V; rewrite (negbTE (IH A _)) //.
  by case/orP: H V=>// /undefbE ->; rewrite valid_undef.
rewrite negb_and negbK has_getkeys -orbA /=.
case/orP=>// V; last by rewrite validPtUn andbCA (negbTE (IH A _)).
by case: (keyP V X)=>u ->; rewrite joinA pts_undef2 undef_join valid_undef.
Qed.

End Invalid.

(********************************)
(********************************)
(* Canonical structure programs *)
(********************************)
(********************************)

(* We syntactify a unionmap into a seq term as follows.                         *)
(*                                                                              *)
(* - if the map is f1 \+ f2, then recurse over both and concatenate the results *)
(* - if the map is the empty map, return [::]                                   *)
(* - if the map is k \-> v then add k to the context, and return [Pts x v],     *)
(*      where x is the index for l in the context                               *)
(*  if the map is whatever else, add the map to the context and return          *)
(*      [Var n], where n is the index for the map in the context                *)

Module Syntactify.
Section Syntactify.
Variables (K : ordType) (C : pred K) (T : Type) (U : union_map_class C T).
Implicit Types (i : ctx U) (ts : seq (term T)).

(* a tagging structure to control the flow of computation *)
Structure tagged_map := Tag {untag : U}.

Local Coercion untag : tagged_map >-> UMC.sort.

(* in reversed order; first test for unions, then empty, pts and vars *)
Definition var_tag := Tag.
Definition key_tag := var_tag.
Definition empty_tag := key_tag.
Canonical Structure union_tag hc := empty_tag hc.

(* Main structure                                    *)
(* - i : input context                               *)
(* - j : output context                              *)
(* - ts : syntactification of map_of using context j *)

Definition axiom i j ts (pivot : tagged_map) :=
  [/\ interp j ts = pivot :> U, sub_ctx i j & all (wf j) ts].
Structure form i j ts := Form {pivot : tagged_map; _ : axiom i j ts pivot}.

Local Coercion pivot : form >-> tagged_map.

(* check for union *)

Lemma union_pf i j k ts1 ts2 (f1 : form i j ts1) (f2 : form j k ts2) :
        axiom i k (ts1 ++ ts2) (union_tag (untag f1 \+ untag f2)).
Proof.
case: f1 f2=>_ [<- S1 W1][_][<- S2 W2]; split.
- by rewrite /interp foldr_cat fE joinC -(sc_interp S2 W1).
- by apply: sc_trans S1 S2.
by rewrite all_cat (sc_wf S2 W1) W2.
Qed.

Canonical union_form i j k ts1 ts2 f1 f2 :=
  Form (@union_pf i j k ts1 ts2 f1 f2).

(* check if reached empty *)

Lemma empty_pf i : axiom i i [::] (empty_tag Unit).
Proof. by []. Qed.

Canonical empty_form i := Form (@empty_pf i).

(* check for pts k v *)

Lemma pts_pf vars keys1 keys2 k v (f : xfind keys1 keys2 k):
        axiom (Context keys1 vars) (Context keys2 vars)
              [:: Pts k v] (key_tag (pts (xuntag f) v)).
Proof. by case: f=>p [E H]; split=>//=; rewrite ?E ?unitR // (onth_size E). Qed.

Canonical pts_form vars keys1 keys2 k v f :=
  Form (@pts_pf vars keys1 keys2 k v f).

(* check for var *)

Lemma var_pf keys vars1 vars2 n (f : xfind vars1 vars2 n) :
        axiom (Context keys vars1) (Context keys vars2)
              [:: Var T n] (var_tag (xuntag f)).
Proof. by case: f=>p [E H]; split=>//=; rewrite ?E ?unitR // (onth_size E). Qed.

Canonical var_form keys vars1 vars2 v f := Form (@var_pf keys vars1 vars2 v f).

End Syntactify.

Module Exports.
Coercion untag : tagged_map >-> UMC.sort.
Coercion pivot : form >-> tagged_map.
Canonical union_tag.
Canonical union_form.
Canonical empty_form.
Canonical pts_form.
Canonical var_form.
End Exports.
End Syntactify.

Export Syntactify.Exports.

(*********************)
(* Automating validX *)
(*********************)

(* validX is a refined lemma for subterm checking which *)
(* automatically discharges the spurious argument from above *)

Module ValidX.
Section ValidX.
Variables (K : ordType) (C : pred K) (T : Type) (U : union_map_class C T).
Implicit Types (j : ctx U) (ts : seq (term T)).
Notation form := Syntactify.form.
Notation untag := Syntactify.untag.

(* The rform structure has two important components:                      *)
(*                                                                        *)
(* -- a packed/hoisted map m, which will be reified into the ts2 argument *)
(*    of subterm ts2 ts1                                                  *)
(*                                                                        *)
(* -- a boolean b, which will be instantiated with true in the validX     *)
(*    lemma, and will be unified with subterm ts2 ts1 in the start        *)
(*    instance                                                            *)
(*                                                                        *)
(* The other components of rform are j ts1 and pivot, which are forced by *)
(* needing to compose the proofs, but behave plainly in unification.      *)

Structure packed_map (m : U) := Pack {unpack : U}.
Canonical equate (m : U) := Pack m m.

Definition raxiom j ts1 m (b : bool) (pivot : packed_map m) :=
  all (wf j) ts1 -> valid (interp j ts1) -> b -> valid (unpack pivot).

Structure rform j ts1 m b :=
  RForm {pivot :> packed_map m; _ : raxiom j ts1 b pivot}.

(* start instance: note how subterm ts2 ts1 is unified with *)
(* the boolean component of rform *)

Lemma start_pf j k ts1 ts2 (f2 : form j k ts2) :
        @raxiom j ts1 (untag f2) (subterm ts2 ts1) (equate f2).
Proof.
case: f2=>f2 [<- S A2] A1; rewrite (sc_interp S A1)=>V.
case/(subterm_sound A2 (sc_wf S A1))=>xs.
by case/domeqP; rewrite V=>/validL ->.
Qed.

Canonical start j k ts1 ts2 f2 := RForm (@start_pf j k ts1 ts2 f2).

End ValidX.

(* Wrappers for automated versions of joinKx(xK), cancPL(PR) lemmas *)
Section WrappersForCancellationLemmas.
Variable U : cpcm.

Lemma joinKx' (x1 x2 x : U) : x1 \+ x = x2 \+ x -> valid (x1 \+ x) -> x1 = x2.
Proof. by move=>/[swap]; exact: joinKx. Qed.

Lemma joinxK' (x x1 x2 : U) : x \+ x1 = x \+ x2 -> valid (x \+ x1) -> x1 = x2.
Proof. by move=>/[swap]; exact: joinxK. Qed.

Lemma cancPL' (P : U -> Prop) (s1 s2 t1 t2 : U) :
       precise P -> s1 \+ t1 = s2 \+ t2 -> P s1 -> P s2 -> valid (s1 \+ t1) ->
       (s1 = s2) * (t1 = t2).
Proof. by move=>H E H1 H2 V; apply: cancPL H V H1 H2 E. Qed.

Lemma cancPR' (P : U -> Prop) (s1 s2 t1 t2 : U) :
       precise P -> s1 \+ t1 = s2 \+ t2 -> P t1 -> P t2 -> valid (s1 \+ t1) ->
       (s1 = s2) * (t1 = t2).
Proof. by move=>H E H1 H2 V; apply: cancPR H V H1 H2 E. Qed.
End WrappersForCancellationLemmas.

Module Exports.
Canonical equate.
Canonical start.

Section Exports.
Variables (K : ordType) (C : pred K) (T : Type) (U : union_map_class C T).
Implicit Types (j : ctx U) (ts : seq (term T)).
Notation form := Syntactify.form.
Notation untag := Syntactify.untag.

(* the main lemma; note how the boolean component of rform is set to true *)

Lemma validX m j ts1 (f1 : form (empx U) j ts1) (g: rform j ts1 m true) :
        valid (untag f1) -> valid (unpack (pivot g)).
Proof. by case: g f1; case=>pivot H [f1][<- Sc A] /(H A); apply. Qed.

End Exports.

Arguments validX [K C T U m j ts1 f1 g] _.

Example ex0 (x y z : nat) (v1 v2 : nat) h:
          valid (Unit \+ y \\-> v1 \+ h \+ x \\-> v1) ->
          valid (x \\-> v2 \+ Unit).
Proof. apply: validX. Abort.

(* Automated versions of joinKx(xK), cancPL(PR) lemmas *)
Notation joinKX V E := (joinKx' E (validX V)).
Notation joinXK V E := (joinxK' E (validX V)).
Notation cancPLX pf V H1 H2 E := (cancPL' pf E H1 H2 (validX V)).
Notation cancPRX pf V H1 H2 E := (cancPR' pf E H1 H2 (validX V)).

End Exports.
End ValidX.

Export ValidX.Exports.

(*********************)
(* Automating domeqX *)
(*********************)

Module DomeqX.
Section DomeqX.
Variables (K : ordType) (C : pred K) (T : Type) (U : union_map_class C T).
Implicit Types (j : ctx U) (ts : seq (term T)).
Notation form := Syntactify.form.
Notation untag := Syntactify.untag.

Structure packed_map (m : U) := Pack {unpack : U}.
Canonical equate (m : U) := Pack m m.

(* b is the pair of residual terms *)
Definition raxiom j k ts1 m b (pivot : packed_map m) :=
  all (wf j) ts1 -> sub_ctx j k /\
  (dom_eq (interp k b.1) (interp k b.2) ->
   dom_eq (interp k ts1) (unpack pivot)).

Structure rform j k ts1 m b :=
  RForm {pivot :> packed_map m; _ : raxiom j k ts1 b pivot}.

(* start instance: note how subtract ts1 ts2 [::] is unified with *)
(* the b component of rform thus passing the residual terms *)

Lemma start_pf j k ts1 ts2 (f2 : form j k ts2) :
        @raxiom j k ts1 (untag f2) (subtract ts1 ts2 [::]) (equate f2).
Proof.
case: f2=>f2 [<- S A2]; case E : (subtract _ _ _)=>[rs1 rs2] A1; split=>//.
case/(subtract_sound (sc_wf S A1) A2): E=>ys [/= D1 D2 D].
rewrite unitR in D1; apply: domeq_trans D1 _.
rewrite domeq_sym; apply: domeq_trans D2 _.
by rewrite domeq_sym; apply: domeqUn.
Qed.

Canonical start j k ts1 ts2 f2 := RForm (@start_pf j k ts1 ts2 f2).

End DomeqX.

Module Exports.
Canonical equate.
Canonical start.

Section Exports.
Variables (K : ordType) (C : pred K) (T : Type) (U : union_map_class C T).
Implicit Types (j : ctx U) (ts : seq (term T)).
Notation form := Syntactify.form.
Notation untag := Syntactify.untag.

(* the main lemma; notice how residuals rs1, rs2 are passed to g to compute *)

Lemma domeqX m j k rs1 rs2 ts1 (f1 : form (empx U) j ts1)
                               (g : rform j k ts1 m (rs1, rs2)) :
        dom_eq (pprint k (rev rs1)) (pprint k rs2) ->
        dom_eq (untag f1) (unpack (pivot g)).
Proof.
case: g f1; case=>pivot R [f1][<- _ A1] /=; case/(_ A1): R=>S D.
by rewrite !pp_interp interp_rev (sc_interp S A1).
Qed.

End Exports.

Arguments domeqX [K C T U m j k rs1 rs2 ts1 f1 g] _.

Example ex0 (x y z : nat) (v1 v2 : nat) h:
          dom_eq (Unit \+ y \\-> v1 \+ h \+ x \\-> v1) (x \\-> v2 \+ Unit).
Proof. apply: domeqX=>/=. Abort.

End Exports.
End DomeqX.

Export DomeqX.Exports.

(***********************)
(* Automating invalidX *)
(***********************)

Module InvalidX.
Section InvalidX.
Variables (K : ordType) (C : pred K) (T : Type) (U : union_map_class C T).
Implicit Types (i : ctx U) (ts : seq (term T)).
Notation form := Syntactify.form.
Notation untag := Syntactify.untag.

Structure packed_map (m : U) := Pack {unpack : U}.
Canonical equate (m : U) := Pack m m.

(* b is the boolean that we want to get out of isundef *)
Definition raxiom i ts m b (pivot : packed_map m) :=
  b -> valid (unpack pivot) = false.

Structure rform i ts m b :=
  RForm {pivot :> packed_map m; _ : raxiom i ts b pivot}.

(* start instance: note how isundef i ts is unified with *)
(* the b component of rform, which will be set to true by lemma statements *)

Lemma start_pf i ts (f : form (empx U) i ts) :
        @raxiom i ts (untag f) (isundef i ts) (equate f).
Proof. by case: f=>f [<- S A] /(isundef_sound A) /negbTE. Qed.

Canonical start i ts f := RForm (@start_pf i ts f).

End InvalidX.

Module Exports.
Canonical equate.
Canonical start.

Section Exports.
Variables (K : ordType) (C : pred K) (T : Type) (U : union_map_class C T).
Implicit Types (i : ctx U) (ts : seq (term T)).
Notation form := Syntactify.form.
Notation untag := Syntactify.untag.

(* the main lemmas *)

Lemma undefX m i ts (g : rform i ts m true) : unpack (pivot g) = undef.
Proof. by case: g; case=>pivot /= /(_ (erefl _))/negbT/invalidE. Qed.

Lemma invalidX m i ts (g : rform i ts m true) :
        valid (unpack (pivot g)) = false.
Proof. by rewrite undefX valid_undef. Qed.

End Exports.

Arguments invalidX {K C T U m i ts g}.

Example ex0 (x y z : nat) (v1 v2 : nat) h:
          valid (Unit \+ y \\-> v1 \+ h \+ y \\-> v1).
Proof. rewrite invalidX. Abort.

End Exports.
End InvalidX.

Export InvalidX.Exports.

(************************************************)
(* Pushing an omap-like function inside a union *)
(************************************************)

Module OmfX.
Section OmfX.

Inductive syntx (A : Type) :=
  | UnitOmf
  | PtOmf of stamp & A
  | UnOmf of syntx A & syntx A
  | OtherOmf of natmap A.

Fixpoint omf_interp A B (f : omap_fun (nat_mapUMC A) (nat_mapUMC B)) e : natmap B :=
  match e with
    UnitOmf => Unit
  | PtOmf k v => if map_fun f (k, v) is Some w then pts k w else Unit
  | UnOmf h1 h2 => omf_interp f h1 \+ omf_interp f h2
  | OtherOmf h => f h
  end.

Structure tagged_natmap A := Tag {untag : natmap A}.
Definition unit_tag := Tag.
Definition pt_tag := unit_tag.
Definition union_tag := pt_tag.
Definition recurse_unguard_tag := union_tag.
Canonical recurse_guard_tag A f := @recurse_unguard_tag A f.

Definition guard_ax A B ts e (f : omap_fun (nat_mapUMC A) (nat_mapUMC B)) :=
  untag e = f (omf_interp id_omap_fun ts).

Structure guarded_form A B ts := GForm {
  gpivot :> tagged_natmap B;
  guard_of : omap_fun (nat_mapUMC A) (nat_mapUMC B);
  _ : guard_ax ts gpivot guard_of}.

Definition unguard_ax A (ts : syntx A) e :=
  untag e = omf_interp id_omap_fun ts.

Structure unguarded_form A (ts : syntx A) := UForm {
  upivot :> tagged_natmap A;
  _ : unguard_ax ts upivot}.

(* we first try to see if there's more function guards *)
Lemma recurse_guard_pf A B C ts (f : omap_fun (nat_mapUMC B) (nat_mapUMC C))
                       (g : @guarded_form A B ts) :
        guard_ax ts (recurse_guard_tag (f (untag g)))
                    (comp_omap_fun (guard_of g) f).
Proof. by case: g=>e g pf /=; rewrite pf. Qed.
Canonical recurse_guard A B C ts f g := GForm (@recurse_guard_pf A B C ts f g).

(* if not, we descend to unguarded form to syntactify the underlying expression *)
Lemma recurse_unguard_pf A ts (u : @unguarded_form A ts) :
        guard_ax ts (recurse_unguard_tag (untag u)) id_omap_fun.
Proof. by case: u. Qed.
Canonical recurse_unguard A ts u := GForm (@recurse_unguard_pf A ts u).

(* syntactifying union recursively descends to both sides *)
Lemma unguard_union_pf A ts1 ts2 (u1 : @unguarded_form A ts1) (u2 : @unguarded_form A ts2) :
        unguard_ax (UnOmf ts1 ts2) (union_tag (untag u1 \+ untag u2)).
Proof. by case: u1 u2=>u1 pf1 [u2 pf2]; rewrite /= pf1 pf2. Qed.
Canonical unguard_union A ts1 ts2 u1 u2 := UForm (@unguard_union_pf A ts1 ts2 u1 u2).

(* base case for syntactifying points-to *)
Lemma unguard_pts_pf A k (v : A) : unguard_ax (PtOmf k v) (pt_tag (pts k v)).
Proof. by []. Qed.
Canonical unguard_pts A k v := UForm (@unguard_pts_pf A k v).

(* base case for syntactifying empty map Unit *)
Lemma unguard_unit_pf A : unguard_ax (UnitOmf A) (unit_tag Unit).
Proof. by []. Qed.
Canonical unguard_unit A := UForm (@unguard_unit_pf A).

(* base case for syntactifying all other expressions *)
Lemma unguard_other_pf A (e : natmap A) : unguard_ax (OtherOmf e) (Tag e).
Proof. by []. Qed.
Canonical unguard_other A e := UForm (@unguard_other_pf A e).

End OmfX.

Module Exports.
Canonical recurse_guard_tag.
Canonical recurse_guard.
Canonical recurse_unguard.
Canonical unguard_union.
Canonical unguard_pts.
Canonical unguard_unit.
Canonical unguard_other.

(* main lemma *)

Lemma omfX A B C ts (f : omap_fun (nat_mapUMC B) (nat_mapUMC C))
                    (g : @guarded_form A B ts) :
        valid (omf_interp id_omap_fun ts) ->
        f (untag g) =
        omf_interp (comp_omap_fun (guard_of g) f) ts.
Proof.
case: g=>eq g /=; elim: ts eq=>[|s a|ts1 IH1 ts2 IH2|t] /= eq pf V.
- by rewrite pf !omf_unit.
- rewrite validPt in V; rewrite pf omfPt // /obind /oapp /=.
  by case: (OmapFun.mfunc _ _)=>[x|] //; rewrite ?omfPt ?omf_unit.
- rewrite pf /= !omfUn //; last by rewrite -omfUn ?valid_omf.
  by rewrite IH1 ?(validL V) // IH2 ?(validR V).
by rewrite pf.
Qed.
End Exports.
End OmfX.

Export OmfX.Exports.


Require Import DbLib.DeBruijn.
Require Import DbLib.DblibTactics.
Require Export Linear.Basics.

Inductive ty : Set :=
  | TyUnit
  | TyPrim : String.string -> ty
  | TyFun : ty -> ty -> ty
.

Hint Constructors ty : linear.

(* Terms, or 'expressions' *)
Inductive term : Set :=
  | TUnit
  | TPrim : String.string -> term
  | TVar : nat -> term
  | TAbs : ty -> term -> term
  | TApp : term -> term -> term
.

Hint Constructors term : linear.

Inductive value : term -> Prop :=
  | VUnit : value TUnit
  | VPrim : forall s, value (TPrim s)
  | VVar : forall x, value (TVar x)
  | VAbs : forall t e, value (TAbs t e)
.

Hint Constructors value : linear.

(* Substitution via DbLib *)

Instance Var_term : Var term := {
  var := TVar
}.

(* Traverse the variable/value structure of a term.
   We also need a similar function for location traversal and substituion. *)
Fixpoint traverse_term (f : nat -> nat -> term) l t :=
  match t with
  | TVar x =>
      f l x
  | TAbs t e =>
      TAbs t (traverse_term f (1 + l) e)
  | TApp e1 e2 =>
      TApp (traverse_term f l e1) (traverse_term f l e2)
  | _ => t
  end.

Instance Traverse_term : Traverse term term := {
  traverse := traverse_term
}.

Instance TraverseVarInjective_term : @TraverseVarInjective term _ term _.
Proof.
  constructor. prove_traverse_var_injective.
Qed.

Instance TraverseFunctorial_term : @TraverseFunctorial term _ term _.
Proof.
  constructor. prove_traverse_functorial.
Qed.

Instance TraverseRelative_term : @TraverseRelative term term _.
Proof.
  constructor. prove_traverse_relative.
Qed.

Instance TraverseIdentifiesVar_term : @TraverseIdentifiesVar term _ _.
Proof.
  constructor. prove_traverse_identifies_var.
Qed.

Instance TraverseVarIsIdentity_term : @TraverseVarIsIdentity term _ term _.
Proof.
  constructor. prove_traverse_var_is_identity.
Qed.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  An attempt at a variable module in a context.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.
Require Import Coq.Bool.Bool.

Require Export BoolEqualitySigDef.

Add LoadPath "/home/milnes/Desktop/Research/Cyclone/CycloneCoq/3".
Require Export CpdtTactics.
Require Export Case.
Require Export TacticNotations.
Require Export NatLemmas.

Module PhiModule <: BoolEqualitySig.

Inductive Phi : Type :=
 | witnesschanges  : Phi                            (* Allowing witness changes. \delta *)
 | aliases        : Phi.                             (* Allowing aliases as the opened type. \amp *)

Definition T := Phi.

Function beq_phi (p p' : Phi) : bool :=
  match p, p' with
    | witnesschanges, witnesschanges => true
    | aliases, aliases => true
    | _, _ => false
  end.

Definition beq_t := beq_phi.

Lemma beq_phi_refl:
  forall (k : Phi),
    beq_phi k k = true.
Proof.
  destruct k.
  reflexivity.
  reflexivity.
Qed.
Hint Resolve beq_phi_refl.
Definition beq_t_refl := beq_phi_refl.

Lemma beq_phi_sym : forall x y : Phi, beq_phi x y = beq_phi y x.
Proof.
  intros.
  destruct x;  destruct y; crush.
Qed.
Hint Immediate beq_phi_sym.
Definition beq_t_sym := beq_phi_sym.

Lemma beq_phi_trans :
  forall x y z,
    beq_phi x y = true -> beq_phi y z = true -> beq_phi x z = true.
Proof.
   destruct x; destruct y; destruct z; crush.
Qed.
Hint Resolve beq_phi_trans.
Definition beq_t_trans := beq_phi_trans.

Lemma beq_phi_eq:
  forall (k k': Phi),
    beq_phi k k' = true ->
    k = k'.
Proof.
  intros.
  destruct k; destruct k'.
  reflexivity.
  inversion H.
  inversion H.
  reflexivity.
Qed.
Hint Resolve beq_phi_eq.
Definition beq_t_eq := beq_phi_eq.

Lemma beq_phi_neq:
  forall (k k': Phi),
    beq_phi k k' = false ->
    k <> k'.
Proof.
  intros.
  destruct k; destruct k'.
  inversion H.
  discriminate.
  discriminate.
  inversion H.
Qed.
Hint Resolve beq_phi_neq.
Definition beq_t_neq := beq_phi_neq.

End PhiModule.


Let test_stack_unification_interaction_with_delta A
  : (if negb _ then true else false) = if orb false (negb A) then true else false
  := eq_refl.

(* Test patterns unification *)

Lemma l1 : (forall P, (exists x:nat, P x) -> False)
         -> forall P, (exists x:nat, P x /\ P x) -> False.
Proof.
intros; apply (H _ H0).
Qed.

Lemma l2 :  forall A:Set, forall Q:A->Set,
           (forall (P: forall x:A, Q x -> Prop),
                   (exists x:A, exists y:Q x, P x y) -> False)
         -> forall (P: forall x:A, Q x -> Prop),
                   (exists x:A, exists y:Q x, P x y /\ P x y) -> False.
Proof.
intros; apply (H _ H0).
Qed.

Lemma l3 : (forall P, ~(exists x:nat, P x))
         -> forall P:nat->Prop, ~(exists x:nat, P x -> P x).
Proof.
intros; apply H.
Qed.

  (* Feature introduced June 2011 *)

Lemma l7 : forall x (P:nat->Prop), (forall f, P (f x)) -> P (x+x).
Proof.
intros x P H; apply H.
Qed.

(* Example submitted for Zenon *)

Axiom zenon_noteq : forall T : Type, forall t : T, ((t <> t) -> False).
Axiom zenon_notall : forall T : Type, forall P : T -> Prop,
  (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False).

  (* Must infer "P := fun x => x=x" in zenon_notall *)
Check (fun _h1 => (zenon_notall nat _ (fun _T_0 =>
          (fun _h2 => (zenon_noteq _ _T_0 _h2))) _h1)).

(* Core of an example submitted by Ralph Matthes (BZ#849)

   It used to fail because of the K-variable x in the type of "sum_rec ..."
   which was not in the scope of the evar ?B. Solved by a head
   beta-reduction of the type "(fun _ : unit + unit => L unit) x" of
   "sum_rec ...". Shall we used more reduction when solving evars (in
   real_clean)?? Is there a risk of starting too long reductions?

   Note that the example originally came from a non re-typable
   pretty-printed term (the checked term is actually re-printed the
   same form it is checked).
*)

Set Implicit Arguments.
Inductive L (A:Set) : Set := c : A -> L A.
Parameter f: forall (A:Set)(B:Set), (A->B) -> L A -> L B.
Parameter t: L (unit + unit).

Check (f (fun x : unit + unit =>
  sum_rec (fun _ : unit + unit => L unit)
    (fun y => c y) (fun y => c y) x) t).

(* Test patterns unification in apply *)

Require Import Arith.
Parameter x y : nat.
Parameter G:x=y->x=y->Prop.
Parameter K:x<>y->x<>y->Prop.
Lemma l4 : (forall f:x=y->Prop, forall g:x<>y->Prop,
            match eq_nat_dec x y with left a => f a | right a => g a end)
   -> match eq_nat_dec x y with left a => G a a | right a => K a a end.
Proof.
intros.
apply H.
Qed.

(* Test unification modulo eta-expansion (if possible) *)

(* In this example, two instances for ?P (argument of hypothesis H) can be
   inferred (one is by unifying the type [Q true] and [?P true] of the
   goal and type of [H]; the other is by unifying the argument of [f]);
   we need to unify both instances up to allowed eta-expansions of the
   instances (eta is allowed if the meta was applied to arguments)

   This used to fail before revision 9389 in trunk
*)

Lemma l5 :
   forall f : (forall P, P true), (forall P, f P = f P) ->
   forall Q, f (fun x => Q x) = f (fun x => Q x).
Proof.
intros.
apply H.
Qed.

(* Feature deactivated in commit 14189 (see commit log)
(* Test instantiation of evars by unification *)

Goal (forall x, 0 + x = 0 -> True) -> True.
intros; eapply H.
rewrite <- plus_n_Sm. (* should refine ?x with S ?x' *)
Abort.
*)

(* Check handling of identity equation between evars *)
(* The example failed to pass until revision 10623 *)

Lemma l6 :
  (forall y, (forall x, (forall z, y = 0 -> y + z = 0) -> y + x = 0) -> True)
  -> True.
intros.
eapply H.
intros.
apply H0. (* Check that equation ?n[H] = ?n[H] is correctly considered true *)
reflexivity.
Qed.

(* Check treatment of metas erased by K-redexes at the time of turning
   them to evas *)

Inductive nonemptyT (t : Type) : Prop := nonemptyT_intro : t -> nonemptyT t.
Goal True.
try case nonemptyT_intro. (* check that it fails w/o anomaly *)
Abort.

(* Test handling of return type and when it is decided to make the
   predicate dependent or not - see "bug" BZ#1851 *)

Goal forall X (a:X) (f':nat -> X), (exists f : nat -> X, True).
intros.
exists (fun n => match n with O => a | S n' => f' n' end).
constructor.
Qed.

(* Check use of types in unification (see Andrej Bauer's mail on
   coq-club, June 1 2009; it did not work in 8.2, probably started to
   work after Sozeau improved support for the use of types in unification) *)

Goal (forall (A B : Set) (f : A -> B), (fun x => f x) = f) ->
 forall (A B C : Set) (g : (A -> B) -> C) (f : A -> B), g (fun x => f x) = g f.
Proof.
  intros.
  rewrite H with (f:=f0).
Abort.

(* Three tests provided by Dan Grayson as part of a custom patch he
   made for a more powerful "destruct" for handling Voevodsky's
   Univalent Foundations. The test checks if second-order matching in
   tactic unification is able to guess by itself on which dependent
   terms to abstract so that the elimination predicate is well-typed *)

Definition test1 (X : Type) (x : X) (fxe : forall x1 : X, identity x1 x1) :
  identity (fxe x) (fxe x).
Proof. destruct (fxe x). apply identity_refl. Defined.

(* a harder example *)

Definition UU := Type .
Inductive paths {T:Type}(t:T): T -> UU := idpath: paths t t.
Inductive foo (X0:UU) (x0:X0) : forall (X:UU)(x:X), UU := newfoo : foo x0 x0.
Definition idonfoo {X0:UU} {x0:X0} {X1:UU} {x1:X1} : foo x0 x1 -> foo x0 x1.
Proof. intros t. exact t. Defined.

Lemma test2 (T:UU) (t:T) (k : foo t t) : paths k (idonfoo k).
Proof.
  destruct k.
  apply idpath.
Defined.

(* an example with two constructors *)

Inductive foo' (X0:UU) (x0:X0) : forall (X:UU)(x:X), UU :=
| newfoo1 : foo' x0 x0
| newfoo2 : foo' x0 x0 .
Definition idonfoo' {X0:UU} {x0:X0} {X1:UU} {x1:X1} :
  foo' x0 x1 -> foo' x0 x1.
Proof. intros t. exact t. Defined.
Lemma test3 (T:UU) (t:T) (k : foo' t t) : paths k (idonfoo' k).
Proof.
  destruct k.
  apply idpath.
  apply idpath.
Defined.

(* An example where it is necessary to evar-normalize the instance of
   an evar to evaluate if it is a pattern *)

Check
  let a := ?[P] in
  fun (H : forall y (P : nat -> Prop), y = 0 -> P y)
      x (p:x=0) =>
    H ?[y] a p : x = 0.
(* We have to solve "?P ?y[x] == x = 0" knowing from
   "p : (x=0) == (?y[x] = 0)" that "?y := x" *)