Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj12eqsynthconj4 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv1 (plus Zero lv0))).
Admitted.
QuickChick conj12eqsynthconj4.


Require Import Coq.Program.Equality.
Require Export DeclarationEvaluation.
Set Implicit Arguments.

(******************************************************************************)
(* Progress                                                                   *)
(******************************************************************************)

Lemma can_form_tarr {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tarr T1 T2)) :
  ∃ t2, t = abs T1 t2.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma can_form_tall {Γ t T} (v: Value t) (wt: Typing Γ t (tall T)) :
  ∃ t1, t = tabs t1.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma can_form_texist {Γ t T} (v: Value t) (wt: Typing Γ t (texist T)) :
  ∃ T11 t12, t = pack T11 t12 (texist T).
Proof.
  depind wt; try contradiction; exists U, t2; reflexivity.
Qed.

Lemma progress {t U} (wt: Typing empty t U) :
  Value t ∨ ∃ t', red t t'.
Proof with try (subst; eauto using red).
  depind wt; simpl; auto.
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
    destruct (can_form_tarr v1 wt1)...
  - destruct IHwt as [vt|[t1' r1]]...
    destruct (can_form_tall vt wt)...
  - destruct IHwt as [vt|[t1' r1]]...
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct (can_form_texist v1 wt1) as [? [? ?]]...
Qed.

(******************************************************************************)
(* Preservation                                                               *)
(******************************************************************************)

Lemma preservation {Γ t U} (wt: Typing Γ t U) :
  ∀ {t'}, red t t' → Typing Γ t' U.
Proof.
  induction wt; intros t' r; inversion r; subst; eauto using Typing.
  - inversion wt1; eauto using subst_evar_Typing with subst.
  - inversion wt; eauto using subst_etvar_Typing with subst.
  - inversion wt1; subst; clear wt1; rewrite tsubstTm_substTm0_comm; isimpl.
    eapply subst_evar_Typing; eauto with infra.
    generalize (subst_etvar_Typing _ _ H37 _ _ _ wt2
                 (evar G (tsubstTy X0 T11 T12)) (XS tm X0)).
    isimpl; eauto with infra.
Qed.


Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export unfolding.

Lemma wf_typ_from_wf_env_typ : forall x T E,
  wf_env (x ~ bind_typ T ++ E) ->
  WF E T.
Proof with auto.
  intros x T E H.
  dependent destruction H...
Qed.

Lemma wf_typ_from_binds_typ : forall x U E,
  wf_env E ->
  binds x (bind_typ U) E ->
  WF E U.
Proof with auto.
  induction 1; intros J; analyze_binds J...
  apply IHwf_env in BindsTac.
  rewrite_alist (nil ++ [(X, bind_sub)] ++ E).
  apply wf_weakening...
  injection BindsTacVal; intros; subst...
  rewrite_alist (nil ++ [(x0, bind_typ T)] ++ E).
  apply wf_weakening...
  rewrite_alist (nil ++ [(x0, bind_typ T)] ++ E).
  apply wf_weakening...
Qed.

Lemma wf_typ_strengthening : forall E F x U T,
 WF (F ++ x ~ bind_typ U ++ E) T ->
 WF (F ++ E) T.
Proof with simpl_env; eauto.
  intros E F x U T H.
  remember (F ++ x ~ bind_typ U ++ E) as G.
  generalize dependent F.
  induction H; intros F Heq; subst...
  analyze_binds H...
  apply WF_rec with (L:=L).
  intros.
  rewrite_alist (([(X, bind_sub)] ++ F) ++ E).
  apply H0...
  intros.
  rewrite_alist (([(X, bind_sub)] ++ F) ++ E).
  apply H2...
Qed.

Lemma wf_env_strengthening : forall x T E F,
  wf_env (F ++ x ~ bind_typ T ++ E) ->
  wf_env (F ++ E).
Proof with eauto using wf_typ_strengthening.
  induction F; intros Wf_env; inversion Wf_env; subst; simpl_env in *...
Qed.

Lemma  subst_tt_rt_type_v2 : forall E1 E2 m A B X,
    WF (E1 ++ E2) A  ->
    rt_type  B ->
    WF (E1 ++ (X~m) ++ E2) B ->
    rt_type  (subst_tt X A B).
Proof with auto.
  intros.
  dependent induction H0...
  dependent destruction H1...
  simpl...
Qed.

Lemma subst_tt_wf2_v2 : forall E1 E2 m A B X,
    WF (E1 ++ E2) A  ->
    WF (E1 ++ (X ~ m) ++ E2) B ->
    WF (E1 ++ E2) (subst_tt X A B).
Proof with auto.
  intros.
  dependent induction H0;simpl in *;try solve [constructor;eauto]...
    +
      destruct (X0==X)...
      analyze_binds H0...
    +
      assert (type A).
      get_type...
      apply WF_rec with (L:=L \u {{X}} \u fv_tt A);intros...
      rewrite_alist ( ((X0 ~ bind_sub) ++ E1 )++ E2).
      rewrite subst_tt_open_tt_var...
      apply H0 with (m0:=m)...
      rewrite_alist (nil ++ (X0 ~ bind_sub) ++ (E1 ++ E2)).
      apply wf_weakening...
      rewrite subst_tt_open_tt_var...
      rewrite <- subst_tt_open_tt...
      rewrite_alist ( ((X0 ~ bind_sub) ++ E1 )++ E2).
      apply H2 with (m0:=m)...
      rewrite_alist (nil ++ (X0 ~ bind_sub) ++ (E1 ++ E2)).
      apply wf_weakening...
    +
      constructor...
      apply IHWF1 with (m0:=m)...
      apply IHWF2 with (m0:=m)...
      eapply subst_tt_rt_type_v2 with (m:=m);eauto.
      eapply subst_tt_collect...
      eauto.
Qed.

Lemma wf_open_type: forall A G,
    WF G (typ_mu A) -> WF G (open_tt A (typ_mu A)).
Proof with auto.
  intros.
  dependent destruction H.
  pick fresh X.
  rewrite subst_tt_intro with (X:=X)...
  rewrite_alist (nil ++ E).
  apply subst_tt_wf2_v2 with (m:=bind_sub)...
  simpl.
  apply WF_rec with (L:=L)...
  simpl...
  apply H...
Qed.

Lemma typing_regular : forall E e T,
  typing E e T ->
  wf_env E /\ expr e /\ WF E T.
Proof with auto.
  intros.
  dependent induction H;simpl in *;destructs_hypos...
  -
    repeat split...
    apply wf_typ_from_binds_typ with (x:=x)...
  -
    split.
    pick fresh Y.
    specialize_x_and_L Y L.
    destructs_hypos.
    dependent destruction H0...
    split...
    apply lc_abs with (L:=L)...
    intros.
    apply H0...
    pick fresh X.
    specialize_x_and_L X L.
    destructs_hypos.
    dependent destruction H0...
    get_type...
    pick fresh X.
    specialize_x_and_L X L.
    destructs_hypos.
    dependent destruction H0...
    constructor...
    add_nil.
    apply wf_typ_strengthening with (x:=X) (U:=T1)...
  -
    dependent destruction H6.
    repeat split...
  -
    split...
    split...
    apply lc_fold...
    get_type...
  -
    split...
    split...
    apply lc_unfold...
    get_type...
    apply wf_open_type...
  -
    repeat split...
    get_well_form...
  -
    repeat split...
    apply wf_rcd_lookup with (i:=i) (T:=T)...

Qed.

Lemma typing_weakening: forall E1 E2 E3 e T,
    typing (E1 ++ E3) e T ->
    wf_env (E1 ++ E2 ++ E3) ->
    typing (E1 ++ E2 ++ E3) e T.
Proof with simpl_env; eauto using wf_typ_from_wf_env_typ.
  intros.

  remember (E1 ++ E3) as Ht.
  generalize dependent E1.
  induction H;intros;subst...
  -
    apply typing_abs with (L:=L \u dom E1 \u dom E2 \u dom E3).
    intros.
    rewrite_alist (([(x, bind_typ T1)] ++ E1) ++ E2 ++ E3).
    apply H0...
    rewrite_alist ([(x, bind_typ T1)] ++ E1 ++ E2 ++ E3).
    constructor...
    assert (x \notin L) by auto.
    apply H in H3.
    apply typing_regular  in H3.
    destruct H3.
    dependent destruction H3.
    apply wf_weakening...
  -
    apply typing_fold...
    apply wf_weakening...
  -
    apply typing_sub with (S:=S).
    apply IHtyping...
    apply Sub_weakening...
Qed.

Lemma uniq_from_wf_env : forall E,
  wf_env E ->
  uniq E.
Proof.
  intros E H; induction H; auto.
Qed.

Lemma strengthening_wfs_typ: forall E1 E2 S X T,
    WF (E1 ++ X ~ bind_typ S ++ E2) T->
    WF (E1 ++ E2) T.
Proof with auto.
  intros.
  dependent induction H;try solve [constructor;eauto]...
  -
    analyze_binds H...
  -
    apply WF_rec with (L:=L \u {{X}});intros.
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ E2).
    apply H0 with (X1:=X) (S0:=S)...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ E2).
    apply H2 with (X1:=X) (S0:=S)...
Qed.

Lemma strengthening_sub_typ: forall E1 E2 A B X T,
    Sub (E1 ++ X ~ bind_typ T ++ E2) A B ->
    wf_env  (E1 ++ E2 ) ->
    Sub (E1 ++ E2) A B.
Proof with auto.
  intros.
  dependent induction H;try solve [constructor;eauto]...
  -
    constructor...
    analyze_binds H0...
  -
    constructor...
    apply strengthening_wfs_typ with (X:=X) (S:=T) ...
  -
    apply S_rec with (L:=L \u {{X}} \u dom (E1 ++ E2));intros.
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ E2).
    apply H0 with (X1:=X) (T0:=T)...
    rewrite_alist ([(X0, bind_sub)] ++ E1 ++ E2).
    constructor...
    rewrite_alist (([(X0, bind_sub)] ++ E1) ++ E2).
    apply H2 with (X1:=X) (T0:=T)...
    rewrite_alist ([(X0, bind_sub)] ++ E1 ++ E2).
    constructor...
  -
    apply S_rcd...
    apply strengthening_wfs_typ with (X:=X) (S:=T) ...
    apply strengthening_wfs_typ with (X:=X) (S:=T) ...
    intros.
    eapply H6 with (i:=i)...
Qed.

Lemma  subst_tt_rt_expr : forall   A B X,
    rt_expr  B ->
    expr A  ->
    expr B ->
    rt_expr  (subst_ee X A B).
Proof with auto.
  intros.
  induction H...
  dependent destruction H1...
  simpl...
Qed.

Ltac get_expr :=
    repeat match goal with
    | [ H : typing _ _ _ |- _ ] => apply typing_regular in H;destructs_hypos
           end.

Lemma typing_through_subst_ee : forall F U E x T e u,
  typing (F ++ x ~ bind_typ U ++ E) e T ->
  typing E u U ->
  typing (F ++ E) (subst_ee x u e) T.
Proof with eauto.
  intros.
  remember (F ++ x ~ bind_typ U ++ E) as E'.
  generalize dependent F.
  induction H;intros;subst;simpl in *...
  -
    constructor...
    apply wf_env_strengthening in H...
  -
    destruct (x0==x)...
    subst...
    analyze_binds_uniq H1...
    apply uniq_from_wf_env...
    injection BindsTacVal; intros; subst.
    rewrite_alist (nil ++ F ++ E).
    apply typing_weakening...
    simpl.
    apply wf_env_strengthening in H...
    analyze_binds H1...
    constructor...
    apply wf_env_strengthening in H...
    constructor...
    apply wf_env_strengthening in H...
  -
    apply typing_abs with (L:=L \u {{x}})...
    intros.
    rewrite subst_ee_open_ee_var...
    rewrite_alist (([(x0, bind_typ T1)] ++ F) ++ E).
    apply H1...
    apply typing_regular in H0...
    apply H0.
  -
    apply typing_fold...
    rewrite_alist ( (F ++ (x ~ bind_typ U) ++ E) ) in H1.
    apply wf_typ_strengthening in H1...
  -
    apply typing_sub with (S:=S)...
    rewrite_alist (F ++ (x ~ bind_typ U) ++ E) in H1.
    apply typing_regular in H.
    destruct H.
    apply strengthening_sub_typ in H1...
    apply wf_env_strengthening with (x:=x) (T:=U)...
  -
    constructor...
    apply wf_env_strengthening with (x:=x) (T:=U)...
  -
    constructor...
    apply subst_tt_rt_expr...
    get_expr...
    get_expr...
Qed.

Lemma typing_inv_abs : forall E S1 e1 T,
  typing E (exp_abs S1 e1) T ->
  forall U1 U2, Sub E T (typ_arrow U1 U2) ->
     Sub E U1 S1
  /\ exists S2, exists L, forall x, x `notin` L ->
     typing (x ~ bind_typ S1 ++ E) (open_ee e1 x) S2 /\ Sub E S2 U2.
Proof with auto.
  intros E S1 e1 T Typ.
  remember (exp_abs S1 e1) as e.
  generalize dependent e1.
  generalize dependent S1.
  induction Typ; intros S1 b1 EQ U1 U2 Sub; inversion EQ; subst.
  -
    inversion Sub; subst.
    split...
    exists T2. exists L...
    inversion H2.
  -
    assert (definition.Sub G S (typ_arrow U1 U2)).
    apply Transitivity with (B:=T)...
    assert (typing G (exp_abs S1 b1) (typ_arrow U1 U2)).
    apply typing_sub with (S:=S)...
    dependent destruction H2...
Qed.

Lemma typing_inv_fold: forall S G T v,
    typing G (exp_fold T v) S ->
    forall U, Sub G S (typ_mu U) ->
    (exists T', typing G v (open_tt T' (typ_mu T')) /\ Sub G (open_tt T' (typ_mu T')) (open_tt U (typ_mu U))).
Proof with auto.
  intros.
  generalize dependent U.
  dependent induction H;intros...
  -
    exists A...
    split...
    apply unfolding_lemma...
  -
    specialize (IHtyping T v).
    assert (exp_fold T v = exp_fold T v) by auto.
    apply IHtyping with (U:=U) in H2...
    apply Transitivity with (B:=T0)...
Qed.

Lemma rt_expr_step: forall e1 e2,
    rt_expr e1 ->
    step e1 e2 ->
    rt_expr e2.
Proof with auto.
  intros.
  induction H...
  dependent destruction H0...
  dependent destruction H0...
Qed.

Lemma lookup_field_in_value : forall v T i Ti G,
  value v ->
  typing G v T ->
  Tlookup i T = Some Ti ->
  exists vi, tlookup i v = Some vi /\ typing G vi Ti.
Proof with auto.
  intros.
  generalize dependent  Ti.
  dependent induction H0;intros;simpl in *; try solve [inversion H1|inversion H2|inversion H]...
  -
    apply rcd_types_match with (i:=i) (Ti:=Ti) in H1...
    destruct H1.
    destruct H1.
    apply IHtyping with (Ti:= x) in H...
    destruct H.
    destruct H.
    exists x0...
    split...
    apply typing_sub with (S:=x)...
  -
    destruct (i0==i)...
    +
      inversion H3...
      subst...
      exists e1...
    +
      dependent destruction H.
      apply IHtyping2  with (Ti:= Ti) in H0...
Qed.

Lemma step_preserves_record_tm : forall e1 e2,
    rt_expr e1 ->
    step e1 e2 ->
    rt_expr e2.
Proof with auto.
  intros.
  induction H...
  inversion H0...
  inversion H0...
Qed.

Lemma preservation : forall E e e' T,
    typing E e T ->
    step e e' ->
    typing E e' T.
Proof with auto.
  intros.
  generalize dependent e'.
  dependent induction H;intros;try solve [dependent destruction H1;auto|inversion H0]...
  -
    dependent destruction H1...
    +
      dependent destruction H.
      pick fresh Y.
      rewrite subst_ee_intro with (x:=Y)...
      rewrite_alist (nil ++ G).
      apply typing_through_subst_ee with (U:=T1)...
      apply H...
      apply typing_inv_abs with (U1:=T1) (U2:=T2) in H...
      destruct H.
      destruct H4.
      destruct H4.
      pick fresh Y.
      rewrite subst_ee_intro with (x:=Y)...
      rewrite_alist (nil ++ G).
      apply typing_through_subst_ee with (U:=T)...
      specialize (H4 Y).
      assert (Y \notin x0) by auto.
      apply H4 in H5.
      destruct H5.
      apply typing_sub with (S:=x)...
      apply Sub_weakening...
      apply typing_regular in H5.
      destruct H5...
      apply typing_sub with (S:=T1)...
    +
      apply typing_app with (T1:=T1)...
    +
      apply typing_app with (T1:=T1)...
  -
    dependent destruction H0...
    dependent destruction H...
    apply typing_inv_fold with (U:=T) in H...
    destruct H...
    destruct H.
    apply typing_sub with (S:=open_tt x (typ_mu x))...
  -
    apply typing_sub with (S:=S)...
  -
    dependent destruction H1...
    +
      apply lookup_field_in_value with (T:=T) (Ti:=Ti) (i:=i) (G:=G) in H1...
      destruct H1.
      destruct H1.
      rewrite H1 in H2...
      inversion H2...
      subst...
    +
      apply IHtyping in H1...
      apply typing_proj with (T:=T)...
  -
    dependent destruction H4...
    constructor...
    apply step_preserves_record_tm with (e1:=e2)...
Qed.

Lemma canonical_form_abs : forall e U1 U2,
  value e ->
  typing empty e (typ_arrow U1 U2) ->
  exists V, exists e1, e = exp_abs V e1.
Proof.
  intros e U1 U2 Val Typ.
  remember empty as E.
  remember (typ_arrow U1 U2) as T.
  revert U1 U2 HeqT HeqE.
  induction Typ; intros U1 U2 EQT EQE; subst;
    try solve [ inversion Val | inversion EQT | eauto ].

  inversion H; subst; eauto.
  inversion H2.
Qed.

Lemma canonical_form_fold : forall e U,
  value e ->
  typing empty e (typ_mu U) ->
  exists V, exists e1, (Sub empty (typ_mu V) (typ_mu U) /\ value e1 /\ e = exp_fold (typ_mu V) e1).
Proof with auto.
  intros e U Val Typ.
  remember empty as E.
  remember (typ_mu U) as T.
  assert (WF E T).
  apply typing_regular in Typ...
  destructs_hypos...
  revert U HeqT HeqE.
  induction Typ; intros U EQT EQE; subst;
    try solve [ inversion Val | inversion EQT | eauto ].
  -
    dependent destruction Val.
    exists A...
    exists e...
    repeat split...
    apply sub_refl...
  -
    dependent destruction H...
    dependent destruction H0...
    apply IHTyp with (U:=A1) in Val...
    destruct Val.
    destruct H3.
    exists x.
    exists x0.
    destructs_hypos...
    repeat split...
    apply Transitivity with (B:=typ_mu A1)...
    apply S_rec with (L:=L)...
    apply typing_regular in Typ.
    apply Typ.
    inversion H1.
Qed.

Ltac destructs_exists :=
  repeat
    match goal with
    | [H : exists _, _ |- _ ] => destruct H
    end.

Lemma progress : forall e T,
  typing empty e T ->
  value e \/ exists e', step e e'.
Proof with eauto.
  intros.
  dependent induction H...
  -
    inversion H0...
  -
    left.
    constructor.
    pick fresh Y.
    assert (Y \notin L) by auto.
    apply H in H1...
    apply typing_regular in H1.
    destruct H1.
    destruct H2.
    apply lc_abs with (L:=L).
    intros.
    apply H in H4.
    apply typing_regular in H4.
    apply H4.
    apply wf_typ_from_wf_env_typ in H1.
    apply wf_type with (E:=empty)...
  -
    right.
    assert (empty ~= empty) by auto.
    apply IHtyping1 in H1.
    destruct H1...
    assert (empty ~= empty) by auto.
    apply IHtyping2 in H2...
    destruct H2...
    apply canonical_form_abs with (U1:=T1) (U2:=T2) in H1...
    destruct H1.
    destruct H1.
    exists (open_ee x0 e2).
    subst.
    apply step_beta...
    apply typing_regular in H.
    apply H.
    destruct H2.
    exists (exp_app e1 x).
    apply step_app2...
    destruct H1.
    exists (exp_app x e2).
    apply step_app1...
    apply typing_regular in H0.
    apply H0.
  -
    assert (empty ~= empty) by auto.
    apply IHtyping in H1.
    destruct H1.
    left.
    constructor...
    apply wf_type in H0...
    right.
    destruct H1.
    exists (exp_fold (typ_mu A) x).
    constructor...
    apply typing_regular in H.
    destruct H.
    destruct H2.
    apply wf_type in H0...
  -
    assert (empty ~= empty) by auto.
    apply IHtyping in H0.
    right.
    destruct H0...
    +
      apply canonical_form_fold with (U:=T) in H0...
      destruct H0.
      destruct H0.
      destruct H0.
      destruct H1.
      exists x0...
      rewrite H2.
      apply step_fld...
      apply Sub_regular in H0.
      apply wf_type with (E:=empty)...
      apply H0.
      apply typing_regular in H.
      apply wf_type with (E:=empty)...
      apply H.
    +
      destruct H0.
      exists (exp_unfold (typ_mu T) x).
      apply step_unfold...
      apply typing_regular in H...
      apply wf_type with (E:=empty)...
      apply H.
  -
    destruct IHtyping...
    +
      right...
      assert (Ht:=H1).
      apply lookup_field_in_value with (G:=empty) (T:=T) (i:=i) (Ti:=Ti) in H1...
      destruct H1.
      destruct H1.
      exists x...
    +
      right.
      destruct H1...
  -
    destruct IHtyping1;destruct IHtyping2...
    +
      destruct H5...
    +
      destruct H4...
    +
      destruct H4;destruct H5...
Qed.


(** Coq coding by choukh, Jan 2021 **)

Require Export ZFC.Lib.Ordinal.
Require Import ZFC.Lib.ChoiceFacts.
Require ZFC.Lib.WosetMin.

(* set-theoretic form *)
Definition set_theoretic_Zorn := ChoiceFacts.AC_VI.

(* general form *)
Definition general_Zorn := ∀ A R, poset A R →
  (∀ B, B ⊆ A → loset B (R ⥏ B) → ∃ u, upperBound u B A R) →
  ∃ m, maximal m A R.

(* nonempty form *)
Definition nonempty_Zorn := ∀ A R, ⦿ A → poset A R →
  (∀ B, ⦿ B → B ⊆ A → loset B (R ⥏ B) → ∃ u, upperBound u B A R) →
  ∃ m, maximal m A R.

(* 链是全序集 *)
Lemma chain_is_loset : ∀ A, is_chain A ↔ loset A (SubsetRel A).
Proof with eauto; try congruence.
  split.
  - intros Hchn. apply loset_iff_connected_poset.
    split; [|apply subsetRel_poset].
    intros a Ha b Hb Hnq.
    pose proof (Hchn a Ha b Hb) as []; [left|right]; apply binRelI...
  - intros Hlo x Hx y Hy.
    destruct (classic (x = y)) as [|Hnq]. left...
    eapply lo_connected in Hnq as H... destruct H.
    * apply binRelE3 in H as []...
    * apply binRelE3 in H as []...
Qed.

(* 集合的包含关系在子集上的限制等于子集的包含关系 *)
Lemma subRel_of_subselRel : ∀ A B, B ⊆ A →
  (SubsetRel A) ⥏ B = SubsetRel B.
Proof with auto.
  intros A B Hsub.
  ext Hx.
  - apply SepE in Hx as [Hx Hp].
    apply CPrdE1 in Hp as [a [Ha [b [Hb Hp]]]]. subst x.
    apply binRelE3 in Hx. apply binRelI...
  - apply binRelE1 in Hx as [a [Ha [b [Hb [Hx H]]]]]. subst x.
    apply SepI. apply binRelI; [apply Hsub..|]... apply CPrdI...
Qed.

(* 佐恩引理一般形式到集合论形式 *)
Lemma general_Zorn_to_set_theoretic :
  general_Zorn → set_theoretic_Zorn.
Proof with eauto; try congruence.
  intros AC6_0 A Hzn.
  pose proof (AC6_0 A (SubsetRel A)) as [m Hmax].
  - apply subsetRel_poset.
  - intros B Hsub Hlo.
    assert (Hchn: is_chain B). {
      apply chain_is_loset.
      rewrite subRel_of_subselRel in Hlo...
    }
    exists (⋃ B). split. apply Hzn...
    intros y Hy. destruct (classic (y = ⋃ B)). right...
    left. apply binRelI. apply Hsub... apply Hzn...
    split... apply union_is_ub...
  - exists m... eapply sub_maximal_iff...
Qed.

(* 佐恩引理与其非空形式等价 *)
Lemma nonempty_Zorn_iff_general : general_Zorn ↔ nonempty_Zorn.
Proof with auto.
  split; intros Hzn.
  - intros A R [a Ha] Hpo Hub. apply Hzn...
    intros B Hsub Hlo. destruct (classic (B = ∅)).
    + exists a. split... intros y Hy. subst. exfalso0.
    + apply Hub... apply EmptyNE...
  - intros A R Hpo Hub. apply Hzn...
    specialize Hub with ∅ as [m [Hm _]].
    apply empty_sub_all. rewrite subRel_empty.
    apply empty_loset. exists m...
Qed.

(* AC cycle
  3' → (Zorn ↔ WO) → 6 (→ ... → 3')
*)

Import RecursionOnOrdinals.

(* 佐恩引理一般形式的证明 *)
Lemma Zorn's : AC_III' → general_Zorn.
Proof with eauto; try congruence.
  intros AC3' A R Hpo Hub.
  (* 反证法 *)
  contra as Harc.
  apply po_archimedean_iff_no_maximal in Harc...
  (* 子集的上界集 *)
  set (λ B, {x ∊ A | ∀b ∈ B, (b <ᵣ x) R}) as Upper.
  (* 全序子集族 *)
  set {B ∊ 𝒫 A | loset B (R ⥏ B)} as ℬ.
  (* 上界集族 *)
  set {Upper B | B ∊ ℬ} as 𝒜.
  pose proof (AC3' 𝒜) as [F [HfF [HdF HrF]]]. {
    intros x Hx. apply ReplAx in Hx as [B [HB Hx]]. subst x.
    apply SepE in HB as [Hsub Hlo]. apply PowerAx in Hsub.
    specialize Hub with B as [u [Hu Hle]]...
    apply Harc in Hu as [v [Hv Hlt]].
    exists v. apply SepI... intros b Hb.
    apply Hle in Hb. eapply relLe_lt_trans... apply Hpo.
  }
  (* 上界函数 *)
  set (Func ℬ A (λ B, F[Upper B])) as f.
  assert (HrF': ∀B ∈ ℬ, F[Upper B] ∈ Upper B). {
    intros B HB. apply HrF. apply ReplI...
  }
  assert (Hf: f: ℬ ⇒ A). {
    apply meta_function. intros B HB.
    apply HrF' in HB. apply SepE1 in HB...
  }
  (* f(B)是B的严格上界 *)
  assert (f_strict: ∀B ∈ ℬ, strictUpperBound f[B] B A R). {
    intros B HB. split. eapply ap_ran...
    unfold f. rewrite meta_func_ap...
    apply HrF' in HB. apply SepE2 in HB. apply HB...
  }
  set (Recursion (λ B, f[B])) as a.
  assert (HB: ∀α ⋵ 𝐎𝐍, {a β | β ∊ α} ∈ ℬ). {
    ord_induction. intros α Hoα IH.
    assert (Hsub: {a β | β ∊ α} ⊆ A). {
      intros x Hx. apply ReplAx in Hx as [β [Hβ Hx]]. subst x.
      assert (Hoβ: β ⋵ 𝐎𝐍). eapply ord_is_ords...
      unfold a. rewrite recursion_spec... eapply ap_ran...
    }
    apply SepI. apply PowerAx...
    apply loset_iff_connected_poset.
    split; [|eapply subRel_poset]...
    intros x Hx y Hy Hnq.
    apply ReplAx in Hx as H. destruct H as [δ [Hδ Heqx]].
    apply ReplAx in Hy as H. destruct H as [ε [Hε Heqy]]. subst x y.
    assert (Hoδ: δ ⋵ 𝐎𝐍). eapply ord_is_ords...
    assert (Hoε: ε ⋵ 𝐎𝐍). eapply ord_is_ords; revgoals...
    destruct (classic (δ = ε)) as [|Hnq']...
    apply ord_connected in Hnq' as []; auto; [left|right];
    (apply SepI; [|apply CPrdI; auto]); unfold a;
    [rewrite (recursion_spec _ ε)|rewrite (recursion_spec _ δ)]; auto;
    (apply f_strict; [apply IH|apply ReplI])...
  }
  assert (Hmono: ∀α ⋵ 𝐎𝐍, ∀β ∈ α, (a β <ᵣ a α) R). {
    intros α Hoα β Hlt.
    unfold a. rewrite (recursion_spec _ α)...
    apply f_strict. apply HB... apply ReplI...
  }
  set {x ∊ A | ∃α ⋵ 𝐎𝐍, x = a α} as A'.
  set (ϕ_Repl (λ x α, α ⋵ 𝐎𝐍 ∧ x = a α) A') as Ω.
  apply Burali_Forti. exists Ω.
  intros α Hoα. apply ϕ_ReplAx.
  - intros x Hx. rewrite <- unique_existence. split.
    + apply SepE2 in Hx as [ξ [Hξ Hx]]...
    + intros δ ε [Hoδ H1] [Hoε H2]. subst x.
      contra.
      apply ord_connected in H as []; auto;
      apply Hmono in H; auto; rewrite H2 in H;
      eapply relLt_irrefl; eauto; apply Hpo.
  - exists (a α). split... apply SepI...
    unfold a. rewrite recursion_spec... eapply ap_ran...
Qed.

Module AlternativeProofWithoutRecursion.
Import WosetMin.FullVer.

(* 佐恩引理一般形式的证明 *)
Lemma Zorn's : AC_III' → general_Zorn.
Proof with eauto; try congruence.
  intros AC3' A R Hpo Hub. assert (H := Hpo).
  destruct H as [_ [_ [Htr Hir]]].
  (* 反证法 *)
  contra as Harc.
  apply po_archimedean_iff_no_maximal in Harc...
  (* 子集的上界集 *)
  set (λ B, {x ∊ A | ∀b ∈ B, (b <ᵣ x) R}) as Upper.
  (* 全序子集族 *)
  set {B ∊ 𝒫 A | loset B (R ⥏ B)} as ℬ.
  (* 上界集族 *)
  set {Upper B | B ∊ ℬ} as 𝒜.
  pose proof (AC3' 𝒜) as [F [HfF [HdF HrF]]]. {
    intros x Hx. apply ReplAx in Hx as [B [HB Hx]]. subst x.
    apply SepE in HB as [Hsub Hlo]. apply PowerAx in Hsub.
    specialize Hub with B as [u [Hu Hle]]...
    apply Harc in Hu as [v [Hv Hlt]].
    exists v. apply SepI... intros b Hb.
    apply Hle in Hb. eapply relLe_lt_trans...
  }
  (* 上界函数 *)
  set (Func ℬ A (λ B, F[Upper B])) as f.
  assert (HrF': ∀B ∈ ℬ, F[Upper B] ∈ Upper B). {
    intros B HB. apply HrF. apply ReplI...
  }
  assert (Hf: f: ℬ ⇒ A). {
    apply meta_function. intros B HB.
    apply HrF' in HB. apply SepE1 in HB...
  }
  (* f(B)是B的严格上界 *)
  assert (f_strict: ∀B ∈ ℬ, strictUpperBound f[B] B A R). {
    intros B HB. split. eapply ap_ran...
    unfold f. rewrite meta_func_ap...
    apply HrF' in HB. apply SepE2 in HB. apply HB...
  }
  set (λ t B, {x ∊ B | (x <ᵣ t) R}) as seg.
  set (λ B, ∀x ∈ B, x = f[seg x B]) as inductive.
  set (λ B, B ⊆ A ∧
    (* a *) woset B (R ⥏ B) ∧
    (* b *) inductive B
  ) as good.
  assert (comparability: ∀ B C,
    B ≠ C → good B → good C →
    (∃t ∈ B, seg t B = C) ∨ ∃t ∈ C, seg t C = B
  ). {
    cut (∀ B C, ⦿ (B - C) → good B → good C →
      ∃t ∈ B, seg t B = C
    ). {
      intros H B C Hnq HgB HgC.
      destruct (classic (C ⊆ B)) as [Hcb|Hbc].
      - left. apply H... apply EmptyNE.
        intros H0. apply sub_iff_no_comp in H0...
        apply Hnq. eapply sub_antisym...
      - right. apply H... apply EmptyNE.
        intros H0. apply Hbc. apply sub_iff_no_comp...
    }
    intros B C Hne [HsB [HwB HiB]] [HsC [HwC HiC]].
    destruct HwB as [HloB HminB].
    destruct HwC as [HloC HminC].
    pose proof (HminB (B - C)) as [b [Hb Hble]]...
    apply SepE in Hb as [Hb Hb'].
    exists b. split... apply sub_antisym.
    + intros x Hx. apply SepE in Hx as [Hx Hxb].
      contra as Hx'.
      assert (x ∈ B - C). apply SepI... apply Hble in H.
      eapply (lo_irrefl _ B)... eapply relLt_le_trans...
      apply HloB. apply SepI... apply CPrdI...
    + contra as Hnsub.
      pose proof (HminC (C - seg b B)) as [c [Hc Hcle]]... {
        apply EmptyNE. intros H. apply sub_iff_no_comp in H...
      }
      pose proof (HminB (B - seg c C)) as [d [Hd Hdle]]... {
        apply EmptyNE. intros H. apply sub_iff_no_comp in H.
        apply H in Hb. apply SepE1 in Hb...
      }
      assert (Hdb: (d ≤ᵣ b) (R ⥏ B)). {
        apply Hdle. apply SepI...
        intros H. apply Hb'. apply SepE1 in H...
      }
      apply SepE in Hc as [Hc Hc'].
      apply SepE in Hd as [Hd Hd'].
      assert (Heq: d = c). {
        rewrite (HiB d), HiC... f_equal.
        ext Hx.
        - contra.
          apply SepE in Hx as [Hx Hxk].
          assert (Hx': x ∈ B - seg c C). apply SepI...
          apply Hdle in Hx'. eapply (lo_irrefl _ B)...
          eapply relLt_le_trans... apply HloB.
          apply SepI... apply CPrdI...
        - apply SepE in Hx as [Hx Hxc].
          destruct (classic (d = b)) as [|Hnq]. {
            subst d. contra.
            assert (Hx': x ∈ C - seg b B). apply SepI...
            apply Hcle in Hx'. eapply (lo_irrefl _ C)...
            eapply relLt_le_trans... apply HloC.
            apply SepI... apply CPrdI...
          }
          assert (HdC: d ∈ C). {
            contra as HdC.
            assert (HdB: d ∈ B - C). apply SepI...
            apply Hble in HdB as []; destruct Hdb...
            eapply (lo_irrefl _ B)... eapply relLt_trans... apply HloB.
          }
          assert (HxB: x ∈ B). {
            contra.
            assert (Hx': x ∈ C - seg b B). {
              apply SepI... intros H'. apply H. apply SepE1 in H'...
            }
            apply Hcle in Hx'. eapply (lo_irrefl _ C)...
            eapply relLt_le_trans... apply HloC.
            apply SepI... apply CPrdI...
          }
          apply SepI...
          destruct (classic (d = c)). subst...
          eapply lo_connected in H as []; eauto; apply SepE1 in H.
          + exfalso. apply Hd'. apply SepI...
          + eapply relLt_trans...
      }
      destruct Hdb... apply SepE1 in H.
      apply Hc'. apply SepI... subst...
  }
  assert (good_or_not: ∀ B, good B →
    ∀x ∈ B, ∀y ∈ A, (y <ᵣ x) R → y ∈ B ∨ ¬∃C, good C ∧ y ∈ C
  ). {
    intros B HgB x Hx y Hy Hyx.
    destruct (classic (y ∈ B)) as [|Hy']...
    right. intros [C [HgC HyC]].
    destruct (classic (B = C)) as [|Hnq]...
    pose proof (comparability B C Hnq HgB HgC).
    destruct H as [[t [Ht Hseg]]|[t [Ht Hseg]]]; subst.
    - apply SepE1 in HyC...
    - apply Hy'. apply SepE2 in Hx.
      apply SepI... eapply relLt_trans...
  }
  set {B ∊ 𝒫 A | good B} as 𝒞.
  assert (Hsubu: ⋃ 𝒞 ⊆ A). {
    intros x Hx. apply UnionAx in Hx as [C [HC Hx]].
    apply SepE1 in HC. apply PowerAx in HC. apply HC...
  }
  assert (union_lo: loset ⋃ 𝒞 (R ⥏ ⋃ 𝒞)). {
    apply loset_iff_connected_poset.
    split; [|eapply subRel_poset]...
    intros x Hx y Hy Hnq.
    assert (H := Hx). apply UnionAx in H as [X [HX Hx']].
    assert (H := Hy). apply UnionAx in H as [Y [HY Hy']].
    apply SepE2 in HX. apply SepE2 in HY.
    destruct (classic (X = Y)) as [|HnQ]. {
      subst Y. apply (lo_connected (R ⥏ X) X) in Hnq...
      destruct Hnq; [left|right]; apply SepE1 in H;
      apply SepI; auto; apply CPrdI... apply HX.
    }
    pose proof (comparability X Y HnQ HX HY).
    destruct H as [[t [Ht Hseg]]|[t [Ht Hseg]]].
    + subst Y. apply SepE1 in Hy'.
      apply (lo_connected (R ⥏ X) X) in Hnq...
      destruct Hnq; [left|right]; apply SepE1 in H;
      apply SepI; auto; apply CPrdI... apply HX.
    + subst X. apply SepE1 in Hx'.
      apply (lo_connected (R ⥏ Y) Y) in Hnq...
      destruct Hnq; [left|right]; apply SepE1 in H;
      apply SepI; auto; apply CPrdI... apply HY.
  }
  assert (union_wo: woset ⋃ 𝒞 (R ⥏ ⋃ 𝒞)). {
    split... intros B [b Hb] Hsub.
    apply Hsub in Hb as H.
    apply UnionAx in H as [C [HC HbC]].
    apply SepE2 in HC as HgC.
    set ((Min C (R ⥏ C))[B ∩ C]) as m.
    pose proof (min_correct C (R ⥏ C) (B ∩ C)) as [Hm Hmin].
    - apply HgC.
    - exists b. apply BInterI...
    - intros x Hx. apply BInterE in Hx as []...
    - exists m. fold m in Hm, Hmin.
      apply BInterE in Hm as [HmB HmC].
      assert (HmU: m ∈ ⋃ 𝒞). apply Hsub...
      split... intros x Hx.
      assert (HxU: x ∈ ⋃ 𝒞). apply Hsub...
      destruct (classic (x ∈ C)) as [HxC|HxC].
      + assert (x ∈ B ∩ C) by (apply BInterI; auto).
        apply Hmin in H as []; [left|right]...
        apply SepE1 in H. apply SepI... apply CPrdI...
      + destruct (classic (m = x))...
        eapply lo_connected in H as [|Hxm]... left... right.
        exfalso. apply SepE1 in Hxm. apply Hsubu in HxU as HxA.
        pose proof (good_or_not C HgC m HmC x HxA Hxm) as []...
        apply H. apply UnionAx in HxU as [D [HD HxD]].
        exists D. split... apply SepE2 in HD...
  }
  assert (union_ind: inductive ⋃ 𝒞). {
    intros t Ht. apply UnionAx in Ht as [B [HB Ht]].
    apply SepE2 in HB as HgB. assert (H := HgB).
    destruct H as [_ [_ Hap]].
    apply Hap in Ht as Heqt. rewrite Heqt at 1. f_equal.
    ext Hx.
    - apply SepE in Hx as [Hx Hxt]. apply SepI...
      apply UnionAx. exists B. split...
    - apply SepE in Hx as [Hx Hxt]. apply SepI...
      apply Hsubu in Hx as HxA.
      pose proof (good_or_not B HgB t Ht x HxA Hxt) as []...
      exfalso. apply H. apply UnionAx in Hx as [C [HC HxC]].
      exists C. split... apply SepE2 in HC...
  }
  (* since ⋃ 𝒞 is woset and inductive,
  it is good but we don't need this fact,
  instead we prove suc of ⋃ 𝒞 is good *)
  assert (Hu: ⋃ 𝒞 ∈ ℬ). {
    apply SepI. apply PowerAx... apply union_lo.
  }
  set (⋃ 𝒞 ∪ {f[⋃ 𝒞],}) as S.
  assert (Hsubs: S ⊆ A). {
    intros x Hx. apply BUnionE in Hx as []. apply Hsubu...
    apply SingE in H. subst. eapply ap_ran...
  }
  assert (suc_lo: loset S (R ⥏ S)). {
    apply loset_iff_connected_poset.
    split; [|eapply subRel_poset]...
    intros x Hx y Hy Hnq.
    assert (HxS := Hx). assert (HyS := Hy).
    apply BUnionE in Hx as [Hx|Hx];
    apply BUnionE in Hy as [Hy|Hy].
    - apply (lo_connected (R ⥏ ⋃ 𝒞) ⋃ 𝒞) in Hnq as []; auto; [left|right];
      apply SepE1 in H; apply SepI; auto; apply CPrdI...
    - left. apply SingE in Hy. rewrite Hy.
      apply f_strict in Hx... apply SepI... apply CPrdI...
    - right. apply SingE in Hx. rewrite Hx.
      apply f_strict in Hy... apply SepI... apply CPrdI...
    - apply SingE in Hx; apply SingE in Hy...
  }
  assert (suc_wo: woset S (R ⥏ S)). {
    split... intros B [b Hb] Hsub.
    set (B ∩ ⋃ 𝒞) as C.
    assert (Hor: ∀x ∈ B, x ∈ C ∨ x ∈ B ∧ x = f[⋃ 𝒞]). {
      intros x Hx. apply Hsub in Hx as HxS.
      apply BUnionE in HxS as []; [left|right].
      apply BInterI... apply SingE in H...
    }
    destruct (classic (C = ∅)) as [H0|Hne].
    - apply Hor in Hb as [Hb|[Hb Heqb]].
      + exfalso. eapply EmptyE...
      + exists b. split... intros x Hx. cut (b = x). right...
        apply Hor in Hx as [Hx|[Hx Heqx]]...
        exfalso. eapply EmptyE...
    - destruct union_wo as [_ Hmin].
      pose proof (Hmin C) as [m [Hm Hle]].
      + apply EmptyNE in Hne...
      + intros x Hx. apply BInterE in Hx as []...
      + apply BInterE in Hm as [HmB HmU].
        exists m. split... intros x Hx.
        apply Hor in Hx as [Hx|[Hx Heqx]].
        * apply Hle in Hx as H.
          apply BInterE in Hx as [HxB _].
          destruct H; [left|right]...
          apply SepE1 in H. apply SepI...
          apply CPrdI; apply Hsub...
        * left. subst x. apply SepI. apply f_strict...
          apply CPrdI; apply Hsub...
  }
  assert (suc_good: good S). {
    split... split... intros t Ht.
    apply BUnionE in Ht as [Ht|Ht].
    - apply union_ind in Ht as Heqt.
      rewrite Heqt at 1. f_equal.
      ext Hx.
      + apply SepE in Hx as [Hx Hxt].
        apply SepI... apply BUnionI1...
      + apply SepE in Hx as [Hx Hxt].
        apply SepI... apply BUnionE in Hx as []...
        apply SingE in H. subst. rewrite Heqt in Hxt.
        exfalso. eapply relLt_irrefl...
        eapply relLt_trans... apply f_strict...
    - apply SingE in Ht. rewrite Ht at 1. f_equal.
      ext Hx.
      + apply SepI. apply BUnionI1...
        rewrite Ht. apply f_strict...
      + apply SepE in Hx as [Hx Hxt].
        apply BUnionE in Hx as []... apply SingE in H.
        exfalso. subst. eapply relLt_irrefl...
  }
  assert (Hfu: f[⋃ 𝒞] ∈ ⋃ 𝒞). {
    apply UnionAx. exists S. split... apply SepI...
    apply PowerAx. apply Hsubs. apply BUnionI2...
  }
  apply f_strict in Hu as [_ Hlt]. apply Hlt in Hfu.
  eapply relLt_irrefl...
Qed.

End AlternativeProofWithoutRecursion.

Section ImportWoStruct.
Import WoStruct.

Theorem WO_to_Zorn : WO → general_Zorn.
Proof with eauto; try congruence.
  intros WO. intros A Q Hpo Hub.
  pose proof (WO A) as [W Hwo].
  set (WoStruct.constr A W Hwo) as S.
  set (λ f, ∃a ∈ A, dom f = seg a (R S) ∧
    ∀b ∈ dom f, f[b] = 1 → (b <ᵣ a) Q) as P.
  set (λ f y, y = match (ixm (P f)) with
    | inl _ => Embed 1
    | inr _ => 0
  end) as γ.
  pose proof (recursion_spec_intro S γ) as [Hff [Hdf Hrf]]. {
    intros f. unfold γ. rewrite <- unique_existence.
    destruct (ixm (P f)); split...
  }
  set (Recursion S γ) as f. fold f in Hff, Hdf, Hrf.
  set {a ∊ A | f[a] = 1} as C.
  assert (contra: Embed 0 ≠ 1). {
    intros H. apply (suc_neq_0 0)...
  }
  assert (Hsubd: ∀a ∈ A, seg a (R S) ⊆ WoStruct.A S). {
    intros a Ha x Hx. apply SepE1 in Hx.
    eapply dom_binRel in Hx... apply wo.
  }
  assert (Heqd: ∀a ∈ A, dom (f ↾ seg a (R S)) = seg a (R S)). {
    intros a Ha. apply restr_dom... rewrite Hdf...
  }
  assert (HC: ∀a ∈ A, a ∈ C ↔ ∀b ∈ C, (b <ᵣ a) (R S) → (b <ᵣ a) Q). {
    intros a HaA. split.
    - intros Ha b Hb Hlt.
      apply SepE in Ha as [_ Hfa].
      apply SepE in Hb as [Hb Hfb]. rewrite Hrf in Hfa...
      assert (Hb': b ∈ seg a (R S)). apply SepI... eapply domI...
      destruct (ixm (P (f ↾ seg a (R S))))...
      destruct p as [a' [Ha' [Heqa' Hsub]]].
      assert (Heq: a = a'). {
        rewrite Heqd in Heqa'... eapply seg_injective... apply wo.
      }
      rewrite Heq. apply Hsub.
      + eapply domI. apply restrI...
        eapply func_point... rewrite Hdf...
      + rewrite (restr_ap f (WoStruct.A S))...
    - intros Hinc. apply SepI... rewrite Hrf...
      destruct (ixm (P (f ↾ seg a (R S))))...
      exfalso. apply n. unfold P.
      exists a. repeat split...
      intros b Hb Hfb. rewrite Heqd in Hb...
      apply Hsubd in Hb as HbA...
      apply SepE2 in Hb as Hlt.
      apply Hinc... apply SepI...
      erewrite restr_ap in Hfb; revgoals...
  }
  assert (Hsub: C ⊆ A). {
    intros x Hx. apply SepE1 in Hx...
  }
  assert (Hlo: loset C (Q ⥏ C)). {
    apply loset_iff_connected_poset.
    split; [|eapply subRel_poset]...
    intros a Ha b Hb Hnq.
    apply SepE1 in Ha as HaA.
    apply SepE1 in Hb as HbA.
    eapply lo_connected in Hnq as [];
    [left|right|apply Hwo|auto..];
    (apply SepI; [apply HC|apply CPrdI])...
  }
  pose proof (Hub C) as [u [Hu Hle]]...
  exists u. split... intros d Hd.
  destruct (classic ((u <ᵣ d) Q))... exfalso.
  assert (HdC: d ∈ C). {
    apply HC... intros b Hb Hbd. apply Hle in Hb.
    eapply relLe_lt_trans... apply Hpo.
  }
  apply Hle in HdC. eapply relLt_irrefl. apply Hpo.
  eapply relLe_lt_trans... apply Hpo.
Qed.

End ImportWoStruct.

Theorem Zorn_to_WO : general_Zorn → WO.
Proof with eauto; try congruence.
  intros Zorn X.
  set {w ∊ 𝒫 X × 𝒫 (X × X) | woset (π1 w) (π2 w)} as 𝓦.
  set (BinRel 𝓦 (λ u v,
    let A := π1 u in let B := π1 v in
    let RA := π2 u in let RB := π2 v in
    A ⊂ B ∧
    RA = RB ⥏ A ∧
    ∀a ∈ A, ∀b ∈ B - A, (a <ᵣ b) RB
  )) as 𝓡.
  pose proof (Zorn 𝓦 𝓡) as [𝓜 [H𝓜 Hmax]]. {
    (* poset 𝓦 𝓡 *)
    repeat split.
    - apply binRel_is_binRel.
    - apply rel_is_rel.
    - intros u v w Huv Hvw.
      apply binRelE2 in Huv as [Hu [_ [[H11 H11'] [H12 H13]]]].
      apply binRelE2 in Hvw as [_ [Hw [[H21 H21'] [H22 H23]]]].
      apply binRelI... repeat split.
      + eapply sub_trans...
      + intros Heq. rewrite Heq in H11.
        apply H21'. eapply sub_antisym...
      + ext Hx.
        * rewrite H12 in Hx. apply SepE in Hx as [H1 H2].
          rewrite H22 in H1. apply SepE1 in H1. apply SepI...
        * apply SepE in Hx as [H1 H2].
          rewrite H12. apply SepI...
          rewrite H22. apply SepI...
          apply CPrdE1 in H2 as [a [Ha [b [Hb Hx]]]].
          subst x. apply CPrdI; apply H11...
      + intros a Ha b Hb.
        destruct (classic (b ∈ π1 v)) as [Hb'|Hb'].
        * assert ((a <ᵣ b) (π2 v)). {
            apply H13... apply SepE in Hb as [H1 H2]. apply SepI...
          }
          rewrite H22 in H. apply SepE1 in H...
        * apply H23. apply H11...
          apply SepE in Hb as [H1 H2]. apply SepI...
    - intros w Hp. apply binRelE3 in Hp as [[] _]...
  } {
    (* chain 𝓒 has upper bound *)
    intros 𝓒 Hsub Hlo.
    set (⋃ {π1 w | w ∊ 𝓒}) as U.
    set (BinRel U (λ s t, ∃ C RC, (s <ᵣ t) RC ∧ <C, RC> ∈ 𝓒)) as RU.
    assert (HU: <U, RU> ∈ 𝓦). {
      apply SepI; zfc_simple. {
        apply CPrdI.
        - apply PowerAx. intros x Hx.
          apply UnionAx in Hx as [A [HA Hx]].
          apply ReplAx in HA as [p [Hp Heq]].
          apply Hsub in Hp. apply SepE1 in Hp.
          apply CPrdE1 in Hp as [A' [HA [R [_ Hp]]]].
          subst p. zfc_simple. subst A'.
          apply PowerAx in HA. apply HA...
        - apply PowerAx. intros p Hp.
          apply binRelE1 in Hp as [a [Ha [b [Hb [Heq [C [RC [Hlt Hp]]]]]]]].
          subst p. apply Hsub in Hp. apply SepE1 in Hp.
          apply CPrdE2 in Hp as [_ H].
          apply PowerAx in H. apply H...
      }
      (* woset U RU *)
      split; [apply loset_iff_connected_poset; split|].
      - (* connected RU U *)
        intros a Ha b Hb Hnq.
        assert (HaU := Ha). assert (HbU := Hb).
        apply UnionAx in Ha as [A [HA Ha]].
        apply UnionAx in Hb as [B [HB Hb]].
        apply ReplAx in HA as [p [HpC HA]].
        apply ReplAx in HB as [q [HqC HB]]. subst.
        destruct (classic (p = q)). {
          subst. apply Hsub in HpC.
          apply SepE in HpC as [Hp Hwo].
          apply CPrdE1 in Hp as [A [_ [RA [_ Hp]]]].
          subst. zfc_simple.
          eapply lo_connected in Hnq as [];
          [left|right|apply Hwo|auto..]; apply binRelI...
        }
        eapply lo_connected in H as [];
        [| |apply Hlo|auto..]; apply SepE1 in H;
        apply binRelE2 in H as [Hp [Hq [HAB _]]];
        apply SepE in Hp as [Hp HwoA];
        apply SepE in Hq as [Hq HwoB];
        apply CPrdE1 in Hp as [A [_ [RA [_ Hp]]]];
        apply CPrdE1 in Hq as [B [_ [RB [_ Hq]]]];
        subst; zfc_simple; [apply HAB in Ha|apply HAB in Hb];
        (eapply lo_connected in Hnq as [];
        [left|right|apply HwoB|auto..]; apply binRelI)...
      - (* poset U RU *)
        repeat split.
        + apply binRel_is_binRel.
        + apply rel_is_rel.
        + intros u v w Huv Hvw.
          apply binRelE2 in Huv as [Hu [Hv [C [RC [Huv HC]]]]].
          apply binRelE2 in Hvw as [_ [Hw [D [RD [Hvw HD]]]]].
          destruct (classic (<C, RC> = <D, RD>)). {
            apply op_iff in H as []; subst.
            apply Hsub in HC. apply SepE2 in HC. zfc_simple.
            apply binRelI... exists D, RD. split...
            eapply relLt_trans... apply HC.
          }
          eapply lo_connected in H as [];
          [| |apply Hlo|auto..]; apply SepE1 in H;
          apply binRelE2 in H as [Hp [Hq [_ [H _]]]];
          apply SepE in Hp as [Hp HwoA];
          apply SepE in Hq as [Hq HwoB];
          apply CPrdE1 in Hp as [A [_ [RA [_ Hp]]]];
          apply CPrdE1 in Hq as [B [_ [RB [_ Hq]]]];
          apply op_iff in Hp as [];
          apply op_iff in Hq as [];
          subst; zfc_simple; apply binRelI; auto;
          exists B, RB; split; auto; [
            rewrite H in Huv; apply SepE1 in Huv|
            rewrite H in Hvw; apply SepE1 in Hvw
          ]; eapply relLt_trans; eauto; apply HwoB.
        + intros u Hp. apply binRelE3 in Hp as [C [RC [Hlt Hp]]].
          apply Hsub in Hp. apply SepE2 in Hp. zfc_simple.
          eapply lo_irrefl. apply Hp. apply Hlt.
      - (* has min *)
        intros A [a Ha] HAU.
        apply HAU in Ha as HaU.
        apply UnionAx in HaU as [C [HC HaC]].
        apply ReplAx in HC as [p [HpC HC]].
        apply Hsub in HpC as Hp.
        apply SepE in Hp as [Hp [_ Hmin]].
        apply CPrdE1 in Hp as [C' [_ [RC [_ Hp]]]].
        subst p. zfc_simple. subst C'.
        pose proof (Hmin (A ∩ C)) as [m [Hm Hle]].
        + exists a. apply BInterI...
        + intros x Hx. apply BInterE in Hx as []...
        + apply BInterE in Hm as [HmA HmC].
          exists m. split... intros x HxA.
          destruct (classic (m = x)) as [|Hmx]. right... left.
          apply binRelI; [apply HAU..|]...
          destruct (classic (x ∈ C)) as [HxC|HxC']. {
            assert (x ∈ A ∩ C). apply BInterI...
            apply Hle in H as []...
          }
          apply HAU in HxA as Hx.
          apply UnionAx in Hx as [D [HD Hx]].
          apply ReplAx in HD as [q [HqC HD]].
          apply Hsub in HqC as Hq.
          apply SepE in Hq as [Hq Hwo].
          apply CPrdE1 in Hq as [D' [_ [RD [_ Hq]]]].
          subst q. zfc_simple. subst D'.
          destruct (classic (<C, RC> = <D, RD>)) as [|Hnq]. {
            apply op_iff in H as []; subst...
          }
          eapply lo_connected in Hnq as [];
          [| |apply Hlo|auto..]; apply SepE1 in H;
          apply binRelE3 in H as [H1 [_ H3]]; zfc_simple.
          * exists D, RD. split... apply H3... apply SepI...
          * apply H1 in Hx...
    }
    (* show that <U, RU> is upper bound of 𝓒 *)
    exists (<U, RU>). split... intros p HpC.
    destruct (classic (p = <U, RU>)) as [|Hnq]. right... left.
    apply binRelI... apply Hsub in HpC as Hp.
    apply SepE in Hp as [Hp Hwo].
    apply CPrdE1 in Hp as [A [_ [RA [_ Hp]]]].
    subst. zfc_simple.
    assert (HAU: A ⊆ U). {
      apply union_is_ub. apply ReplAx.
      exists <A, RA>. split... zfc_simple.
    }
    assert (HeqR: RA = RU ⥏ A). {
      destruct Hwo as [[Hbr _] _].
      ext p Hp.
      - apply Hbr in Hp as H.
        apply CPrdE1 in H as [a [Ha [b [Hb Heqp]]]].
        subst p. apply SepI.
        apply binRelI; [apply HAU..|]... apply CPrdI...
      - apply SepE in Hp as [Hp Hpp].
        apply binRelE1 in Hp as [a [Ha [b [Hb [Hp [B [RB [Hlt HP]]]]]]]].
        subst p. apply CPrdE2 in Hpp as [HaA HaB].
        destruct (classic (<A, RA> = <B, RB>)). {
          apply op_iff in H as []; subst...
        }
        eapply lo_connected in H as [];
        [| |apply Hlo|auto..]; apply SepE1 in H;
        apply binRelE3 in H as [_ [H2 _]]; zfc_simple.
        * rewrite H2. apply SepI... apply CPrdI...
        * rewrite H2 in Hlt. apply SepE1 in Hlt...
    }
    repeat split...
    - intros Heq. apply Hnq. apply op_iff. split...
      rewrite HeqR, Heq.
      ext p Hp.
      apply SepE1 in Hp... apply SepI... apply SepE1 in Hp...
    - intros a Ha b Hb. apply binRelI.
      apply HAU... apply SepE1 in Hb...
      apply SepE in Hb as [Hb Hb'].
      apply UnionAx in Hb as [B [HB Hb]].
      apply ReplAx in HB as [q [HqC HB]].
      apply Hsub in HqC as Hq.
      apply SepE in Hq as [Hq HwoB].
      apply CPrdE1 in Hq as [B' [_ [RB [_ Hq]]]].
      subst q. zfc_simple. subst B'.
      destruct (classic (<A, RA> = <B, RB>)). {
        apply op_iff in H as []; subst...
      }
      eapply lo_connected in H as [];
      [| |apply Hlo|auto..]; apply SepE1 in H;
      apply binRelE3 in H as [H1 [_ H3]]; zfc_simple;
      exists B, RB; split...
      * apply H3... apply SepI...
      * apply H1 in Hb...
  }
  (* by contradiction show that M = X and RM is the desired well order *)
  apply SepE in H𝓜 as H. destruct H as [Hp Hwo].
  apply CPrdE1 in Hp as [M [Hsub [RM [_ Hp]]]].
  subst. zfc_simple. apply PowerAx in Hsub.
  exists RM. replace X with M...
  contra as HMX.
  assert (Hpsub: M ⊂ X). split...
  apply comp_nonempty in Hpsub as [s Hs].
  apply SepE in Hs as [Hs Hs'].
  set (M ∪ {s,}) as M'.
  set (BinRel (M ∪ {s,}) (λ x y,
    match (ixm (x = s)) with
    | inl _ => False
    | inr _ =>
      match (ixm (y = s)) with
      | inl _ => True
      | inr _ => (x <ᵣ y) RM
  end end)) as RM'.
  assert (Hsub': M' ⊆ X). {
    intros x Hx. apply BUnionE in Hx as [].
    apply Hsub... apply SingE in H...
  }
  assert (HM': <M', RM'> ∈ 𝓦). {
    apply SepI; zfc_simple.
    apply CPrdI; apply PowerAx...
    intros p Hp. apply SepE1 in Hp.
    apply CPrdE1 in Hp as [a [Ha [b [Hb Hp]]]].
    subst. apply CPrdI; apply Hsub'...
    (* woset M' RM' *)
    split; [apply loset_iff_connected_poset; split|].
    - (* connected RM' M' *)
      intros a Ha b Hb Hnq.
      apply BUnionE in Ha as [Ha|Ha];
      apply BUnionE in Hb as [Hb|Hb].
      + eapply lo_connected in Hnq as [];
        [left|right|apply Hwo|auto..];
        (apply binRelI; [apply BUnionI1; auto..|]);
        destruct (ixm (a = s)); try congruence;
        destruct (ixm (b = s))...
      + left. apply binRelI.
        apply BUnionI1... apply BUnionI2... apply SingE in Hb.
        destruct (ixm (b = s))...
        destruct (ixm (a = s))...
      + right. apply binRelI.
        apply BUnionI1... apply BUnionI2... apply SingE in Ha.
        destruct (ixm (b = s))...
        destruct (ixm (a = s))...
      + apply SingE in Ha; apply SingE in Hb...
    - (* poset M' RM' *)
      repeat split.
      + apply binRel_is_binRel.
      + apply rel_is_rel.
      + intros x y z Hxy Hyz.
        apply binRelE2 in Hxy as [Hx [Hy Hxy]].
        apply binRelE2 in Hyz as [_ [Hz Hyz]].
        apply binRelI...
        (apply BUnionE in Hx as [Hx|Hx]; [|apply SingE in Hx]);
        (apply BUnionE in Hy as [Hy|Hy]; [|apply SingE in Hy]);
        (apply BUnionE in Hz as [Hz|Hz]; [|apply SingE in Hz]);
        destruct (ixm (x = s));
        destruct (ixm (y = s));
        destruct (ixm (z = s))...
        * eapply relLt_trans... apply Hwo.
        * exfalso...
      + intros x Hp. apply binRelE2 in Hp as [Hx [_ H]].
        apply BUnionE in Hx as [Hx|Hx].
        * destruct (ixm (x = s))...
          eapply lo_irrefl... apply Hwo.
        * apply SingE in Hx.
          destruct (ixm (x = s))...
    - (* has min *)
      intros A [a Ha] HAM'.
      destruct (classic (A - {s,} = ∅)) as [|Hne]. {
        exists a. split... intros x Hx. right.
        replace A with {a,} in Hx.
        apply SingE in Hx... clear x Hx.
        ext Hx.
        - apply SingE in Hx...
        - apply sub_iff_no_comp in H.
          apply H in Hx. apply SingE in Hx.
          apply H in Ha. apply SingE in Ha. subst...
      }
      destruct Hwo as [_ Hmin].
      pose proof (Hmin (A - {s,})) as [m [Hm Hle]].
      + apply EmptyNE...
      + intros x Hx. apply SepE in Hx as [Hx Hx'].
        apply SingNE in Hx'. apply HAM' in Hx.
        apply BUnionE in Hx as []... apply SingE in H...
      + apply SepE in Hm as [Hm Hm']. apply SingNE in Hm'.
        exists m. split... intros x Hx.
        destruct (classic (m = x)) as [|Hnq]. right... left.
        apply binRelI; [apply HAM'..|]...
        destruct (ixm (m = s))...
        destruct (ixm (x = s))...
        assert (x ∈ A - {s,}). apply SepI... apply SingNI...
        apply Hle in H as []...
  }
  apply Hmax in HM' as H.
  destruct H; revgoals. {
    apply op_iff in H as [H _].
    apply Hs'. rewrite <- H. apply BUnionI2...
  }
  apply H. apply binRelI...
  repeat split; zfc_simple...
  - intros x Hx. apply BUnionI1...
  - intros Heq. apply Hs'. rewrite Heq. apply BUnionI2...
  - ext Hx.
    + destruct Hwo as [[Hbr _] _].
      apply Hbr in Hx as Hp. apply SepI...
      apply CPrdE1 in Hp as [a [Ha [b [Hb Hp]]]].
      subst. apply binRelI; [apply BUnionI1..|]...
      destruct (ixm (a = s))...
      destruct (ixm (b = s))...
    + apply SepE in Hx as [H1 H2].
      apply binRelE1 in H1 as [a [_ [b [_ [Heq Hlt]]]]].
      subst. apply CPrdE2 in H2 as [Ha Hb].
      destruct (ixm (a = s))...
      destruct (ixm (b = s))...
  - intros a Ha b Hb.
    apply SepE in Hb as [Hb Hb'].
    apply binRelI; [apply BUnionI1|..]...
    destruct (ixm (a = s))...
    destruct (ixm (b = s))...
    apply BUnionE in Hb as []...
    apply SingE in H0...
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A1 A2 B1 B2 A1prime A3 B3 B3prime : Universe, ((wd_ A1prime A3 /\ (wd_ A1 A2 /\ (wd_ A3 B3 /\ (wd_ B1 A1prime /\ (wd_ A3 B3prime /\ (wd_ B1 B2 /\ (wd_ A1prime B3prime /\ (wd_ A3 B1 /\ (wd_ B1 B3prime /\ (wd_ A1 B1 /\ (wd_ A1 B2 /\ (wd_ A2 B1 /\ (wd_ A2 B2 /\ (col_ A1 A2 A1prime /\ (col_ A1 A2 A3 /\ (col_ B1 B2 B3 /\ col_ B3prime B1 B2)))))))))))))))) -> col_ B1 B3prime B3)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Forcing.
Require Import RelationClasses.

Import NatForcing.
Import NatCondition.
Open Scope forcing_scope.

Hint Extern 4 => progress (unfold le in *) : forcing.

Program Definition later_sheaf_f {p : nat} (q : subp p) (T : sheaf q) : subp q -> Type :=
  fun r =>
    match r with
      | 0 => unit
      | S r' => sheaf_f T r'
    end.
Next Obligation of later_sheaf_f. unfold le. destruct r. simpl in *. subst x; forcing. Qed.

Program Definition subppred {q} (r : subp q) : subp q := pred r.
Next Obligation. intros. destruct r. simpl in *. unfold le in *. destruct x; forcing. Defined.

Program Definition later_transp {p} (q : subp p) (T : sheaf q) : transport (later_sheaf_f q T) :=
  λ (r : subp q) (t : subp r) (M : later_sheaf_f q T r),
  let (tn, tprf) as t return later_sheaf_f q T (iota t) := t in
    match tn return forall prf : tn <= r, later_sheaf_f q T (iota (exist tn prf)) with
      | 0 => fun prf => tt
      | S t' => fun prf => Θ T (subppred r) t' _
    end tprf.

Next Obligation. intros. destruct r, t. destruct x; simpl in *; forcing. Defined.

Next Obligation.
  destruct r as [[|r'] Hr]; simpl in *; unfold le in *.
  elimtype False. depelim prf.

  unfold subppred; simpl.
  apply M.
Defined.

Notation " '{Σ'  x } " := (exist x _).

Forcing Operator later : (Type -> Type).

Lemma later_transp_transport p (q : subp p) (T : sheaf q) : trans_prop (later_transp q T).
Proof. red; intros.
  split; red; intros.
  destruct T as [s [trans prf]].
  destruct prf. red in r.
  revert x; case_eq q0.
  intros.
  subst q0.
  destruct x.
  simpl. destruct x0. reflexivity.
  simpl.
  unfold Θ.
  simpl in *. unfold later_sheaf_f in x0.
  simpl in x0. assert(x <= ` q) by (unfold le in *; auto with arith).
  pose proof (r {Σ x, H}).
  simpl. unfold subppred.
  simpl. apply H0.

  unfold compose.
  destruct T as [sh [trans [re tr]]].
  revert r s x; case_eq q0. intros.

  destruct s as [[|s'] prf].
  now simpl in *.

  destruct r as [[|r'] prfr].
  now simpl in *.

  destruct x.
  inversion prfr.
  simpl in * |-.
  red in tr.
  simpl in *.
  unfold compose in tr. unfold subppred.
  simpl.
  unfold Θ. simpl.
  assert(x <=  ` q) by forcing.
  pose (x':={Σ x, H0}:subp q).
  pose proof (tr x').
  assert(r' <= x) by forcing.
  pose (rs':={Σ r', H2}:subp x').
  specialize (H1 rs'). assert (s' <= r') by forcing.
  specialize (H1 ({Σ s', H3})).
  unfold later_sheaf_f in x0.
  simpl in x0. specialize (H1 x0).
  apply H1.
Qed.

Program Definition later_trans_sheaf {p : nat} (q : subp p) (T : sheaf q) : sheaf q :=
          existT (later_sheaf_f q T) (exist (later_transp q T) (later_transp_transport p q T)).

Program Definition later_trans_impl : later_trans :=
          fun p : nat => exist later_trans_sheaf _.

Next Obligation of later_trans_impl.
  red; intros.
  unfold sheafC.
  destruct arg as [sh [transp [rt tt]]].
  simpl. unfold later_trans_sheaf. simpl. apply f_equal. apply exist_eq.
  unfold Θ. simpl.
  extensionality s0.
  extensionality t.
  extensionality x.
  destruct t.
  destruct x0. reflexivity.
  simpl. apply f_equal.
  destruct s0.
  simpl. destruct x1; reflexivity.
Qed.

Next Obligation.
  red.
  intros.
  exact (later_trans_impl p).
Defined.

Notation " '{Σ' x } " := (exist x _).

Time Forcing Operator next : (forall T : Set, T -> later T).

Next Obligation.
  intros. red; simpl; intros.
  apply (H (one_trans _ _ _ r1)).
Qed.

Next Obligation.
  red; simpl; intros. split ; red; intros; reflexivity.
Qed.

Definition innernext_fnty {p} (r : subp p) (arg : sheaf r) :=
  ∀ r1 : subp r,
    sheaf_f arg r1
    → later_sheaf_f (embed r1) (sheafC r (ι r) r1 arg) (ι r1).

Definition innernext_fncommpi {p} (r : subp p) (arg : sheaf r) (f1 : innernext_fnty r arg) :=
  ∀ (r1 : subp r) (s1 : subp r1) (arg1 : sheaf_f arg r1),
     later_transp (embed r1) (sheafC r (ι r) r1 arg) (ι r1) s1 (f1 r1 arg1) =
                  f1 (ι s1) (Θ arg r1 s1 arg1).

Definition innernext_ty {p} (r : subp p) (arg : sheaf r) := sig (innernext_fncommpi r arg).

Coercion embed : P >-> subp.

Program Definition innernextfn {p} (r : subp p) (arg : sheaf r) : innernext_fnty r arg :=
 (fun (r1 : subp r) =>
    let (r1t, r1prf) as r1 return sheaf_f arg r1 -> later_sheaf_f (`r1)
                                                                      (sheafC r r r1 arg) (embed r1)
                                  := r1 in
    (match r1t return forall H : r1t <= r, sheaf_f arg {Σ r1t, H} -> later_sheaf_f (embed r1t)
                                                                      (sheafC r (embed r) {Σ r1t, H} arg) (embed r1t)  with
      | 0 => fun H sh => tt
      | S n => fun H sh => Θ arg {Σ S n, H} n sh
    end r1prf)).

Program Definition innernext {p} (r : subp p) (arg : sheaf r) : innernext_ty r arg := innernextfn r arg.

Next Obligation of innernext.
Proof. Transparent later_transp.
  red; intros.
  destruct s1 as [[|s1'] Hs1]; simpl.
  reflexivity.
  destruct arg as [sh [tr [trr trt]]].
  simpl in *.
  red in trt.
  repeat unfold Θ. simpl.
  repeat unfold Θ. simpl.
  unfold iota in *; simpl.
  destruct r1 as [[|r1'] Hr1]; simpl in *.
  inversion Hs1. unfold compose in trt.

  assert(s1' <= r1') by auto with forcing arith.
  assert(r1' <= ` r) by auto with forcing arith.
  assert(r1' <= S r1') by auto with forcing arith.
  pose proof (trt {Σ S r1', Hr1} {Σ r1', H1} {Σ s1', H}).
  simpl in H2.
  rewrite H2.
  assert(s1' <= S s1') by auto with forcing arith.
  pose proof (trt {Σ S r1', Hr1} {Σ S s1', Hs1} {Σ s1', H3}).
  simpl in H4.
  rewrite H4.
  reflexivity.
Qed.

Transparent later_transp.
Program Definition nextdef p : { x | next_transprop1 p (embed p) x } :=
            @innernext p.

Next Obligation of nextdef.
Proof.
  red; intros.
  pose proof (proj2_sig (innernext r arg)).
  red in H. apply exist_eq.
  extensionality s1.
  extensionality arg1.
  destruct s1 as [[|x'] Hx]; simpl; reflexivity.
Qed.

Next Obligation.
Proof nextdef.

Forcing Operator fixp : (forall T : Type, (later T -> T) -> T).

(** Should be automatable: simple reindexings of commutation
  properties. *)

Next Obligation.
Proof.
  red in H; simpl in H.
  red; simpl; intros; apply (H (iota r2) s2 arg2).
Qed.

Next Obligation.
  red; split; red; intros; reflexivity.
Qed.

Next Obligation.
  red. simpl.
  intros.
  unfold fixp_transprop1 in H.
  apply (H (iota r1) s1).
Qed.

Next Obligation.
  red; split; red; intros; reflexivity.
Qed.

Definition Pred (p : nat) := { x : nat | x < p }.

Program Definition Pred_to_sub (p : nat) (q : Pred p) : subp p := q.
Next Obligation of Pred_to_sub.
  destruct q; forcing.
Defined.

Program Definition succ_of_Pred (p : nat) (q : Pred p) : subp p := S q.
Next Obligation of succ_of_Pred.
  destruct q; forcing.
Defined.

Program Definition subp0 (p : nat) : subp p := 0.

Require Import Wf.

Lemma le_decr : forall n m, S n <= m -> n <= m.
Proof. intros. red in H |- *. inversion H. auto with arith.
  auto with arith.
Defined.

Fixpoint subp_rect_aux {q : nat} (P : subp q -> Type)
                   (p0 : P (subp0 q)) (pS : forall r : Pred q, P (Pred_to_sub q r) -> P (succ_of_Pred q r))
                   (r : nat) (prf : r <= q) : P (exist r prf) :=
  match (exist r prf) as r' return P r' with
    | exist 0 prf => p0
    | exist (S n) prf => pS (exist n prf) (subp_rect_aux P p0 pS n (le_decr _ _ prf))
  end.

Definition subp_rect {q : nat} (P : subp q -> Type)
                (p0 : P (subp0 q)) (pS : forall r : Pred q, P (Pred_to_sub q r) -> P (succ_of_Pred q r))
                (r : subp q) : P r :=
  let (r, rprf) as r' return P r' := r in
    subp_rect_aux P p0 pS r rprf.

Global Program Instance iota_iota p (q : subp p) (r : P) {I : Iota p q r} : Iota p q (iota (Iota:=I) q : P) | 1000 := { iota := iota q }.
Next Obligation of iota_iota. intros. rewrite iota_identity. reflexivity. Qed.

Program Definition secondinnerinnerfnty p (r : subp p) (arg : sheaf r) (r1 : subp r) :=
 ∀ r2 : subp r1,
               later_sheaf_f (embed r2) (sheafC r (iota r) (iota r2) arg)
                             (iota r2) → projT1 (sheafC r (iota r) (iota r2) arg) (iota r2).

Program Definition secondinnerinnerfnprop p (r : subp p) (arg : sheaf r) (r1 : subp r)
                                     (f2 : secondinnerinnerfnty p r arg r1) :=
           ∀ (r2 : subp r1) (s2 : ssubp r2)
             (arg2 : later_sheaf_f (embed r2) (sheafC r (iota r) (iota r2) arg)
                                   (iota r2)),
             (` (projT2 (sheafC r (iota r) (iota r2) arg)))
               (iota r2) (iota s2) (f2 r2 arg2) =
               f2 (iota s2)
               (later_transp (embed r2) (sheafC r (iota r) (iota r2) arg)
                             (iota r2) (iota s2) arg2).

Program Definition secondinnerfnty p (r : subp p) (arg : sheaf r) (r1 : subp r) :=
          sig (secondinnerinnerfnprop p r arg r1).

Program Definition secondfnty p (r : subp p) (arg : sheaf r) (r1 : subp r) :=
          secondinnerfnty p r arg r1 → projT1 (sheafC r (iota r) (iota r1) arg) (iota r1).

Example lif1 {p} {q : subp p} (r : subp q) : subp p.
Proof. exact (iota r). Defined.

Program Lemma secondfnprop_trans p (r : subp p) (arg : sheaf r) :
          ∀ (r1 : subp r) (s1 : subp r1) (arg1 : secondinnerfnty p r arg r1),
            secondinnerinnerfnprop p r arg (lif1 s1) (λ s2 : subp s1, (` arg1) (lif1 s2)).
  intros.
  red in arg1.
  destruct arg1 as [f2 Hf2].
  red in Hf2. red. simpl.
  intros. specialize (Hf2 (iota r2)).
  simpl in Hf2.
  apply Hf2.
Qed.

Program Definition lift_secondinnerfn p (r : subp p) (arg : sheaf r) (r1 : subp r) (arg1 : secondinnerfnty p r arg r1) (s1 : subp r1) : secondinnerfnty p r arg (lif1 s1) :=
          exist _ (secondfnprop_trans p r arg r1 s1 arg1).

Program Definition secondfnprop p (r : subp p) (arg : sheaf r) (f1 : forall r1 : subp r, secondfnty p r arg r1) :=
          ∀ (r1 : subp r) (s1 : subp r1)
            (arg1 : secondinnerfnty p r arg r1),
            ((` (projT2 (sheafC r (iota r) (iota r1) arg)))
               (iota r1) (iota s1) (f1 r1 arg1) =
               f1 (iota s1) (lift_secondinnerfn p r arg r1 arg1 s1)).

Definition innerfn p (r : subp p) (arg : sheaf r) (r1 : subp r) : secondfnty p r arg r1 :=
  fun (f2 : secondinnerfnty p r arg r1) =>
    subp_rect (fun r : subp r1 => sheaf_f arg (iota r))
                          (` f2 (subp0 _) tt)
                          (fun (r' : Pred (`r1)) a => ` f2 (succ_of_Pred _ r') a)
                          (iota r1).

Program Definition secondfn :=
          (fun p (r : subp p) (arg : sheaf r) =>
             (exist (innerfn p r arg) _ : sig (secondfnprop p r arg))).

Program Definition lift_subp {p} (q : subp p) : subp (S p) := q.
Program Definition lift_Pred {p} (q : Pred p) : Pred (S p) := q.
Next Obligation of lift_Pred.
  destruct q as [q Hq]. forcing.
Qed.

Lemma lift_subp_rect_aux {q : nat} (P : subp (S q) -> Type)
                         (p0 : P (subp0 (S q)))
                         (pS : forall r : Pred (S q), P (Pred_to_sub (S q) r) -> P (succ_of_Pred (S q) r))
                         (r : nat) (prf : r <= (S q)) (prf' : r <= q) :
  subp_rect_aux P p0 pS r prf = subp_rect_aux (fun r : subp q => P (lift_subp r))
                p0 (fun r prf => pS (lift_Pred r) prf) r prf'.
Proof. induction r; simpl; auto.
  apply f_equal. apply IHr.
Qed.

Program Definition subp_le {p} (q : subp p) r (prf : p <= r) : subp r := q.

Ltac forward H :=
  match type of H with
    | forall X : ?T, _ => let arg := fresh in
                            assert (arg:T);[|specialize (H arg)]
  end.

Next Obligation of secondfn.
  intros [r1 Hr1].
  induction r1; simpl; intros.
  unfold innerfn; simpl.
  unfold Θ in *; simpl in *.
  red in arg1.

  (* 0 *)
  destruct s1 as [[|s1] Hs1]; simpl.
  apply (proj2_sig arg1 (subp0 0) (subp0 _)).

  inversion Hs1.

  (* S n *)
  Transparent later_transp.
  forward IHr1; forcing.
  pose (proj2_sig arg1 (embed (S r1)) s1).
  simpl in e.
  unfold innerfn.
  simpl. rewrite e. clear e.
  destruct s1 as [[|s1] Hs1]; simpl; auto.
  apply f_equal.
  unfold innerfn in IHr1.
  simpl in *.

  simpl.
  assert(s1 <= r1) by forcing.
  assert(r1 <= r1) by forcing.
  rewrite lift_subp_rect_aux with (prf':=H1).
  rewrite lift_subp_rect_aux with (prf':=reflexivity s1 : s1 <= s1).
  specialize (IHr1 {Σ s1, H0}).
  simpl in IHr1.
  repeat (unfold Θ in *; simpl in *).
  specialize (IHr1 (lift_secondinnerfn p r arg _ arg1 (lift_subp (embed r1)))).
  simpl in IHr1.
  apply IHr1.
Qed.

Next Obligation.
  red.
  intros p.
  exists (secondfn p).
  red; intros. reflexivity.
Qed.


From stdpp Require Import prelude finite.
From Coq Require Import FinFun.
From VLSM.Lib Require Import Preamble ListExtras StdppExtras.

(** * Finite function utility definitions and lemmas *)

Lemma listing_from_finite (A : Type) `{finite.Finite A} : Listing (enum A).
Proof.
  constructor.
  - by apply NoDup_ListNoDup, NoDup_enum.
  - by intro a; apply elem_of_list_In, elem_of_enum.
Qed.

Lemma map_option_listing
      {A B : Type} (f : A -> option B) (g : B -> A)
      (f_proj_inj : forall a b, f a = Some b -> a = g b)
      (f_surj : forall b, f (g b) = Some b)
      (A_listing : list A) (A_finite : Listing A_listing) : Listing (map_option f A_listing).
Proof.
  destruct A_finite as [Hnodup Hfull].
  split.
  - clear Hfull.
    induction A_listing as [| a l IHl]; [by constructor |].
    inversion_clear Hnodup as [| ? ? H1 H2].
    specialize (IHl H2); clear H2.
    simpl.
    destruct (f a) eqn: Hfa; [| done].
    apply f_proj_inj in Hfa. subst a.
    constructor; [| done].
    contradict H1.
    apply in_map_option in H1.
    destruct H1 as [a [Ha Hfa]].
    apply f_proj_inj in Hfa.
    by subst a.
  - intro b.
    specialize (Hfull (g b)).
    apply in_map_option.
    exists (g b).
    split; [done |].
    by apply f_surj.
Qed.

Section sec_sum_listing.
(** [Listing] for the sum type implies [Listing] for each projection *)

Context
  {Left Right : Type}
  {sum_listing : list (Left + Right)}
  .

Definition left_listing
  (sum_finite : Listing sum_listing)
  : list Left
  := list_sum_project_left sum_listing.

Definition right_listing
  (sum_finite : Listing sum_listing)
  : list Right
  := list_sum_project_right sum_listing.

Lemma left_finite
  (sum_finite : Listing sum_listing)
  : Listing (left_listing sum_finite).
Proof.
  revert sum_finite.
  apply map_option_listing with (g := inl); [| done].
  by destruct a; simpl; congruence.
Qed.

Lemma right_finite
  (sum_finite : Listing sum_listing)
  : Listing (right_listing sum_finite).
Proof.
  revert sum_finite.
  apply map_option_listing with (g := inr); [| done].
  by destruct a; simpl; congruence.
Qed.

End sec_sum_listing.


Require Import Vloc.Lib.theory.
Require Import Vloc.CCode.rev.

(* NOTE: don't need a module! *)
Definition rev_internal : heap_lang.val :=
  (* NOTE: there is a difference between λ: and rec:  besides notation! Recursion! *)
  (rec: "rev_internal" "prev" "cur" :=
    match: "cur" with
      (* return the new head of the list, the end *)
      NONE        => "prev"
      (* turn rest to previous and return *)
    | SOME "node" =>
        (* Due to notation differences, we need to have a few paranthesis lying about *)
        let: "elem" := Fst (!"node") in
        let: "rest" := Snd (!"node") in
        "node" <- ("elem", "prev");;
        "rev_internal" (SOME "node") "rest"
    end%Ei). (* without this scope tag, this does not work; I do not know why *)

(* NOTE: "rev_internal" (quotes) does not work, but rev_internal does *)
Definition iRev : heap_lang.val := λ: "list", (rev_internal NONE "list").

#[local] Instance prog_ctx : refines_ctx := { gName := 1; nspace := nroot .@ "test"}.

#[local] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

(*
   We'll need a way to compare VST lists and iris lists.
   We could do something direct, but it's probably easier
   to just say that they both equal the same Coq level list.

   For simplicity, let's stick to integers.
*)

(* first a VST list *)
Definition node_t := Tstruct _node noattr.

Fixpoint Vlist (sigma: list Z) (p: val) : mpred :=
 match sigma with
 | h::hs =>
    EX y:val,
    (* NOTE: should malloc_token be here? -> Probably!  It makes sense here. *)
    data_at Ews node_t (Vint (Int.repr h),y) p  *  malloc_token Ews node_t p * Vlist hs y
 | nil =>
    ⌜ (p = nullval) ⌝  (* NOTE: I used to have an emp here; why? -> Allows binding logic to empty memory *)
 end.

(* now an iris list *)

(* NOTE: we don't want an iris heap here directly, we want our simulated one. *)
Fixpoint Ilist (sigma : list Z) v : mpred :=
  match sigma with
  | x :: xs => ∃ (p : loc), ⌜ v = InjRV (#p) ⌝ ∗ ∃ (v' : ival), p |-> ((#x), v')%V ∗ Ilist xs v'
  | [] => ⌜ (v = InjLV (LitV LitUnit)) ⌝
  end.

(* and we can compare them *)
Definition EquivList σ V I : mpred
  := (Ilist σ I * Vlist σ V)%logic.

(*NOTE: gather_SEP really runs let i := fresh "i" in freeze i := L; thaw i. for any input L *)

(* We'll need a bunch of helpers describing how EquivList works *)
(* It would also be good to have stuff for Vlist and Ilist but we can wrap them up for this proof *)

(* If either value is it's NULL equivalent, the list is empty *)
Lemma Equiv_null_l σ Ival :
  EquivList σ nullval Ival |-- EquivList [] nullval Ival.
Proof.
  destruct σ; auto.
  (*NOTE: how to do in one step? *)
  iIntros "[Ri Rv]".
  iDestruct "Rv" as (y) "[[Rnull Rtok] Rrest]"; fold Vlist.
  (* I feel like this should be automatic at this point, but I don't know for sure *)
  iDestruct (field_at_ptr_neq_null with "Rnull") as "%Hcontra".
  exfalso.
  apply Hcontra.
  apply ptr_eq_nullval.
Qed.

Lemma Equiv_null_r σ Vval :
  EquivList σ Vval (InjLV (#())) |-- (EquivList [] Vval (InjLV (#()))).
Proof.
  destruct σ; auto.
  iIntros "[Ril Rvl]".
  iDestruct "Ril" as (p) "[%Hcontra RUselessButICantDrop]"; fold Ilist.
  discriminate.
Qed.

(* If the list is empty, both values are known to be null *)
Lemma Equiv_empty Vval Ival :
  EquivList [] Vval Ival |-- (!! (Vval = nullval) && !! (Ival = (InjLV (#()))) && EquivList [] Vval Ival).
Proof.
  iIntros "[%Ri %Rv]".
  auto.
Qed.

(* Null is the same as an empty list *)
Lemma Equiv_emp_nullList:
  emp |-- EquivList [] nullval (InjLV (#())).
Proof.
  iIntros "_".
  auto.
Qed.

(* for the non-empty cases *)

(* If either value is not null, then both aren't null and the list has a head *)
Lemma Equiv_not_null σ Vval Ival :
  (Vval ≠ nullval \/ Ival ≠ (InjLV (#()))) ->
  (EquivList σ Vval Ival |-- EX (s : Z), EX (σ' : list Z), (!! (Vval ≠ nullval /\ Ival ≠ (InjLV (#())))) &&  (EquivList (s :: σ') Vval Ival))%logic.
Proof.
  (* exhaustive check of all the cases *)
  intros H; destruct H as [HV | HI]; destruct σ as [| s σ'].
  {
    iIntros "[_ %Contra]".
    contradiction.
  }
  2:{
    iIntros "[%Contra _]".
    contradiction.
  }
  1,2:
    iIntros "[Ri Rv]";
    iDestruct "Rv" as (Vval') "[[Rdat Rmal] Rvr]";
    iDestruct "Ri" as (l HIval') "[%iv [Ripts Rir]]";
    iDestruct (field_at_ptr_neq_null with "Rdat") as "%Hvpt";
    iExists s;
    iExists σ';
    fold Vlist Ilist.
  - iSplitR; auto.
    + iPureIntro; split; auto.
      rewrite HIval'.
      auto.
    + unfold EquivList; simpl.
      iSplitL "Ripts Rir".
      { iExists l. iSplitR; auto. iExists iv. iFrame.  }
      { iExists Vval'. iFrame. }
  - iSplitR; auto.
    + iPureIntro; split; auto.
      destruct (eq_dec Vval nullval); auto.
      subst Vval.
      exfalso.
      apply Hvpt.
      apply ptr_eq_nullval.
    + unfold EquivList; simpl.
      iSplitL "Ripts Rir".
      { iExists l. iSplitR; auto. iExists iv. iFrame.  }
      { iExists Vval'. iFrame. }
Qed.

(* If the list has a head, then we can pull out the head of both sublists *)
Lemma Equiv_pop s σ' Vval Ival:
  EquivList (s :: σ') Vval Ival |--
      (EX Vval', EX Ival', EX (p : loc), (
      (!! (Ival = InjRV (#p) /\ Vval ≠ nullval) && (data_at Ews node_t (Vint (Int.repr s),Vval') Vval * malloc_token Ews node_t Vval) * p |-> (#s, Ival')%V *
      EquivList σ' Vval' Ival'))).
Proof.
  iIntros  "[RI RV]".
  simpl.
  iDestruct "RI" as (p Hip Ival') "(RIpts & Ri')".
  iDestruct "RV" as (Vval') "[[Rvdata Rvmal] Rv']".
  iExists Vval'.
  iExists Ival'.
  iExists p.
  iSplitR "Ri' Rv'".
  2: iFrame.
  iSplitR "RIpts"; auto.
  iSplit; last iFrame.
  iSplit; auto.
  iPoseProof (field_at_ptr_neq_null with "Rvdata") as "%H".
  iPureIntro.
  intro Hcontra.
  subst Vval.
  assert (ptr_eq nullval nullval = true); auto.
  apply ptr_eq_True.
  apply mapsto_memory_block.is_pointer_or_null_nullval.
  destruct H.
  rewrite H0.
  auto.
Qed.

(* Likewise, if we have all the stuff to add a head, we can *)
Lemma EquivList_push v v' i i' (l : loc) s σ:
  ((i = InjRV (#l)) /\ (v ≠ nullval)) -> (EquivList σ v' i' * data_at Ews node_t (Vint (Int.repr s), v') v * malloc_token Ews node_t v * l |-> (#s, i')%V) |-- EquivList (s :: σ) v i.
Proof.
  iIntros (Hnnull) "[[[[Ri Rv] Rdata] Rmalloc] Rpts]".
  destruct Hnnull as [Hi Hv].
  unfold EquivList.
  iSplitL "Rpts Ri".
  - iExists l; fold Ilist.
    iSplitR; auto.
    iExists i'.
    iFrame.
  - iExists v'; fold Vlist.
    iFrame.
Qed.

(* VST helper so we don't have to reprove things about nullval al the time *)
Lemma EquivList_local_facts σ v i:
   EquivList σ v i |--
       !! (is_pointer_or_null v /\ (v=nullval <-> σ=nil) /\ (i=(InjLV (#())) <-> σ=nil)).
Proof.
  iIntros "EqList".
  destruct σ.
  - iDestruct "EqList" as "[%Ilist %Vlist]".
    subst v; subst i.
    iPureIntro.
    split; first apply mapsto_memory_block.is_pointer_or_null_nullval. (* I hope I never apply this lemma again *)
    split; split; auto.
  - iDestruct (Equiv_pop with "EqList") as (v' i' p) "[[[[%Hi %Hv] [Hdata Hmalloc]] ptsTo] EqList']".
    subst i.
    iDestruct (data_at_valid_ptr with "Hdata") as "Hvalid"; auto.
    { rewrite sizeof_Tstruct; simpl. lia. } (* NOTE: This is a weird goal.  Why does it come up? *)
    iSplitL.
    { destruct v; auto. }
    iPureIntro; split; split; intro; try contradiction; try list_solve.
Qed.
#[export] Hint Resolve EquivList_local_facts : saturate_local.

(* The main program we want to verify *)
Definition rev_list_internal_spec :=
  DECLARE _rev_list_internal
    WITH gv: globals, ctx: ref_id, Vprev: val, Vcur: val, Iprev: ival, Icur: ival, Lcur: list Z, Lprev: list Z
    PRE [ tptr node_t, tptr node_t ]
      PROP()
      PARAMS(Vprev; Vcur)
      GLOBALS()
      SEP(EquivList Lprev Vprev Iprev ; EquivList Lcur Vcur Icur ;
            refines_right ctx ((of_val rev_internal) Iprev Icur))
    POST [ tptr node_t ]
      EX Vres: val, EX Ires: ival, EX σ': list Z,
      PROP()
      RETURN(Vres)
      SEP(EquivList σ' Vres Ires ; (refines_right ctx (ectxi_language.of_val Ires))).

(* the wrapper to just reverse a list *)
Definition rev_list_spec :=
  DECLARE _rev_list
    WITH gv: globals, ctx: ref_id, Vhead: val, Ihead: ival, σ: list Z
    PRE [ tptr node_t ]
      PROP()
      PARAMS(Vhead)
      GLOBALS()
      SEP(EquivList σ Vhead Ihead ;
            refines_right ctx ((of_val iRev) Ihead))
    POST [ tptr node_t ]
      EX Vres: val, EX Ires: ival, EX σ': list Z,
      PROP()
      RETURN(Vres)
      SEP(EquivList σ' Vres Ires ; (refines_right ctx (ectxi_language.of_val Ires))).

(* While this isn't really needed, I wanted to test out allocation, so we'll verify this too *)

(* heap lang version of an empty node *)
Definition empty_node : heap_lang.val :=
  λ: "_", (let: "l" := (Alloc ((#0), InjLV (#()))) in (SOME "l")%V)%Ei.

Definition empty_node_spec :=
  DECLARE _empty_node
    WITH gv: globals, ctx: ref_id
    PRE []
      PROP()
      PARAMS()
      GLOBALS(gv)
      SEP(mem_mgr gv; refines_right ctx ((of_val empty_node) (#())))
    POST [tptr node_t ]
      EX V: val, EX I : ival,
      PROP()
      RETURN(V)
      SEP(mem_mgr gv; EquivList [0]%Z V I; (refines_right ctx (ectxi_language.of_val I))).

Definition Gprog : funspecs := ltac:(with_library prog [
    rev_list_internal_spec ;
    rev_list_spec ;
    empty_node_spec
  ]).

Lemma rev_internal_lemma : semax_body Vprog Gprog f_rev_list_internal rev_list_internal_spec.
Proof.
  start_function.
  unfold rev_internal.
  (* NOTE: To get rid of the %Ei tag *)
  (*Open Scope iris_expr_scope.*)
  SPR_beta; fold rev_internal. (* do remember to fold this! Things are messy otherwise *)
  SPR_recc; SPR_beta.
  (* either cur is null or not *)
  destruct (eq_dec Vcur nullval); subst.
  {
    (* if it is null, then the iris one is too *)
    sep_apply Equiv_null_l; sep_apply Equiv_empty.
    Intros.
    rename H into HIcurNull.
    subst Icur.

    (* Step iris to ending *)
    SPR_inl.
    SPR_recc.
    SPR_beta.

    (* We cannot get past this if statement in this case *)
    forward_if (
      PROP (False)
      LOCAL()
      SEP()
    ).
    {
      forward.
      iIntros "[[ReqNull RrefR] ReqPrev]".
      iExists Vprev.
      iExists Iprev.
      iExists Lprev.
      iFrame.
      auto.
    }
    {
      (* Null != Null *)
      contradiction.
    }
  }
  {
    (* If it's not null, then... *)

    (* we have an element in BOTH lists *)
    sep_apply (Equiv_not_null Lcur); [left; auto|].
    Intros c Lcur'; clear Lcur.
    sep_apply (Equiv_pop c Lcur').
    Intros Vcur' Icur' IlocCur.
    rename H0 into HIlocCur; subst Icur.

    (* and we can reduce the right hand side! *)
    SPR_inr.
    SPR_recc; SPR_beta.

    (* including loads *)
    SPR_load IlocCur.
    SPR_fst.
    SPR_recc.
    SPR_beta.
    SPR_load IlocCur.
    SPR_snd.
    SPR_recc.
    SPR_beta.

    SPR_pairc. (* I hate this :( (also I needed the underscores again) *)
    SPR_store IlocCur (#c, Iprev)%V. (* NOTE: how to get rid of the %V here? -> needed for notation to fire *)

    (* now we step *)
    SPR_recc; SPR_beta.

    (* run the right side to the same point now *)

    (* This if statement cannot be entered *)
    forward_if.
    { contradiction. }

    forward.
    forward.

    (* we added a new element to the front of Lprev *)
    sep_apply (EquivList_push Vcur Vprev (InjRV (#IlocCur))); auto.
    (*viewshift_SEP' (IlocCur |-> _) (data_at _ _ _ _) (malloc_token _ _ _) (EquivList Lprev _ _) *)
        (*(EquivList (c :: Lprev) Vcur (InjRV (#IlocCur))%V).*)
    (*{*)
      (*entailer!.*)
      (*iIntros "[[[Rpt Rdta] Rmlc] Reqt]".*)
      (*iModIntro.*)
      (*iApply EquivList_push; auto.*)
      (*iFrame.*)
    (*}*)

    (* Almost forgot this step! *)
    SPR_injrc.

    (* If Ei is open here, this will break; I think it conflicts *)
    forward_call (gv, ctx, Vcur, Vcur', (InjRV (#IlocCur))%V, Icur', Lcur', (c :: Lprev)).

    Intros ret.
    destruct ret as [p lret]; destruct p as [vret iret].
    forward.

    Exists vret.
    Exists iret.
    Exists lret.
    entailer!.
  }
Qed.

Lemma rev_list_lemma : semax_body Vprog Gprog f_rev_list rev_list_spec.
Proof.
  start_function; unfold iRev.
  SPR_beta.
  SPR_injlc.
  forward_call (gv, ctx, nullval, Vhead, (InjLV (#())), Ihead, σ, ([] : list Z)).
  { iIntros "Re". iDestruct (Equiv_emp_nullList with "Re") as "R". iVST; cancel. }

  Intros tuple.
  destruct tuple as [[v' i'] σ'].
  simpl.
  forward.
  Exists v'.
  Exists i'.
  Exists σ'.
  entailer!.
  unfold ectxi_language.of_val; simpl.
  cancel.
Qed.

Lemma empty_node_lemma : semax_body Vprog Gprog f_empty_node empty_node_spec.
Proof.
  start_function.
  unfold empty_node.

  (* allocate the C node *)
  forward_call (node_t, gv).
  Intros ptr.

  (* allocate the heap_lang node *)
  SPR_beta.
  SPR_pairc.

  SPR_alloc.
  Intros l.

  SPR_recc.
  SPR_beta.

  (* now we go through the if statement *)
  destruct (eq_dec ptr nullval).
  {
    (* If we have null, we can prove false since exit *)
    forward_if (PROP(False) LOCAL() SEP()).
    {
      forward_call.
      contradiction.
    }
    contradiction.
  }

  {
    (* If we don't have null, we continue *)
    rewrite if_false; auto.
    evar (e : iexp); evar (v : ival). (* so we don't rewrite them all *)
    forward_if (
      PROP()
      LOCAL(temp _ptr ptr; gvars gv)
      SEP(refines_right ctx e; (l |-> v); mem_mgr gv; malloc_token Ews node_t ptr; data_at_ Ews node_t ptr)
    ); subst e v.
    {
      (* We can't enter the if *)
      contradiction.
    }
    {
      (* Skipping it just gives us what we already know in this case *)
      forward.
      entailer!.
      apply derives_refl.
    }

    rename n into HnotNull.

    (* Now we initialize memory *)
    do 2 forward.

    (* Don't forget to build our list *)
    (* NOTE: this doesn't seem to like sep_apply *)
    viewshift_SEP' (malloc_token _ _ _) (EquivList [] nullval (InjLV (#())) * malloc_token Ews node_t ptr)%logic.
    {
      go_lower.
      iIntros "Rmalloc"; iFrame.
      iApply Equiv_emp_nullList.
      auto.
    }
    Intros.
    SPR_injrc.

    (* also add the one element to it *)
    viewshift_SEP' (EquivList [] _ _) (malloc_token _ _ _) (data_at _ _ _ _) (_ |-> _) (EquivList [0]%Z ptr (InjRV (#l))%V).
    {
      go_lower.
      iIntros "[[Rm Ra] Rpt]".
      iApply EquivList_push; auto.
      iModIntro.
      iFrame.
    }

    (* and return *)
    forward.

    Exists ptr.
    Exists (InjRV (#l)).
    simpl.
    entailer!.
  }
Qed.


(*
 - Definition of the pseudofunctor `⦃ P ⦄` from a polynomial code `P`
From 'GrpdHITs/code/algebra/one_types_polynomials.v'
*)

Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import Integers.signature.

Require Import Integers.Prebicategories.DispPrebicat.
Require Import Integers.Prebicategories.PseudoFunctor.
Require Import Integers.type_prebicat.

Local Open Scope cat.
Local Open Scope bicategory_scope.
Local Open Scope mor_disp_scope.

(** Preliminary  definitions**)
(* For coproduct *)
Definition coprodf_path
           {X1 X2 Y1 Y2 : UU}
           {f1 g1 : X1 → Y1}
           {f2 g2 : X2 → Y2}
           (p1 : f1 ~ g1)
           (p2 : f2 ~ g2)
           (x : X1 ⨿ X2)
  : coprodf f1 f2 x = coprodf g1 g2 x.
Proof.
  induction x as [x | x].
  - exact (maponpaths inl (p1 x)).
  - exact (maponpaths inr (p2 x)).
Defined.

Definition coprodf_id
           {X Y : UU}
           (x : X ⨿ Y)
  : coprodf (λ z, z) (λ z, z) x = x.
Proof.
  induction x as [x | x].
  - exact (idpath (inl x)).
  - exact (idpath (inr x)).
Defined.

Definition coprodf_comp
           {X1 X2 Y1 Y2 Z1 Z2 : UU}
           (f1 : X1 → Y1)
           (g1 : Y1 → Z1)
           (f2 : X2 → Y2)
           (g2 : Y2 → Z2)
           (x : X1 ⨿ X2)
  : (coprodf (g1 ∘ f1)%functions (g2 ∘ f2)%functions x
     =
     (coprodf g1 g2) (coprodf f1 f2 x))%functions.
Proof.
  induction x as [x | x].
  - exact (idpath (inl (g1 (f1 x)))).
  - exact (idpath (inr (g2 (f2 x)))).
Defined.

Definition coprodf_path_maponpaths_inl
           {X₁ X₂ Y₁ Y₂ : UU}
           (f : X₁ → X₂)
           (g : Y₁ → Y₂)
           {x₁ x₂ : X₁}
           (p : x₁ = x₂)
  : maponpaths (coprodf f g) (maponpaths inl p) = maponpaths inl (maponpaths f p).
Proof.
  induction p.
  exact (idpath (idpath (inl (f x₁)))).
Defined.

Definition coprodf_path_maponpaths_inr
           {X₁ X₂ Y₁ Y₂ : UU}
           (f : X₁ → X₂)
           (g : Y₁ → Y₂)
           {y₁ y₂ : Y₁}
           (p : y₁ = y₂)
  : maponpaths (coprodf f g) (maponpaths inr p) = maponpaths inr (maponpaths g p).
Proof.
  induction p.
  exact (idpath (idpath (inr (g y₁)))).
Defined.

(* For product *)
Definition dirprodf_path
           {X1 X2 Y1 Y2 : UU}
           {f1 g1 : X1 → Y1}
           {f2 g2 : X2 → Y2}
           (p1 : f1 ~ g1)
           (p2 : f2 ~ g2)
           (x : X1 × X2)
  : dirprodf f1 f2 x = dirprodf g1 g2 x
  := pathsdirprod (p1 (pr1 x)) (p2 (pr2 x)).

Definition dirprodf_id
           {X Y : UU}
           (x : X × Y)
  : dirprodf (λ z, z) (λ z, z) x = x
  := pathsdirprod (idpath (pr1 x)) (idpath (pr2 x)).

Definition dirprodf_comp
           {X1 X2 Y1 Y2 Z1 Z2 : UU}
           (f1 : X1 → Y1)
           (g1 : Y1 → Z1)
           (f2 : X2 → Y2)
           (g2 : Y2 → Z2)
           (x : X1 × X2)
  : (dirprodf (g1 ∘ f1)%functions (g2 ∘ f2)%functions x
     =
     (dirprodf g1 g2) (dirprodf f1 f2 x))%functions
  := pathsdirprod (idpath (g1 (f1 (pr1 x)))) (idpath (g2 (f2 (pr2 x)))).

Definition path_dirprodf_path
           {X₁ X₂ Y₁ Y₂ : UU}
           {f₁ g₁ : X₁ → Y₁}
           {f₂ g₂ : X₂ → Y₂}
           {p₁ q₁ : f₁ ~ g₁}
           {p₂ q₂ : f₂ ~ g₂}
           (s₁ : p₁ ~ q₁) (s₂ : p₂ ~ q₂)
           (x : X₁ × X₂)
  : dirprodf_path p₁ p₂ x = dirprodf_path q₁ q₂ x
  := (maponpaths (λ z, pathsdirprod z _) (s₁ (pr1 x)))
       @ maponpaths (λ z, pathsdirprod _ z) (s₂ (pr2 x)).

Definition pathsdirprod_concat
           {X Y : UU}
           {x₁ x₂ x₃ : X}
           {y₁ y₂ y₃ : Y}
           (p₁ : x₁ = x₂) (p₂ : x₂ = x₃)
           (q₁ : y₁ = y₂) (q₂ : y₂ = y₃)
  : pathsdirprod p₁ q₁ @ pathsdirprod p₂ q₂
    =
    pathsdirprod (p₁ @ p₂) (q₁ @ q₂).
Proof.
  induction p₁, q₁.
  exact (idpath (pathsdirprod p₂ q₂)).
Defined.

Definition dirprodf_path_concat
           {X₁ X₂ Y₁ Y₂ : UU}
           {f₁ g₁ h₁ : X₁ → Y₁}
           {f₂ g₂ h₂ : X₂ → Y₂}
           (p₁ : f₁ ~ g₁) (q₁ : g₁ ~ h₁)
           (p₂ : f₂ ~ g₂) (q₂ : g₂ ~ h₂)
           (x : X₁ × X₂)
  : dirprodf_path p₁ p₂ x @ dirprodf_path q₁ q₂ x
    =
    dirprodf_path (homotcomp p₁ q₁) (homotcomp p₂ q₂) x
  := pathsdirprod_concat  (p₁ (pr1 x)) (q₁ (pr1 x)) (p₂ (pr2 x)) (q₂ (pr2 x)).

Definition maponpaths_pathsdirprod
           {X₁ X₂ Y₁ Y₂ : UU}
           (φ : X₁ → X₂)
           (χ : Y₁ → Y₂)
           {x₁ x₂ : X₁}
           (p : x₁ = x₂)
           {y₁ y₂ : Y₁}
           (q : y₁ = y₂)
  : pathsdirprod (maponpaths φ p) (maponpaths χ q)
    =
    maponpaths (dirprodf φ χ) (pathsdirprod p q).
Proof.
  induction p, q.
  exact (idpath _).
Defined.

Definition maponpaths_dirprodf_path
           {X₁ X₂ X₃ Y₁ Y₂ Y₃ : UU}
           (φ : X₂ → X₃)
           (χ : Y₂ → Y₃)
           {f₁ g₁ : X₁ → X₂}
           {f₂ g₂ : Y₁ → Y₂}
           (p₁ : f₁ ~ g₁)
           (p₂ : f₂ ~ g₂)
           (x : X₁ × Y₁)
  : dirprodf_path
      (λ (z : X₁), maponpaths φ (p₁ z))
      (λ (z : Y₁), maponpaths χ (p₂ z))
      x
    =
    maponpaths
      (dirprodf φ χ)
      (dirprodf_path p₁ p₂ x)
  := maponpaths_pathsdirprod φ χ (p₁ (pr1 x)) (p₂ (pr2 x)).

(** Action of polynomials on functions **)
Definition actmap (P : poly_code) {A B : UU} (f : A → B)
  : type_prebicat ⟦ act P A, act P B ⟧.
Proof.
  cbn.
  induction P as [X | | | ].
  - exact (λ y, y).
  - exact f.
  - exact (coprodf IHP1 IHP2).
  - exact (dirprodf IHP1 IHP2).
Defined.

(** `actmap` preserves composition, identity and homotopies **)
Definition poly_comp
           (P : poly_code)
           {A B C : UU}
           (f : A → B) (g : B → C)
  : actmap P g ∘ actmap P f ~ actmap P (g ∘ f)%functions.
Proof.
  induction P as [X | | | ].
  - exact (λ x, idpath x).
  - exact (λ x, idpath (g(f x))).
  - intro x.
    refine (!coprodf_comp _ _ _ _ x @ _).
    exact (coprodf_path IHP1 IHP2 x).
  - intro x.
    refine (!dirprodf_comp _ _ _ _ x @ _).
    exact (dirprodf_path IHP1 IHP2 x).
Defined.

Definition poly_id
           (P : poly_code)
           (A : UU)
  : (λ x : act P A, x) ~ (actmap P (λ x : A, x)).
Proof.
  induction P as [X | | | ].
  - exact (λ x, idpath x).
  - exact (λ x, idpath x).
  - exact (λ x, !coprodf_id x @ coprodf_path IHP1 IHP2 x).
  - exact (λ x, !dirprodf_id x @ dirprodf_path IHP1 IHP2 x).
Defined.

Definition poly_homot
           (P : poly_code)
           {A B : UU}
           {f g : A → B}
           (p : f ~ g)
  : actmap P f ~ actmap P g.
Proof.
  induction P as [X | | |].
  - exact (λ x, idpath x).
  - exact p.
  - exact (coprodf_path IHP1 IHP2).
  - exact (dirprodf_path IHP1 IHP2).
Defined.

(** The pseudofunctor **)
Definition poly_type_data (P : poly_code)
  : pseudofunctor_data type_prebicat type_prebicat.
Proof.
  use make_pseudofunctor_data.
  - exact (λ X, act P X).
  - exact (λ A B f, actmap P f).
  - exact (λ A B f g θ, poly_homot P θ).
  - exact (λ X, poly_id P X).
  - exact (λ A B C f g, poly_comp P f g).
Defined.

Definition poly_type_laws (P : poly_code)
  : pseudofunctor_laws (poly_type_data P).
Proof.
  repeat split; induction P as [X | | | ].
  - exact (λ A B f, idpath _).
  - exact (λ A B f, idpath _).
  - intros X Y f.
    apply funextsec.
    intro x.
    induction x as [x | x].
    + exact (maponpaths (maponpaths inl) (eqtohomot (IHP1 _ _ _) x)).
    + exact (maponpaths (maponpaths inr) (eqtohomot (IHP2 _ _ _) x)).
  - intros A B f.
    apply funextsec.
    exact (λ x, path_dirprodf_path (eqtohomot (IHP1 A B f)) (eqtohomot (IHP2 A B f)) x).
  - exact (λ A B f g h θ γ, idpath _).
  - exact (λ A B f g h θ γ, idpath _).
  - intros A B f g h θ γ.
    apply funextsec.
    intro x.
    induction x as [x | x].
    + exact ((maponpaths (maponpaths inl) (eqtohomot (IHP1 _ _ _ _ _ θ γ) x))
               @ maponpathscomp0 inl _ _).
    + exact ((maponpaths (maponpaths inr) (eqtohomot (IHP2 _ _ _ _ _ θ γ) x))
               @ maponpathscomp0 inr _ _).
  - intros A B f g h θ γ.
    apply funextsec.
    intro x.
    refine (_ @ !(dirprodf_path_concat _ _ _ _ _)).
    apply path_dirprodf_path.
    + exact (eqtohomot (IHP1 _ _ _ _ _ θ γ)).
    + exact (eqtohomot (IHP2 _ _ _ _ _ θ γ)).
  - exact (λ A B C f g h θ, idpath _).
  - intros A B C f g h θ.
    apply funextsec.
    exact (λ x, !pathscomp0rid _).
  - intros A B C f g h θ.
    apply funextsec.
    intro x.
    induction x as [x | x].
    +  exact (!maponpathscomp0 inl _ _
              @ maponpaths (maponpaths inl) (eqtohomot (IHP1 _ _ _ f _ _ θ) x)
              @ maponpathscomp0 inl _ _).
    + exact (!maponpathscomp0 inr _ _
              @ maponpaths (maponpaths inr) (eqtohomot (IHP2 _ _ _ f _ _ θ) x)
              @ maponpathscomp0 inr _ _).
  - intros A B C f g h θ.
    apply funextsec.
    intro x.
    refine (dirprodf_path_concat _ _ _ _ x @ _).
    refine (path_dirprodf_path
              (eqtohomot (IHP1 _ _ _ f _ _ θ))
              (eqtohomot (IHP2 _ _ _ f _ _ θ)) x @ _).
    exact (!dirprodf_path_concat _ _ _ _ x).
  - exact (λ A B C f g h θ, idpath _).
  - intros A B C f g h θ.
    apply funextsec.
    exact (λ x, !pathscomp0rid _).
  - intros A B C f g h θ.
    apply funextsec.
    intro x.
    induction x as [x | x].
    + refine (!maponpathscomp0 inl _ _ @ _).
      refine (_ @ maponpaths (λ p, p @ _) (!(coprodf_path_maponpaths_inl _ _ _))).
      exact (maponpaths (maponpaths inl) (eqtohomot (IHP1 A B C f g h θ) x)
                        @ maponpathscomp0 inl _ _).
    + refine (!maponpathscomp0 inr _ _ @ _).
      refine (_ @ maponpaths (λ p, p @ _) (!(coprodf_path_maponpaths_inr _ _ _))).
      exact (maponpaths (maponpaths inr) (eqtohomot (IHP2 A B C f g h θ) x)
                        @ maponpathscomp0 inr _ _).
  - intros A B C f g h θ.
    apply funextsec.
    intro x.
    refine (dirprodf_path_concat _ _ _ _ x @ _).
    refine (path_dirprodf_path
              (eqtohomot (IHP1 A B C f g h θ))
              (eqtohomot (IHP2 A B C f g h θ))
              x @ !_).
    refine (maponpaths (λ z, z @ _) (!_) @ _).
    + exact (maponpaths_dirprodf_path _ _ _ _ x).
    + exact (dirprodf_path_concat _ _ _ _ x).
  - exact (λ A B f, idpath _).
  - exact (λ A B f, idpath _).
  - intros A B f.
    apply funextsec.
    intro x.
    induction x as [x | x].
    + exact (maponpaths (maponpaths inl) (eqtohomot (IHP1 A B f) x)
               @ maponpathscomp0 inl _ _
               @ maponpaths (λ p, p @ _) (maponpathscomp0 inl _ _)
               @ maponpaths (λ p, (p @ _) @ _) (!coprodf_path_maponpaths_inl _ _ _)).
    + exact (maponpaths (maponpaths inr) (eqtohomot (IHP2 A B f) x)
               @ maponpathscomp0 inr _ _
               @ maponpaths (λ p, p @ _) (maponpathscomp0 inr _ _)
               @ maponpaths (λ p, (p @ _) @ _) (!(coprodf_path_maponpaths_inr _ _ _))).
  - intros A B f.
    apply funextsec.
    intro x.
    refine (path_dirprodf_path (eqtohomot (IHP1 A B f)) (eqtohomot (IHP2 A B f)) x @ _).
    refine (!(dirprodf_path_concat _ _ _ _ x) @ _).
    refine (maponpaths (λ z, z @ _) _).
    refine (!(dirprodf_path_concat _ _ _ _ x) @ _).
    refine (maponpaths (λ z, z @ _) _).
    exact (maponpaths_dirprodf_path _ _ _ _ x).
  - exact (λ A B f, idpath _).
  - exact (λ A B f, idpath _).
  - intros A B f.
    apply funextsec.
    intro x.
    induction x as [x | x].
    + exact (maponpaths (maponpaths inl) (eqtohomot (IHP1 A B f) x)
               @ maponpathscomp0 inl _ _
               @ maponpaths (λ p, p @ _) (maponpathscomp0 inl _ _)).
    + exact (maponpaths (maponpaths inr) (eqtohomot (IHP2 A B f) x)
               @ maponpathscomp0 inr _ _
               @ maponpaths (λ p, p @ _) (maponpathscomp0 inr _ _)).
  - intros A B f.
    apply funextsec.
    intro x.
    refine (path_dirprodf_path (eqtohomot (IHP1 A B f)) (eqtohomot (IHP2 A B f)) x @ _).
    refine (!dirprodf_path_concat _ _ _ _ x @ _).
    refine (maponpaths (λ z, z @ _) _).
    exact (!dirprodf_path_concat _ _ _ _ x).
  - exact (λ A B C D f g h, idpath _).
  - exact (λ A B C D f g h, idpath _).
  - intros A B C D f g h.
    apply funextsec.
    intro x.
    induction x as [x | x].
    + refine (maponpaths (λ p, p @ _) (!(maponpathscomp0 inl _ _))
                @ !(maponpathscomp0 inl _ _)
                @ maponpaths (maponpaths inl) (eqtohomot (IHP1 A B C D f g h) x)
                @ maponpathscomp0 inl _ _
                @ maponpaths (λ p, p @ _) (! _)).
      exact (coprodf_path_maponpaths_inl _ _ (poly_comp P1 f g x)).
    + refine (maponpaths (λ p, p @ _) (!(maponpathscomp0 inr _ _))
                @ !(maponpathscomp0 inr _ _)
                @ maponpaths (maponpaths inr) (eqtohomot (IHP2 A B C D f g h) x)
                @ maponpathscomp0 inr _ _
                @ maponpaths (λ p, p @ _) (! _)).
      exact (coprodf_path_maponpaths_inr _ _ (poly_comp P2 f g x)).
  - intros A B C D f g h.
    apply funextsec.
    intro x.
    symmetry.
    refine (maponpaths (λ p, p @ _) (!_) @ _).
    { exact (maponpaths_dirprodf_path _ _ _ _ x). }
    refine (dirprodf_path_concat _ _ _ _ x @ _).
    refine (!path_dirprodf_path
                (eqtohomot (IHP1 A B C D f g h))
                (eqtohomot (IHP2 A B C D f g h))
                x @ _).
    refine (!dirprodf_path_concat _ _ _ _ x @ _).
    refine (maponpaths (λ z, z @ _) _).
    exact (!dirprodf_path_concat _ _ _ _ x).
Qed.

Definition poly_type (P : poly_code)
  : pseudofunctor type_prebicat type_prebicat.
Proof.
  use make_pseudofunctor.
  - exact (poly_type_data P).
  - exact (poly_type_laws P).
  - split.
    + exact (λ A, type_prebicat_invertible_2cell).
    + exact (λ A B C f g, type_prebicat_invertible_2cell).
Defined.

Notation "⦃ P ⦄" := (poly_type P).