(** Adapted from "Elements of Set Theory" Chapter 8 **)
(** Coq coding by choukh, Mar 2021 **)

Require ZFC.Lib.NatIsomorphism.
Require Coq.micromega.Lia.

Require Export ZFC.Elements.EST8_3.
Require Import ZFC.Lib.LoStruct.
Import StructureCasting.

(*** EST第八章4：序类型乘法，序类型算术定律 ***)

(* 字典序 *)
Definition LoMul_R := λ S T, BinRel (A S × A T) (λ p1 p2,
  (π2 p1 <ᵣ π2 p2) (R T) ∨
  (π1 p1 <ᵣ π1 p2) (R S) ∧ π2 p1 = π2 p2
).
Notation "S * T" := (LoMul_R S T) : LoStruct_scope.

Lemma loMul_is_binRel : ∀ S T, is_binRel (S * T) (A S × A T).
Proof.
  intros S T x Hx.
  apply binRelE1 in Hx as [a [Ha [b [Hb [Hx _]]]]].
  subst x. apply CPrdI; auto.
Qed.

Lemma loMul_trans : ∀ S T, tranr (S * T).
Proof with eauto.
  intros S T x y z Hxy Hyz.
  destruct (lo S) as [_ [HtrS _]].
  destruct (lo T) as [_ [HtrT _]].
  apply binRelE2 in Hxy as [Hx [Hy [Hxy|[Hxy H1]]]];
  apply binRelE2 in Hyz as [_  [Hz [Hyz|[Hyz H2]]]]; apply binRelI...
  - left. eapply HtrT...
  - left. congruence.
  - left. congruence.
  - right. split. eapply HtrS... congruence.
Qed.

Lemma loMul_irrefl : ∀ S T, irrefl (S * T).
Proof.
  intros S T x H.
  apply binRelE2 in H as [Hx [_ [H|[H _]]]];
  (eapply lo_irrefl; [apply lo|]); eauto.
Qed.

Lemma loMul_connected : ∀ S T, connected (S * T) (A S × A T).
Proof with auto.
  intros S T x Hx y Hy Hnq.
  apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]].
  apply CPrdE1 in Hy as [c [Hc [d [Hd Hy]]]]. subst.
  destruct (classic (a = c)); destruct (classic (b = d)).
  - exfalso. apply Hnq. apply op_iff...
  - eapply (lo_connected _ _ (lo T)) in H0 as []; auto;
    [left|right]; (apply binRelI; [apply CPrdI..|zfc_simple])...
  - eapply (lo_connected _ _ (lo S)) in H as []; auto;
    [left|right]; (apply binRelI; [apply CPrdI..|zfc_simple])...
  - eapply (lo_connected _ _ (lo T)) in H0 as []; auto;
    [left|right]; (apply binRelI; [apply CPrdI..|zfc_simple])...
Qed.

Theorem loMul_loset : ∀ S T, loset (A S × A T) (S * T).
Proof.
  intros S T.
  apply loset_iff_connected_poset. repeat split.
  - apply loMul_connected.
  - apply loMul_is_binRel.
  - eapply binRel_is_rel. apply loMul_is_binRel.
  - apply loMul_trans.
  - apply loMul_irrefl.
Qed.

Definition LoMul := λ S T,
  constr (A S × A T) (S * T) (loMul_loset S T).
Notation "S ⋅ T" := (LoMul S T) : LoStruct_scope.

Lemma loMul_well_defined : ∀ S S' T T',
  S ≅ S' → T ≅ T' → S ⋅ T ≅ S' ⋅ T'.
Proof with eauto; try congruence.
  intros * [f [Hf Hopf]] [g [Hg Hopg]].
  apply bijection_is_func in Hf as [Hf [Hinjf Hrf]].
  apply bijection_is_func in Hg as [Hg [Hinjg Hrg]].
  assert (H := Hf). destruct H as [_ [Hdf _]].
  assert (H := Hg). destruct H as [_ [Hdg _]].
  set (Func (A S × A T) (A S' × A T') (λ x, <f[π1 x], g[π2 x]>)) as F.
  assert (Hbi: F: A S × A T ⟺ A S' × A T'). {
    apply meta_bijection.
    - intros x Hx. apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]].
      subst x. zfc_simple. apply CPrdI; eapply ap_ran...
    - intros x1 H1 x2 H2 Heq.
      apply CPrdE1 in H1 as [a [Ha [b [Hb H1]]]].
      apply CPrdE1 in H2 as [c [Hc [d [Hd H2]]]].
      subst. zfc_simple. apply op_iff in Heq as [H1 H2].
      apply injectiveE in H1... apply injectiveE in H2...
    - intros y Hy.
      apply CPrdE1 in Hy as [a [Ha [b [Hb Hy]]]].
      subst. zfc_simple.
      exists <f⁻¹[a], g⁻¹[b]>. split; zfc_simple.
      + apply CPrdI; eapply ap_ran; eauto;
        apply bijection_is_func; apply inv_bijection;
        apply bijection_is_func...
      + rewrite inv_ran_reduction, inv_ran_reduction...
  }
  apply bijection_is_func in Hbi as HF. destruct HF as [HF _].
  exists F. split... unfold LoMul. simpl.
  intros x Hx y Hy. unfold F.
  rewrite meta_func_ap, meta_func_ap...
  apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]].
  apply CPrdE1 in Hy as [c [Hc [d [Hd Hy]]]].
  subst. zfc_simple. split; intros Hxy.
  - apply binRelI; zfc_simple; [apply CPrdI; eapply ap_ran; eauto..|].
    apply binRelE2 in Hxy as [_ [_ [Hlt|[Hlt Heq]]]]; zfc_simple.
    + left. apply Hopg...
    + right. split... apply Hopf...
  - apply binRelI; zfc_simple; [apply CPrdI..|]...
    apply binRelE2 in Hxy as [_ [_ [Hlt|[Hlt Heq]]]]; zfc_simple.
    + left. apply Hopg...
    + right. split. apply Hopf... apply injectiveE in Heq...
Qed.

Import OrderType.

Definition otMul_spec := λ ρ σ τ,
  ∀ S T, ρ = ot S → σ = ot T → τ = ot (S ⋅ T).
Definition OtMul := λ ρ σ, describe (otMul_spec ρ σ).
Notation "ρ ⋅ σ" := (OtMul ρ σ) : OrderType_scope.

Lemma otMul_spec_intro : ∀ ρ σ ⋵ 𝐎𝐓, otMul_spec ρ σ (ρ ⋅ σ).
Proof.
  intros ρ [S HS] σ [T HT]. apply (desc_spec (otMul_spec ρ σ)).
  rewrite <- unique_existence. split.
  - exists (ot (S ⋅ T)%lo). intros S' T' H1 H2. subst.
    apply ot_correct in H1. apply ot_correct in H2.
    apply ot_correct. apply loMul_well_defined; auto.
  - intros τ1 τ2 H1 H2.
    pose proof (H1 S T HS HT).
    pose proof (H2 S T HS HT). congruence.
Qed.

Lemma otMul_eq_ot_of_loMul : ∀ S T, ot S ⋅ ot T = ot (S ⋅ T)%lo.
Proof. intros. erewrite otMul_spec_intro; auto. Qed.

Theorem otMul_well_defined : ∀ S S' T T',
  S ≅ S' → T ≅ T' → ot S ⋅ ot T = ot S' ⋅ ot T'.
Proof.
  intros * HisoS HisoT. do 2 rewrite otMul_eq_ot_of_loMul.
  apply ot_correct. apply loMul_well_defined; auto.
Qed.

Lemma otMul_iff_loMul : ∀ S T U,
  ot S ⋅ ot T = ot U ↔ (S ⋅ T ≅ U)%lo.
Proof.
  intros. split; intros H.
  - apply ot_correct. rewrite <- otMul_eq_ot_of_loMul. apply H.
  - rewrite otMul_eq_ot_of_loMul. apply ot_correct. apply H.
Qed.

Import Coq.micromega.Lia.
Import ZFC.Lib.NatIsomorphism.
Open Scope omega_scope.

Lemma lt_nba_ndc : ∀ n a b c d ∈ ω, n ≠ 0 →
  a ∈ n → b ∈ d → n ⋅ b + a ∈ n ⋅ d + c.
Proof with nauto.
  intros n Hn a Ha b Hb c Hc d Hd Hn0 Han Hbd.
  apply nat_subtr' in Hbd as [e [He [Hsum He0]]]...
  rewrite <- Hsum, mul_distr, add_assoc; auto; [|apply mul_ran..]...
  apply add_preserve_lt'... apply add_ran...
  apply mul_ran... apply mul_ran...
  apply add_enlarge_lt... apply mul_ran...
  apply mul_enlarge_lt...
Qed.

Lemma neq_nba_ndc : ∀ n a b c d ∈ ω, n ≠ 0 →
  a ∈ n → b ∈ d → n ⋅ b + a ≠ n ⋅ d + c.
Proof with eauto.
  intros n Hn a Ha b Hb c Hc d Hd Hn0 Han Hbd Heq.
  pose proof (lt_nba_ndc n Hn a Ha b Hb c Hc d Hd Hn0 Han Hbd).
  eapply nat_not_lt_self; revgoals...
  apply add_ran... apply mul_ran...
  apply add_ran... apply mul_ran...
Qed.

Lemma lt_nba_nm : ∀ n m a b ∈ ω,
  a ∈ n → b ∈ m → n ⋅ b + a ∈ n ⋅ m.
Proof with nauto.
  intros n Hn m Hm a Ha b Hb Han Hbm.
  apply nat_subtr' in Hbm as [e [He [Hsum Hne]]]...
  rewrite <- Hsum, mul_distr...
  apply add_preserve_lt'... apply mul_ran... apply mul_ran...
  apply mul_enlarge_lt...
Qed.

Lemma loMul_n_m : ∀ n m : nat, (LOⁿ n ⋅ LOⁿ m)%lo ≅ LOⁿ (n * m)%nat.
Proof with neauto; try congruence.
  intros. rewrite mul_isomorphic_n.
  set (Func (n × m) (n ⋅ m) (λ p, n ⋅ π2 p + π1 p)) as F.
  assert (Hbi: F: n × m ⟺ n ⋅ m). {
    apply meta_bijection.
    - intros x Hx.
      apply CPrdE1 in Hx as [a [Ha [b [Hb Hp]]]]. subst. zfc_simple.
      set (Embed m) as m'. assert (Hm': m' ∈ ω). apply embed_ran...
      ω_destruct m'... rewrite H in Hb. exfalso0.
      assert (Haw: a ∈ ω). eapply ω_trans...
      assert (Hbw: b ∈ ω). eapply ω_trans...
      rewrite Heq, mul_suc, add_comm; neauto; [|apply mul_ran]...
      assert (Hle: n ⋅ b ⋸ n ⋅ m'). {
        destruct (classic (b = m')) as [|Hnq]. right... left.
        apply mul_preserve_lt'...
        - intros H0. rewrite H0 in Ha. exfalso0.
        - rewrite Heq in Hb. apply BUnionE in Hb as []...
          apply SingE in H...
      }
      destruct Hle.
      + apply add_preserve_lt_trans... apply mul_ran... apply mul_ran...
      + rewrite H. apply add_preserve_lt... apply mul_ran...
    - intros x1 H1 x2 H2 Heq.
      apply CPrdE1 in H1 as [a [Ha [b [Hb H1]]]].
      apply CPrdE1 in H2 as [c [Hc [d [Hd H2]]]].
      subst. zfc_simple.
      assert (Haw: a ∈ ω). eapply ω_trans...
      assert (Hbw: b ∈ ω). eapply ω_trans...
      assert (Hcw: c ∈ ω). eapply ω_trans...
      assert (Hdw: d ∈ ω). eapply ω_trans...
      assert (Hn0: Embed n ≠ 0). {
        intros H0. rewrite H0 in Ha. exfalso0.
      }
      destruct (classic (a = c ∧ b = d)). apply op_iff...
      exfalso. apply not_and_or in H as [];
      apply nat_connected in H as []...
      + apply nat_subtr' in H as [e [He [Hsum Hnq0]]]...
        rewrite (add_comm (n ⋅ b)) in Heq; [|apply mul_ran|]...
        rewrite (add_comm (n ⋅ d)) in Heq; [|apply mul_ran|]...
        rewrite <- Hsum, add_assoc in Heq; [..|apply mul_ran]...
        apply add_cancel' in Heq; [|apply mul_ran|apply add_ran;[|apply mul_ran]|auto]...
        rewrite add_comm in Heq; [..|apply mul_ran]...
        destruct (classic (b = d)). {
          subst. rewrite <- (add_0_r (n ⋅ d)) in Heq at 1; [|apply mul_ran]...
          apply add_cancel' in Heq; [..|apply mul_ran]...
        }
        apply nat_connected in H as []; auto;
        (rewrite <- (add_0_r (n ⋅ b)) in Heq; [|apply mul_ran])...
        * apply (neq_nba_ndc n (embed_ran n) 0 (embed_ran 0) b Hbw e He d Hdw)...
          apply neq_0_gt_0...
        * apply (neq_nba_ndc n (embed_ran n) e He d Hdw 0 (embed_ran 0) b Hbw)...
          rewrite <- Hsum, add_comm in Hc...
          eapply add_shrink_lt; revgoals...
      + apply nat_subtr' in H as [e [He [Hsum Hnq0]]]...
        rewrite (add_comm (n ⋅ b)) in Heq; [|apply mul_ran|]...
        rewrite (add_comm (n ⋅ d)) in Heq; [|apply mul_ran|]...
        rewrite <- Hsum, add_assoc in Heq; [..|apply mul_ran]...
        apply add_cancel' in Heq; [|apply add_ran;[|apply mul_ran]|apply mul_ran|auto]...
        rewrite add_comm in Heq; [..|apply mul_ran]...
        destruct (classic (b = d)). {
          subst. rewrite <- (add_0_r (n ⋅ d)) in Heq at 2; [|apply mul_ran]...
          apply add_cancel' in Heq; [..|apply mul_ran]...
        }
        apply nat_connected in H as []; auto;
        (rewrite <- (add_0_r (n ⋅ d)) in Heq; [|apply mul_ran])...
        * apply (neq_nba_ndc n (embed_ran n) e He b Hbw 0 (embed_ran 0) d Hdw)...
          rewrite <- Hsum, add_comm in Ha...
          eapply add_shrink_lt; revgoals...
        * apply (neq_nba_ndc n (embed_ran n) 0 (embed_ran 0) d Hdw e He b Hbw)...
          apply neq_0_gt_0...
      + apply (neq_nba_ndc n (embed_ran n) a Haw b Hbw c Hcw d Hdw)...
      + apply (neq_nba_ndc n (embed_ran n) c Hcw d Hdw a Haw b Hbw)...
    - intros y Hy.
      assert (Hn0: Embed n ≠ 0). {
        intros H0. rewrite H0, mul_0_l in Hy... exfalso0.
      }
      assert (Hm0: Embed m ≠ 0). {
        intros H0. rewrite H0, mul_0_r in Hy... exfalso0.
      }
      assert (Hyw: y ∈ ω). eapply ω_trans... apply mul_ran...
      generalize dependent Hy.
      ω_induction y; intros Hy.
      + exists <0, 0>. split. apply CPrdI.
        apply neq_0_gt_0... apply neq_0_gt_0...
        zfc_simple. rewrite mul_0_r, add_0_r...
      + rename m0 into k. rename Hm into Hk.
        rewrite suc in Hy...
        apply add_shrink_lt in Hy as Hy'; [..|apply mul_ran]...
        apply IH in Hy' as [p [Hp Heq]].
        apply CPrdE1 in Hp as [a [Ha [b [Hb Hp]]]].
        subst. zfc_simple.
        assert (Haw: a ∈ ω). eapply ω_trans...
        assert (Hbw: b ∈ ω). eapply ω_trans...
        destruct (classic (a + 1 = n)).
        * rewrite add_assoc, H in Hy; [|apply mul_ran|..]...
          rewrite <- (mul_1_r n) in Hy at 2...
          rewrite <- mul_distr in Hy...
          apply mul_preserve_lt' in Hy; [|apply add_ran|..]...
          exists <0, b + 1>. split. apply CPrdI...
          apply neq_0_gt_0... zfc_simple.
          rewrite add_0_r, suc, add_assoc, H...
          rewrite <- (mul_1_r n) at 3...
          apply mul_distr... apply mul_ran...
          apply mul_ran... apply add_ran...
        * apply nat_connected in H as []; [| |apply add_ran|]...
          --- exists <a + 1, b>. split. apply CPrdI... zfc_simple.
              rewrite suc, add_assoc... apply mul_ran...
          --- exfalso. apply (ω_not_dense a)...
              exists n. split... split... rewrite suc...
  }
  apply bijection_is_func in Hbi as HF. destruct HF as [HF _].
  exists F. split; simpl; (rewrite embed_proj_id; [|apply mul_ran])...
  intros x Hx y Hy. unfold F.
  rewrite meta_func_ap, meta_func_ap...
  apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]];
  apply CPrdE1 in Hy as [c [Hc [d [Hd Hy]]]]; subst; zfc_simple.
  assert (Haw: a ∈ ω). eapply ω_trans...
  assert (Hbw: b ∈ ω). eapply ω_trans...
  assert (Hcw: c ∈ ω). eapply ω_trans...
  assert (Hdw: d ∈ ω). eapply ω_trans...
  assert (Hn0: Embed n ≠ 0). {
    intros H0. rewrite H0 in Ha. exfalso0.
  }
  split; intros Hxy.
  - apply binRelE3 in Hxy as []; zfc_simple.
    + apply binRelE3 in H. apply binRelI.
      apply lt_nba_nm... apply lt_nba_nm...
      apply lt_nba_ndc...
    + destruct H as [Hac Hbd]. apply binRelE3 in Hac.
      subst. apply binRelI.
      apply lt_nba_nm... apply lt_nba_nm...
      apply add_preserve_lt'... apply mul_ran...
  - apply binRelE3 in Hxy. apply binRelI.
    apply CPrdI... apply CPrdI... zfc_simple.
    destruct (classic (b = d)); [right|left].
    + split... subst. apply binRelI...
      apply add_preserve_lt' in Hxy... apply mul_ran...
    + apply binRelI... apply nat_connected in H as []...
      exfalso. eapply nat_not_lt_gt; revgoals.
      apply Hxy. apply lt_nba_ndc...
      apply add_ran... apply mul_ran...
      apply add_ran... apply mul_ran...
Qed.

(** 序类型算术定律 **)

Open Scope LoStruct_scope.

Lemma loAdd_assoc : ∀ S T U, S + T + U ≅ S + (T + U).
Proof with auto; try congruence.
  intros. unfold LoAdd at 1 3. simpl. unfold LoDisj_A.
  set (A (S + T) × {0,} ∪ A U × {1,}) as Dom.
  set (A S × {0,} ∪ A (T + U) × {1,}) as Ran.
  set (Func Dom Ran (λ x, match (ixm (π2 x = 0)) with
    | inl _ => match (ixm (π2 (π1 x) = 0)) with
      | inl _ => <π1 (π1 x), 0>
      | inr _ => <<π1 (π1 x), 0>, 1> end
    | inr _ => <<π1 x, 1>, 1> end
  )) as F.
  pose proof contra_1_0 as H10.
  pose proof contra_0_1 as H01.
  assert (Hbi: F: Dom ⟺ Ran). {
    apply meta_bijection.
    - intros x Hx.
      apply BUnionE in Hx as []; destruct (ixm (π2 x = 0));
      apply CPrdE1 in H as [a [Ha [b [Hb Heq]]]];
      apply SingE in Hb; subst; zfc_simple.
      + apply BUnionE in Ha as []; destruct (ixm (π2 a = 0));
        apply CPrdE1 in H as [c [Hc [d [Hd Heq]]]];
        apply SingE in Hd; subst; zfc_simple.
        * apply BUnionI1. apply CPrdI...
        * apply BUnionI2. apply CPrdI...
          apply BUnionI1. apply CPrdI...
      + apply BUnionI2. apply CPrdI...
        apply BUnionI2. apply CPrdI...
    - intros x1 H1 x2 H2 Heq.
      destruct (ixm (π2 x1 = 0)) as [Hx1|Hx1];
      destruct (ixm (π2 x2 = 0)) as [Hx2|Hx2];
      destruct (ixm (π2 (π1 x1) = 0)) as [Hx11|Hx12];
      destruct (ixm (π2 (π1 x2) = 0)) as [Hx21|Hx22];
      apply op_iff in Heq as []; subst;
      apply BUnionE in H1 as [H1|H1];
      apply BUnionE in H2 as [H2|H2];
      apply CPrdE1 in H1 as [a [Ha [b [Hb H1]]]];
      apply CPrdE1 in H2 as [c [Hc [d [Hd H2]]]];
      apply SingE in Hb; apply SingE in Hd; subst; zfc_simple;
      try (apply op_iff in H as []; congruence);
      apply BUnionE in Ha as [Ha|Ha];
      apply BUnionE in Hc as [Hc|Hc];
      apply CPrdE1 in Ha as [s [Hs [t [Ht Ha]]]];
      apply CPrdE1 in Hc as [u [Hu [v [Hv Hc]]]];
      apply SingE in Ht; apply SingE in Hv; subst; zfc_simple;
      apply op_iff in H as []; subst...
    - intros y Hy. apply BUnionE in Hy as [];
      apply CPrdE1 in H as [a [Ha [b [Hb Hy]]]];
      apply SingE in Hb; subst.
      + exists <<a, 0>, 0>. split.
        apply BUnionI1. apply CPrdI...
        apply BUnionI1. apply CPrdI... zfc_simple.
        destruct (ixm (Embed 0 = 0))...
      + apply BUnionE in Ha as [];
        apply CPrdE1 in H as [c [Hc [d [Hd H]]]];
        apply SingE in Hd; subst; zfc_simple.
        * exists <<c, 1>, 0>. split.
          apply BUnionI1. apply CPrdI...
          apply BUnionI2. apply CPrdI... zfc_simple.
          destruct (ixm (Embed 0 = 0))...
          destruct (ixm (Embed 1 = 0))...
        * exists <c, 1>. split.
          apply BUnionI2. apply CPrdI... zfc_simple.
          destruct (ixm (Embed 1 = 0))...
  }
  apply bijection_is_func in Hbi as HF. destruct HF as [HF _].
  exists F. split... unfold LoAdd. simpl.
  intros x Hx y Hy. unfold F.
  rewrite meta_func_ap, meta_func_ap...
  split; intros Hxy.
  - destruct (ixm (π2 x = 0));
    destruct (ixm (π2 y = 0));
    apply BUnionE in Hx as [Hx|Hx];
    apply BUnionE in Hy as [Hy|Hy];
    apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]];
    apply CPrdE1 in Hy as [c [Hc [d [Hd Hy]]]];
    apply SingE in Hb; apply SingE in Hd; subst; zfc_simple;
    (apply BUnionE in Hxy as [Hxy|Hxy]; [
      apply BUnionE in Hxy as [Hxy|Hxy];
      apply ReplAx in Hxy as H; destruct H as [p [Hp H]];
      apply op_iff in H as [H1 H2];
      apply op_iff in H1 as [H1 H1'];
      apply op_iff in H2 as [H2 H2']; subst; zfc_simple
    |]).
    + apply BUnionE in Hp as [Hp|Hp].
      * apply BUnionE in Hp as [Hp|Hp];
        apply ReplAx in Hp as [q [Hq H]];
        apply BUnionE in Ha as [Ha|Ha];
        apply BUnionE in Hc as [Hc|Hc];
        apply CPrdE1 in Ha as [s [Hs [t [Ht Ha]]]];
        apply CPrdE1 in Hc as [u [Hu [v [Hv Hc]]]];
        apply SingE in Ht; apply SingE in Hv; subst; zfc_simple;
        apply op_iff in Ha as []; apply op_iff in Hc as []...
        -- destruct (ixm (Embed 0 = 0))...
           apply BUnionI1. apply BUnionI1.
           apply ReplAx. exists q; split...
        -- destruct (ixm (Embed 1 = 0))...
           apply BUnionI1. apply BUnionI2. apply ReplAx.
           exists <<π1 q, 0>, <π2 q, 0>>. split; zfc_simple.
           apply BUnionI1. apply BUnionI1.
           apply ReplAx. exists q; split...
      * apply CPrdE1 in Hp as [s [Hs [t [Ht Hp]]]];
        apply CPrdE1 in Hs as [u [Hu [v [Hv Hs]]]];
        apply CPrdE1 in Ht as [x [Hx [y [Hy Ht]]]];
        apply SingE in Hv; apply SingE in Hy; subst; zfc_simple.
        destruct (ixm (Embed 0 = 0))...
        destruct (ixm (Embed 1 = 0))...
        apply BUnionI2. apply CPrdI; apply CPrdI...
        apply BUnionI1. apply CPrdI...
    + apply CPrdE1 in Hxy as [s [Hs [t [Ht Hxy]]]].
      apply op_iff in Hxy as [_ H]. subst.
      apply CPrdE2 in Ht as [_ H]. apply SingE in H...
    + apply CPrdE1 in Hxy as [s [Hs [t [Ht Hxy]]]].
      apply op_iff in Hxy as []; subst.
      apply CPrdE2 in Hs as [Hs _].
      apply BUnionE in Hs as [];
      apply CPrdE1 in H as [x [Hx [y [Hy H]]]];
      apply SingE in Hy; subst; zfc_simple.
      * destruct (ixm (Embed 0 = 0))...
        apply BUnionI2. apply CPrdI; apply CPrdI... apply BUnionI2...
      * destruct (ixm (Embed 1 = 0))...
        apply BUnionI1. apply BUnionI2. apply ReplAx.
        exists <<x, 0>, <c, 1>>. split; zfc_simple.
        apply BUnionI2. apply CPrdI; apply CPrdI...
    + apply CPrdE1 in Hxy as [s [Hs [t [Ht Hxy]]]].
      apply op_iff in Hxy as [_ H]. subst.
      apply CPrdE2 in Ht as [_ H]. apply SingE in H...
    + apply BUnionI1. apply BUnionI2. apply ReplAx.
      exists <<π1 p, 1>, <π2 p, 1>>. split; zfc_simple.
      apply BUnionI1. apply BUnionI2...
    + apply CPrdE2 in Hxy as [H _].
      apply CPrdE2 in H as [_ H]. apply SingE in H...
  - destruct (ixm (π2 x = 0));
    destruct (ixm (π2 y = 0));
    apply BUnionE in Hx as [Hx|Hx];
    apply BUnionE in Hy as [Hy|Hy];
    apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]];
    apply CPrdE1 in Hy as [c [Hc [d [Hd Hy]]]];
    apply SingE in Hb; apply SingE in Hd; subst; zfc_simple;
    (apply BUnionE in Hxy as [Hxy|Hxy]; [
      apply BUnionE in Hxy as [Hxy|Hxy];
      apply ReplAx in Hxy as H; destruct H as [p [Hp H]];
      apply op_iff in H as [H1 H2];
      destruct (ixm (π2 a = 0));
      destruct (ixm (π2 c = 0));
      apply op_iff in H1 as [H1 H1'];
      apply op_iff in H2 as [H2 H2'];
      subst; zfc_simple
    |]);
    try (apply BUnionE in Ha as [Ha|Ha];
      apply CPrdE1 in Ha as [s [Hs [t [Ht Ha]]]];
      apply SingE in Ht);
    try (apply BUnionE in Hc as [Hc|Hc];
      apply CPrdE1 in Hc as [u [Hu [v [Hv Hc]]]];
      apply SingE in Hv);
    subst; zfc_simple;
    destruct (ixm (Embed 0 = 0));
    destruct (ixm (Embed 1 = 0))...
    + destruct (ixm (Embed 0 = 0))...
      apply BUnionI1. apply BUnionI1. apply ReplAx.
      exists <<s, 0>, <u, 0>>. split; zfc_simple.
      apply BUnionI1. apply BUnionI1...
    + apply BUnionE in Hp as [Hp|Hp].
      * apply BUnionE in Hp as [Hp|Hp];
        apply ReplAx in Hp as [q [Hq H]]; subst; zfc_simple;
        apply op_iff in H1 as [];
        apply op_iff in H2 as []; subst;
        apply BUnionI1; apply BUnionI1; apply ReplAx;
        exists <<π1 q, 1>, <π2 q, 1>>; split; zfc_simple.
        apply BUnionI1. apply BUnionI2.
        apply ReplAx. exists q. split...
      * apply CPrdE0 in Hp as [_ H]. apply CPrdE0 in H as [_ H].
        rewrite H2 in H. zfc_simple. apply SingE in H...
    + apply CPrdE1 in Hxy as [a [Ha [b [Hb H]]]].
      apply op_iff in H as [_ H]. subst.
      apply CPrdE2 in Hb as [_ H]. apply SingE in H...
    + apply BUnionI1. apply BUnionI1. apply ReplAx.
      exists <<s, 0>, <u, 1>>. split; zfc_simple.
      apply BUnionI2. apply CPrdI; apply CPrdI...
    + apply CPrdE1 in Hxy as [a [Ha [b [Hb H]]]].
      apply op_iff in H as [_ H]. subst.
      apply CPrdE2 in Hb as [_ H]. apply SingE in H...
    + apply CPrdE1 in Hxy as [a [Ha [b [Hb H]]]].
      apply op_iff in H as [H _]. subst.
      apply CPrdE2 in Ha as [_ H]. apply SingE in H...
    + apply BUnionI2. apply CPrdI. apply CPrdI...
      apply BUnionI2. apply CPrdI... apply CPrdI...
    + apply BUnionI2. apply CPrdI. apply CPrdI...
      apply BUnionI2. apply CPrdI... apply CPrdI...
    + apply BUnionI2. apply CPrdI. apply CPrdI...
      apply BUnionI1. apply CPrdI... apply CPrdI...
    + apply BUnionI2. apply CPrdI. apply CPrdI...
      apply BUnionI2. apply CPrdI... apply CPrdI...
    + apply BUnionE in Hp as [Hp|Hp].
      * apply BUnionE in Hp as [Hp|Hp];
        apply ReplAx in Hp as [q [Hq H]]; subst; zfc_simple;
        apply op_iff in H1 as [];
        apply op_iff in H2 as []; subst;
        apply BUnionI1; apply BUnionI1; apply ReplAx;
        exists <<π1 q, 1>, <π2 q, 1>>; split; zfc_simple.
      * apply CPrdE0 in Hp as [_ H]. apply CPrdE0 in H as [_ H].
        rewrite H2 in H. zfc_simple. apply SingE in H...
    + apply BUnionE in Hp as [Hp|Hp].
      * apply BUnionE in Hp as [Hp|Hp];
        apply ReplAx in Hp as [q [Hq H]]; subst; zfc_simple;
        apply op_iff in H1 as [];
        apply op_iff in H2 as []; subst;
        apply BUnionI1; apply BUnionI1; apply ReplAx;
        exists <<π1 q, 1>, <π2 q, 1>>; split; zfc_simple.
      * apply CPrdE0 in Hp as [_ H]. apply CPrdE0 in H as [_ H].
        rewrite H2 in H. zfc_simple. apply SingE in H...
    + apply CPrdE2 in Hxy as [H _].
      apply CPrdE2 in H as [_ H]. apply SingE in H...
    + apply CPrdE2 in Hxy as [H _].
      apply CPrdE2 in H as [_ H]. apply SingE in H...
    + apply BUnionE in Hp as [Hp|Hp].
      * apply BUnionE in Hp as [Hp|Hp];
        apply ReplAx in Hp as [q [Hq H]]; subst; zfc_simple;
        apply op_iff in H1 as [];
        apply op_iff in H2 as []; subst...
        apply BUnionI1. apply BUnionI2. apply ReplAx.
        exists q. split; zfc_simple.
      * apply CPrdE0 in Hp as [H _]. rewrite H1 in H.
        apply CPrdE0 in H as [_ H]. zfc_simple. apply SingE in H...
    + apply BUnionE in Hp as [Hp|Hp].
      * apply BUnionE in Hp as [Hp|Hp];
        apply ReplAx in Hp as [q [Hq H]]; subst; zfc_simple;
        apply op_iff in H1 as [];
        apply op_iff in H2 as []; subst...
        apply BUnionI1. apply BUnionI2. apply ReplAx.
        exists q. split; zfc_simple.
      * apply CPrdE0 in Hp as [H _]. rewrite H1 in H.
        apply CPrdE0 in H as [_ H]. zfc_simple. apply SingE in H...
    + apply BUnionE in Hp as [Hp|Hp].
      * apply BUnionE in Hp as [Hp|Hp];
        apply ReplAx in Hp as [q [Hq H]]; subst; zfc_simple;
        apply op_iff in H1 as [];
        apply op_iff in H2 as []; subst...
        apply BUnionI1. apply BUnionI2. apply ReplAx.
        exists q. split; zfc_simple.
      * apply CPrdE0 in Hp as [H _]. rewrite H1 in H.
        apply CPrdE0 in H as [_ H]. zfc_simple. apply SingE in H...
    + apply BUnionE in Hp as [Hp|Hp].
      * apply BUnionE in Hp as [Hp|Hp];
        apply ReplAx in Hp as [q [Hq H]]; subst; zfc_simple;
        apply op_iff in H1 as [];
        apply op_iff in H2 as []; subst...
        apply BUnionI1. apply BUnionI2. apply ReplAx.
        exists q. split; zfc_simple.
      * apply CPrdE0 in Hp as [H _]. rewrite H1 in H.
        apply CPrdE0 in H as [_ H]. zfc_simple. apply SingE in H...
    + apply CPrdE2 in Hxy as [H _].
      apply CPrdE2 in H as [_ H]. apply SingE in H...
Qed.

Lemma loMul_assoc : ∀ S T U, S ⋅ T ⋅ U ≅ S ⋅ (T ⋅ U).
Proof with auto; try congruence.
  intros. unfold LoMul. simpl.
  set (A S × A T × A U) as Dom.
  set (A S × (A T × A U)) as Ran.
  set (Func Dom Ran (λ x, <π1 (π1 x), <π2 (π1 x), π2 x>>)) as F.
  assert (Hbi: F: Dom ⟺ Ran). {
    apply meta_bijection.
    - intros x Hx.
      apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]].
      apply CPrdE1 in Ha as [c [Hc [d [Hd Ha]]]].
      subst. zfc_simple. apply CPrdI... apply CPrdI...
    - intros x1 H1 x2 H2 Heq.
      apply CPrdE1 in H1 as [a [Ha [b [Hb H1]]]].
      apply CPrdE1 in Ha as [c [Hc [d [Hd Ha]]]].
      apply CPrdE1 in H2 as [s [Hs [t [Ht H2]]]].
      apply CPrdE1 in Hs as [u [Hu [v [Hv Hs]]]].
      subst. zfc_simple.
      apply op_iff in Heq as [H1 H2].
      apply op_iff in H2 as [H2 H3]...
    - intros y Hy.
      apply CPrdE1 in Hy as [a [Ha [b [Hb Hy]]]].
      apply CPrdE1 in Hb as [c [Hc [d [Hd Hb]]]].
      exists <<a, c>, d>. split. apply CPrdI... apply CPrdI...
      subst. zfc_simple.
  }
  apply bijection_is_func in Hbi as HF. destruct HF as [HF _].
  exists F. split... unfold LoAdd. simpl.
  intros x Hx y Hy. unfold F.
  rewrite meta_func_ap, meta_func_ap...
  apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]].
  apply CPrdE1 in Ha as [c [Hc [d [Hd Ha]]]].
  apply CPrdE1 in Hy as [s [Hs [t [Ht Hy]]]].
  apply CPrdE1 in Hs as [u [Hu [v [Hv Hs]]]].
  split; intros Hxy; apply binRelI; subst; zfc_simple;
  try (apply CPrdI; auto; apply CPrdI; auto).
  - apply binRelE1 in Hxy as [a [Ha [s [Hs [H [Hlt|[Hlt Heq]]]]]]];
    apply op_iff in H as []; subst; zfc_simple.
    + left. apply binRelI. apply CPrdI... apply CPrdI...
      left. zfc_simple.
    + apply binRelE1 in Hlt as [k [Hk [l [Hl [H' [Hlt|[Hlt Heq']]]]]]];
      apply op_iff in H' as []; subst; zfc_simple.
      * left. apply binRelI. apply CPrdI... apply CPrdI...
        right. zfc_simple...
      * right. split...
  - apply binRelE1 in Hxy as [a [Ha [s [Hs [H [Hlt|[Hlt Heq]]]]]]];
    apply op_iff in H as []; subst; zfc_simple.
    + apply binRelE1 in Hlt as [k [Hk [l [Hl [H' [Hlt|[Hlt Heq']]]]]]];
      apply op_iff in H' as []; subst; zfc_simple. left...
      right. split... apply binRelI. apply CPrdI... apply CPrdI...
      left. zfc_simple...
    + apply op_iff in Heq as []; subst.
      right. split... apply binRelI. apply CPrdI... apply CPrdI...
      right. zfc_simple...
Qed.

Lemma loMul_distr : ∀ S T U, S ⋅ (T + U) ≅ S ⋅ T + S ⋅ U.
Proof with auto; try congruence.
  intros. unfold LoMul. unfold LoAdd at 4. simpl.
  unfold LoDisj_A. simpl.
  set (A S × (A T × {0,} ∪ A U × {1,})) as Dom.
  set ((A S × A T) × {0,} ∪ (A S × A U) × {1,}) as Ran.
  set (Func Dom Ran (λ x, match (ixm (π2 (π2 x) = 0)) with
    | inl _ => <π1 x, π1 (π2 x), 0>
    | inr _ => <π1 x, π1 (π2 x), 1> end
  )) as F.
  pose proof contra_0_1 as H01.
  pose proof contra_1_0 as H10.
  assert (Hbi: F: Dom ⟺ Ran). {
    apply meta_bijection.
    - intros x Hx.
      apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]].
      apply BUnionE in Hb as [];
      apply CPrdE1 in H as [c [Hc [d [Hd H]]]];
      apply SingE in Hd; subst; zfc_simple.
      + destruct (ixm (Embed 0 = 0))...
        apply BUnionI1. apply CPrdI... apply CPrdI...
      + destruct (ixm (Embed 1 = 0))...
        apply BUnionI2. apply CPrdI... apply CPrdI...
    - intros x1 H1 x2 H2 Heq.
      apply CPrdE1 in H1 as [a [Ha [b [Hb H1]]]].
      apply CPrdE1 in H2 as [c [Hc [d [Hd H2]]]].
      apply BUnionE in Hb as [];
      apply CPrdE1 in H as [s [Hs [t [Ht Hb]]]];
      apply BUnionE in Hd as [];
      apply CPrdE1 in H as [u [Hu [v [Hv Hd]]]];
      apply SingE in Ht; apply SingE in Hv; subst; zfc_simple;
      destruct (ixm (Embed 0 = 0));
      destruct (ixm (Embed 1 = 0)); try congruence;
      apply op_iff in Heq as [H1 H2];
      apply op_iff in H1 as []...
    - intros y Hy. apply BUnionE in Hy as [];
      apply CPrdE1 in H as [a [Ha [b [Hb H]]]];
      apply CPrdE1 in Ha as [c [Hc [d [Hd Ha]]]];
      apply SingE in Hb; subst; zfc_simple.
      + exists <c, <d, 0>>. split; zfc_simple.
        apply CPrdI... apply BUnionI1. apply CPrdI...
        destruct (ixm (Embed 0 = 0))...
      + exists <c, <d, 1>>. split; zfc_simple.
        apply CPrdI... apply BUnionI2. apply CPrdI...
        destruct (ixm (Embed 1 = 0))...
  }
  apply bijection_is_func in Hbi as HF. destruct HF as [HF _].
  exists F. split... unfold LoAdd. simpl.
  intros x Hx y Hy. unfold F.
  rewrite meta_func_ap, meta_func_ap...
  split; intros Hxy;
  apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]];
  apply CPrdE1 in Hy as [c [Hc [d [Hd Hy]]]];
  apply BUnionE in Hb as [];
  apply CPrdE1 in H as [s [Hs [t [Ht Hb]]]];
  apply BUnionE in Hd as [];
  apply CPrdE1 in H as [u [Hu [v [Hv Hd]]]];
  apply SingE in Ht; apply SingE in Hv; subst; zfc_simple;
  destruct (ixm (Embed 0 = 0));
  destruct (ixm (Embed 1 = 0))...
  - apply BUnionI1. apply BUnionI1. apply ReplAx.
    exists <<a, s>, <c, u>>. split; zfc_simple.
    apply binRelI. apply CPrdI... apply CPrdI...
    apply binRelE3 in Hxy as []; zfc_simple.
    + apply BUnionE in H as [].
      * apply BUnionE in H as []; apply ReplAx in H as [x [Hx H]];
        apply op_iff in H as [H1 H2];
        apply op_iff in H1 as [];
        apply op_iff in H2 as []; subst... left.
        unfold relLt. rewrite <- (rel_pair (R T))...
        eapply binRel_is_rel. apply lo.
      * apply CPrdE2 in H as [_ H].
        apply CPrdE2 in H as [_ H]. apply SingE in H...
    + destruct H as [H1 H2]. apply op_iff in H2 as []; subst. right...
  - apply BUnionI2. apply CPrdI; apply CPrdI; auto; apply CPrdI...
  - apply binRelE3 in Hxy as []; zfc_simple.
    + apply BUnionE in H as [].
      * apply BUnionE in H as []; apply ReplAx in H as [x [Hx H]];
        apply op_iff in H as [H1 H2];
        apply op_iff in H1 as [];
        apply op_iff in H2 as []; subst...
      * apply CPrdE2 in H as [_ H].
        apply CPrdE2 in H as [_ H]. apply SingE in H...
    + destruct H as [H1 H2]. apply op_iff in H2 as []; subst...
  - apply BUnionI1. apply BUnionI2. apply ReplAx.
    exists <<a, s>, <c, u>>. split; zfc_simple.
    apply binRelI. apply CPrdI... apply CPrdI...
    apply binRelE3 in Hxy as []; zfc_simple.
    + apply BUnionE in H as [].
      * apply BUnionE in H as []; apply ReplAx in H as [x [Hx H]];
        apply op_iff in H as [H1 H2];
        apply op_iff in H1 as [];
        apply op_iff in H2 as []; subst... left.
        unfold relLt. rewrite <- (rel_pair (R U))...
        eapply binRel_is_rel. apply lo.
      * apply CPrdE2 in H as [H _].
        apply CPrdE2 in H as [_ H]. apply SingE in H...
    + destruct H as [H1 H2]. apply op_iff in H2 as []; subst...
  - apply binRelI; zfc_simple.
    + apply CPrdI... apply BUnionI1. apply CPrdI...
    + apply CPrdI... apply BUnionI1. apply CPrdI...
    + apply BUnionE in Hxy as [].
      * apply BUnionE in H as []; apply ReplAx in H as [x [Hx H]];
        apply op_iff in H as [H1 H2];
        apply op_iff in H1 as [];
        apply op_iff in H2 as []; subst...
        apply binRelE1 in Hx as [b [Hb [d [Hd [Hx [Hlt|[Hlt Heq]]]]]]];
        subst; zfc_simple; subst; zfc_simple.
        -- left. apply BUnionI1. apply BUnionI1. apply ReplAx.
           exists <s, u>. split; zfc_simple...
        -- right. split...
      * apply CPrdE2 in H as [_ H].
        apply CPrdE2 in H as [_ H]. apply SingE in H...
  - apply binRelI; zfc_simple.
    + apply CPrdI... apply BUnionI1. apply CPrdI...
    + apply CPrdI... apply BUnionI2. apply CPrdI...
    + left. apply BUnionI2. apply CPrdI; apply CPrdI...
  - apply binRelI; zfc_simple.
    + apply CPrdI... apply BUnionI2. apply CPrdI...
    + apply CPrdI... apply BUnionI1. apply CPrdI...
    + apply BUnionE in Hxy as [].
      * apply BUnionE in H as []; apply ReplAx in H as [x [Hx H]];
        apply op_iff in H as [H1 H2];
        apply op_iff in H1 as [];
        apply op_iff in H2 as []; subst...
      * apply CPrdE2 in H as [_ H].
        apply CPrdE2 in H as [_ H]. apply SingE in H...
  - apply binRelI; zfc_simple.
    + apply CPrdI... apply BUnionI2. apply CPrdI...
    + apply CPrdI... apply BUnionI2. apply CPrdI...
    + apply BUnionE in Hxy as [].
      * apply BUnionE in H as []; apply ReplAx in H as [x [Hx H]];
        apply op_iff in H as [H1 H2];
        apply op_iff in H1 as [];
        apply op_iff in H2 as []; subst...
        apply binRelE1 in Hx as [b [Hb [d [Hd [Hx [Hlt|[Hlt Heq]]]]]]];
        subst; zfc_simple; subst; zfc_simple.
        -- left. apply BUnionI1. apply BUnionI2. apply ReplAx.
           exists <s, u>. split; zfc_simple...
        -- right. split...
      * apply CPrdE2 in H as [H _].
        apply CPrdE2 in H as [_ H]. apply SingE in H...
Qed.

Import StructureCasting.

Lemma loAdd_0_r : ∀ S, S + LOⁿ 0 ≅ S.
Proof with auto; try congruence.
  intros. unfold LoAdd. simpl.
  unfold LoDisj_A. simpl.
  set (A S × {0,} ∪ 0 × {1,}) as Dom.
  set (Func Dom (A S) (λ x, match (ixm (π2 x = 0)) with
    | inl _ => π1 x
    | inr _ => ∅
  end)) as F.
  pose proof contra_0_1 as H01.
  pose proof contra_1_0 as H10.
  assert (Hbi: F: Dom ⟺ A S). {
    apply meta_bijection.
    - intros x Hx.
      apply BUnionE in Hx as []; destruct (ixm (π2 x = 0));
      apply CPrdE0 in H as []...
      apply SingE in H0... exfalso0. exfalso0.
    - intros x1 H1 x2 H2 Heq.
      destruct (ixm (π2 x1 = 0)) as [Hx1|Hx1];
      destruct (ixm (π2 x2 = 0)) as [Hx2|Hx2];
      apply BUnionE in H1 as [H1|H1];
      apply BUnionE in H2 as [H2|H2];
      apply CPrdE1 in H1 as [a [Ha [b [Hb H1]]]];
      apply CPrdE1 in H2 as [c [Hc [d [Hd H2]]]];
      apply SingE in Hb; apply SingE in Hd; subst; zfc_simple.
      exfalso0. exfalso0. exfalso0.
    - intros y Hy. exists <y, 0>. split.
      + apply BUnionI1. apply CPrdI...
      + zfc_simple. destruct (ixm (Embed 0 = 0))...
  }
  apply bijection_is_func in Hbi as HF. destruct HF as [HF _].
  exists F. split; simpl...
  intros x Hx y Hy. unfold F.
  rewrite meta_func_ap, meta_func_ap...
  split; intros Hxy;
  destruct (ixm (π2 x = 0));
  destruct (ixm (π2 y = 0));
  apply BUnionE in Hx as [Hx|Hx];
  apply BUnionE in Hy as [Hy|Hy];
  apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]];
  apply CPrdE1 in Hy as [c [Hc [d [Hd Hy]]]];
  apply SingE in Hb; apply SingE in Hd; subst; zfc_simple; [(
    apply BUnionE in Hxy as [Hxy|Hxy]; [
      apply BUnionE in Hxy as [Hxy|Hxy];
      apply ReplAx in Hxy as [p [Hp H]];
      apply op_iff in H as [H1 H2];
      apply op_iff in H1 as [H1 H1'];
      apply op_iff in H2 as [H2 H2']; subst; zfc_simple
    |]
  )..| | | |]; try exfalso0.
  - unfold relLt. rewrite <- (rel_pair (R S))...
    eapply binRel_is_rel. apply lo.
  - apply CPrdE2 in Hxy as [_ H].
    apply CPrdE2 in H as [_ H]. apply SingE in H...
  - apply BUnionI1. apply BUnionI1. apply ReplAx.
    exists <a, c>. split; zfc_simple...
Qed.

Lemma loAdd_0_l : ∀ S, LOⁿ 0 + S ≅ S.
Proof with auto; try congruence.
  intros. unfold LoAdd. simpl.
  unfold LoDisj_A. simpl.
  set (0 × {0,} ∪ A S × {1,}) as Dom.
  set (Func Dom (A S) (λ x, match (ixm (π2 x = 0)) with
    | inl _ => ∅
    | inr _ => π1 x
  end)) as F.
  pose proof contra_0_1 as H01.
  pose proof contra_1_0 as H10.
  assert (Hbi: F: Dom ⟺ A S). {
    apply meta_bijection.
    - intros x Hx.
      apply BUnionE in Hx as []; destruct (ixm (π2 x = 0));
      apply CPrdE0 in H as []...
      exfalso0. exfalso0. apply SingE in H0...
    - intros x1 H1 x2 H2 Heq.
      destruct (ixm (π2 x1 = 0)) as [Hx1|Hx1];
      destruct (ixm (π2 x2 = 0)) as [Hx2|Hx2];
      apply BUnionE in H1 as [H1|H1];
      apply BUnionE in H2 as [H2|H2];
      apply CPrdE1 in H1 as [a [Ha [b [Hb H1]]]];
      apply CPrdE1 in H2 as [c [Hc [d [Hd H2]]]];
      apply SingE in Hb; apply SingE in Hd; subst; zfc_simple.
      exfalso0. exfalso0. exfalso0.
    - intros y Hy. exists <y, 1>. split.
      + apply BUnionI2. apply CPrdI...
      + zfc_simple. destruct (ixm (Embed 1 = 0))...
  }
  apply bijection_is_func in Hbi as HF. destruct HF as [HF _].
  exists F. split; simpl...
  intros x Hx y Hy. unfold F.
  rewrite meta_func_ap, meta_func_ap...
  split; intros Hxy;
  destruct (ixm (π2 x = 0));
  destruct (ixm (π2 y = 0));
  apply BUnionE in Hx as [Hx|Hx];
  apply BUnionE in Hy as [Hy|Hy];
  apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]];
  apply CPrdE1 in Hy as [c [Hc [d [Hd Hy]]]];
  apply SingE in Hb; apply SingE in Hd; subst; zfc_simple; [(
    apply BUnionE in Hxy as [Hxy|Hxy]; [
      apply BUnionE in Hxy as [Hxy|Hxy];
      apply ReplAx in Hxy as [p [Hp H]];
      apply op_iff in H as [H1 H2];
      apply op_iff in H1 as [H1 H1'];
      apply op_iff in H2 as [H2 H2']; subst; zfc_simple
    |]
  )..| | | |]; try exfalso0.
  - unfold relLt. rewrite <- (rel_pair (R S))...
    eapply binRel_is_rel. apply lo.
  - apply CPrdE2 in Hxy as [H _].
    apply CPrdE2 in H as [_ H]. apply SingE in H...
  - apply BUnionI1. apply BUnionI2. apply ReplAx.
    exists <a, c>. split; zfc_simple...
Qed.

Lemma loMul_1_r : ∀ S, S ⋅ LOⁿ 1 ≅ S.
Proof with nauto; try congruence.
  intros. unfold LoMul. simpl.
  set (Func (A S × 1) (A S) π1) as F.
  assert (Hbi: F: A S × 1 ⟺ A S). {
    apply meta_bijection.
    - intros x Hx. apply CPrdE0 in Hx as []...
    - intros x1 H1 x2 H2 Heq.
      apply CPrdE1 in H1 as [a [Ha [b [Hb H1]]]].
      apply CPrdE1 in H2 as [c [Hc [d [Hd H2]]]].
      rewrite one in Hb, Hd.
      apply SingE in Hb. apply SingE in Hd. subst. zfc_simple.
    - intros y Hy. exists <y, 0>. split; zfc_simple.
      apply CPrdI... apply BUnionI2...
  }
  apply bijection_is_func in Hbi as HF. destruct HF as [HF _].
  exists F. split; simpl...
  intros x Hx y Hy. unfold F.
  rewrite meta_func_ap, meta_func_ap...
  apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]].
  apply CPrdE1 in Hy as [c [Hc [d [Hd Hy]]]].
  rewrite one in Hb, Hd.
  apply SingE in Hb. apply SingE in Hd. subst. zfc_simple.
  split; intros Hxy.
  - apply binRelE3 in Hxy as [|[]]; zfc_simple.
    apply SepE2 in H. zfc_simple.
    exfalso. apply (nat_irrefl ∅)...
  - apply binRelI; zfc_simple.
    apply CPrdI... apply BUnionI2...
    apply CPrdI... apply BUnionI2...
    right. split...
Qed.

Lemma loMul_1_l : ∀ S, LOⁿ 1 ⋅ S ≅ S.
Proof with nauto; try congruence.
  intros. unfold LoMul. simpl.
  set (Func (1 × A S) (A S) π2) as F.
  assert (Hbi: F: 1 × A S ⟺ A S). {
    apply meta_bijection.
    - intros x Hx. apply CPrdE0 in Hx as []...
    - intros x1 H1 x2 H2 Heq.
      apply CPrdE1 in H1 as [a [Ha [b [Hb H1]]]].
      apply CPrdE1 in H2 as [c [Hc [d [Hd H2]]]].
      rewrite one in Ha, Hc.
      apply SingE in Ha. apply SingE in Hc. subst. zfc_simple.
    - intros y Hy. exists <0, y>. split; zfc_simple.
      apply CPrdI... apply BUnionI2...
  }
  apply bijection_is_func in Hbi as HF. destruct HF as [HF _].
  exists F. split; simpl...
  intros x Hx y Hy. unfold F.
  rewrite meta_func_ap, meta_func_ap...
  apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]].
  apply CPrdE1 in Hy as [c [Hc [d [Hd Hy]]]].
  rewrite one in Ha, Hc.
  apply SingE in Ha. apply SingE in Hc. subst. zfc_simple.
  split; intros Hxy.
  - apply binRelE3 in Hxy as [|[]]; zfc_simple.
    apply SepE2 in H. zfc_simple.
    exfalso. apply (nat_irrefl ∅)...
  - apply binRelI; zfc_simple.
    apply CPrdI... apply BUnionI2...
    apply CPrdI... apply BUnionI2... left...
Qed.

Lemma loMul_0_r : ∀ S, S ⋅ LOⁿ 0 ≅ LOⁿ 0.
Proof with auto; try congruence.
  intros. unfold LoMul. simpl.
  exists ∅. split; simpl.
  rewrite cprd_0_r. apply empty_bijection.
  intros x Hx. apply CPrdE0 in Hx as [_ H]. exfalso0.
Qed.

Lemma loMul_0_l : ∀ S, LOⁿ 0 ⋅ S ≅ LOⁿ 0.
Proof with auto; try congruence.
  intros. unfold LoMul. simpl.
  exists ∅. split; simpl.
  rewrite cprd_0_l. apply empty_bijection.
  intros x Hx. apply CPrdE0 in Hx as [H _]. exfalso0.
Qed.

Open Scope OrderType_scope.

Theorem otAdd_assoc : ∀ ρ σ τ ⋵ 𝐎𝐓, ρ + σ + τ = ρ + (σ + τ).
Proof with auto.
  intros ρ [S HS] σ [T HT] τ [U HU]. subst.
  do 4 rewrite otAdd_eq_ot_of_loAdd.
  apply ot_correct. apply loAdd_assoc.
Qed.

Theorem otMul_assoc : ∀ ρ σ τ ⋵ 𝐎𝐓, ρ ⋅ σ ⋅ τ = ρ ⋅ (σ ⋅ τ).
Proof with auto.
  intros ρ [S HS] σ [T HT] τ [U HU]. subst.
  do 4 rewrite otMul_eq_ot_of_loMul.
  apply ot_correct. apply loMul_assoc.
Qed.

Theorem otMul_distr : ∀ ρ σ τ ⋵ 𝐎𝐓, ρ ⋅ (σ + τ) = ρ ⋅ σ + ρ ⋅ τ.
Proof with auto.
  intros ρ [S HS] σ [T HT] τ [U HU]. subst.
  rewrite (otAdd_eq_ot_of_loAdd T U).
  rewrite (otMul_eq_ot_of_loMul S T).
  rewrite (otMul_eq_ot_of_loMul S U).
  rewrite otMul_eq_ot_of_loMul.
  rewrite otAdd_eq_ot_of_loAdd.
  apply ot_correct. apply loMul_distr.
Qed.

Theorem otAdd_0_r : ∀ρ ⋵ 𝐎𝐓, ρ + otⁿ 0 = ρ.
Proof with auto.
  intros ρ [S HS]. subst.
  unfold otⁿ. rewrite otAdd_eq_ot_of_loAdd.
  apply ot_correct. apply loAdd_0_r.
Qed.

Theorem otAdd_0_l : ∀ρ ⋵ 𝐎𝐓, otⁿ 0 + ρ = ρ.
Proof with auto.
  intros ρ [S HS]. subst.
  unfold otⁿ. rewrite otAdd_eq_ot_of_loAdd.
  apply ot_correct. apply loAdd_0_l.
Qed.

Theorem otMul_1_r : ∀ρ ⋵ 𝐎𝐓, ρ ⋅ otⁿ 1 = ρ.
Proof with auto.
  intros ρ [S HS]. subst.
  unfold otⁿ. rewrite otMul_eq_ot_of_loMul.
  apply ot_correct. apply loMul_1_r.
Qed.

Theorem otMul_1_l : ∀ρ ⋵ 𝐎𝐓, otⁿ 1 ⋅ ρ = ρ.
Proof with auto.
  intros ρ [S HS]. subst.
  unfold otⁿ. rewrite otMul_eq_ot_of_loMul.
  apply ot_correct. apply loMul_1_l.
Qed.

Theorem otMul_0_r : ∀ρ ⋵ 𝐎𝐓, ρ ⋅ otⁿ 0 = otⁿ 0.
Proof with auto.
  intros ρ [S HS]. subst.
  unfold otⁿ. rewrite otMul_eq_ot_of_loMul.
  apply ot_correct. apply loMul_0_r.
Qed.

Theorem otMul_0_l : ∀ρ ⋵ 𝐎𝐓, otⁿ 0 ⋅ ρ = otⁿ 0.
Proof with auto.
  intros ρ [S HS]. subst.
  unfold otⁿ. rewrite otMul_eq_ot_of_loMul.
  apply ot_correct. apply loMul_0_l.
Qed.


Require Import init.

Require Export linear_base.
Require Export linear_grade.
Require Import module_category.
Require Import linear_subspace.

Require Import set.
Require Import nat.
Require Import unordered_list.

Section LinearGradeSum.

Context {R : CRingObj}.
Variable (I : Type).
Variable (V : I → ModuleObj R).

Let U := cring_U R.
Let UP := cring_plus R.
Let UM := cring_mult R.
Let UO := cring_one R.

Local Existing Instances UP UM UO.

Let VP k := module_plus (V k).
Let VZ k := module_zero (V k).
Let VN k := module_neg (V k).
Let VPC k := module_plus_comm (V k).
Let VPA k := module_plus_assoc (V k).
Let VPZ k := module_plus_lid (V k).
Let VPN k := module_plus_linv (V k).
Let VS k := module_scalar (V k).
Let VSC k := module_scalar_comp (V k).
Let VSE k := module_scalar_id (V k).
Let VSL k := module_scalar_ldist (V k).
Let VSR k := module_scalar_rdist (V k).

Local Existing Instances VP VZ VN VPC VPA VPZ VPN VS VSC VSE VSL VSR.

Definition grade_sum_base := (∀ k, module_V (V k)).
Definition grade_sum_finite (A : grade_sum_base) :=
    simple_finite (set_type (λ k, 0 ≠ A k)).
Definition grade_sum_type := set_type grade_sum_finite.

Definition single_to_grade_sum_base {k} (A : module_V (V k)) : grade_sum_base.
    intros n.
    classic_case (k = n).
    -   subst k.
        exact A.
    -   exact 0.
Defined.

Lemma single_to_grade_sum_finite {k} : ∀ A : module_V (V k),
    grade_sum_finite (single_to_grade_sum_base A).
Proof.
    intros A.
    exists 1.
    exists (λ _, [0|nat_one_pos]).
    split.
    intros [a a_neq] [b b_neq] eq; clear eq.
    unfold single_to_grade_sum_base in *.
    apply set_type_eq; cbn.
    classic_case (k = a) as [ak|ak];
    classic_case (k = b) as [bk|bk].
    1: subst; reflexivity.
    all: contradiction.
Qed.

Definition single_to_grade_sum {k} (A : module_V (V k))
    := [_|single_to_grade_sum_finite A].

Theorem single_to_grade_sum_eq : ∀ k, ∀ (A B : module_V (V k)),
    single_to_grade_sum A = single_to_grade_sum B → A = B.
Proof.
    intros k A B eq.
    apply set_type_eq in eq.
    assert (∀ x, [single_to_grade_sum A|] x = [single_to_grade_sum B|] x) as eq2.
    {
        rewrite eq.
        reflexivity.
    }
    clear eq.
    unfold single_to_grade_sum, single_to_grade_sum_base in eq2.
    cbn in eq2.
    specialize (eq2 k).
    destruct (sem (k = k)) as [eq|neq]; try contradiction.
    destruct eq; cbn in eq2.
    exact eq2.
Qed.

Lemma grade_sum_plus_finite : ∀ A B : grade_sum_type,
    grade_sum_finite (λ k, [A|] k + [B|] k).
Proof.
    intros [A A_fin] [B B_fin]; cbn.
    apply (simple_finite_trans _ _ (simple_finite_sum _ _ A_fin B_fin)).
    assert (∀ (n : set_type (λ k, 0 ≠ A k + B k)), {0 ≠ A [n|]} + {0 ≠ B [n|]})
        as n_in.
    {
        intros [n n_neq]; cbn.
        classic_case (0 = A n) as [Anz|Anz].
        -   right.
            rewrite <- Anz in n_neq.
            rewrite plus_lid in n_neq.
            exact n_neq.
        -   left; exact Anz.
    }
    exists (λ n, match (n_in n) with
        | strong_or_left  H => inl [[n|]|H]
        | strong_or_right H => inr [[n|]|H]
    end).
    split.
    intros a b eq.
    destruct (n_in a) as [neq1|neq1]; destruct (n_in b) as [neq2|neq2].
    all: inversion eq as [eq2].
    all: apply set_type_eq; exact eq2.
Qed.

Instance grade_sum_plus : Plus grade_sum_type := {
    plus A B := [_|grade_sum_plus_finite A B]
}.

Program Instance grade_sum_plus_comm : PlusComm grade_sum_type.
Next Obligation.
    unfold plus; cbn.
    apply set_type_eq; cbn.
    apply functional_ext.
    intros n.
    apply plus_comm.
Qed.

Program Instance grade_sum_plus_assoc : PlusAssoc grade_sum_type.
Next Obligation.
    unfold plus; cbn.
    apply set_type_eq; cbn.
    apply functional_ext.
    intros n.
    apply plus_assoc.
Qed.

Lemma grade_sum_zero_finite : grade_sum_finite (λ k, 0).
Proof.
    unfold grade_sum_finite.
    exists 0.
    exists (λ x : set_type (λ k : I, (zero (U := module_V (V k))) ≠ 0),
        False_rect _ ([|x] Logic.eq_refl)).
    split.
    intros [a neq].
    contradiction.
Qed.

Instance grade_sum_zero : Zero grade_sum_type := {
    zero := [_|grade_sum_zero_finite]
}.

Program Instance grade_sum_plus_lid : PlusLid grade_sum_type.
Next Obligation.
    unfold plus, zero; cbn.
    apply set_type_eq; cbn.
    apply functional_ext.
    intros n.
    apply plus_lid.
Qed.

Lemma grade_sum_neg_finite : ∀ A : grade_sum_type, grade_sum_finite (λ k, -[A|] k).
Proof.
    intros [A A_fin]; cbn.
    apply (simple_finite_trans _ _ A_fin).
    assert (∀ (n : set_type (λ k, 0 ≠ - A k)), 0 ≠ A [n|]) as n_in.
    {
        intros [n n_neq]; cbn.
        intros eq.
        rewrite <- eq in n_neq.
        rewrite neg_zero in n_neq.
        contradiction.
    }
    exists (λ n, [[n|]|n_in n]).
    split.
    intros a b eq.
    apply set_type_eq in eq; cbn in eq.
    apply set_type_eq in eq; cbn in eq.
    exact eq.
Qed.

Instance grade_sum_neg : Neg grade_sum_type := {
    neg A := [_|grade_sum_neg_finite A]
}.

Program Instance grade_sum_plus_linv : PlusLinv grade_sum_type.
Next Obligation.
    unfold plus, neg, zero; cbn.
    apply set_type_eq; cbn.
    apply functional_ext.
    intros n.
    apply plus_linv.
Qed.

Theorem single_to_grade_sum_plus : ∀ k (A B : module_V (V k)),
    single_to_grade_sum (A + B) =
    single_to_grade_sum A + single_to_grade_sum B.
Proof.
    intros k A B.
    apply set_type_eq; cbn.
    apply functional_ext; intros x.
    unfold plus at 2; cbn.
    unfold single_to_grade_sum_base.
    destruct (sem (k = x)) as [eq|neq].
    2: symmetry; apply plus_rid.
    destruct eq; cbn.
    reflexivity.
Qed.

Lemma grade_sum_scalar_finite : ∀ α (A : grade_sum_type),
    grade_sum_finite (λ k, α · [A|] k).
Proof.
    intros α [A A_fin]; cbn.
    apply (simple_finite_trans _ _ A_fin).
    assert (∀ (n : set_type (λ k, 0 ≠ α · A k)), 0 ≠ A [n|]) as n_in.
    {
        intros [n n_neq]; cbn.
        intros eq.
        rewrite <- eq in n_neq.
        rewrite scalar_ranni in n_neq.
        contradiction.
    }
    exists (λ n, [[n|]|n_in n]).
    split.
    intros a b eq.
    apply set_type_eq in eq; cbn in eq.
    apply set_type_eq in eq; cbn in eq.
    exact eq.
Qed.

Instance grade_sum_scalar_mult : ScalarMult U grade_sum_type := {
    scalar_mult α A := [_|grade_sum_scalar_finite α A]
}.

Program Instance grade_sum_scalar_comp : ScalarComp U grade_sum_type.
Next Obligation.
    unfold scalar_mult; cbn.
    apply set_type_eq; cbn.
    apply functional_ext.
    intros n.
    apply scalar_comp.
Qed.

Program Instance grade_sum_scalar_id : ScalarId U grade_sum_type.
Next Obligation.
    unfold scalar_mult; cbn.
    apply set_type_eq; cbn.
    apply functional_ext.
    intros n.
    apply scalar_id.
Qed.

Program Instance grade_sum_scalar_ldist : ScalarLdist U grade_sum_type.
Next Obligation.
    unfold plus, scalar_mult; cbn.
    apply set_type_eq; cbn.
    apply functional_ext.
    intros n.
    apply scalar_ldist.
Qed.

Program Instance grade_sum_scalar_rdist : ScalarRdist U grade_sum_type.
Next Obligation.
    unfold plus at 2, scalar_mult; cbn.
    apply set_type_eq; cbn.
    apply functional_ext.
    intros n.
    apply scalar_rdist.
Qed.

Theorem single_to_grade_sum_scalar : ∀ k α (A : module_V (V k)),
    single_to_grade_sum (α · A) = α · single_to_grade_sum A.
Proof.
    intros k A B.
    apply set_type_eq; cbn.
    apply functional_ext; intros x.
    unfold scalar_mult at 2; cbn.
    unfold single_to_grade_sum_base.
    destruct (sem (k = x)) as [eq|neq].
    -   destruct eq; cbn.
        reflexivity.
    -   rewrite scalar_ranni.
        reflexivity.
Qed.

Lemma single_to_grade_sum_zero : ∀ k, (single_to_grade_sum (k := k) 0) = 0.
Proof.
    intros k.
    apply set_type_eq; cbn.
    unfold single_to_grade_sum_base.
    apply functional_ext.
    intros x.
    destruct (sem (k = x)) as [eq|neq].
    -   destruct eq; cbn.
        reflexivity.
    -   reflexivity.
Qed.

Lemma grade_sum_list_sum_k : ∀ (al : ulist (grade_sum_type)) k,
    [ulist_sum al|] k = ulist_sum (ulist_image (λ a, [a|] k) al).
Proof.
    intros al k.
    induction al using ulist_induction.
    -   rewrite ulist_image_end.
        do 2 rewrite ulist_sum_end.
        reflexivity.
    -   rewrite ulist_image_add.
        do 2 rewrite ulist_sum_add.
        unfold plus at 1; cbn.
        rewrite IHal.
        reflexivity.
Qed.

Definition grade_sum_subspace_set n (v : grade_sum_type)
    := ∃ v' : module_V (V n), single_to_grade_sum v' = v.

Lemma grade_sum_subspace_zero : ∀ n, grade_sum_subspace_set n 0.
Proof.
    intros n.
    exists 0.
    apply single_to_grade_sum_zero.
Qed.

Lemma grade_sum_subspace_plus : ∀ n u v,
    grade_sum_subspace_set n u → grade_sum_subspace_set n v →
    grade_sum_subspace_set n (u + v).
Proof.
    intros n u' v' [u u_eq] [v v_eq]; subst u' v'.
    exists (u + v).
    apply single_to_grade_sum_plus.
Qed.

Lemma grade_sum_subspace_scalar : ∀ n a v,
    grade_sum_subspace_set n v → grade_sum_subspace_set n (a · v).
Proof.
    intros n a v' [v v_eq]; subst v'.
    exists (a · v).
    apply single_to_grade_sum_scalar.
Qed.

Definition grade_sum_subspace n := make_subspace
    (grade_sum_subspace_set n)
    (grade_sum_subspace_zero n)
    (grade_sum_subspace_plus n)
    (grade_sum_subspace_scalar n).

Program Instance grade_sum_grade : GradedSpace U grade_sum_type := {
    grade_I := I;
    grade_subspace n := grade_sum_subspace n;
}.
Next Obligation.
    rename H into neq.
    destruct H0 as [v1 v1_eq].
    destruct H1 as [v2 v2_eq].
    rewrite <- v2_eq in v1_eq.
    unfold single_to_grade_sum_base in v1_eq; cbn in v1_eq.
    apply set_type_eq in v1_eq; cbn in v1_eq.
    unfold single_to_grade_sum_base in v1_eq.
    (* I don't know why Coq is being so finicky about this *)
    assert (∀ n,
           match sem (i = n) with
           | strong_or_left a =>
               Logic.eq_rect_r (λ k : I, module_V (V k) → module_V (V n))
                 (λ A : module_V (V n), A) a v1
           | strong_or_right _ => 0
           end =
           match sem (j = n) with
           | strong_or_left a =>
               Logic.eq_rect_r (λ k : I, module_V (V k) → module_V (V n))
                 (λ A : module_V (V n), A) a v2
           | strong_or_right _ => 0
           end) as v1_eq'.
    {
        intros m.
        change
            match sem (i = m) with
            | strong_or_left a =>
                Logic.eq_rect_r (λ k : I, module_V (V k) → module_V (V m))
                  (λ A : module_V (V m), A) a v1
            | strong_or_right _ => 0
            end
            with
            ((λ n, match sem (i = n) with
            | strong_or_left a =>
                Logic.eq_rect_r (λ k : I, module_V (V k) → module_V (V n))
                  (λ A : module_V (V n), A) a v1
            | strong_or_right _ => 0
            end) m).
        rewrite v1_eq.
        reflexivity.
    }
    clear v1_eq.
    specialize (v1_eq' j).
    destruct (sem (i = j)) as [ij_eq|ij_neq];
    destruct (sem (j = j)) as [jj_eq|jj_neq];
    try contradiction.
    destruct jj_eq; cbn in v1_eq'.
    subst v2.
    rewrite single_to_grade_sum_zero in v2_eq.
    exact v2_eq.
Qed.
Next Obligation.
    pose proof (simple_finite_bij _ [|v]) as [n [f f_bij]].
    revert v f f_bij.
    nat_induction n; intros.
    {
        exists ulist_end.
        split.
        -   rewrite ulist_image_end, ulist_sum_end.
            apply set_type_eq.
            apply functional_ext.
            intros k.
            symmetry.
            classic_contradiction contr.
            contradiction (nat_lt_0_false (f [k|contr])).
        -   apply ulist_prop_end.
    }
    pose proof (sur f [n|nat_lt_suc n]) as [x x_eq].
    pose (v' (i : I) := If [x|] = i then 0 else [v|] i).
    assert (∀ k : set_type (λ k, 0 ≠ v' k), 0 ≠ [v|] [k|]) as f_in.
    {
        intros [k k_neq].
        unfold v' in k_neq.
        cbn.
        case_if [eq|neq].
        -   contradiction.
        -   exact k_neq.
    }
    assert (grade_sum_finite v') as v'_fin.
    {
        apply (simple_finite_trans _ _ [|v]).
        exists (λ k, [[k|]|f_in k]).
        split.
        intros a b eq.
        apply set_type_eq.
        inversion eq.
        reflexivity.
    }
    pose (f' (k : set_type (λ k, 0 ≠ v' k)) := [f [[k|]|f_in k]|]).
    assert (∀ k, initial_segment n (f' k)) as f'_in.
    {
        intros k.
        unfold initial_segment.
        unfold f'.
        split.
        -   rewrite <- nat_lt_suc_le.
            apply [|f _].
        -   destruct k as [k k_neq].
            cbn.
            unfold v' in k_neq.
            intros contr.
            apply set_type_eq in x_eq.
            cbn in x_eq.
            rewrite <- x_eq in contr.
            apply set_type_eq in contr.
            apply inj in contr.
            apply set_type_eq in contr.
            cbn in contr.
            case_if [eq|neq].
            +   contradiction.
            +   symmetry in contr.
                contradiction.
    }
    specialize (IHn [v'|v'_fin] (λ k, [f' k|f'_in k])).
    prove_parts IHn.
    {
        split; split.
        -   intros a b eq.
            unfold f' in eq.
            apply set_type_eq in eq; cbn in eq.
            apply set_type_eq in eq; cbn in eq.
            apply inj in eq.
            apply set_type_eq in eq; cbn in eq.
            apply set_type_eq in eq; cbn in eq.
            exact eq.
        -   intros [y y_lt].
            unfold initial_segment in y_lt.
            pose proof (trans y_lt (nat_lt_suc n)) as y_lt2.
            pose proof (sur f [y|y_lt2]) as [[z z_neq] z_eq].
            assert (0 ≠ v' z) as z_neq'.
            {
                unfold v'.
                case_if [eq|neq].
                -   subst z.
                    rewrite set_type_simpl in z_eq.
                    rewrite x_eq in z_eq.
                    apply set_type_eq in z_eq; cbn in z_eq.
                    subst y.
                    contradiction (irrefl _ y_lt).
                -   exact z_neq.
            }
            exists [z|z_neq'].
            unfold f'.
            apply set_type_eq; cbn.
            apply set_type_eq in z_eq; cbn in z_eq.
            rewrite <- z_eq.
            do 2 apply f_equal.
            apply set_type_eq; reflexivity.
    }
    destruct IHn as [l [v'_eq l_in]].
    assert (∀ n, grade_sum_subspace_set n (single_to_grade_sum ([v|] n))) as v_in.
    {
        intros m.
        exists ([v|] m).
        reflexivity.
    }
    exists (make_subspace_vector (grade_sum_subspace [x|]) _ (v_in [x|]) ː l).
    split.
    -   rewrite ulist_image_add; cbn.
        rewrite ulist_sum_add.
        rewrite <- v'_eq.
        apply set_type_eq.
        unfold plus; cbn.
        unfold single_to_grade_sum_base.
        unfold v'.
        apply functional_ext.
        intros k.
        case_if [eq|neq].
        +   destruct eq; cbn.
            rewrite plus_rid.
            reflexivity.
        +   rewrite plus_lid.
            reflexivity.
    -   rewrite ulist_prop_add; cbn.
        split.
        +   exists [x|].
            reflexivity.
        +   exact l_in.
Qed.
Next Obligation.
    rename H into l_in.
    rename H0 into l_uni.
    rename H1 into l_zero.
    destruct l as [|v l] using ulist_induction.
    1: apply ulist_prop_end.
    assert (0 = sub_vector_v v) as v_z.
    {
        clear IHl.
        classic_contradiction v_nz.
        apply ulist_prop_add in l_in as [[i i_eq] l_in].
        pose proof (sub_vector_in v) as v_in.
        rewrite <- i_eq in v_in.
        destruct v_in as [v' v_eq].
        rewrite ulist_image_add, ulist_unique_add in l_uni.
        rewrite <- i_eq in l_uni.
        rewrite ulist_image_add in l_zero.
        rewrite <- v_eq in l_zero, v_nz.
        clear v v_eq i_eq.
        rename v' into v.
        destruct l_uni as [v_nin l_uni].
        clear l_uni.
        rewrite ulist_sum_add in l_zero.
        unfold zero, plus in l_zero; cbn in l_zero.
        apply set_type_eq in l_zero; cbn in l_zero.
        assert (∀ k, 0 = single_to_grade_sum_base v k +
            [ulist_sum (ulist_image sub_vector_v l)|] k) as eq2.
        {
            intros k.
            unfold VZ.
            change (@zero _ (module_zero (V k))) with
                ((λ k : I, (@zero _ (module_zero (V k)))) k).
            rewrite l_zero.
            reflexivity.
        }
        clear l_zero.
        specialize (eq2 i).
        unfold single_to_grade_sum_base in eq2.
        destruct (sem (i = i)) as [eq|];
            [>destruct eq; cbn in eq2|contradiction].
        induction l as [|a l] using ulist_induction.
        1: {
            rewrite ulist_image_end, ulist_sum_end in eq2.
            unfold zero at 2 in eq2; cbn in eq2.
            rewrite plus_rid in eq2.
            subst v.
            rewrite (single_to_grade_sum_zero) in v_nz.
            contradiction.
        }
        apply ulist_prop_add in l_in as [[j aj] l_in].
        apply IHl; clear IHl.
        -   exact l_in.
        -   rewrite ulist_image_add, in_ulist_add in v_nin.
            rewrite not_or in v_nin.
            apply v_nin.
        -   rewrite ulist_image_add, ulist_sum_add in eq2.
            unfold plus at 2 in eq2; cbn in eq2.
            rewrite plus_assoc in eq2.
            rewrite (plus_comm v) in eq2.
            rewrite <- plus_assoc in eq2.
            rewrite plus_0_ab_na_b in eq2.
            rewrite <- eq2; clear eq2.
            rewrite <- neg_zero.
            apply f_equal.
            assert (grade_sum_subspace_set j (sub_vector_v a)) as a_in.
            {
                rewrite aj.
                apply sub_vector_in.
            }
            destruct a_in as [a' a_eq].
            rewrite ulist_image_add in v_nin.
            rewrite <- aj in v_nin.
            rewrite <- a_eq.
            clear a_eq a aj.
            rename a' into a.
            unfold single_to_grade_sum; cbn.
            unfold single_to_grade_sum_base.
            destruct (sem (j = i)) as [ij_eq|ij_neq].
            +   rewrite in_ulist_add in v_nin.
                rewrite not_or in v_nin.
                subst.
                destruct v_nin; contradiction.
            +   reflexivity.
    }
    rewrite ulist_prop_add.
    split.
    1: exact v_z.
    apply IHl.
    -   rewrite ulist_prop_add in l_in.
        apply l_in.
    -   rewrite ulist_image_add, ulist_unique_add in l_uni.
        apply l_uni.
    -   rewrite ulist_image_add, ulist_sum_add in l_zero.
        rewrite <- v_z in l_zero.
        rewrite plus_lid in l_zero.
        exact l_zero.
Qed.
(* begin hide *)

End LinearGradeSum.
(* end hide *)

Definition grade_sum {R} I (V : I → ModuleObj R) := make_module R
    (grade_sum_type I V)
    (grade_sum_plus I V)
    (grade_sum_zero I V)
    (grade_sum_neg I V)
    (grade_sum_plus_assoc I V)
    (grade_sum_plus_comm I V)
    (grade_sum_plus_lid I V)
    (grade_sum_plus_linv I V)
    (grade_sum_scalar_mult I V)
    (grade_sum_scalar_id I V)
    (grade_sum_scalar_ldist I V)
    (grade_sum_scalar_rdist I V)
    (grade_sum_scalar_comp I V)
.


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From adtind Require Import goal50.

Set Printing Depth 1000.
Definition lfind_eval  x l:=
count l x.

Compute lfind_eval  (Succ Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Succ (Succ (Succ (Succ Zero)))) (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Zero) (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Zero) (Cons (Succ Zero) (Cons (Succ (Succ (Succ (Succ (Succ Zero))))) (Cons (Succ Zero) (Cons Zero (Cons Zero Nil))))).

Compute lfind_eval  (Zero) (Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil))))).

Compute lfind_eval  (Succ (Succ Zero)) (Nil).

Compute lfind_eval  (Succ Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Cons (Succ (Succ (Succ Zero))) (Cons Zero (Cons Zero Nil))).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Succ (Succ (Succ (Succ Zero)))) (Nil).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Zero) (Cons (Succ Zero) (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Nil).

Compute lfind_eval  (Zero) (Nil).


Require Import XRbase Equalities Orders OrdersTac.

Local Open Scope XR_scope.

Lemma Req_dec : forall r1 r2:R, {r1 = r2} + {r1 <> r2}.
Proof.
  intros x y.
  destruct (total_order_T x y) as [ [hlt | heq ] | hgt].
  right. apply Rlt_dichotomy_converse. left. assumption.
  left. assumption.
  right. apply Rlt_dichotomy_converse. right. assumption.
Qed.

Definition Reqb r1 r2 := if Req_dec r1 r2 then true else false.

Lemma Reqb_eq : forall r1 r2, Reqb r1 r2 = true <-> r1=r2.
Proof.
 intros x y. split.
 {
   intro h. unfold Reqb in h. destruct (Req_dec x y).
   { assumption. }
   { inversion h. }
 }
 {
   intro eq. subst y.
   unfold Reqb. destruct (Req_dec x x).
   { reflexivity. }
   { elim n. reflexivity. }
 }
Qed.

Module R_as_UBE <: UsualBoolEq.
 Definition t := R.
 Definition eq := @eq R.
 Definition eqb := Reqb.
 Definition eqb_eq := Reqb_eq.
End R_as_UBE.

Module R_as_DT <: UsualDecidableTypeFull := Make_UDTF R_as_UBE.

Definition Rcompare x y :=
 match total_order_T x y with
  | inleft (left _) => Lt
  | inleft (right _) => Eq
  | inright _ => Gt
 end.

Lemma Rcompare_spec : forall x y, CompareSpec (x=y) (x<y) (y<x) (Rcompare x y).
Proof.
 intros x y.
 unfold Rcompare.
 destruct (total_order_T x y) as [[H|H]|H].
 constructor. assumption.
 constructor. assumption.
 constructor. assumption.
Qed.

Module R_as_OT <: OrderedTypeFull.
 Include R_as_DT.
 Definition lt := Rlt.
 Definition le := Rle.
 Definition compare := Rcompare.

 Instance lt_strorder : StrictOrder Rlt.
 Proof.
   split.
   {
     unfold Irreflexive. unfold Reflexive.
     apply Rlt_irrefl.
   }
   {
     unfold Transitive.
     apply Rlt_trans.
   }
Qed.

 Instance lt_compat : Proper (Logic.eq==>Logic.eq==>iff) Rlt.
 Proof.
   unfold Proper.
   unfold respectful.
   intros x y eq x' y' eq'.
   subst y y'.
   split;intros;assumption.
 Qed.

 Lemma le_lteq : forall x y, x <= y <-> x < y \/ x = y.
 Proof.
   unfold Rle.
   intros x y.
   split;intro;assumption.
 Qed.

 Definition compare_spec := Rcompare_spec.

End R_as_OT.

Module ROrder := OTF_to_OrderTac R_as_OT.
Ltac r_order := ROrder.order.


Require Export Db.Lemmas.
Require Export Stlc.SpecSyntax.
Require Export Stlc.SpecEvaluation.
Require Export Coq.Program.Tactics.
Require Import Common.Common.
Require Import Common.Relations.

Require Import Omega.

Local Ltac crush :=
  intros; cbn in * |-;
  repeat
    (cbn;
     repeat crushStlcSyntaxMatchH;
     repeat crushDbSyntaxMatchH;
     subst*);
  try discriminate;
  eauto with eval.

(* ** Evaluation contexts *)
Lemma ectx_cat (C₁ C₂: PCtx) :
  ECtx C₁ → ECtx C₂ → ECtx (pctx_cat C₁ C₂).
Proof.
  induction C₂; simpl; intros; destruct_conjs; auto.
Qed.

Lemma pctx_cat_app (t : Tm) (C₁ C₂ : PCtx) :
  pctx_app t (pctx_cat C₁ C₂) = pctx_app (pctx_app t C₁) C₂.
Proof.
  induction C₂; crush.
Qed.

Lemma eval_ctx C t t' (eC : ECtx C) :
  t --> t' -> pctx_app t C --> pctx_app t' C.
Proof.
  induction 1.
  rewrite <- ?pctx_cat_app in *.
  eauto using ectx_cat with eval.
Qed.

Lemma evalstar_ctx {t t'} C (eC: ECtx C) :
  t -->* t' → pctx_app t C -->* pctx_app t' C.
Proof.
  induction 1; eauto using eval_ctx with eval.
Qed.

Lemma evalplus_ctx C t t' (eC: ECtx C) :
  t -->+ t' → pctx_app t C -->+ pctx_app t' C.
Proof.
  induction 1; eauto using eval_ctx with eval.
Qed.

Lemma evaln_ctx {C t t' n} :
  ECtx C → evaln t t' n -> evaln (pctx_app t C) (pctx_app t' C) n.
Proof.
  intros ec.
  induction 1; unfold evaln; eauto using eval_ctx with eval.
Qed.

Lemma termination_closed_under_antireduction {t t'} :
  t --> t' → t'⇓ → t⇓.
Proof.
  destruct 2 as [v ?].
  exists v; crush.
Qed.

Lemma terminationN_closed_under_antireduction {t t' n} :
  t --> t' → TerminatingN t' n → TerminatingN t (S n).
Proof.
  destruct 2 as (v & m & ? & ? & ?).
  exists v, (S m); repeat split.
  - crush.
  - omega.
  - eapply stepRel_step; crush.
Qed.

Lemma termination_closed_under_antireductionStar {t t'} :
  t -->* t' → t'⇓ → t⇓.
Proof.
  intros e m. induction e;
  eauto using termination_closed_under_antireduction.
Qed.

Lemma value_ectx_inv C t (ec : ECtx C) :
  Value (pctx_app t C) → Value t.
Proof.
  intros v; induction C; crush.
Qed.

Lemma eval₀_ectx_inv C t (ec : ECtx C) {t' t''} :
  t'' -->₀ t' → t'' = pctx_app t C →
  Value t ∨ C = phole.
Proof.
  induction 1;
  destruct C; crush;
  try match goal with
      [ H : _ = pctx_app t C |- _ ] =>
      (assert (Value (pctx_app t C)) by (rewrite <- H; crush))
  end; eauto using value_ectx_inv.
Qed.

Lemma pctx_cat_phole_leftzero {C} :
  pctx_cat phole C = C.
Proof.
  induction C; crush; f_equal; crush.
Qed.

Lemma pctx_cat_assoc {C C' C''} :
  pctx_cat C (pctx_cat C' C'') = pctx_cat (pctx_cat C C') C''.
Proof.
  induction C''; crush; f_equal; crush.
Qed.

Lemma values_terminate {v : Tm} : Value v → v ⇓.
Proof.
  intros vv. exists v; crush.
Qed.

Definition normal' (t : Tm) := ∀ t', ¬ (t --> t').
Lemma values_are_normal' {t : Tm} : Value t -> normal' t.
Proof. induction 2 using eval_ind'; crush. Qed.

Lemma values_are_normal {t : Tm} : Value t -> normal t.
Proof.
  generalize @values_are_normal'.
  unfold normal, normal', not.
  intros ? ? t'; destruct t'; eauto.
Qed.

Lemma values_terminateN {t n} : Value t → t ⇓_ n.
Proof.
  intros v. exists t, 0; repeat split.
  - crush.
  - omega.
  - eapply stepRel_zero.
Qed.

Section InvertECtxEq.

  Inductive EctxAppEq : ∀ (t : Tm) (C : PCtx) (t' : Tm) (C' : PCtx),  Prop :=
    | EctxAppEqLeft : ∀ t C C', ECtx C → EctxAppEq (pctx_app t C) C' t (pctx_cat C C')
    | EctxAppEqRight : ∀ t C C', ECtx C → EctxAppEq t (pctx_cat C C') (pctx_app t C) C'
    | ECtxValueLeft : ∀ t t' C C', Value t → EctxAppEq t C t' C'
    | ECtxValueRight : ∀ t t' C C', Value t' → EctxAppEq t C t' C'
  .

  Lemma ectxAppEqExtend {t C t' C'} C'' :
    EctxAppEq t C t' C' →
    EctxAppEq t (pctx_cat C C'') t' (pctx_cat C' C'').
  Proof.
    induction 1; rewrite <- ?pctx_cat_assoc; constructor; assumption.
  Qed.

  Lemma ectxAppEqExtendPAbs {t C t' C' τ} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pabs τ C) t' (pabs τ C').
  Proof.
    eapply (ectxAppEqExtend (pabs τ phole)).
  Qed.

  Lemma ectxAppEqExtendPInl {t C t' C'} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pinl C) t' (pinl C').
  Proof.
    eapply (ectxAppEqExtend (pinl phole)).
  Qed.

  Lemma ectxAppEqExtendPInr {t C t' C'} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pinr C) t' (pinr C').
  Proof.
    eapply (ectxAppEqExtend (pinr phole)).
  Qed.

  Lemma ectxAppEqExtendPProj₁ {t C t' C'} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pproj₁ C) t' (pproj₁ C').
  Proof.
    eapply (ectxAppEqExtend (pproj₁ phole)).
  Qed.

  Lemma ectxAppEqExtendPProj₂ {t C t' C'} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pproj₂ C) t' (pproj₂ C').
  Proof.
    eapply (ectxAppEqExtend (pproj₂ phole)).
  Qed.

  Lemma ectxAppEqExtendPPair₁ {t C t' C' t₂} :
    EctxAppEq t C t' C' →
    EctxAppEq t (ppair₁ C t₂) t' (ppair₁ C' t₂).
  Proof.
    eapply (ectxAppEqExtend (ppair₁ phole t₂)).
  Qed.

  Lemma ectxAppEqExtendPPair₂ {t C t' C' t₁} :
    EctxAppEq t C t' C' →
    EctxAppEq t (ppair₂ t₁ C) t' (ppair₂ t₁ C').
  Proof.
    eapply (ectxAppEqExtend (ppair₂ t₁ phole)).
  Qed.

  Lemma ectxAppEqExtendPApp₁ {t C t' C' t₂} :
    EctxAppEq t C t' C' →
    EctxAppEq t (papp₁ C t₂) t' (papp₁ C' t₂).
  Proof.
    eapply (ectxAppEqExtend (papp₁ phole t₂)).
  Qed.

  Lemma ectxAppEqExtendPApp₂ {t C t' C' t₁} :
    EctxAppEq t C t' C' →
    EctxAppEq t (papp₂ t₁ C) t' (papp₂ t₁ C').
  Proof.
    eapply (ectxAppEqExtend (papp₂ t₁ phole)).
  Qed.

  Lemma ectxAppEqExtendPSeq₁ {t C t' C' t₂} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pseq₁ C t₂) t' (pseq₁ C' t₂).
  Proof.
    eapply (ectxAppEqExtend (pseq₁ phole t₂)).
  Qed.

  Lemma ectxAppEqExtendPIte₁ {t C t' C' t₂ t₃} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pite₁ C t₂ t₃) t' (pite₁ C' t₂ t₃).
  Proof.
    eapply (ectxAppEqExtend (pite₁ phole t₂ t₃)).
  Qed.

  Lemma ectxAppEqExtendPCaseof₁ {t C t' C' t₂ t₃} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pcaseof₁ C t₂ t₃) t' (pcaseof₁ C' t₂ t₃).
  Proof.
    eapply (ectxAppEqExtend (pcaseof₁ phole t₂ t₃)).
  Qed.

  Lemma ectxAppEqExtendPFixt {t C t' C' τ₁ τ₂} :
    EctxAppEq t C t' C' →
    EctxAppEq t (pfixt τ₁ τ₂ C) t' (pfixt τ₁ τ₂ C').
  Proof.
    eapply (ectxAppEqExtend (pfixt τ₁ τ₂ phole)).
  Qed.

  Lemma ectxAppEqPHoleRight {t C} : ECtx C → EctxAppEq t C (pctx_app t C) phole.
  Proof.
    change C with (pctx_cat C phole); eauto using EctxAppEq.
  Qed.

  Lemma ectxAppEqPHoleLeft {t C} : ECtx C → EctxAppEq (pctx_app t C) phole t C.
  Proof.
    change C with (pctx_cat C phole); eauto using EctxAppEq.
  Qed.

  Lemma pctx_app_eq t C t' C' :
    ECtx C → ECtx C' →
    pctx_app t C = pctx_app t' C' →
    EctxAppEq t C t' C'.
  Proof.
    revert t' C';
    induction C; intros t' C' eC eC' eq';
    [simpl in *; subst;
     eauto using ectxAppEqPHoleLeft, ectxAppEqPHoleRight, EctxAppEq
    |idtac..];
    (destruct C';
      [change (pctx_app t' phole) with t' in *; subst;
       eauto using ectxAppEqPHoleLeft, ectxAppEqPHoleRight, EctxAppEq
      |idtac..]);
    crush;
    eauto using ectxAppEqExtendPAbs, ectxAppEqExtendPProj₂, ectxAppEqExtendPProj₁, ectxAppEqExtendPInr, ectxAppEqExtendPInl, ectxAppEqExtendPApp₁, ectxAppEqExtendPApp₂, ectxAppEqExtendPPair₁, ectxAppEqExtendPPair₂, ectxAppEqExtendPIte₁, ectxAppEqExtendPCaseof₁, ectxAppEqExtendPSeq₁, ectxAppEqExtendPFixt;
    eauto using value_ectx_inv, ECtxValueRight, ECtxValueLeft.
  Qed.

End InvertECtxEq.

Lemma eval_ectx_inv C t (ec : ECtx C) {t' t''} :
  t'' --> t' → pctx_app t C = t'' →
  Value t ∨ exists t'', t' = pctx_app t'' C ∧ t --> t''.
Proof.
  induction 1.
  intros eq.
  pose proof (pctx_app_eq _ _ _ _ ec H0 eq) as inv.
  induction inv.
  - right.
    exists (pctx_app t' C).
    eauto using pctx_cat_app, eval_ctx₀.
  - destruct (eval₀_ectx_inv C t H1 H eq_refl); crush.
    right; exists t'.
    rewrite pctx_cat_phole_leftzero;
    eauto using (eval_ctx₀ phole).
  - left; crush.
  - exfalso.
    eapply (values_are_normal H1 t').
    eapply (eval_ctx₀ phole); crush.
Qed.

Lemma evalStar_ectx_inv C t (ec : ECtx C) v :
  pctx_app t C -->* v → Value v →
  exists v', Value v' ∧ t -->* v' ∧ pctx_app v' C -->* v.
Proof.
  intros es vv; depind es.
  - exists t; eauto using value_ectx_inv with eval.
  - destruct (eval_ectx_inv C t ec H eq_refl) as [vt|[t'' [eq e]]].
    + exists t; crush.
    + subst.
      destruct (IHes t'' C ec eq_refl vv) as (v' & vv' & es1' & es2').
      exists v'; crush.
Qed.

Lemma inversion_termination_evalcontext C t (ec: ECtx C) :
  Terminating (pctx_app t C) → Terminating t.
Proof.
  destruct 1 as (v & vv & es).
  destruct (evalStar_ectx_inv C t ec v es) as (v' & vv' & es1 & es2); subst; crush.
  exists v'; crush.
Qed.

Corollary divergence_closed_under_evalcontext t :
  t⇑ → ∀ p, ECtx p → (pctx_app t p)⇑.
Proof. eauto using inversion_termination_evalcontext. Qed.

Corollary divergence_closed_under_evalcontext' {t C t'} :
  t⇑ → t' = pctx_app t C → ECtx C → t'⇑.
Proof. intros; subst; eauto using divergence_closed_under_evalcontext. Qed.

Ltac crushImpossibleEvals :=
  match goal with
          [ H : abs _ _ --> _ |- _ ] => exfalso; refine (values_are_normal' _ _ H); crush
        | [ H : true --> _ |- _ ] => exfalso; refine (values_are_normal' _ _ H); crush
        | [ H : false --> _ |- _ ] => exfalso; refine (values_are_normal' _ _ H); crush
        | [ H : unit --> _ |- _ ] => exfalso; refine (values_are_normal' _ _ H); crush
        | [ H : Value ?x, H' : ?x --> _ |- _ ] => exfalso; refine (values_are_normal' H _ H'); crush
        | [ Hx : Value ?x, Hy : Value ?y,  H' : pair ?x ?y --> _ |- _ ] => exfalso; refine (values_are_normal' _ _ H'); crush
        | [ Hx : Value ?x,  H' : inl ?x --> _ |- _ ] => exfalso; refine (values_are_normal' _ _ H'); crush
        | [ Hx : Value ?x,  H' : inr ?x --> _ |- _ ] => exfalso; refine (values_are_normal' _ _ H'); crush
  end.

Lemma TerminatingN_Terminating {t : Tm} {n} : t ⇓_ n -> t ⇓.
Proof.
  destruct 1 as (v & m & vv & ineq & es).
  exists v; eauto using stepRel_to_evalStar.
Qed.

Lemma evalStar_to_evaln {t t'} : t -->* t' → exists n, evaln t t' n.
Proof.
  induction 1.
  - exists 0; apply stepRel_zero.
  - destruct (IHclos_refl_trans_1n) as (n & en).
    exists (S n); eapply stepRel_step; crush.
Qed.

(* This should hold, but doesn't? *)
Lemma Terminating_TerminatingN {t : Tm} : t ⇓ -> ∃ n, t ⇓_ n.
Proof.
  destruct 1 as (v & vv & es).
  destruct (evalStar_to_evaln es) as [n en].
  exists n; econstructor; crush.
Qed.

Lemma determinacy' {t t' t'' t'''} : t --> t' → t'' --> t''' → t = t'' → t' = t'''.
Proof.
  intros e₁.
  revert t'' t'''.
  induction e₁ using eval_ind';
  induction 1 using eval_ind'; crush; try crushImpossibleEvals.
Qed.

Lemma determinacy {t t' t''} : t --> t' → t --> t'' → t' = t''.
Proof.
  eauto using determinacy'.
Qed.

Lemma TerminatingD (t: Tm) (m: t⇓) :
  ∀ t', t --> t' → Terminating t'.
Proof.
  destruct m as (v & vv & es).
  destruct es;
  intros t' e; try crushImpossibleEvals.
  destruct (determinacy H e).
  exists z; crush.
Qed.

Lemma TerminatingDN (t: Tm) n (term: t ⇓_ (S n)) :
  ∀ t', t --> t' → TerminatingN t' n.
Proof.
  destruct term as (v & m & vv & ineq & esn).
  intros t' e.
  destruct esn; try crushImpossibleEvals.
  destruct (determinacy H e).
  exists t'', n0; repeat split.
  - crush.
  - omega.
  - crush.
Qed.

Lemma termination_closed_under_evalplus {t t'} :
  t -->+ t' → t⇓ → t'⇓.
Proof. intros e m; induction e; eauto using TerminatingD. Qed.

Lemma termination_closed_under_evalstar {t t'} :
  t -->* t' → t⇓ → t'⇓.
Proof. intros e m; induction e; eauto using TerminatingD. Qed.

Corollary divergence_closed_under_eval {t t'} :
  t --> t' → t'⇑ → t⇑.
Proof. eauto using TerminatingD with eval. Qed.

Corollary divergence_closed_under_evalplus {t t'} :
  t -->+ t' → t'⇑ → t⇑.
Proof. eauto using termination_closed_under_evalplus. Qed.

Corollary divergence_closed_under_evalstar {t t'} :
  t -->* t' → t'⇑ → t⇑.
Proof. eauto using termination_closed_under_evalstar. Qed.

Lemma cycles_dont_terminate {t} :
  t -->+ t → t⇑.
Proof.
  intros cycle.
  destruct 1 as (v & vv & ?).
  enough (forall t', t' -->+ t → t' -->* v → False) by eauto with eval.
  intros ? cycle'.
  induction 1 as [?|? ? ? e' ? IHes''];
    destruct (inversion_evalPlus cycle') as (? & cycleStart & ?).
  - refine (values_are_normal vv _ cycleStart).
  - rewrite <- ?(determinacy e' cycleStart) in *.
    eauto using IHes'', evalStarPlusToPlus.
Qed.

Lemma TerminatingN_lt {t n n'} :
  TerminatingN t n → n ≤ n' → TerminatingN t n'.
Proof.
  destruct 1 as (v & m & vv & ineq & esm).
  intros ineq'.
  exists v, m; repeat split; crush.
  omega.
Qed.

(* Lemma TerminatingN_eval1 {t t' n} : *)
(*   t --> t' → TerminatingN t' n → TerminatingN t (S n). *)
(* Proof. *)
(*   intros e term. *)
(*   destruct term as [v m]. *)
(*   apply (TerminatingIN t (S n) v (S m)); crush; try omega. *)
(*   eapply stepRel_step; crush. *)
(* Qed. *)

Lemma TerminatingN_eval {t t' n} :
  t --> t' → TerminatingN t' n ↔ TerminatingN t (S n).
Proof.
  intros term.
  split; intros;
  [eapply terminationN_closed_under_antireduction | eapply TerminatingDN];
  crush.
Qed.

Lemma TerminatingN_evaln {t t' n } n' :
  evaln t t' n → TerminatingN t' n' ↔ TerminatingN t (n + n').
Proof.
  induction 1; constructor; auto; intro term;
  change (S n + n') with (S (n + n')) in *;
  [rewrite <- (TerminatingN_eval H) | rewrite <- (TerminatingN_eval H) in term];
  apply IHstepRel; auto.
Qed.

Lemma evaln_split {t t' } n n':
  evaln t t' (n + n') → exists t'', evaln t t'' n ∧ evaln t'' t' n'.
Proof.
  revert t; induction n.
  - intros; exists t; simpl in *; split; [apply stepRel_zero|assumption].
  - intros t esn; depind esn; clear IHesn.
    destruct (IHn t' esn) as (t3 & es1 & es2).
    exists t3; split; try assumption.
    eapply stepRel_step; crush.
Qed.

Lemma TerminatingN_xor_evaln {t t' n} :
  TerminatingN t n → evaln t t' (S n) → False.
Proof.
  intros term esn.
  replace (S n) with (n + 1) in esn by omega.
  destruct (evaln_split n 1 esn) as (t'' & en & e1).
  replace n with (n + 0) in term by omega.
  rewrite <- (TerminatingN_evaln 0 en) in term.
  destruct term as (v & m & vv & ineq & esm).
  assert (m = 0) by omega; subst.
  inversion esm; subst.
  inversion e1.
  crushImpossibleEvals.
Qed.

Section EvalInContext.
  Lemma eval₀_to_eval {t t'} :
    t -->₀ t' →
    t --> t'.
  Proof.
    intros e₀.
    change (t --> t') with (pctx_app t phole --> pctx_app t' phole).
    eapply (eval_ctx₀ phole); crush.
  Qed.

  Lemma eval_from_eval₀ {t t' t₀ t₀' C} :
    t₀ -->₀ t₀' →
    t = pctx_app t₀ C →
    t' = pctx_app t₀' C →
    ECtx C →
    t --> t'.
  Proof.
    intros; subst; eauto using eval_ctx₀.
  Qed.

  Lemma evalstar_ctx' {t t' t₀ t₀' C} :
    t₀ -->* t₀' →
    t = pctx_app t₀ C →
    t' = pctx_app t₀' C →
    ECtx C →
    t -->* t'.
  Proof.
    intros; subst; eauto using evalstar_ctx.
  Qed.

End EvalInContext.

Ltac inferContext :=
  cbn; try reflexivity;
  let rec inferC acc t t₀ :=
      match t with
        | t₀ => instantiate (1 := acc)
        | app ?t1 ?t2 => inferC (pctx_cat (papp₁ phole t2) acc) t1 t₀ + inferC (pctx_cat (papp₂ t1 phole) acc) t2 t₀
        | pair ?t1 ?t2 => inferC (pctx_cat (ppair₁ phole t2) acc) t1 t₀ + inferC (pctx_cat (ppair₂ t1 phole) acc) t2 t₀
        | seq ?t1 ?t2 => inferC (pctx_cat (pseq₁ phole t2) acc) t1 t₀
        | inl ?t1 => inferC (pctx_cat (pinl phole) acc) t1 t₀
        | inr ?t1 => inferC (pctx_cat (pinr phole) acc) t1 t₀
        | ite ?t1 ?t2 ?t3 => inferC (pctx_cat (pite₁ phole t2 t3) acc) t1 t₀
        | caseof ?t1 ?t2 ?t3 => inferC (pctx_cat (pcaseof₁ phole t2 t3) acc) t1 t₀
        | proj₁ ?t1 => inferC (pctx_cat (pproj₁ phole) acc) t1 t₀
        | proj₂ ?t1 => inferC (pctx_cat (pproj₂ phole) acc) t1 t₀
        | pctx_app t₀ ?C => instantiate (1 := pctx_cat C acc)
        | pctx_app ?t1 (pctx_cat ?C1 ?C2) => inferC (pctx_app (pctx_app t1 C1) C2) t₀
        | pctx_app ?t1 ?C => inferC (pctx_cat C acc) t1 t₀
      end
  in repeat match goal with
              | [ |- ?t = pctx_app ?t₀ (pctx_cat ?C1 ?C2) ] => (rewrite -> ?pctx_cat_app)
              | [ |- pctx_app ?t0 ?C = pctx_app ?t' ?C ] => f_equal
              | [ |- ?t = pctx_app ?t₀ ?C ] => (inferC phole t t₀; rewrite -> ?pctx_cat_app; cbn; rewrite -> ?pctx_cat_app in *; reflexivity)
            end.

Lemma test_inferContext (t : Tm) (C' : PCtx): True.
Proof.
  assert (pctx_app (pair (inl t) unit) C' = pctx_app t (pctx_cat (ppair₁ (pinl phole) unit) C')).
  inferContext.
  trivial.
Qed.

Ltac crushStlcEval :=
  match goal with
      [ |- ECtx (pctx_cat _ _) ] => eapply ectx_cat
    | [ |- ECtx (papp₁ _ _) ] => unfold ECtx
    | [ |- ECtx (papp₂ _ _) ] => unfold ECtx
  end.


(*|
##########################################################
Rewriting hypothesis to false with a contradictory theorem
##########################################################

:Link: https://stackoverflow.com/q/71834647
|*)

(*|
Question
********

I want to show that

.. code-block:: coq

    [seq q x t | x <- iota 0 (t + 1)] != [::]

I decided to destruct ``iota 0 (t + 1)`` because I have a lemma that
says:

.. code-block:: coq

    iota 0 (t + 1) != [::]

So the first case of destruct should have ``iota 0 (t + 1) = [::]``
which by the theorem mentioned is false, and I can discriminate. How
can I rewrite the equation in the first destruct case using the lemma?
I cannot figure it out.
|*)

(*|
Answer (Arthur Azevedo De Amorim)
*********************************

You do not need to destruct. Note that ``iota`` is defined by
recursion on its second variable. Your current goal cannot be
simplified because ``t + 1`` does not start with a constructor.
However, you can do ``by rewrite addn1`` to put it in a form where it
can be solved.
|*)

(*|
Answer (Pierre Jouvelot)
************************

In addition to computation, as Arthur suggests, you can sometimes use
contraposition to deal with non-equalities (do ``Search "contra"`` for
variant versions).

For instance, in your case, you can show, if you add some injectivity
constraint:
|*)

From mathcomp Require Import all_ssreflect. (* .none *)
Lemma foo (q : nat -> nat -> nat) t (injq : injective (q ^~ t)) :
  iota 0 (t + 1) != [::] -> [seq q x t | x <- iota 0 (t + 1)] != [::].
Proof.
  apply: contra_neq.
  rewrite [RHS](_ : [::] = [seq q x t | x <- [::]]) //.
  exact: inj_map.
Qed.


Require Import MyTactics.
Require Export List.

(** * [repeat]: definition and facts. *)
Fixpoint repeat {A} (a: A) (n: nat) : list A :=
match n with
| O => nil
| S n => a :: repeat a n
end.

Lemma map_repeat {A B} (f: A -> B) (a: A) (n: nat) :
  map f (repeat a n) = repeat (f a) n.
Proof.
induction n.
* reflexivity.
* simpl. congruence.
Qed.

Lemma repeat_length {A} :
  forall (a: A) n, length (repeat a n) = n.
Proof.
intros a n. induction n; simpl in *; auto.
Qed.

Lemma repeat_nth {A} :
  forall (a a0 : A) k n,
    k < n ->
    nth k (repeat a n) a0 = a.
Proof.
intros a a0 k n H.
generalize dependent k. revert a. induction n; intros a k H; auto.
simpl. destruct k; auto.
Qed.

(** * Facts about [last]. *)
Lemma last_nth {A} :
  forall (l: list A) (default: A),
    last l default = nth (length l - 1) l default.
Proof.
intros l default. induction l.
* reflexivity.
* destruct l as [|b l].
  + reflexivity.
  + transitivity (last (b :: l) default). reflexivity.
    rewrite IHl. simpl.
    replace (length l - 0) with (length l) by auto with arith.
    reflexivity.
Qed.

Lemma last_In {A} :
  forall (l: list A) (default: A),
    l <> nil -> In (last l default) l.
Proof.
intros l default H. destruct l as [|a l].
* exfalso. congruence.
* rewrite last_nth. apply nth_In. auto with arith.
Qed.

Lemma last_map {A B} (f: A -> B):
  forall (l: list A) (default: A),
    last (map f l) (f default) = f (last l default).
Proof.
intros l default. induction l.
* reflexivity.
* simpl map. destruct l as [|b l].
  + reflexivity.
  + transitivity (last (map f (b :: l)) (f default)). reflexivity.
    rewrite IHl. reflexivity.
Qed.

(** * Facts about [app]. *)
Lemma app_comm_cons_cons {A}:
  forall a1 a2 (l1 l2: list A),
    (l1 ++ a1 :: nil) ++ a2 :: l2 = l1 ++ a1 :: a2 :: l2.
Proof.
intros a1 a2 l1.
generalize dependent a2. generalize dependent a1.
induction l1; intros a1 a2 l2.
* reflexivity.
* simpl. f_equal. auto.
Qed.


Require Export Coq.Bool.Bool.

Lemma negb_true_elim
 :  forall x
 ,  true   = negb x
 -> false  = x.
Proof. destruct x; auto. Qed.

Lemma negb_true_intro
 :  forall x
 ,  false = x
 -> true  = negb x .
Proof. destruct x; eauto. Qed.

Lemma negb_false_elim
 :  forall x
 ,  false  = negb x
 -> true   = x.
Proof. destruct x; auto. Qed.

Ltac norm_negb
 := match goal with
    | [H : true  = negb _ |- _ ]
    => apply negb_true_elim in H

    | [H : false = negb _ |- _ ]
    => apply negb_false_elim in H
    end.

(********************************************************************)
Lemma beq_true_split
 :  forall A B
 ,  true = andb A B
 -> true = A /\ true = B.
Proof.
 intros.
 destruct A.
  tauto.
  simpl in H. congruence.
Qed.
Hint Resolve beq_true_split.

Lemma beq_false_split
 :  forall A B
 ,  false = andb A B
 -> false = A \/ false = B.
Proof.
 intros.
 destruct A.
  simpl in H. subst. tauto.
  tauto.
Qed.
Hint Resolve beq_false_split.

Lemma beq_false_join
 :  forall A B
 ,  false = A \/ false = B
 -> false = andb A B.
Proof.
 intros.
 inversion H. subst.
 tauto.
 destruct A; tauto.
Qed.
Hint Resolve beq_false_split.

Ltac norm_andb
 := match goal with
    | [H : true  = andb _ _ |- _]
    => apply beq_true_split in H

    | [H : andb _ _ = true |- _]
    => symmetry in H; apply beq_true_split in H

    | [H : false = andb _ _ |- _]
    => apply beq_false_split in H

    | [H : andb _ _ = false |- _]
    => symmetry in H; apply beq_false_split in H
    end.

(********************************************************************)
Ltac norm_orb
 := match goal with
    | [H : true    = orb _ _ |- _]
    => symmetry in H; apply orb_true_iff in H

    | [H : orb _ _ = true    |- _]
    => apply orb_true_iff in H

    | [H : false   = orb _ _ |- _]
    => symmetry in H; apply orb_false_iff in H

    | [H : orb _ _ = false   |- _]
    => apply orb_false_iff in H
    end.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - reflexivity.
Qed.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - reflexivity.

Qed.

Lemma qreva_nil : forall (x y : lst), qreva x y = append (qreva x Nil) y.
Proof.
   intro.
   induction x.
   - intros. simpl. rewrite IHx. rewrite (IHx (Cons n Nil)). rewrite append_assoc. reflexivity.
   - reflexivity.

Qed.

Lemma qreva_append : forall (x y : lst), qreva (append x y) Nil = append (qreva y Nil) (qreva x Nil).
Proof.
   intros.
   induction x.
   - simpl. rewrite qreva_nil. rewrite IHx. rewrite append_assoc. rewrite (qreva_nil x (Cons n Nil)). reflexivity.
   - simpl. lfind.  reflexivity.
Admitted.

Theorem qreva_qreva : forall (x : lst), eq (qreva (qreva x Nil) Nil) x.
Proof.
   intros.
   induction x.
   - simpl. rewrite (qreva_nil x). rewrite qreva_append. rewrite IHx. simpl. reflexivity.
   - reflexivity.
Qed.


From Coq Require Import ssreflect.
Require Import stdpp.gmap.
From Coq Require Import Lia.

Lemma zip_length_le {A B} {l' : list A} {l1 l2 l3 : list B} :
  length l' <= length l1 -> l2 = l1 ++ l3 -> zip l1 l' = zip l2 l'.
Proof.
  simpl.
  generalize dependent l1.
  generalize dependent l2.
  generalize dependent l3.
  induction l'.
  - intros l3 l2 l1 H1 H2.
    rewrite /zip.
    destruct l2, l1; done.
  - intros l3 l2 l1 H1 H2.
    destruct l2, l1; try done.
    simpl in H2.
    inversion H2.
    simpl in H1.
    inversion H1.
    inversion H2; subst.
    simpl.
    f_equal.
    rewrite (IHl' l3 (l1 ++ l3) l1); try done.
    simpl in H1.
    lia.
Qed.

Lemma map_subseteq_delete `{Countable K}  {V: Type} (m :gmap K V) i : (delete i m) ⊆ m.
Proof.
  rewrite map_subseteq_spec.
  intros k v Hlk.
  destruct (decide (i = k)).
  subst.
  rewrite lookup_delete_Some in Hlk.
  destruct Hlk;done.
  rewrite lookup_delete_ne in Hlk;auto.
Qed.

Lemma map_insert_swap `{Countable K}  {V: Type} (m :gmap K V) k1 k2 v1 v2:
  k1 ≠ k2 ->
  (<[k1:=v1]> (<[k2:=v2]> m) = <[k2:=v2]> (<[k1:=v1]> m)).
Proof.
  intro Hneq.
  revert k1 k2 v1 v2 Hneq.
  induction m using map_ind.
  intros.
  apply map_eq.
  intro.
  destruct (decide (i = k1));
    destruct (decide (i = k2));simplify_map_eq /=;auto.
  intros.
  destruct (decide (i = k1));
    destruct (decide (i = k2));simplify_map_eq /=;auto.
  rewrite IHm. intro; done.
  rewrite 2!insert_insert.
  apply IHm.
  done.
  rewrite insert_insert.
  set X := (Y in Y = _).
  rewrite IHm. auto.
  rewrite insert_insert.
  rewrite /X IHm //.
  apply map_eq.
  intro.
  destruct (decide (i0 = k1));
    destruct (decide (i0 = k2));simplify_map_eq /=;auto.
  rewrite (lookup_insert_ne _ k2) //.
  rewrite (lookup_insert_ne _ k1) //.
Qed.

Section sets.
  Context `{Countable T}.
  Implicit Type A B C : gset T.

  (* lemmas about sets... *)
  Lemma union_split_difference_intersection_L A B:
    A = (A ∖ B) ∪ (A ∩ B) ∧ (A ∖ B) ## (A ∩ B).
  Proof.
    split.
    {
      rewrite union_intersection_l_L.
      rewrite difference_union_L.
      set_solver.
    }
    {
      set_solver.
    }
  Qed.

  Lemma union_split_difference_intersection_subseteq_L A B:
    B ⊆ A ->
    A = (A ∖ B) ∪ B ∧ (A ∖ B) ## B.
  Proof.
    intro H0.
    pose proof (union_split_difference_intersection_L A B) as H1.
    assert (A∩ B = B).
    {
      set_solver + H0.
    }
    rewrite H2 in H1.
    done.
  Qed.

  Lemma union_split_difference_1_L A B:
    A ∪ B = A ∪ (B ∖ A) ∧ A ## (B ∖ A).
  Proof.
    split.
    {
      rewrite union_comm_L (union_comm_L _ (B ∖ A)).
      rewrite difference_union_L //.
    }
    {
      set_solver.
    }
  Qed.

  Lemma union_split_difference_2_L A B:
    A ∪ B = B ∪ (A ∖ B) ∧ B ## (A ∖ B).
  Proof.
    split.
    {
      rewrite  (union_comm_L _ (A ∖ B)).
      rewrite difference_union_L //.
    }
    {
      set_solver.
    }
  Qed.

  Lemma difference_union_cancel_L_l A B:
     (A ∪ B) ∖ A = B ∖ A.
  Proof. set_solver. Qed.

  Lemma not_subseteq A B:
    A ⊈ B -> ∃ a, a ∈ A ∧ a ∉ B.
  Proof.
    intros.
    induction A using set_ind_L.
    pose proof (empty_subseteq B) .
    done.
    destruct (decide (x ∈ B)).
    {
      assert (X ⊈ B).
      {
        intro.
        apply H0.
        set_solver.
      }
      apply IHA in H2 as [a [? ?]].
      exists a.
      split;auto.
      set_solver.
    }
    {
      exists x.
      split;auto.
      set_solver.
    }
  Qed.

  Lemma not_subseteq_diff A B C :
   A ⊆ B -> A ⊈ (B ∖ C) -> ∃ a, a ∈ A ∧ a ∈ C.
  Proof.
    intros Hsub1 Hsub2.
    apply not_subseteq in Hsub2 as [a [Hin Hnin]].
    rewrite elem_of_subseteq in Hsub1.
    exists a.
    split;auto.
    specialize (Hsub1 a Hin).
    set_solver.
  Qed.

  Lemma difference_union_subseteq A B C :
    B ⊆ C ->
    A ∖ B ∪ C = A ∪ C.
  Proof.
    intro Hsub.
    apply (union_split_difference_intersection_subseteq_L) in Hsub.
    destruct Hsub as [Heq _].
    replace (A ∖ B ∪ C) with (A ∖ B ∪ (C ∖ B ∪ B)).
    rewrite (union_comm_L  _ B).
    rewrite union_assoc_L.
    rewrite difference_union_L.
    rewrite -(union_assoc_L _ B).
    rewrite (union_comm_L B).
    set_solver + Heq.
    set_solver + Heq.
  Qed.

  Lemma intersection_subseteq_disjoint A B C:
    C ⊆ A -> C ⊆ B ->
    A ∖ C ## B ->
    A ∩ B = C.
  Proof.
    intros Hsub1 Hsub2 Hdisj.
    rewrite set_eq.
    intros. split.
    set_solver.
    set_solver.
  Qed.

  Lemma difference_difference_union A B C:
    C ⊆ A ->
    A ∖ (B ∖ C) = A ∖ B ∪ C.
  Proof.
    intro.
    rewrite set_eq.
    intros. split.
    intro.
    apply elem_of_difference in H1.
    destruct H1.
    destruct (decide (x ∈ B)).
    destruct (decide (x ∈ C)); set_solver.
    set_solver.
    intro.
    rewrite elem_of_union in H1.
    destruct H1; set_solver.
  Qed.

  Lemma intersection_difference A B:
    A ∖ B = A ∖ (A ∩ B).
  Proof. set_solver. Qed.

End sets.

Section filter.
  Context `{Countable K} {V: Type}.

  Implicit Type m : gmap K V.

  Lemma map_filter_imp m P `{∀ x, Decision (P x)} Q `{∀ x, Decision (Q x)}:
    (∀ x, P x -> Q x) ->
    filter P m ⊆ filter Q m.
  Proof.
    intros Himp.
    induction m using map_ind. done.
    rewrite 2?map_filter_insert.
    case_decide;case_decide.
    {
      apply map_subseteq_spec.
      intros.
      rewrite lookup_insert_Some in H5.
      destruct H5 as [[-> ->]|[Hneq Hlk]].
      {
        rewrite lookup_insert //.
      }
      {
        rewrite lookup_insert_ne //.
        rewrite map_subseteq_spec in IHm.
        by apply IHm.
      }
      }
      by apply Himp in H3.
    rewrite delete_notin //.
    apply map_subseteq_spec.
    intros.
    destruct (decide (i = i0)).
    {
      subst.
      rewrite map_filter_lookup_Some in H5.
      destruct H5;auto.
      rewrite H5 in H2. inversion H2.
    }
    {
      rewrite lookup_insert_ne //.
      rewrite map_subseteq_spec in IHm.
      by apply IHm.
    }
    rewrite 2?delete_notin //.
  Qed.

End filter.