(* ** Translation from ZF over Skolem signature *)

Require Import Undecidability.FOL.Syntax.Facts.
Require Import Undecidability.FOL.Semantics.Tarski.FullFacts.
From Undecidability.FOL.Sets Require Import minZF ZF.
Require Import Undecidability.FOL.Sets.ZF.
Require Import Undecidability.FOL.Undecidability.Reductions.PCPb_to_ZF.
From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.
Local Set Implicit Arguments.
Local Unset Strict Implicit.

Set Default Proof Using "Type".

Local Notation vec := Vector.t.

Local Hint Constructors prv : core.

(* ** Trivial embedding into rich signature *)

#[local] Notation term' := (term sig_empty).
#[local] Notation form' := (form sig_empty _ _ falsity_on).

Definition embed_t (t : term') : term :=
  match t with
  | $x => $x
  | func f ts => False_rect term f
  end.

Fixpoint embed {ff'} (phi : form sig_empty ZF_pred_sig _ ff') : form ff' :=
  match phi with
  | atom P ts => atom P (Vector.map embed_t ts)
  | bin b phi psi => bin b (embed phi) (embed psi)
  | quant q phi => quant q (embed phi)
  | ⊥ => ⊥
  end.

(* ** Translation function *)

Definition sshift {Σ_funcs : funcs_signature} k : nat -> term :=
  fun n => match n with 0 => $0 | S n => $(1 + k + n) end.

Fixpoint rm_const_tm (t : term) : form' :=
  match t with
  | var n => $0 ≡' var (S n)
  | func eset _ => is_eset $0
  | func pair v => let v' := Vector.map rm_const_tm v in
                  ∃ (Vector.hd v')[sshift 1]
                  ∧ ∃ (Vector.hd (Vector.tl v'))[sshift 2]
                  ∧ is_pair $1 $0 $2
                    | func union v => ∃ (Vector.hd (Vector.map rm_const_tm v))[sshift 1] ∧ is_union $0 $1
  | func power v => ∃ (Vector.hd (Vector.map rm_const_tm v))[sshift 1] ∧ is_power $0 $1
  | func omega v => is_om $0
  end.

Fixpoint rm_const_fm {ff : falsity_flag} (phi : form) : form' :=
  match phi with
  | ⊥ => ⊥
  | bin bop phi psi => bin sig_empty _ bop (rm_const_fm phi) (rm_const_fm psi)
  | quant qop phi => quant qop (rm_const_fm phi)
  | atom elem v => let v' := Vector.map rm_const_tm v in
                  ∃ (Vector.hd v') ∧ ∃ (Vector.hd (Vector.tl v'))[sshift 1] ∧ $1 ∈'$0
  | atom equal v => let v' := Vector.map rm_const_tm v in
                  ∃ (Vector.hd v') ∧ ∃ (Vector.hd (Vector.tl v'))[sshift 1] ∧ $1 ≡' $0
  end.

Definition minsolvable S :=
  rm_const_fm (solvable S).

(* ** Vector inversion lemmas *)

Lemma vec_nil_eq X (v : vec X 0) :
  v = Vector.nil.
Proof.
  revert v. now apply Vector.case0.
Qed.

Lemma map_hd X Y n (f : X -> Y) (v : vec X (S n)) :
  Vector.hd (Vector.map f v) = f (Vector.hd v).
Proof.
  now apply (Vector.caseS' v).
Qed.

Lemma map_tl X Y n (f : X -> Y) (v : vec X (S n)) :
  Vector.tl (Vector.map f v) = Vector.map f (Vector.tl v).
Proof.
  now apply (Vector.caseS' v).
Qed.

Lemma in_hd X n (v : vec X (S n)) :
  Vector.In (Vector.hd v) v.
Proof.
  apply (Vector.caseS' v).
  intros. constructor.
Qed.

Lemma in_hd_tl X n (v : vec X (S (S n))) :
  Vector.In (Vector.hd (Vector.tl v)) v.
Proof.
  apply (Vector.caseS' v). intros ? w.
  apply (Vector.caseS' w).
  constructor. constructor.
Qed.

Lemma vec_inv1 X (v : vec X 1) :
  v = Vector.cons (Vector.hd v) Vector.nil.
Proof.
  apply (Vector.caseS' v). intros ?.
  now apply Vector.case0.
Qed.

Lemma vec_inv2 X (v : vec X 2) :
  v = Vector.cons (Vector.hd v) (Vector.cons (Vector.hd (Vector.tl v)) Vector.nil).
Proof.
  apply (Vector.caseS' v). intros x w.
  apply (Vector.caseS' w). intros ?.
  now apply Vector.case0.
Qed.

(* ** Semantics *)

Section Model.

  Open Scope sem.

  Context {V : Type} {I : interp V}.

  Hypothesis M_ZF : forall rho, rho ⊫ ZF'.
  Hypothesis VIEQ : extensional I.

  Instance min_model : interp sig_empty _ V.
  Proof using I.
    split.
    - intros [].
    - now apply i_atom.
  Defined.

  Lemma min_embed_eval (rho : nat -> V) (t : term') :
    eval rho (embed_t t) = eval rho t.
  Proof.
    destruct t as [|[]]. reflexivity.
  Qed.

  Lemma min_embed (rho : nat -> V) (phi : form')  :
    sat I rho (embed phi) <-> sat min_model rho phi.
  Proof.
    induction phi in rho |- *; try destruct b0; try destruct q; cbn.
    1,3-7: firstorder. erewrite Vector.map_map, Vector.map_ext.
    reflexivity. apply min_embed_eval.
  Qed.

  Lemma embed_subst_t (sigma : nat -> term') (t : term') :
    embed_t t`[sigma] = (embed_t t)`[sigma >> embed_t].
  Proof.
    induction t; cbn; trivial. destruct F.
  Qed.

  Lemma embed_subst (sigma : nat -> term') (phi : form') :
    embed phi[sigma] = (embed phi)[sigma >> embed_t].
  Proof.
    induction phi in sigma |- *; cbn; trivial.
    - f_equal. erewrite !Vector.map_map, Vector.map_ext. reflexivity. apply embed_subst_t.
    - firstorder congruence.
    - rewrite IHphi. f_equal. apply subst_ext. intros []; cbn; trivial.
      unfold funcomp. cbn. unfold funcomp. now destruct (sigma n) as [x|[]].
  Qed.

  Lemma embed_sshift n (phi : form') :
    embed phi[sshift n] = (embed phi)[sshift n].
  Proof.
    rewrite embed_subst. apply subst_ext. now intros [].
  Qed.

  Lemma sat_sshift1 (rho : nat -> V) x y (phi : form') :
    (y .: x .: rho) ⊨ phi[sshift 1] <-> (y .: rho) ⊨ phi.
  Proof.
    erewrite sat_comp, sat_ext. reflexivity. now intros [].
  Qed.

  Lemma sat_sshift2 (rho : nat -> V) x y z (phi : form') :
    (z .: y .: x .: rho) ⊨ phi[sshift 2] <-> (z .: rho) ⊨ phi.
  Proof.
    erewrite sat_comp, sat_ext. reflexivity. now intros [].
  Qed.

  Lemma inductive_sat (rho : nat -> V) x :
    (x .: rho) ⊨ is_inductive $0 -> M_inductive x.
  Proof using VIEQ M_ZF.
    cbn. setoid_rewrite VIEQ. split.
    - destruct H as [[y Hy] _]. enough (∅ = y) as -> by apply Hy.
      apply M_ext; trivial; intros z Hz; exfalso.
      + now apply M_eset in Hz.
      + firstorder easy.
    - intros y [z Hz] % H. enough (σ y = z) as -> by apply Hz. apply M_ext; trivial.
      + intros a Ha % sigma_el; trivial. now apply Hz.
      + intros a Ha % Hz. now apply sigma_el.
  Qed.

  Lemma inductive_sat_om (rho : nat -> V) :
    (ω .: rho) ⊨ is_inductive $0.
  Proof using VIEQ M_ZF.
    cbn. setoid_rewrite VIEQ. split.
    - exists ∅. split; try apply M_eset; trivial. now apply M_om1.
    - intros d Hd. exists (σ d). split; try now apply M_om1. intros d'. now apply sigma_el.
  Qed.

  Lemma rm_const_tm_sat (rho : nat -> V) (t : term) x :
    (x .: rho) ⊨ rm_const_tm t <-> x = eval rho t.
  Proof using VIEQ M_ZF.
    induction t in x |- *; try destruct F; cbn; split; try intros ->;
    try rewrite (vec_inv1 v); try rewrite (vec_inv2 v); cbn.
    - now rewrite VIEQ.
    - now rewrite VIEQ.
    - rewrite (vec_nil_eq (Vector.map (eval rho) v)).
      intros H. apply M_ext; trivial; intros y Hy; exfalso.
      + firstorder easy.
      + now apply M_eset in Hy.
    - rewrite (vec_nil_eq (Vector.map (eval rho) v)).
      intros d. now apply M_eset.
    - intros (y & Hy & z & Hz & H).
      rewrite sat_sshift1, IH in Hy; try apply in_hd. subst.
      rewrite sat_sshift2, IH in Hz; try apply in_hd_tl. subst.
      apply M_ext; trivial.
      + intros a Ha % H. rewrite !VIEQ in Ha. now apply M_pair.
      + intros a Ha % M_pair; trivial. apply H. now rewrite !VIEQ.
    - exists (eval rho (Vector.hd v)).
      rewrite sat_sshift1, IH; try apply in_hd. split; trivial.
      exists (eval rho (Vector.hd (Vector.tl v))).
      rewrite sat_sshift2, IH; try apply in_hd_tl. split; trivial.
      intros d. rewrite !VIEQ. now apply M_pair.
    - intros (y & Hy & H).
      rewrite sat_sshift1, IH in Hy; try apply in_hd. subst.
      apply M_ext; trivial.
      + intros y Hy % H. now apply M_union.
      + intros y Hy % M_union; trivial. now apply H.
    - exists (eval rho (Vector.hd v)).
      rewrite sat_sshift1, IH; try apply in_hd. split; trivial.
      intros d. now apply M_union.
    - intros (y & Hy & H).
      rewrite sat_sshift1, IH in Hy; try apply in_hd. subst.
      apply M_ext; trivial.
      + intros y Hy. now apply M_power, H.
      + intros y Hy. now apply H, M_power.
    - exists (eval rho (Vector.hd v)).
      rewrite sat_sshift1, IH; try apply in_hd. split; trivial.
      intros d. now apply M_power.
    - rewrite (vec_nil_eq (Vector.map (eval rho) v)). intros [H1 H2]. apply M_ext; trivial.
      + apply H2. apply (inductive_sat_om rho).
      + apply M_om2; trivial. apply inductive_sat with rho. apply H1.
    - rewrite (vec_nil_eq (Vector.map (eval rho) v)). split.
      + apply (inductive_sat_om rho).
      + intros d Hd. apply M_om2; trivial. apply inductive_sat with rho. apply Hd.
  Qed.

  Lemma rm_const_sat (rho : nat -> V) (phi : form) :
    rho ⊨ phi <-> rho ⊨ rm_const_fm phi.
  Proof using VIEQ M_ZF.
    induction phi in rho |- *; try destruct P; try destruct b0; try destruct q; cbn.
    1,4-6: firstorder easy.
    - rewrite (vec_inv2 t). cbn. split.
      + intros H. exists (eval rho (Vector.hd t)). rewrite rm_const_tm_sat. split; trivial.
        exists (eval rho (Vector.hd (Vector.tl t))). now rewrite sat_sshift1, rm_const_tm_sat.
      + intros (x & Hx & y & Hy & H). apply rm_const_tm_sat in Hx as <-.
        rewrite sat_sshift1, rm_const_tm_sat in Hy. now subst.
    - rewrite (vec_inv2 t). cbn. split.
      + intros H. exists (eval rho (Vector.hd t)). rewrite rm_const_tm_sat. split; trivial.
        exists (eval rho (Vector.hd (Vector.tl t))). now rewrite sat_sshift1, rm_const_tm_sat.
      + intros (x & Hx & y & Hy & H). apply rm_const_tm_sat in Hx as <-.
        rewrite sat_sshift1, rm_const_tm_sat in Hy. now subst.
    - split; intros; firstorder easy.
    - firstorder eauto.
  Qed.

  Theorem min_correct (rho : nat -> V) (phi : form) :
    sat I rho phi <-> sat min_model rho (rm_const_fm phi).
  Proof using VIEQ M_ZF.
    apply rm_const_sat.
  Qed.

  Lemma min_axioms' (rho : nat -> V) :
    rho ⊫ minZF'.
  Proof using VIEQ M_ZF.
    intros A [<-|[<-|[<-|[<-|[<-|[<-|[]]]]]]]; cbn.
    - apply (@M_ZF rho ax_ext). firstorder.
    - exists ∅. apply (@M_ZF rho ax_eset). firstorder.
    - intros x y. exists ({x; y}). apply (@M_ZF rho ax_pair). firstorder.
    - intros x. exists (⋃ x). apply (@M_ZF rho ax_union). firstorder.
    - intros x. exists (PP x). apply (@M_ZF rho ax_power). firstorder.
    - exists ω. split. split.
      + exists ∅. split. apply (@M_ZF rho ax_eset). firstorder. apply (@M_ZF rho ax_om1). firstorder.
      + intros x Hx. exists (σ x). split. 2: apply (@M_ZF rho ax_om1); firstorder.
        intros y. rewrite !VIEQ. now apply sigma_el.
      + intros x [H1 H2]. apply (@M_ZF rho ax_om2); cbn. auto 8. split.
        * destruct H1 as (e & E1 & E2). enough (∅ = e) as -> by assumption.
          apply M_ext; trivial. all: intros y Hy; exfalso; try now apply E1 in Hy.
          apply (@M_ZF rho ax_eset) in Hy; trivial. unfold ZF'. auto 8.
        * intros d (s & S1 & S2) % H2. enough (σ d = s) as -> by assumption.
          apply M_ext; trivial. all: intros y; rewrite sigma_el; trivial. all: rewrite <- !VIEQ; apply S1.
  Qed.

  Arguments subst_ext {_} {_} {_} {_} _ _ _.

  Lemma min_axioms_Z :
    (forall rho phi, Z phi -> rho ⊨ phi) -> forall rho phi, minZ phi -> rho ⊨ phi.
  Proof using M_ZF VIEQ.
    intros H rho phi [].
    - now apply min_axioms'.
    - cbn. specialize (H rho (ax_sep (embed phi0))). cbn in H.
      setoid_rewrite (subst_ext _ _ (($0 .: (fun m : nat => S (S (S m))) >> var) >> embed_t)) in H; try now intros [].
      rewrite <- embed_subst in H. setoid_rewrite min_embed in H. apply H. auto using Z.
  Qed.

  Lemma min_axioms :
    (forall rho phi, ZF phi -> rho ⊨ phi) -> forall rho phi, minZF phi -> rho ⊨ phi.
  Proof using M_ZF VIEQ.
    intros H rho phi [].
    - now apply min_axioms'.
    - apply min_axioms_Z; eauto using minZ. intros. apply H. destruct H0; eauto using ZF.
    - cbn. specialize (H rho (ax_rep (embed phi0))). cbn in H.
      setoid_rewrite (subst_ext _ _ (($2 .: $1 .: Nat.add 3 >> var) >> embed_t)) in H at 1; try now intros [|[]].
      setoid_rewrite (subst_ext _ _ (($2 .: $0 .: Nat.add 3 >> var) >> embed_t)) in H at 2; try now intros [|[]].
      setoid_rewrite (subst_ext _ _ (($0 .: $1 .: Nat.add 4 >> var) >> embed_t)) in H at 3; try now intros [|[]].
      setoid_rewrite (subst_ext _ _ (($0 .: $1 .: Nat.add 4 >> var) >> embed_t)) in H at 4; try now intros [|[]].
      rewrite <- !embed_subst in H. setoid_rewrite min_embed in H. apply H. auto using ZF.
  Qed.

End Model.

Lemma ZF_to_minZF phi :
  entailment_minZF' (rm_const_fm phi) -> entailment_ZF' phi.
Proof.
  intros H D M rho H1 H2. apply min_correct; trivial.
  apply H; trivial. now apply min_axioms'.
Qed.

Lemma extensional_eq_min' V (M : @interp sig_empty _ V) rho :
  extensional M -> rho ⊫ minZF' -> rho ⊫ minZFeq'.
Proof.
  intros H1 H2 phi [<-|[<-|[<-|[<-|H]]]]; try now apply H2.
  all: cbn; intros; rewrite !H1 in *; congruence.
Qed.

Lemma extensional_eq_min_Z V (M : @interp sig_empty _ V) rho :
  extensional M -> (forall phi, minZ phi -> rho ⊨ phi) -> (forall phi, minZeq phi -> rho ⊨ phi).
Proof.
  intros H1 H2 phi []; try now apply H2; auto using minZ.
  apply extensional_eq_min'; auto using minZ.
Qed.

Lemma extensional_eq_min V (M : @interp sig_empty _ V) rho :
  extensional M -> (forall phi, minZF phi -> rho ⊨ phi) -> (forall phi, minZFeq phi -> rho ⊨ phi).
Proof.
  intros H1 H2 phi []; try now apply H2; auto using minZF.
  apply extensional_eq_min'; auto using minZF.
Qed.

(* ** Substitution lemmas *)

Lemma up_sshift1 (phi : form') sigma :
  phi[sshift 1][up (up sigma)] = phi[up sigma][sshift 1].
Proof.
  rewrite !subst_comp. apply subst_ext. intros []; trivial.
  cbn. unfold funcomp. now destruct (sigma n) as [|[]].
Qed.

Lemma up_sshift2 (phi : form') sigma :
  phi[sshift 2][up (up (up sigma))] = phi[up sigma][sshift 2].
Proof.
  rewrite !subst_comp. apply subst_ext. intros [|[]]; trivial.
  cbn. unfold funcomp. now destruct (sigma 0) as [|[]].
  cbn. unfold funcomp. now destruct sigma as [|[]].
Qed.

Lemma rm_const_tm_subst (sigma : nat -> term') (t : term) :
  (rm_const_tm t)[up sigma] = rm_const_tm t`[sigma >> embed_t].
Proof.
  induction t; cbn; try destruct F.
  - unfold funcomp. now destruct (sigma x) as [k|[]].
  - reflexivity.
  - cbn. rewrite (vec_inv2 v). cbn. rewrite up_sshift2, up_sshift1, !IH; trivial. apply in_hd_tl. apply in_hd.
  - cbn. rewrite (vec_inv1 v). cbn. rewrite up_sshift1, IH; trivial. apply in_hd.
  - cbn. rewrite (vec_inv1 v). cbn. rewrite up_sshift1, IH; trivial. apply in_hd.
  - reflexivity.
Qed.

Lemma rm_const_fm_subst (sigma : nat -> term') (phi : form) :
  (rm_const_fm phi)[sigma] = rm_const_fm phi[sigma >> embed_t].
Proof.
  induction phi in sigma |- *; cbn; trivial; try destruct P.
  - rewrite (vec_inv2 t). cbn. now rewrite up_sshift1, !rm_const_tm_subst.
  - rewrite (vec_inv2 t). cbn. now rewrite up_sshift1, !rm_const_tm_subst.
  - firstorder congruence.
  - rewrite IHphi. f_equal. erewrite subst_ext. reflexivity. intros []; trivial.
    unfold funcomp. cbn. unfold funcomp. now destruct (sigma n) as [x|[]].
Qed.

Lemma rm_const_fm_shift (phi : form) :
  (rm_const_fm phi)[↑] = rm_const_fm phi[↑].
Proof.
  rewrite rm_const_fm_subst. erewrite subst_ext. reflexivity. now intros [].
Qed.

Lemma eq_sshift1 (phi : form') t :
  phi[sshift 1][up t..] = phi.
Proof.
  erewrite subst_comp, subst_id; try reflexivity. now intros [].
Qed.

Lemma eq_sshift2 (phi : form') t :
  phi[sshift 2][up (up t..)] = phi[sshift 1].
Proof.
  erewrite subst_comp, subst_ext; try reflexivity. now intros [|].
Qed.

(* ** Deductions in minimal axiomatisation *)

Ltac prv_all' x :=
  apply AllI; edestruct (@nameless_equiv_all sig_empty) as [x ->]; cbn; subsimpl.

Ltac use_exists' H x :=
  apply (ExE H); edestruct (@nameless_equiv_ex sig_empty) as [x ->]; cbn; subsimpl.

Lemma minZF_refl' { p : peirce } t :
  minZFeq' ⊢ t ≡' t.
Proof.
  change (minZFeq' ⊢ ($0 ≡' $0)[t..]).
  apply AllE. apply Ctx. firstorder.
Qed.

Lemma minZF_refl { p : peirce } A t :
  minZFeq' <<= A -> A ⊢ t ≡' t.
Proof.
  apply Weak, minZF_refl'.
Qed.

Lemma minZF_sym { p : peirce } A x y :
  minZFeq' <<= A -> A ⊢ x ≡' y -> A ⊢ y ≡' x.
Proof.
  intros HA H. assert (HS : A ⊢ ax_sym'). apply Ctx. firstorder.
  apply (AllE x) in HS. cbn in HS. apply (AllE y) in HS. cbn in HS.
  subsimpl_in HS. now apply (IE HS).
Qed.

Lemma minZF_trans { p : peirce } A x y z :
  minZFeq' <<= A -> A ⊢ x ≡' y -> A ⊢ y ≡' z -> A ⊢ x ≡' z.
Proof.
  intros HA H1 H2. assert (HS : A ⊢ ax_trans'). apply Ctx. firstorder.
  apply (AllE x) in HS. cbn in HS. apply (AllE y) in HS. cbn in HS. apply (AllE z) in HS. cbn in HS.
  subsimpl_in HS. eapply IE. now apply (IE HS). assumption.
Qed.

Lemma minZF_elem' { p : peirce } x y u v :
  minZFeq' ⊢ x ≡' u → y ≡' v → x ∈' y → u ∈' v.
Proof.
  assert (minZFeq' ⊢ ax_eq_elem'). apply Ctx. firstorder.
  apply (AllE x) in H. cbn in H. apply (AllE y) in H. cbn in H.
  apply (AllE u) in H. cbn in H. apply (AllE v) in H. cbn in H.
  subsimpl_in H. apply H.
Qed.

Lemma minZF_elem { p : peirce } A x y u v :
  minZFeq' <<= A -> A ⊢ x ≡' u -> A ⊢ y ≡' v -> A ⊢ x ∈' y -> A ⊢ u ∈' v.
Proof.
  intros HA H1 H2 H3. eapply IE. eapply IE. eapply IE.
  eapply Weak. eapply minZF_elem'. auto. all: eauto.
Qed.

Lemma minZF_ext { p : peirce } A x y :
  minZFeq' <<= A -> A ⊢ sub' x y -> A ⊢ sub' y x -> A ⊢ x ≡' y.
Proof.
  intros HA H1 H2. assert (HS : A ⊢ ax_ext'). apply Ctx. firstorder.
  apply (AllE x) in HS. cbn in HS. apply (AllE y) in HS. cbn in HS.
  subsimpl_in HS. eapply IE. now apply (IE HS). assumption.
Qed.

Lemma minZF_Leibniz_tm { p : peirce } A (t : term') x y :
  minZFeq' <<= A -> A ⊢ x ≡' y -> A ⊢ t`[x..] ≡' t`[y..].
Proof.
  intros HA H. destruct t as [[]|[]]; cbn; trivial. now apply minZF_refl.
Qed.

Lemma and_equiv { p : peirce } (phi psi phi' psi' : form') A :
  (A ⊢ phi <-> A ⊢ phi') -> (A ⊢ psi <-> A ⊢ psi') -> (A ⊢ phi ∧ psi) <-> (A ⊢ phi' ∧ psi').
Proof.
  intros H1 H2. split; intros H % CE; apply CI; intuition.
Qed.

Lemma or_equiv { p : peirce } (phi psi phi' psi' : form') A :
  (forall B, A <<= B -> B ⊢ phi <-> B ⊢ phi') -> (forall B, A <<= B -> B ⊢ psi <-> B ⊢ psi') -> (A ⊢ phi ∨ psi) <-> (A ⊢ phi' ∨ psi').
Proof.
  intros H1 H2. split; intros H; apply (DE H).
  1,3: apply DI1; apply H1; auto.
  1,2: apply DI2; apply H2; auto.
Qed.

Lemma impl_equiv { p : peirce } (phi psi phi' psi' : form') A :
  (forall B, A <<= B -> B ⊢ phi <-> B ⊢ phi') -> (forall B, A <<= B -> B ⊢ psi <-> B ⊢ psi') -> (A ⊢ phi → psi) <-> (A ⊢ phi' → psi').
Proof.
  intros H1 H2. split; intros H; apply II.
  - apply H2; auto. eapply IE. apply (Weak H). auto. apply H1; auto.
  - apply H2; auto. eapply IE. apply (Weak H). auto. apply H1; auto.
Qed.

Lemma all_equiv { p : peirce } (phi psi : form') A :
  (forall t, A ⊢ phi[t..] <-> A ⊢ psi[t..]) -> (A ⊢ ∀ phi) <-> (A ⊢ ∀ psi).
Proof.
  intros H1. split; intros H2; apply AllI.
  all: edestruct (nameless_equiv_all A) as [x ->]; apply H1; auto.
Qed.

Lemma ex_equiv { p : peirce } (phi psi : form') A :
  (forall B t, A <<= B -> B ⊢ phi[t..] <-> B ⊢ psi[t..]) -> (A ⊢ ∃ phi) <-> (A ⊢ ∃ psi).
Proof.
  intros H1. split; intros H2.
  - apply (ExE H2). edestruct (nameless_equiv_ex A) as [x ->]. apply ExI with x. apply H1; auto.
  - apply (ExE H2). edestruct (nameless_equiv_ex A) as [x ->]. apply ExI with x. apply H1; auto.
Qed.

Lemma minZF_Leibniz { p : peirce } A (phi : form') x y :
  minZFeq' <<= A -> A ⊢ x ≡' y -> A ⊢ phi[x..] <-> A ⊢ phi[y..].
Proof.
  revert A. induction phi using form_ind_subst; cbn; intros A HA HXY; try tauto.
  - destruct P0; rewrite (vec_inv2 t); cbn; split.
    + apply minZF_elem; trivial; now apply minZF_Leibniz_tm.
    + apply minZF_sym in HXY; trivial. apply minZF_elem; trivial; now apply minZF_Leibniz_tm.
    + intros H. eapply minZF_trans; trivial. apply minZF_Leibniz_tm; trivial. eapply minZF_sym; eauto.
      eapply minZF_trans; trivial. apply H. now apply minZF_Leibniz_tm.
    + intros H. eapply minZF_trans; trivial. apply minZF_Leibniz_tm; eauto.
      eapply minZF_trans; trivial. apply H. apply minZF_Leibniz_tm; trivial. now apply minZF_sym.
  - destruct b0.
    + apply and_equiv; firstorder easy.
    + apply or_equiv; intros B HB.
      * apply IHphi1. now rewrite HA. now apply (Weak HXY).
      * apply IHphi2. now rewrite HA. now apply (Weak HXY).
    + apply impl_equiv; intros B HB.
      * apply IHphi1. now rewrite HA. now apply (Weak HXY).
      * apply IHphi2. now rewrite HA. now apply (Weak HXY).
  - destruct x as [n|[]], y as [m|[]]. destruct q.
    + apply all_equiv. intros [k|[]]. specialize (H ($(S k)..) A HA HXY).
      erewrite !subst_comp, subst_ext, <- subst_comp. rewrite H.
      erewrite !subst_comp, subst_ext. reflexivity. all: now intros [|[]]; cbn.
    + apply ex_equiv. intros B [k|[]] HB. cbn. specialize (H ($(S k)..) B).
      erewrite !subst_comp, subst_ext, <- subst_comp. rewrite H. 2: now rewrite HA. 2: now apply (Weak HXY).
      erewrite !subst_comp, subst_ext. reflexivity. all: now intros [|[]]; cbn.
Qed.

Lemma iff_equiv { p : peirce } (phi psi phi' psi' : form') A :
  (forall B, A <<= B -> B ⊢ phi <-> B ⊢ phi') -> (forall B, A <<= B -> B ⊢ psi <-> B ⊢ psi') -> (A ⊢ phi ↔ psi) <-> (A ⊢ phi' ↔ psi').
Proof.
  intros H1 H2. split; intros [H3 H4] % CE; apply CI; eapply impl_equiv.
  3,9: apply H3. 5,10: apply H4. all: firstorder.
Qed.

(* ** Verification of translated axioms *)

Lemma prv_ex_eq { p : peirce } A x phi :
  minZFeq' <<= A -> A ⊢ phi[x..] <-> A ⊢ ∃ $0 ≡' x`[↑] ∧ phi.
Proof.
  intros HA. split; intros H.
  - apply (ExI x). cbn. subsimpl. apply CI; trivial. now apply minZF_refl.
  - use_exists' H y. eapply minZF_Leibniz; eauto 3. apply minZF_sym; eauto 3.
Qed.

Lemma use_ex_eq { p : peirce } A x phi psi :
  minZFeq' <<= A -> A ⊢ phi[x..] → psi <-> A ⊢ (∃ $0 ≡' x`[↑] ∧ phi) → psi.
Proof.
  intros H. apply impl_equiv; try tauto. intros B HB. apply prv_ex_eq. now rewrite H.
Qed.

Local Ltac simpl_ex :=
  try apply prv_ex_eq; try apply use_ex_eq; auto; cbn; subsimpl.

Local Ltac simpl_ex_in H :=
  try apply prv_ex_eq in H; try apply use_ex_eq in H; auto; cbn in H; subsimpl_in H.

Lemma prv_to_min_refl { p : peirce } :
  minZFeq' ⊢ rm_const_fm ax_refl.
Proof.
  prv_all x. repeat simpl_ex. apply minZF_refl'.
Qed.

Lemma prv_to_min_sym { p : peirce } :
  minZFeq' ⊢ rm_const_fm ax_sym.
Proof.
  prv_all x. prv_all y. apply II. assert1 H. use_exists' H a. assert1 H'.
  apply CE2 in H'. use_exists' H' b. repeat simpl_ex. eapply minZF_trans; auto.
  - apply minZF_sym; auto. eapply CE1. auto.
  - eapply minZF_trans; auto. apply minZF_sym; auto. eapply CE2. auto. eapply CE1, Ctx. auto.
Qed.

Lemma prv_to_min_trans { p : peirce } :
  minZFeq' ⊢ rm_const_fm ax_trans.
Proof.
  prv_all x. prv_all y. prv_all z.
  repeat simpl_ex. apply II. repeat simpl_ex. apply II.
  repeat simpl_ex. eapply minZF_trans; auto.
Qed.

Lemma prv_to_min_elem { p : peirce } :
  minZFeq' ⊢ rm_const_fm ax_eq_elem.
Proof.
  prv_all x. prv_all y. prv_all u. prv_all v.
  repeat simpl_ex. apply II. repeat simpl_ex. apply II. repeat simpl_ex. apply II.
  repeat simpl_ex. eapply minZF_elem; auto.
Qed.

Lemma prv_to_min_ext { p : peirce } :
  minZFeq' ⊢ rm_const_fm ax_ext.
Proof.
  prv_all x. prv_all y. apply II. apply II.
  repeat simpl_ex. apply minZF_ext; auto; prv_all z; apply II.
  - assert3 H. apply (AllE z) in H. cbn in H. subsimpl_in H.
    repeat simpl_ex_in H. rewrite imps in H.
    repeat simpl_ex_in H. apply (Weak H). auto.
  - assert2 H. apply (AllE z) in H. cbn in H. subsimpl_in H.
    repeat simpl_ex_in H. rewrite imps in H.
    repeat simpl_ex_in H. apply (Weak H). auto.
Qed.

Lemma prv_to_min_eset { p : peirce } :
  minZFeq' ⊢ rm_const_fm ax_eset.
Proof.
  prv_all x. simpl_ex. apply II.
  assert1 H. use_exists' H y. clear H. eapply IE. 2: eapply CE2, Ctx; auto 1.
  assert1 H. apply CE1 in H. apply (AllE x) in H. cbn in H. now subsimpl_in H.
Qed.

Lemma prv_to_min_pair { p : peirce } :
  minZFeq' ⊢ rm_const_fm ax_pair.
Proof.
  prv_all x. prv_all y. prv_all z. apply CI.
  - simpl_ex. apply II.
    assert1 H. use_exists' H u. clear H. assert1 H. apply CE in H as [H1 H2].
    repeat simpl_ex_in H1. apply (AllE z) in H1. cbn in H1. subsimpl_in H1.
    apply CE1 in H1. apply (IE H1) in H2. apply (DE H2); [apply DI1 | apply DI2].
    all: repeat simpl_ex.
  - assert (HP : minZFeq' ⊢ ax_pair') by (apply Ctx; firstorder).
    apply (AllE y) in HP. cbn in HP. apply (AllE x) in HP. cbn in HP. use_exists' HP u. clear HP. apply II.
    simpl_ex. apply (ExI u). cbn. subsimpl. apply CI.
    + repeat simpl_ex.
    + assert2 H. apply (AllE z) in H. cbn in H. subsimpl_in H. apply CE2 in H. apply (IE H). clear H. eapply DE.
      * apply Ctx. auto.
      * apply DI1. assert1 H. repeat simpl_ex_in H.
      * apply DI2. assert1 H. repeat simpl_ex_in H.
Qed.

Lemma prv_to_min_union { p : peirce } :
  minZFeq' ⊢ rm_const_fm ax_union.
Proof.
  prv_all x. prv_all y. apply CI.
  - simpl_ex. apply II.
    assert1 H. use_exists' H u. clear H. assert1 H. apply CE in H as [H1 H2].
    simpl_ex_in H1. apply (AllE y) in H1. cbn in H1. subsimpl_in H1.
    apply CE1 in H1. apply (IE H1) in H2. use_exists' H2 z.
    apply (ExI z). cbn. subsimpl. apply CI; repeat simpl_ex.
    + eapply CE1. auto.
    + eapply CE2. auto.
  - assert (HU : minZFeq' ⊢ ax_union') by (apply Ctx; firstorder).
    apply (AllE x) in HU. cbn in HU. use_exists' HU u.
    apply II. assert1 H. use_exists' H z. clear H. assert1 H. apply CE in H as [H1 H2].
    repeat simpl_ex_in H1. repeat simpl_ex_in H2. simpl_ex.
    apply (ExI u). cbn. subsimpl. apply CI.
    + simpl_ex. apply Ctx. auto.
    + assert3 Hu. apply (AllE y) in Hu. cbn in Hu. subsimpl_in Hu. apply CE2 in Hu.
      apply (IE Hu). apply (ExI z). cbn. subsimpl. now apply CI.
Qed.

Lemma prv_to_min_power { p : peirce } :
  minZFeq' ⊢ rm_const_fm ax_power.
Proof.
  prv_all x. prv_all y. apply CI.
  - simpl_ex. apply II.
    assert1 H. use_exists' H u. clear H. assert1 H. apply CE in H as [H1 H2].
    simpl_ex_in H1. apply (AllE y) in H1. cbn in H1. subsimpl_in H1.
    apply CE1 in H1. apply (IE H1) in H2. prv_all z.
    repeat simpl_ex. apply II. repeat simpl_ex. apply imps.
    apply (AllE z) in H2. cbn in H2. now subsimpl_in H2.
  - assert (HP : minZFeq' ⊢ ax_power') by (apply Ctx; firstorder).
    apply (AllE x) in HP. cbn in HP. use_exists' HP u. clear HP. apply II.
    simpl_ex. apply (ExI u). cbn. subsimpl. apply CI.
    + simpl_ex. apply Ctx. auto.
    + assert2 H. apply (AllE y) in H. cbn in H. subsimpl_in H. apply CE2 in H. apply (IE H). clear H.
      prv_all z. apply II. assert2 H. apply (AllE z) in H. cbn in H. subsimpl_in H.
      repeat simpl_ex_in H. rewrite imps in H. repeat simpl_ex_in H. apply (Weak H). auto 8.
Qed.

Lemma prv_to_min_inductive { p : peirce } A n :
  minZFeq' <<= A -> A ⊢ rm_const_fm (inductive $n) -> A ⊢ is_inductive $n.
Proof.
  cbn. intros HA HI. apply CI.
  - apply CE1 in HI. use_exists' HI x. clear HI.
    apply (ExI x). cbn. assert1 H. apply CE in H as [H1 H2]. apply CI; trivial.
    change (∃ $0 ≡' ↑ n ∧ x`[↑] ∈' $0) with (∃ $0 ≡' $n`[↑] ∧ x`[↑] ∈' $0) in H2.
    now simpl_ex_in H2.
  - apply CE2 in HI. prv_all x. apply (AllE x) in HI. cbn in HI. simpl_ex_in HI.
    change (∃ $0 ≡' ↑ n ∧ x`[↑] ∈' $0) with (∃ $0 ≡' $n`[↑] ∧ x`[↑] ∈' $0) in HI.
    simpl_ex_in HI. rewrite imps in *. use_exists' HI y. clear HI.
    assert1 H. apply (ExI y). cbn. subsimpl. apply CI.
    + apply CE1 in H. use_exists' H a. clear H. assert1 H. apply CE in H as [H1 H2].
      simpl_ex_in H1. prv_all b. apply (AllE b) in H2. cbn in H2. subsimpl_in H2.
      eapply iff_equiv; try apply H2; try tauto.
      intros B HB. clear H2. eapply Weak in H1; try apply HB. split; intros H2.
      * use_exists' H1 z. clear H1. assert1 H. apply CE in H as [H H'].
        apply prv_ex_eq in H; try rewrite <- HB; auto. cbn in H. subsimpl_in H.
        apply prv_ex_eq in H; try rewrite <- HB; auto. cbn in H. subsimpl_in H.
        eapply Weak in H2. apply (DE H2). 3: auto.
        -- apply (ExI x). cbn. subsimpl. apply CI; auto. apply (AllE x) in H'. cbn in H'. subsimpl_in H'.
           apply CE2 in H'. eapply IE. apply (Weak H'); auto. apply DI1. apply minZF_refl. rewrite <- HB. auto 6.
        -- apply (ExI z). cbn. subsimpl. apply CI.
           ++ apply (AllE z) in H'. cbn in H'. subsimpl_in H'. apply CE2 in H'. eapply IE.
              apply (Weak H'); auto. apply DI2. apply minZF_refl. rewrite <- HB. auto 6.
           ++ apply (AllE b) in H. cbn in H. subsimpl_in H. apply CE2 in H. eapply IE.
              apply (Weak H); auto. apply DI2. auto.
      * use_exists' H1 z. clear H1. assert1 H. apply CE in H as [H H'].
        apply prv_ex_eq in H; try rewrite <- HB; auto. cbn in H. subsimpl_in H.
        apply prv_ex_eq in H; try rewrite <- HB; auto. cbn in H. subsimpl_in H.
        eapply Weak in H2. use_exists' H2 c. 2: auto. clear H2. assert1 H1. apply CE in H1 as [H1 H2].
        apply (AllE c) in H'. cbn in H'. subsimpl_in H'. apply CE1 in H'. eapply Weak in H'.
        apply (IE H') in H1. 2: auto. clear H'. apply (DE H1).
        -- apply DI1. eapply minZF_elem. rewrite <- HB, HA. auto 8. 3: apply (Weak H2); auto.
           2: auto. apply minZF_refl. rewrite <- HB, HA. auto 8.
        -- apply DI2. apply (AllE b) in H. cbn in H. subsimpl_in H. apply CE1 in H. eapply DE'.
           eapply IE. apply (Weak H). auto. eapply minZF_elem. rewrite <- HB, HA. auto 8.
           3: apply (Weak H2); auto. 2: auto. apply minZF_refl. rewrite <- HB, HA. auto 8.
    + apply CE2 in H. change (∃ $0 ≡' ↑ n ∧ y`[↑] ∈' $0) with (∃ $0 ≡' $n`[↑] ∧ y`[↑] ∈' $0) in H.
      now simpl_ex_in H.
Qed.

Lemma inductive_subst t sigma :
  (inductive t)[sigma] = inductive t`[sigma].
Proof.
  cbn. subsimpl. reflexivity.
Qed.

Lemma is_inductive_subst t sigma :
  (is_inductive t)[sigma] = is_inductive t`[sigma].
Proof.
  cbn. subsimpl. reflexivity.
Qed.

Lemma is_om_subst t sigma :
  (is_om t)[sigma] = is_om t`[sigma].
Proof.
  cbn. subsimpl. reflexivity.
Qed.

Local Arguments is_om : simpl never.
Local Arguments is_inductive : simpl never.

Lemma is_eset_sub { p : peirce } A x y :
  minZFeq' <<= A -> A ⊢ is_eset x -> A ⊢ sub' x y.
Proof.
  intros HA HE. prv_all z. apply II, Exp, IE with (($0 ∈' x`[↑])[z..]).
  - change ((z ∈' x :: A) ⊢ (¬ $0 ∈' x`[↑])[z..]). apply AllE, (Weak HE). auto.
  - cbn. subsimpl. auto.
Qed.

Lemma is_eset_unique { p : peirce } A x y :
  minZFeq' <<= A -> A ⊢ is_eset x -> A ⊢ is_eset y -> A ⊢ x ≡' y.
Proof.
  intros HA H1 H2. apply minZF_ext; auto; now apply is_eset_sub.
Qed.

Lemma prv_to_min_om1 { p : peirce } :
  minZFeq' ⊢ rm_const_fm ax_om1.
Proof.
  apply CI.
  - assert (HO : minZFeq' ⊢ ax_om') by (apply Ctx; firstorder).
    use_exists' HO o. clear HO.
    assert (HE : minZFeq' ⊢ ax_eset') by (apply Ctx; firstorder).
    eapply Weak in HE. use_exists' HE e. clear HE. 2: auto.
    apply (ExI e). cbn. apply CI; auto. apply (ExI o). cbn. subsimpl. rewrite eq_sshift1.
    apply CI; auto. assert2 H. unfold is_om in H at 2. cbn in H. apply CE1 in H.
    rewrite is_inductive_subst in H. cbn in H. apply CE1 in H. use_exists' H e'. clear H.
    assert1 H. apply CE in H as [H1 H2]. eapply minZF_elem; auto; try eassumption.
    2: apply minZF_refl; auto. apply is_eset_unique; auto.
  - prv_all x. simpl_ex. rewrite up_sshift1, eq_sshift1, !is_om_subst. cbn.
    apply II. assert1 H. use_exists' H o. clear H. assert1 H. apply CE in H as [H1 H2].
    unfold is_om in H1 at 3. cbn in H1. apply CE1 in H1. unfold is_inductive in H1. cbn in H1. apply CE2 in H1.
    apply (AllE x) in H1. cbn in H1. subsimpl_in H1. apply (IE H1) in H2. use_exists' H2 y. clear H1 H2.
    apply (ExI y). cbn. subsimpl. apply CI.
    + assert (HP : minZFeq' ⊢ ax_pair') by (apply Ctx; firstorder).
      apply (AllE x) in HP. cbn in HP. subsimpl_in HP. apply (AllE x) in HP. cbn in HP. subsimpl_in HP.
      eapply Weak in HP. use_exists' HP s. 2: auto. clear HP.
      assert (HP : minZFeq' ⊢ ax_pair') by (apply Ctx; firstorder).
      apply (AllE x) in HP. cbn in HP. subsimpl_in HP. apply (AllE s) in HP. cbn in HP. subsimpl_in HP.
      eapply Weak in HP. use_exists' HP t. 2: auto. clear HP.
      apply (ExI t). cbn. subsimpl. apply CI.
      * apply prv_ex_eq; auto 7. apply (ExI s). cbn. subsimpl. apply CI; auto.
        apply prv_ex_eq; auto 7. cbn. subsimpl. apply prv_ex_eq; auto 7. cbn. subsimpl. auto.
      * prv_all z. assert3 H. apply CE1, (AllE z) in H. cbn in H. subsimpl_in H.
        apply CE in H as [H1 H2]. apply CI; rewrite imps in *.
        -- clear H2. apply (DE H1); clear H1.
           ++ apply (ExI x). cbn. subsimpl. apply CI; auto. assert3 H. apply (AllE x) in H. cbn in H. subsimpl_in H.
              apply CE2 in H. apply (IE H). apply DI1. apply minZF_refl. auto 8.
           ++ apply (ExI s). cbn. subsimpl. apply CI.
              ** assert3 H. apply (AllE s) in H. cbn in H. subsimpl_in H.
                 apply CE2 in H. apply (IE H). apply DI2. apply minZF_refl. auto 8.
              ** assert4 H. apply (AllE z) in H. cbn in H. subsimpl_in H.
                 apply CE2 in H. apply (IE H). apply DI1. auto.
        -- rewrite <- imps in H2. eapply Weak in H2. apply (IE H2). 2: auto. clear H1 H2.
           assert1 H. use_exists' H a. clear H. assert1 H. apply CE in H as [H1 H2].
           assert3 H. apply (AllE a) in H. cbn in H. subsimpl_in H.
           apply CE1 in H. apply (IE H) in H1. clear H. apply (DE H1).
           ** apply DI1. eapply minZF_elem; auto 9. 2: apply (Weak H2); auto. apply minZF_refl. auto 9.
           ** apply DI2. apply DE'. apply IE with (z ∈' s). eapply CE1 with (z ≡' x ∨ z ≡' x → z ∈' s).
              replace (z ∈' s ↔ z ≡' x ∨ z ≡' x) with (($0 ∈' s`[↑] ↔ $0 ≡' x`[↑] ∨ $0 ≡' x`[↑])[z..]).
              2: cbn; now subsimpl. apply AllE. auto 7. eapply minZF_elem; auto 9.
              2: apply (Weak H2); auto. apply minZF_refl. auto 9.
    + apply (ExI o). cbn. subsimpl. rewrite !is_om_subst. cbn. apply CI; [eapply CE1 | eapply CE2]; auto.
Qed.

Local Arguments inductive : simpl never.
Local Arguments is_om : simpl nomatch.

Lemma prv_to_min_om2 { p : peirce } :
  minZFeq' ⊢ rm_const_fm ax_om2.
Proof.
  cbn. prv_all x. destruct x as [n|[]]. cbn. rewrite rm_const_fm_subst, inductive_subst, !is_inductive_subst.
  cbn. apply II. prv_all m. cbn. rewrite !is_inductive_subst. cbn. simpl_ex.
  rewrite !is_inductive_subst. cbn. apply II. simpl_ex.
  change (∃ $0 ≡' ↑ n ∧ m`[↑] ∈' $0) with (∃ $0 ≡' $n`[↑] ∧ m`[↑] ∈' $0).
  simpl_ex. assert1 H. use_exists' H k. clear H.
  cbn. rewrite !is_inductive_subst. cbn. subsimpl. assert1 H. apply CE in H as [H1 % CE2 H2].
  apply (AllE $n) in H1. cbn in H1. subsimpl_in H1. rewrite is_inductive_subst in H1. cbn in H1.
  assert3 H3. apply prv_to_min_inductive in H3; auto. apply (IE H1) in H3.
  apply (AllE m) in H3. cbn in H3. subsimpl_in H3. now apply (IE H3).
Qed.

Lemma prv_to_min { p : peirce } phi :
  phi el ZFeq' -> minZFeq' ⊢ rm_const_fm phi.
Proof.
  intros [<-|[<-|[<-|[<-|[<-|[<-|[<-|[<-|[<-|[<-|[<-|[]]]]]]]]]]]].
  - apply prv_to_min_refl.
  - apply prv_to_min_sym.
  - apply prv_to_min_trans.
  - apply prv_to_min_elem.
  - apply prv_to_min_ext.
  - apply prv_to_min_eset.
  - apply prv_to_min_pair.
  - apply prv_to_min_union.
  - apply prv_to_min_power.
  - apply prv_to_min_om1.
  - apply prv_to_min_om2.
Qed.

(* ** Deduction *)

Section Deduction.

  Lemma rm_const_tm_prv { p : peirce } t :
    minZFeq' ⊢ ∃ rm_const_tm t.
  Proof.
    induction t; try destruct F; cbn.
    - apply (ExI $x). cbn. apply minZF_refl'.
    - apply Ctx. firstorder.
    - rewrite (vec_inv2 v). cbn.
      assert (H1 : minZFeq' ⊢ ∃ rm_const_tm (Vector.hd v)) by apply IH, in_hd.
      assert (H2 : minZFeq' ⊢ ∃ rm_const_tm (Vector.hd (Vector.tl v))) by apply IH, in_hd_tl.
      use_exists' H1 x. eapply Weak in H2. use_exists' H2 y. 2: auto.
      assert (H : minZFeq' ⊢ ax_pair') by (apply Ctx; firstorder).
      apply (AllE x) in H. cbn in H. apply (AllE y) in H. cbn in H.
      eapply Weak in H. use_exists' H z. 2: auto. apply (ExI z). cbn.
      apply (ExI x). cbn. subsimpl. rewrite eq_sshift1. apply CI; auto.
      apply (ExI y). cbn. subsimpl. erewrite !subst_comp, subst_ext. apply CI; auto. now intros [].
    - rewrite (vec_inv1 v). cbn. specialize (IH _ (in_hd v)). use_exists' IH x.
      assert (H : minZFeq' ⊢ ax_union') by (apply Ctx; firstorder). apply (AllE x) in H. cbn in H.
      eapply Weak in H. use_exists' H y. 2: auto. apply (ExI y). cbn. apply (ExI x). cbn. subsimpl.
      rewrite eq_sshift1. apply CI; auto.
    - rewrite (vec_inv1 v). cbn. specialize (IH _ (in_hd v)). use_exists' IH x.
      assert (H : minZFeq' ⊢ ax_power') by (apply Ctx; firstorder). apply (AllE x) in H. cbn in H.
      eapply Weak in H. use_exists' H y. 2: auto. apply (ExI y). cbn. apply (ExI x). cbn. subsimpl.
      rewrite eq_sshift1. apply CI; auto.
    - apply Ctx. firstorder.
  Qed.

  Lemma rm_const_tm_sub { p : peirce } A t (x y : term') :
    minZFeq' <<= A -> A ⊢ (rm_const_tm t)[x..] -> A ⊢ (rm_const_tm t)[y..] -> A ⊢ sub' x y.
  Proof.
    intros HA. induction t in A, HA, x, y |- *; try destruct F; cbn -[is_inductive sub'].
    - intros H1 H2. prv_all z. apply II. eapply minZF_elem; auto; try apply minZF_refl; auto.
      eapply minZF_trans; auto. apply (Weak H1); auto. apply minZF_sym; auto. apply (Weak H2). auto.
    - intros H _. prv_all z. apply II. apply Exp. apply (AllE z) in H. cbn in H. subsimpl_in H.
      eapply IE; try apply (Weak H); auto.
    - rewrite (vec_inv2 v). cbn. rewrite !eq_sshift1. intros H1 H2. prv_all a. apply II.
      eapply Weak in H1. use_exists' H1 b. 2: auto. clear H1. assert1 H. apply CE in H as [H1 H3].
      eapply Weak in H3. use_exists' H3 c. 2: auto. clear H3. assert1 H. apply CE in H as [H3 H4].
      eapply Weak in H2. use_exists' H2 d. 2: auto. clear H2. assert1 H. apply CE in H as [H2 H5].
      eapply Weak in H5. use_exists' H5 e. 2: auto. clear H5. assert1 H. apply CE in H as [H5 H6].

      (* making the goal a bit more readable, could be automated *)
      pose (B := ((rm_const_tm (Vector.hd v))[b..]
           ∧ (∃ (rm_const_tm (Vector.hd (Vector.tl v)))[sshift 2][up (up x..)][up b..]
                ∧ (∀ $0 ∈' x`[↑]`[↑] ↔ $0 ≡' b`[↑]`[↑] ∨ $0 ≡' ↑ 0)) :: a ∈' x :: A)).
      fold B in H1, H2, H3, H4, H5, H6. fold B. rewrite !eq_sshift2, !eq_sshift1 in *.

      assert (HB : minZFeq' <<= B). { rewrite HA. unfold B. auto. }
      apply (AllE a) in H6. cbn in H6. subsimpl_in H6. eapply IE. eapply CE2. apply H6.
      apply (AllE a) in H4. cbn in H4. subsimpl_in H4. eapply DE.
      + eapply IE. eapply CE1. apply (Weak H4); auto. apply Ctx. unfold B. auto.
      + apply DI1. eapply minZF_trans; auto. apply minZF_ext; auto.
        * eapply (IH _ (in_hd v)); auto; eapply Weak. apply H1. auto. apply H2. auto.
        * eapply (IH _ (in_hd v)); auto; eapply Weak. apply H2. auto. apply H1. auto.
      + apply DI2. eapply minZF_trans; auto. apply minZF_ext; auto.
        * eapply (IH _ (in_hd_tl v)); auto; eapply Weak. apply H3. auto. apply H5. auto.
        * eapply (IH _ (in_hd_tl v)); auto; eapply Weak. apply H5. auto. apply H3. auto.
    - rewrite (vec_inv1 v). cbn. rewrite !eq_sshift1 in *. intros H1 H2.
      prv_all a. apply II. eapply Weak in H1. use_exists' H1 b. 2: auto.
      eapply Weak in H2. use_exists' H2 c. 2: auto. clear H1 H2.
      assert1 H. apply CE in H as [H1 H2]. apply (AllE a) in H2. cbn in H2. subsimpl_in H2.
      eapply IE. eapply CE2, H2. clear H2.
      assert2 H. apply CE in H as [H2 H3]. apply (AllE a) in H3. cbn in H3. subsimpl_in H3.
      apply CE1 in H3. assert3 H4. apply (IE H3) in H4. use_exists' H4 d. clear H3 H4.
      apply (ExI d). cbn. subsimpl. apply CI. 2: eapply CE2; auto.
      eapply (IH _ (in_hd v) _ b c) in H1; auto. apply (AllE d) in H1. cbn in H1. subsimpl_in H1.
      eapply Weak in H1. apply (IE H1). 2: auto. eapply CE1; auto.
    - rewrite (vec_inv1 v). cbn. rewrite !eq_sshift1. intros H1 H2.
      prv_all a. apply II. eapply Weak in H1. use_exists' H1 b. 2: auto.
      eapply Weak in H2. use_exists' H2 c. 2: auto. clear H1 H2.
      assert1 H. apply CE in H as [H1 H2]. apply (AllE a) in H2. cbn in H2. subsimpl_in H2.
      eapply IE. eapply CE2, H2. clear H2.
      assert2 H. apply CE in H as [H2 H3]. apply (AllE a) in H3. cbn in H3. subsimpl_in H3.
      apply CE1 in H3. assert3 H4. apply (IE H3) in H4. clear H3.
      prv_all d. apply II. apply (IH _ (in_hd v) _ b c) in H1; auto. apply (AllE d) in H1. cbn in H1. subsimpl_in H1.
      eapply Weak in H1. apply (IE H1). 2: auto. apply (AllE d) in H4. cbn in H4. subsimpl_in H4.
      eapply Weak in H4. apply (IE H4). all: auto.
    - intros [H1 H2] % CE [H3 H4] % CE. apply (AllE y) in H2.
      cbn -[is_inductive] in H2. subsimpl_in H2. apply (IE H2). apply H3.
  Qed.

  Lemma rm_const_tm_equiv { p : peirce } A t (x y : term') :
    minZFeq' <<= A -> A ⊢ (rm_const_tm t)[x..] -> A ⊢ y ≡' x <-> A ⊢ (rm_const_tm t)[y..].
  Proof.
    intros HA Hx. split; intros H.
    - eapply minZF_Leibniz; eauto.
    - apply minZF_ext; trivial; eapply rm_const_tm_sub; eauto.
  Qed.

  Lemma rm_const_tm_swap { p : peirce } A t s x a :
    minZFeq' <<= A -> A ⊢ (rm_const_tm t)[x..] -> A ⊢ (rm_const_tm s)[a.:x..] <-> A ⊢ (rm_const_tm s`[t..])[a..].
  Proof.
    induction s in A, a, x |- *; cbn; try destruct F; cbn; intros HA Hx; try tauto.
    - destruct x0; cbn; try tauto. now apply rm_const_tm_equiv.
    - rewrite (vec_inv2 v). cbn. apply ex_equiv. intros B y HB. cbn. apply and_equiv.
      + erewrite !subst_comp, subst_ext. setoid_rewrite subst_ext at 2.
        apply IH; try apply in_hd. now rewrite HA. now apply (Weak Hx).
        all: intros [|[]]; cbn; try reflexivity. apply subst_term_shift.
      + apply ex_equiv. intros C z HC. cbn. apply and_equiv; try tauto.
        erewrite !subst_comp, subst_ext. setoid_rewrite subst_ext at 2.
        apply IH; try apply in_hd_tl. now rewrite HA, HB. apply (Weak Hx). now rewrite HB.
        all: intros [|[]]; cbn; try reflexivity.
        rewrite !subst_term_comp. now apply subst_term_id.
    - rewrite (vec_inv1 v). cbn. apply ex_equiv. intros B y HB. cbn. apply and_equiv; try tauto.
      erewrite !subst_comp, subst_ext. setoid_rewrite subst_ext at 2.
      apply IH; try apply in_hd. now rewrite HA. now apply (Weak Hx).
      all: intros [|[]]; cbn; try reflexivity. apply subst_term_shift.
    - rewrite (vec_inv1 v). cbn. apply ex_equiv. intros B y HB. cbn. apply and_equiv; try tauto.
      erewrite !subst_comp, subst_ext. setoid_rewrite subst_ext at 2.
      apply IH; try apply in_hd. now rewrite HA. now apply (Weak Hx).
      all: intros [|[]]; cbn; try reflexivity. apply subst_term_shift.
  Qed.

  Lemma rm_const_fm_swap { p : peirce } A phi t x :
    minZFeq' <<= A -> A ⊢ (rm_const_tm t)[x..] -> A ⊢ (rm_const_fm phi)[x..] <-> A ⊢ rm_const_fm phi[t..].
  Proof.
    revert A. induction phi using form_ind_subst; cbn; intros A HA Hx.
    all: try destruct P0; try destruct b0; try destruct q; try tauto.
    - rewrite (vec_inv2 t0). cbn. apply ex_equiv. cbn. intros B a HB. apply and_equiv.
      + rewrite subst_comp. erewrite subst_ext.
        * eapply rm_const_tm_swap. now rewrite HA. now apply (Weak Hx).
        * intros [|[|]]; trivial. now destruct x as [|[]].
      + apply ex_equiv. cbn. intros C a' HC. apply and_equiv; try tauto.
        rewrite !subst_comp. erewrite subst_ext. setoid_rewrite subst_ext at 2.
        * eapply rm_const_tm_swap. now rewrite HA, HB. apply (Weak Hx). now rewrite HB.
        * intros [|[]]; reflexivity.
        * intros [|[]]; trivial. now destruct x as [|[]].
    - rewrite (vec_inv2 t0). cbn. apply ex_equiv. cbn. intros B a HB. apply and_equiv.
      + rewrite subst_comp. erewrite subst_ext.
        * eapply rm_const_tm_swap. now rewrite HA. now apply (Weak Hx).
        * intros [|[|]]; trivial. now destruct x as [|[]].
      + apply ex_equiv. cbn. intros C a' HC. apply and_equiv; try tauto.
        rewrite !subst_comp. erewrite subst_ext. setoid_rewrite subst_ext at 2.
        * eapply rm_const_tm_swap. now rewrite HA, HB. apply (Weak Hx). now rewrite HB.
        * intros [|[]]; reflexivity.
        * intros [|[]]; trivial. now destruct x as [|[]].
    - apply and_equiv; firstorder easy.
    - apply or_equiv; intros B HB.
      + apply IHphi1. now rewrite HA. now apply (Weak Hx).
      + apply IHphi2. now rewrite HA. now apply (Weak Hx).
    - apply impl_equiv; intros B HB.
      + apply IHphi1. now rewrite HA. now apply (Weak Hx).
      + apply IHphi2. now rewrite HA. now apply (Weak Hx).
    - apply all_equiv. intros [n|[]]. destruct x as [m|[]].
      assert (A ⊢ (rm_const_fm phi[$(S n)..])[$m..] <-> A ⊢ (rm_const_fm phi[$(S n)..][t..])) by now apply H, (Weak Hx).
      erewrite subst_comp, subst_ext, <- subst_comp, (rm_const_fm_subst ($(S n)..)). setoid_rewrite subst_ext at 2.
      rewrite H0. erewrite rm_const_fm_subst, !subst_comp, subst_ext. reflexivity.
      all: intros [|[]]; cbn; try reflexivity. rewrite subst_term_comp, subst_term_id; reflexivity.
    - apply ex_equiv. intros B s HB. destruct s as [n|[]], x as [m|[]].
      assert (B ⊢ (rm_const_fm phi[$(S n)..])[$m..] <-> B ⊢ (rm_const_fm phi[$(S n)..][t..])).
      { eapply H, (Weak Hx); trivial. now rewrite HA. }
      erewrite subst_comp, subst_ext, <- subst_comp, (rm_const_fm_subst ($(S n)..)). setoid_rewrite subst_ext at 2.
      rewrite H0. erewrite rm_const_fm_subst, !subst_comp, subst_ext. reflexivity.
      all: intros [|[]]; cbn; try reflexivity. rewrite subst_term_comp, subst_term_id; reflexivity.
  Qed.

  Lemma ZF_subst sigma :
    map (subst_form sigma) ZFeq' = ZFeq'.
  Proof.
    reflexivity.
  Qed.

  Lemma ZF_subst' sigma :
    (map (subst_form sigma) minZFeq') = minZFeq'.
  Proof.
    reflexivity.
  Qed.

  Lemma rm_const_shift_subst A :
    map (subst_form ↑) (map rm_const_fm A) = map rm_const_fm (map (subst_form ↑) A).
  Proof.
    erewrite map_map, map_ext, <- map_map. reflexivity. apply rm_const_fm_shift.
  Qed.

  Lemma rm_const_prv' { p : peirce } B phi :
    B ⊢ phi -> forall A, B = A ++ ZFeq' -> ([rm_const_fm p0 | p0 ∈ A] ++ minZFeq') ⊢ rm_const_fm phi.
  Proof.
    intros H. pattern p, B, phi. revert p B phi H. apply prv_ind_full; cbn; intros; subst.
    - apply II. now apply (H0 (phi::A0)).
    - eapply IE; eauto.
    - apply AllI. erewrite map_app, ZF_subst', rm_const_shift_subst. apply H0. now rewrite map_app, ZF_subst.
    - pose proof (rm_const_tm_prv t). eapply Weak in H1. apply (ExE H1). 2: auto.
      edestruct (nameless_equiv_ex ([rm_const_fm p | p ∈ A0] ++ minZFeq')) as [x ->]. specialize (H0 A0 eq_refl).
      apply (AllE x) in H0. apply rm_const_fm_swap with (x:=x); auto. apply (Weak H0). auto.
    - pose proof (rm_const_tm_prv t). eapply Weak in H1. apply (ExE H1). 2: auto.
      edestruct (nameless_equiv_ex ([rm_const_fm p | p ∈ A0] ++ minZFeq')) as [x ->]. specialize (H0 A0 eq_refl).
      apply (ExI x). apply <- rm_const_fm_swap; auto. apply (Weak H0). auto.
    - apply (ExE (H0 A0 eq_refl)). erewrite map_app, ZF_subst', rm_const_shift_subst, rm_const_fm_shift.
      apply (H2 (phi::[p[↑] | p ∈ A0])). cbn. now rewrite map_app, ZF_subst.
    - apply Exp. eauto.
    - apply in_app_iff in H as [H|H].
      + apply Ctx. apply in_app_iff. left. now apply in_map.
      + eapply Weak. now apply prv_to_min. auto.
    - apply CI; eauto.
    - eapply CE1; eauto.
    - eapply CE2; eauto.
    - eapply DI1; eauto.
    - eapply DI2; eauto.
    - eapply DE; try now apply H0.
      + now apply (H2 (phi::A0)).
      + now apply (H4 (psi::A0)).
    - apply Pc.
  Qed.

  Lemma rm_const_prv { p : peirce } A phi :
    (A ++ ZFeq') ⊢ phi -> ((map rm_const_fm A) ++ minZFeq') ⊢ rm_const_fm phi.
  Proof.
    intros H. now apply (rm_const_prv' H).
  Qed.

End Deduction.


Require Import utility.
Require Import PredomAux.
Require Import PredomSum.
Require Import untypedlambda.
Require Import untypeddensem.

Set Implicit Arguments.
Unset Strict Implicit.

(* Need this for nice pretty-printing *)
Unset Printing Implicit Defensive.

(*==========================================================================
  Semantics of substitution and renaming
  ==========================================================================*)

(* Apply semantic function pointwise to a renaming or substitution *)
Fixpoint SemSubst env env' : Subst env' env -> SemEnv env -c> SemEnv env' :=
  match env' with
  | O => fun s => K _ (tt : DOne)
  | S _ => fun s => <| SemSubst (tlMap s) , SemVal (hdMap s) |>
  end.

Fixpoint SemRenaming env env' : Renaming env' env -> SemEnv env -c> SemEnv env' :=
  match env' with
  | O  => fun s => K _ (tt : DOne)
  | S _ => fun s => <| SemRenaming (tlMap s) , SemVar (hdMap s) |>
  end.

Lemma SemLiftRenaming :
  forall env env' (r : Renaming env env'), SemRenaming (tlMap (liftRenaming r)) == SemRenaming r << FST.
Proof.
induction env. intros. simpl.
apply (DOne_final (K (Dprod (SemEnv env') VInf) (tt:DOne)) _).

intros.
simpl. destruct (consMapInv r) as [r' [var eq]].
subst. simpl. rewrite hdConsMap. rewrite tlConsMap.
specialize (IHenv env' r').
rewrite PROD_fun_comp. rewrite IHenv. auto.
Qed.

(*==========================================================================
  Semantic function commutes with renaming
  ==========================================================================*)

Implicit Arguments uncurry.
Add Parametric Morphism (D E F:cpo) : (@SUM_fun D E F)
with signature (@Oeq (D -c> F)) ==> (@Oeq (E -c> F)) ==> (@Oeq (Dsum D E -c> F))
as SUM_fun_eq_compat.
intros f0 f1 feq g0 g1 geq.
refine (fcont_eq_intro _).
intro d. case d. intro dl. rewrite SUM_fun_simpl. rewrite SUM_fun_simpl. simpl. auto.
intro dr. rewrite SUM_fun_simpl. rewrite SUM_fun_simpl. simpl. auto.
Qed.

Lemma SemCommutesWithRenaming:
   (forall env (v : Value env) env' (r : Renaming env env'),
   SemVal v << SemRenaming r == SemVal (renameVal r v))
/\ (forall env (exp : Exp env) env' (r : Renaming env env'),
   SemExp exp << SemRenaming r == SemExp (renameExp r exp)).
Proof.
apply ExpValue_ind.

(* VAR *)
intros env var env' r.
simpl.
induction var.
simpl. rewrite SND_PROD_fun.
destruct (consMapInv r) as [r' [v eq]]. subst.
simpl. rewrite hdConsMap. trivial.
destruct (consMapInv r) as [r' [v eq]]. subst.
simpl.
specialize (IHvar r').
rewrite <- IHvar. rewrite fcont_comp_assoc.
rewrite tlConsMap. rewrite FST_PROD_fun. trivial.

(* TNUM *)
intros. simpl. rewrite fcont_comp_assoc. rewrite <- K_com; trivial.

(* LAMBDA *)
intros E body IH E' s.
specialize (IH _ (liftRenaming s)).
rewrite renameLAMBDA.
simpl SemVal.
rewrite fcont_comp_assoc. rewrite fcont_comp_assoc. rewrite fcont_comp_assoc. rewrite fcont_comp_assoc.
rewrite Curry_comp. rewrite fcont_comp_assoc.
rewrite <- IH. rewrite PROD_map_fun. rewrite ID_comp_left. rewrite <- SemLiftRenaming. auto.

(* OP *)
intros env n v1 IH1 v2 IH2 env' s. rewrite renameOP. simpl.
repeat (rewrite fcont_comp_assoc). rewrite <- IH1. rewrite <- IH2.
Implicit Arguments INR [D1 D2]. Implicit Arguments INL [D1 D2]. Implicit Arguments uncurry [D E F].
rewrite PROD_fun_compr. rewrite PROD_fun_compr.
refine (fcont_comp_eq_compat _ _).
admit.

(* IFZ *)
intros env v IH e1 IH1 e2 IH2 env' s. rewrite renameIFZ. simpl.
repeat (rewrite fcont_comp_assoc). rewrite PROD_fun_compl.
rewrite (PROD_fun_eq_compat (fcont_comp_assoc _ _ _) (Oeq_refl _)).
rewrite (PROD_fun_eq_compat (fcont_comp_eq_compat (Oeq_refl _) (IH _ _) ) (Oeq_refl _)).
rewrite (PROD_fun_eq_compat (Oeq_refl _) (fcont_comp_unitL _)).
rewrite <- (PROD_fun_eq_compat (Oeq_refl _) (fcont_comp_unitR _)).

Lemma xx D E F G (f:E -C-> F -C-> G) (h:D -C-> F) (g: E -C-> D) :
          EV << PROD_fun f (h << g) ==
   EV << PROD_fun (curry (uncurry _ _ _ f << SWAP << PROD_map h ID << SWAP)) g.
intros ; apply fcont_eq_intro ; auto.
Qed.

rewrite xx. refine (fcont_comp_eq_compat (Oeq_refl _) _).
refine (PROD_fun_eq_compat _ (Oeq_refl _)). apply Oeq_sym.
refine (curry_unique _). rewrite fcont_comp_assoc.
apply fcont_eq_intro.
intros d. repeat (rewrite fcont_comp_simpl). case d ; clear d. intros ds dn.
repeat (rewrite PROD_map_simpl). rewrite ID_simpl. simpl. repeat (rewrite ID_simpl). simpl.
repeat (rewrite EV_simpl).  repeat (rewrite fcont_comp_simpl).
rewrite SUM_fun_simpl.
unfold VInf.
admit.

(* VAL *)
intros env v IH env' s. rewrite renameVAL. simpl. rewrite fcont_comp_assoc. rewrite IH. auto.

(* LET *)
intros env e2 IH2 e1 IH1 env' s. rewrite renameLET. simpl.
repeat (rewrite fcont_comp_assoc).
rewrite <- IH2. clear IH2.
rewrite <- IH1. clear IH1.
refine (fcont_comp_eq_compat _ _). trivial. simpl.
rewrite SemLiftRenaming.
rewrite PROD_fun_comp.
refine (PROD_fun_eq_compat _ _).
(*simpl.
rewrite Curry_comp. simpl. *)
rewrite PROD_map_fun.
rewrite KLEISLIR_comp.
rewrite ID_comp_left.
admit.  trivial.

(* APP *)
intros env v1 IH1 v2 IH2 env' s. rewrite renameAPP. simpl.
rewrite fcont_comp_assoc. rewrite <- IH1. rewrite <- IH2.
rewrite PROD_fun_comp. trivial.
Qed.

Set Printing Implicit Defensive.

Lemma SemShiftRenaming :
  forall env env' (r : Renaming env env'), SemRenaming (shiftRenaming r) == SemRenaming r << FST.
Proof.
induction env. intros. simpl.
apply (DOne_final (K (Dprod (SemEnv env') VInf) (tt:DOne)) _).

intros.
simpl. destruct (consMapInv r) as [r' [var eq]].
subst. simpl. rewrite hdConsMap. rewrite tlConsMap.
specialize (IHenv env' r').
rewrite PROD_fun_comp. rewrite IHenv. auto.
Qed.

Lemma SemIdRenaming : forall env, SemRenaming (idRenaming env) == ID.
Proof.
induction env.
simpl.
apply (DOne_final (K DOne _) _).

rewrite idRenamingDef. simpl SemRenaming. rewrite tlConsMap. rewrite SemShiftRenaming.
rewrite IHenv. rewrite ID_comp_left.
apply fcont_eq_intro. intros. destruct x.  auto.
Qed.

Lemma SemShiftSubst :
  forall env env' (s : Subst env env'), SemSubst (shiftSubst s) == SemSubst s << FST.
Proof.
induction env. intros. simpl.
apply (DOne_final (K (Dprod (SemEnv env') VInf) (tt:DOne)) _).

intros.
simpl. destruct (consMapInv s) as [s' [var eq]].
subst. simpl. rewrite hdConsMap. rewrite tlConsMap.
specialize (IHenv env' s').
rewrite PROD_fun_comp.
refine (PROD_fun_eq_compat _ _).
rewrite IHenv. auto. unfold shiftSubst.
rewrite shiftConsMap. rewrite hdConsMap.
simpl. rewrite <- (proj1 SemCommutesWithRenaming).
refine (fcont_comp_eq_compat _ _). trivial.
(* Seems a bit round-about *)
assert ((fun t0 => SVAR t0) = tlMap (liftRenaming (idRenaming env'))).
rewrite LiftRenamingDef. rewrite tlConsMap. apply MapExtensional.   auto.
rewrite H.
rewrite SemLiftRenaming. rewrite SemIdRenaming. rewrite ID_comp_left. auto.
Qed.

Lemma SemLiftSubst :
  forall env env' (s : Subst env env'), SemSubst (tlMap (liftSubst s)) == SemSubst s << FST.
Proof.
intros.
rewrite LiftSubstDef. rewrite tlConsMap. apply SemShiftSubst.
Qed.

(*==========================================================================
  Semantic function commutes with substitution
  ==========================================================================*)

Lemma SemCommutesWithSubst:
   (forall env (v : Value env) env' (s : Subst env env'),
   SemVal v << SemSubst s == SemVal (substVal s v))
/\ (forall env (e : Exp env) env' (s : Subst env env'),
   SemExp e << SemSubst s == SemExp (substExp s e)).
Proof.
apply ExpVal_ind.

(* TINT *)
intros. simpl. rewrite <- K_com; trivial.

(* TBOOL *)
intros. simpl. rewrite <- K_com; trivial.

(* TVAR *)
intros env ty var env' s.
simpl.
unfold substVal. simpl travVal.
induction var. simpl.   rewrite SND_PROD_fun.
destruct (consMapInv s) as [s' [v eq]]. subst.
simpl. rewrite hdConsMap. trivial.
destruct (consMapInv s) as [s' [v eq]]. subst.
simpl.
specialize (IHvar s').
rewrite <- IHvar. rewrite fcont_comp_assoc.
rewrite tlConsMap. rewrite FST_PROD_fun. trivial.

(* TFIX *)
intros E t t1 body IH E' s. rewrite substTFIX. simpl.
rewrite fcont_comp_assoc.
rewrite Curry_comp. rewrite Curry_comp. rewrite <- IH.
clear IH. simpl. rewrite PROD_map_fun. rewrite PROD_map_fun. rewrite ID_comp_left. rewrite ID_comp_left.
rewrite SemLift2Subst. rewrite fcont_comp_assoc. rewrite PROD_fun_comp. rewrite fcont_comp_assoc. trivial.

(* TPAIR *)
intros E t1 t2 v1 IH1 v2 IH2 E' s. rewrite substTPAIR. simpl.
rewrite <- IH1. rewrite <- IH2. rewrite PROD_fun_comp. trivial.

(* TFST *)
intros E t1 t2 v IH E' s. rewrite substTFST. simpl.
rewrite <- IH. repeat (rewrite fcont_comp_assoc). trivial.

(* TSND *)
intros E t1 t2 v IH E' s. rewrite substTSND. simpl.
rewrite <- IH. repeat (rewrite fcont_comp_assoc). trivial.

(* TOP *)
intros E n v1 IH1 v2 IH2 E' s. rewrite substTOP. simpl.
repeat (rewrite fcont_comp_assoc). rewrite <- IH1. rewrite <- IH2.
rewrite PROD_fun_comp. trivial.

(* TGT *)
intros E v1 IH1 v2 IH2 E' s. rewrite substTGT. simpl.
repeat (rewrite fcont_comp_assoc). rewrite <- IH1. rewrite <- IH2.
rewrite PROD_fun_comp. trivial.

(* TVAL *)
intros E t v IH E' s. rewrite substTVAL. simpl.
rewrite <- IH. rewrite fcont_comp_assoc. trivial.

(* TLET *)
intros E t1 t2 e2 IH2 e1 IH1 E' s. rewrite substTLET. simpl.
rewrite fcont_comp_assoc.
specialize (IH2 _ s).
specialize (IH1 _ (liftSubst _ s)).
rewrite PROD_fun_comp.
rewrite KLEISLIR_comp.
rewrite <- IH2. clear IH2. rewrite <- IH1. clear IH1. simpl.
rewrite PROD_map_fun. rewrite ID_comp_left. rewrite ID_comp_left. rewrite SemLiftSubst.  trivial.

(* TAPP *)
intros E t1 t2 v1 IH1 v2 IH2 E' s. rewrite substTAPP. simpl.
rewrite fcont_comp_assoc. rewrite <- IH1. rewrite <- IH2.
rewrite PROD_fun_comp. trivial.

(* TIF *)
intros E t ec IHc te1 IH1 te2 IH2 E' s. rewrite substTIF. simpl.
rewrite fcont_comp3_comp.
rewrite <- IHc. rewrite <- IH1. rewrite <- IH2. trivial.
Qed.


Require Coq.Lists.List.

Definition head := List.head.
Definition tail := List.tail.
Definition map := List.map.

Arguments cons {A} _ _.
Arguments app {A} _ _ .
Arguments length {A} _.
Arguments head {A} _.
Arguments tail {A} _.
Arguments map {A B} _ _.

Module ListNotation.
  Infix "++" := app.
  Infix "::" := cons.
  Notation "[ ]" := nil.
  Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..).
End ListNotation.
Import ListNotation.

Fixpoint foldl {A R} (f:R -> A -> R) (i:R) (xs:list A) :=
  match xs with
  | nil => i
  | x::xs' => foldl f (f i x) xs'
  end.

Fixpoint foldr {A R} (f:A -> R -> R) (i:R) (xs:list A) :=
  match xs with
  | nil => i
  | x::xs' => f x (foldr f i xs')
  end.

Definition for_each {A B} : list A -> (A -> B) -> list B := fun x y => map y x.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)
(* Zm.v, by Vince Barany *)

Require Export CoRN.model.Zmod.ZMod.
Require Export CoRN.algebra.CFields.

(**
* Zm
Let m be a positive integer.
We will look at the integers modulo m and prove that they form a ring.
Eventually we will proof that Zp is even a field for p prime.
*)

(* Definition of rings Zm  *)

Open Scope Z_scope.

Section zm.

Variable m:positive.

Lemma m_gt_0 : m>0.
Proof.
 red; simpl; reflexivity.
Qed.
(* This was a "Local"! *)

(**
** Zm is a CSetoid
*)

Section zm_setoid.

Definition ZModeq (a b:Z) : Prop := (Zmodeq m a b).
Definition ZModap (a b:Z) : CProp := (Not (Zmodeq m a b)).

Lemma Zmodeq_wd : forall a b:Z, a=b -> a mod m = b mod m.
Proof.
 intros a b Heq.
 elim Heq.
 auto.
Qed.

Lemma Zmodap_irreflexive: (irreflexive ZModap).
Proof.
 red.
 intro x.
 intro H.
 elim H.
 apply Zmodeq_refl.
Qed.

Lemma Zmodap_symmetric: (Csymmetric ZModap).
Proof.
 red.
 intros x y H.
 intro H0.
 elim H.
 apply Zmodeq_symm.
 exact H0.
Qed.

Lemma Zmodap_cotransitive: (cotransitive ZModap).
Proof.
 red.
 intros x y H.
 intros z.
 elim (Zmodeq_dec m x z).
  elim (Zmodeq_dec m y z).
   intros Hyz Hxz.
   elim H.
   apply (Zmodeq_trans _ _ _ _ Hxz (Zmodeq_symm _ _ _ Hyz)).
  intros _ Hxz.
  right.
  intro Hzy.
  apply H.
  apply (Zmodeq_trans _ _ _ _ Hxz Hzy).
 intro H_xz.
 left.
 intro Hxz.
 elim H_xz.
 exact Hxz.
Qed.

Lemma Zmodap_tight_apart: (tight_apart ZModeq ZModap).
Proof.
 red.
 intros x y.
 split.
  elim (Zmodeq_dec m x y).
   intros H Hnn.
   exact H.
  intros Hn Hnn.
  elim Hnn.
  intro H.
  elim Hn.
  exact H.
 intro H.
 intro Hnn.
 elim Hnn.
 exact H.
Qed.

(* Begin_Tex_Verb *)
Lemma Zm_is_CSetoid : (is_CSetoid _ ZModeq ZModap).
Proof.
 (* End_Tex_Verb *)
 apply Build_is_CSetoid.
    exact Zmodap_irreflexive.
   exact Zmodap_symmetric.
  exact Zmodap_cotransitive.
 exact Zmodap_tight_apart.
Qed.

(* Begin_Tex_Verb *)
Definition Zm_csetoid :=
                    (Build_CSetoid Z ZModeq ZModap Zm_is_CSetoid).
(* End_Tex_Verb *)

End zm_setoid.

(**
** Zm is a CAbGroup
*)

Section zm_group.

Definition Zm_plus (a b:Zm_csetoid) : Zm_csetoid := (a+b).
 (* ? `((a%m)+(b%m))%m` ? *)

(* Begin_Tex_Verb *)
Lemma Zm_plus_strext : (bin_fun_strext _ _ _ Zm_plus).
Proof.
 (* End_Tex_Verb *)
 red.
 intros.
 elim (Zmodeq_dec m x1 x2).
  elim (Zmodeq_dec m y1 y2).
   intros Hyeq Hxeq.
   elim X.
   auto with zarith.
  intros Hyneq _.
  right.
  intro Hyeq.
  elim Hyneq.
  exact Hyeq.
 intros Hxneq.
 left.
 intro Hxeq.
 elim Hxneq.
 exact Hxeq.
Qed.

(* Begin_Tex_Verb *)
Lemma Zm_plus_wd : (bin_fun_wd _ _ _ Zm_plus).
Proof.
 (* End_Tex_Verb *)
 apply bin_fun_strext_imp_wd.
 exact Zm_plus_strext.
Qed.

(* Begin_Tex_Verb *)
Definition Zm_plus_op :=
  (Build_CSetoid_bin_op _ _ Zm_plus_strext).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Zm_plus_associative : (associative Zm_plus_op).
Proof.
 (* End_Tex_Verb *)
 red.
 intros x y z.
 simpl.
 unfold ZModeq.
 unfold Zm_plus.
 rewrite Zplus_assoc.
 apply Zmodeq_refl.
Qed.

(* Begin_Tex_Verb *)
Definition Zm_csemi_grp :=
    (Build_CSemiGroup Zm_csetoid Zm_plus_op Zm_plus_associative).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Zm_plus_zero_rht: (is_rht_unit Zm_plus_op 0).
Proof.
 (* End_Tex_Verb *)
 red; simpl.
 intros.
 unfold ZModeq.
 unfold Zm_plus.
 rewrite Zplus_0_r.
 auto with zarith.
Qed.

(* Begin_Tex_Verb *)
Lemma Zm_plus_zero_lft: (is_lft_unit Zm_plus_op 0).
Proof.
 (* End_Tex_Verb *)
 red; simpl.
 intros.
 unfold ZModeq.
 auto with zarith.
Qed.

(* Begin_Tex_Verb *)
Lemma Zm_plus_commutes: (commutes Zm_plus_op).
Proof.
 (* End_Tex_Verb *)
 red; simpl.
 intros.
 unfold ZModeq.
 unfold Zm_plus.
 rewrite Zplus_comm.
 auto with zarith.
Qed.

(* Begin_Tex_Verb *)
Definition Zm_is_CMonoid :=
    (Build_is_CMonoid Zm_csemi_grp 0 Zm_plus_zero_rht Zm_plus_zero_lft).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition Zm_cmonoid := (Build_CMonoid _ _ Zm_is_CMonoid).
(* End_Tex_Verb *)

(* Tex_Prose
\subsection{Integers modulo m form a group}
*)

(* Begin_Tex_Verb *)
Definition Zm_opp (x:Zm_cmonoid) : Zm_cmonoid := -x.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Zm_opp_strext : (un_op_strext _ Zm_opp).
Proof.
 (* End_Tex_Verb *)
 red; red; simpl.
 intros x y.
 unfold ZModeq; unfold ZModap; unfold Zm_plus; unfold Zm_opp.
 intro Hneq.
 intro Heq.
 apply Hneq.
 apply Zmodeq_opp_elim.
 exact Heq.
Qed.

(* Begin_Tex_Verb *)
Lemma Zm_opp_well_def : (un_op_wd _ Zm_opp).
Proof.
 (* End_Tex_Verb *)
 unfold un_op_wd.
 apply fun_strext_imp_wd.
 exact Zm_opp_strext.
Qed.

(* Begin_Tex_Verb *)
Definition Zm_opp_op :=
  (Build_CSetoid_un_op _ _ Zm_opp_strext).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Zm_is_CGroup : (is_CGroup _ Zm_opp_op).
Proof.
 (* End_Tex_Verb *)
 unfold is_CGroup.
 unfold is_inverse.
 simpl.
 unfold ZModeq; unfold Zm_plus; unfold Zm_opp.
 intro.
 rewrite Zplus_opp_r.
 rewrite Zplus_opp_l.
 auto with zarith.
Qed.

(* Begin_Tex_Verb *)
Definition Zm_cgroup := (Build_CGroup _ _ Zm_is_CGroup).
(* End_Tex_Verb *)

Lemma Zm_is_CAbGroup : (is_CAbGroup Zm_cgroup).
Proof.
 unfold is_CAbGroup.
 exact Zm_plus_commutes.
Qed.

Definition Zm_cabgroup := (Build_CAbGroup _ Zm_is_CAbGroup).

End zm_group.

(**
** Zm is a CRing
*)

Section zm_ring.

Hypothesis Hnontriv: ~(m=xH).

Lemma m_gt_1: m>1.
Proof.
 unfold Z.gt.
 generalize Hnontriv.
 case m; simpl; intros; auto.
 elim Hnontriv0; auto.
Qed.

(* Dit was een Local! *)

Section zm_def.

(* Begin_Tex_Verb *)
Definition Zm_mult (x y:Zm_cabgroup) : Zm_cabgroup := x*y.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Zm_mult_strext : (bin_fun_strext _ _ _ Zm_mult).
Proof.
 (* End_Tex_Verb *)
 red; simpl.
 unfold ZModap;unfold Zm_mult; simpl.
 intros x1 x2 y1 y2.
 intro H.
 elim (Zmodeq_dec m x1 x2).
  elim (Zmodeq_dec m y1 y2).
   intros Hyeq Hxeq.
   elim H.
   apply Zmodeq_mult_elim; auto with zarith.
  intros Hyneq _.
  right.
  intro Hyeq.
  elim Hyneq.
  exact Hyeq.
 intros Hxneq.
 left.
 intro Hxeq.
 elim Hxneq.
 exact Hxeq.
Qed.

(* Begin_Tex_Verb *)
Lemma Zm_mult_wd : (bin_fun_wd _ _ _ Zm_mult).
Proof.
 (* End_Tex_Verb *)
 apply bin_fun_strext_imp_wd.
 exact Zm_mult_strext.
Qed.

(* Begin_Tex_Verb *)
Definition Zm_mult_op := (Build_CSetoid_bin_op _ _ Zm_mult_strext).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Zm_mult_assoc : (associative Zm_mult_op).
Proof.
 (* End_Tex_Verb *)
 unfold associative.
 intros x y z.
 simpl.
 unfold ZModeq; unfold Zm_mult.
 rewrite Zmult_assoc.
 apply Zmodeq_refl.
Qed.

(* Begin_Tex_Verb *)
Lemma Zm_mult_commutative:  forall x y:Zm_cabgroup,
           (Zm_mult_op x y) [=] (Zm_mult_op y x).
Proof.
 (* End_Tex_Verb *)
 intros x y.
 simpl.
 unfold ZModeq; unfold Zm_mult.
 rewrite Zmult_comm.
 apply Zmodeq_refl.
Qed.

(* Begin_Tex_Verb *)
Lemma Zm_mult_one : forall x:Zm_cabgroup, (Zm_mult_op x 1)[=]x.
Proof.
 (* End_Tex_Verb *)
 intro.
 simpl.
 unfold ZModeq; unfold Zm_mult.
 rewrite Zmult_1_r.
 apply Zmodeq_refl.
Qed.

Lemma Zm_mult_onel : forall x:Zm_cabgroup, (Zm_mult_op 1 x)[=]x.
Proof.
 intro.
 astepl (Zm_mult_op x 1).
  exact (Zm_mult_one x).
 exact (Zm_mult_commutative x 1).
Qed.

Definition Zm_mult_semigroup := (Build_CSemiGroup Zm_csetoid Zm_mult_op Zm_mult_assoc).

Lemma Zm_mult_one_r : is_rht_unit Zm_mult_op 1.
Proof.
 red.
 exact Zm_mult_one.
Qed.

Lemma Zm_mult_one_l : is_lft_unit Zm_mult_op 1.
Proof.
 red.
 exact Zm_mult_onel.
Qed.

(* Begin_Tex_Verb *)
Lemma Zm_mult_monoid: (is_CMonoid Zm_mult_semigroup 1).
Proof.
 (* End_Tex_Verb *)
 apply Build_is_CMonoid.
  exact Zm_mult_one_r.
 exact Zm_mult_one_l.
Qed.

(* Begin_Tex_Verb *)
Lemma Zm_mult_plus_dist : (distributive Zm_mult_op Zm_plus_op).
Proof.
 (* End_Tex_Verb *)
 red; simpl.
 intros x y z.
 unfold ZModeq; unfold Zm_mult; unfold Zm_plus.
 rewrite <-Zmult_plus_distr_r.
 apply Zmodeq_refl.
Qed.

(* Begin_Tex_Verb *)
Lemma Zm_non_triv : (ZModap 1 0).
Proof.
 (* End_Tex_Verb *)
 unfold ZModap.
 intro Hfalse.
 generalize (Zmodeq_modeq _ _ _ Hfalse).
 rewrite Zmod_zero_lft.
 rewrite Zmod_one_lft; auto.
  intro H.
  assert False. discriminate. elim H0.
   (* Discriminate in itself caused an error in Coq *)
   exact m_gt_1.
Qed.

(* Begin_Tex_Verb *)
Lemma Zm_is_CRing : (is_CRing Zm_cabgroup 1 Zm_mult_op).
Proof.
 (* End_Tex_Verb *)
 apply Build_is_CRing with Zm_mult_assoc.
    exact Zm_mult_monoid.
   exact Zm_mult_commutative.
  exact Zm_mult_plus_dist.
 exact Zm_non_triv.
Qed.

End zm_def.

(* Begin_Tex_Verb *)
Definition Zm_cring :=  (Build_CRing _ _ _ Zm_is_CRing) : CRing.
Definition Zm := Zm_cring.
(* End_Tex_Verb *)

Section zm_ring_basics.

Definition Zm_mult_ord (a:Zm)(h:nat) := (a[^]h[=][1]) /\
  forall k:nat, (lt k h)->~(a[^]k[=][1]).

End zm_ring_basics.

End zm_ring.

(**
** Zp is a field
From now on m is prime.
*)

Section zp_def.

(* Dit was een Local!!! *)
Hypothesis Hprime: (Prime m).

Lemma p_not_1: ~m=xH.
Proof.
 unfold Prime in Hprime.
 elim Hprime; intros; assumption.
Qed.

Lemma p_gt_0: m>0.
Proof.
 red; simpl; reflexivity.
Qed.

Lemma p_gt_1: m>1.
Proof.
 unfold Z.gt.
 generalize p_not_1.
 case m; simpl; intro H; auto.
 elim H; auto.
Qed.

Definition Zp := (Zm p_not_1).

(**
*** The inverse element in Zp
Let x in Zp, such that x is apart from [0].
Then we will show that there is an inverse element y such that
x[*]y [=] [1] in Zp.
*)

Section zp_nonzero.

Variable x: Zp.
Hypothesis Hx: x[#][0].

Lemma Zp_nonz_mod: 0<(Zmod x m)<m.
Proof.
 generalize (Z_mod_lt x m); intro H; elim H; clear H; intros.
  split.
   elim (Zlt_asymmetric (Zmod x m) 0).
    intro Hfalse; elim Hx; elim Hfalse; clear Hfalse; intro Hfalse.
     elim H; apply Z.lt_gt; auto.
    simpl; rewrite <-Hfalse; auto with zarith.
   apply Z.gt_lt.
  assumption.
 exact p_gt_0.
Qed.

Lemma Zp_nonz_relprime: (Zrelprime x m).
Proof.
 simpl in Hx.
 unfold ZModap in Hx; unfold ZModeq in Hx.
 elim Zp_nonz_mod; intros Hxmod0 Hxmodp.
 unfold Zrelprime.
 rewrite <-Zgcd_mod_lft; auto.
  generalize Hxmod0.
  set (d:=(Zmod x m)).
  cut (d=(Zmod x m)).
   case d.
     intros _ Hfalse; elim (Zlt_irref _ Hfalse).
    intros D HD _.
    rewrite <-HD in Hxmodp.
    rewrite Zgcd_symm.
    elim (prime_rel_prime m Hprime D Hxmodp); auto.
   intros D _ Hfalse; elim (Zge_0_NEG _ Hfalse).
  auto.
 exact p_gt_0.
Qed.

End zp_nonzero.

(* Begin_Tex_Verb *)
Definition Zp_inv (x:Zp)(Hx:(x[#][0])) : Zp := (Zgcd_coeff_a x m).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Zp_inv_strext : forall (x y:Zp)(x_ y_:_), (((Zp_inv x x_)[#](Zp_inv y y_))->(x[#]y)).
Proof.
 (* End_Tex_Verb *)
 intros x y Hx Hy.
 simpl.
 unfold ZModap; unfold Zp_inv.
 intro Hinv.
 intro Heq.
 generalize (Zmodeq_modeq _ _ _ Heq); clear Heq; intro Heq.
 elim Hinv.
 apply Zmodeq_eqmod.
 generalize (Zmod_relprime_inv m x p_gt_1 (Zp_nonz_relprime x Hx)).
 rewrite <- (Zmod_relprime_inv m y p_gt_1 (Zp_nonz_relprime y Hy)).
 rewrite (Zmod_mult_compat m x); auto.
  rewrite (Zmod_mult_compat m y); auto.
   (*unfold p.*)
   rewrite Heq.
   rewrite <-Zmod_mult_compat; auto.
    rewrite <-Zmod_mult_compat; auto.
     intro Hmult.
     apply (Zmod_mult_elim_lft _ _ _ _ p_gt_0 (Zp_nonz_relprime y Hy) Hmult).
    exact m_gt_0.
   exact m_gt_0.
  exact p_gt_0.
 exact p_gt_0.
Qed.

(* Begin_Tex_Verb *)
Lemma Zp_is_CField: (is_CField Zp Zp_inv).
Proof.
 (* End_Tex_Verb *)
 red; red.
 intros x.
 simpl; unfold ZModap; unfold ZModeq; unfold Zm_mult; unfold Zp_inv.
 intros Hx.
 elim (Zp_nonz_mod x Hx); intros Hxmod0 Hxmodp.
 split.
  apply Zmodeq_eqmod.
  rewrite Zmod_one_lft; auto.
   (*rewrite <-Zmod_mult_compat; auto.*)
   (*rewrite Zmod_Zmod; auto.*)
   apply Zmod_relprime_inv; auto.
    exact p_gt_1.
   apply Zrelprime_symm.
   unfold Zrelprime.
   rewrite <-Zgcd_mod_rht; auto.
    generalize Hxmod0.
    set (d:=(Zmod x m)).
    cut (d=(Zmod x m)); auto.
    case d.
      intros _ Hfalse; elim (Zlt_irref _ Hfalse).
     intros D HD _.
     rewrite <-HD in Hxmodp.
     (*fold p;*)
     (*rewrite <-HD.*)
     elim (prime_rel_prime m Hprime D Hxmodp); auto.
    intros D _ Hfalse; elim (Zge_0_NEG _ Hfalse).
   exact p_gt_0.
  exact p_gt_1.
 (*rewrite Zm_mult_commutative.*)
 apply Zmodeq_eqmod.
 rewrite Zmod_one_lft; auto.
  cut ((x * Zgcd_coeff_a x m) mod m = 1).
   intro H; elim H.
   apply Zmodeq_wd.
   apply Zmult_comm.
  apply Zmod_relprime_inv; auto.
   exact p_gt_1.
  apply Zrelprime_symm.
  unfold Zrelprime.
  rewrite <-Zgcd_mod_rht; auto.
   generalize Hxmod0.
   set (d:=(Zmod x m)).
   cut (d=(Zmod x m)); auto.
   case d.
     intros _ Hfalse; elim (Zlt_irref _ Hfalse).
    intros D HD _.
    rewrite <-HD in Hxmodp.
    (*fold p; rewrite <-HD.*)
    elim (prime_rel_prime m Hprime D Hxmodp); auto.
   intros D _ Hfalse; elim (Zge_0_NEG _ Hfalse).
  exact p_gt_0.
 exact p_gt_1.
Qed.

(* Begin_Tex_Verb *)
Definition Fp : CField := (Build_CField _ _ Zp_is_CField Zp_inv_strext).
(* End_Tex_Verb *)

Definition Fp_inv (x:Fp)(Hx:x[#][0]) : Fp := (Zp_inv x Hx).

End zp_def.

(* Basic properties of Zp *)

Section zp_prop.

End zp_prop.

End zm.