(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export bar_induction2.
Require Export subst_tacs.
Require Export per_props_equality.
Require Export lsubstc_vars.

Lemma eq_kseq_of_seq {o} :
  forall lib (s : @CTerm o) v k,
    is_seq lib s
    -> eq_kseq lib s (seq2kseq s k v) k.
Proof.
  introv iss.
  unfold eq_kseq.
  apply implies_equality_natk2nat.
  introv l.
  unfold is_seq in iss.

  assert (equality lib (mkc_nat m) (mkc_nat m) mkc_tnat) as equ by (eauto with slow).

  eapply equality_nat2nat_apply in iss;[|eauto].
  allrw @member_eq.
  apply member_tnat_implies_computes in iss; exrepnd.
  eexists; dands; eauto.
  unfold seq2kseq.

  apply cequivc_nat_implies_computes_to_valc.
  apply computes_to_valc_implies_cequivc in iss0.
  eapply cequivc_trans;[apply cequivc_beta|].
  repeat (rewrite mkcv_less_substc).
  repeat (rewrite mkcv_apply_substc).
  repeat (rewrite mkcv_bot_substc).
  repeat (rewrite mkcv_nat_substc).
  repeat (rewrite mkcv_zero_substc).
  repeat (rewrite mkc_var_substc).
  repeat (rewrite csubst_mk_cv).
  rewrite mkc_zero_eq.

  eapply cequivc_trans;[apply cequivc_mkc_less_nat|].
  boolvar; try omega.
  eapply cequivc_trans;[apply cequivc_mkc_less_nat|].
  boolvar; try omega.
  auto.
Qed.
Hint Resolve eq_kseq_of_seq : slow.

Lemma approxc_bot {o} :
  forall lib (t : @CTerm o), approxc lib mkc_bot t.
Proof.
  introv; destruct_cterms; unfold approxc; simpl.
  unfold mk_bot.
  apply bottom_approx_any; eauto 3 with slow.
Qed.
Hint Resolve approxc_bot : slow.

Lemma mk_seq2kseq0 {o} :
  forall lib (c : @CTerm o) v,
    cequivc lib (seq2kseq c 0 v) (mkc_lam v (mkcv_bot [v])).
Proof.
  introv.
  unfold seq2kseq.
  apply implies_cequivc_lam; introv.

  eapply cequivc_trans;[apply cequivc_sym;apply cequivc_beta|].
  eapply cequivc_trans;[apply cequivc_beta|].
  repeat (rewrite mkcv_less_substc).
  repeat (rewrite mkcv_apply_substc).
  repeat (rewrite mkc_var_substc).
  repeat (rewrite mkcv_nat_substc).
  repeat (rewrite mkcv_zero_substc).
  repeat (rewrite mkcv_bot_substc).
  repeat (rewrite csubst_mk_cv).

  apply cequivc_iff_approxc; dands; eauto 3 with slow.
  apply approxc_assume_hasvalue; intro hv.

  destruct_cterms.
  unfold hasvalue_likec in hv; unfold approxc; allsimpl.
  apply hasvalue_like_implies_or in hv;
    [|repeat (apply isprogram_mk_less; dands; eauto 2 with slow);
       apply isprogram_apply; eauto 3 with slow].

  destruct hv as [hv|hv].

  - apply hasvalue_mk_less in hv; eauto 2 with slow;
    [|apply wf_less; eauto 2 with slow; apply wf_apply; eauto 2 with slow].
    exrepnd; repndors; repnd.

    { apply not_hasvalue_bot in hv1; tcsp. }

    apply reduces_to_if_isvalue_like in hv2; eauto 3 with slow.
    rw <- @int_zero in hv2; ginv.

    eapply approx_trans;
      [apply approx_mk_less;
        [apply reduces_to_implies_approx2;eauto 2 with slow
        |apply approx_refl; eauto 2 with slow
        |apply approx_refl; eauto 2 with slow
        |apply approx_refl; eauto 2 with slow;
         apply isprogram_mk_less; dands; eauto 2 with slow;
         apply isprogram_apply; eauto 3 with slow]
      |].

    rw <- @int_zero.

    eapply approx_trans;
      [apply reduces_to_implies_approx2;
        [repeat (apply isprogram_mk_less; dands; eauto 2 with slow);
          apply isprogram_apply; eauto 3 with slow
        |apply reduces_to_if_step; csunf; simpl; dcwf h; simpl;
         unfold compute_step_comp; simpl; boolvar; try omega; reflexivity]
      |].

    apply hasvalue_mk_less in hv1; eauto 2 with slow;
    [|apply wf_apply; eauto 2 with slow].
    exrepnd.

    eapply reduces_to_eq_val_like in hv0;try (exact hv2); eauto 2 with slow; ginv.
    apply reduces_to_if_isvalue_like in hv4; eauto 3 with slow.
    unfold mk_nat in hv4; ginv.

    repndors; repnd;
    [|apply not_hasvalue_bot in hv1; tcsp].

    eapply approx_trans;
      [apply approx_mk_less;
        [apply reduces_to_implies_approx2;eauto 2 with slow
        |apply approx_refl; eauto 2 with slow
        |apply approx_refl; eauto 2 with slow;
         apply isprogram_apply; eauto 2 with slow
        |apply approx_refl; eauto 2 with slow]
      |].

    eapply approx_trans;
      [apply reduces_to_implies_approx2;
        [repeat (apply isprogram_mk_less; dands; eauto 2 with slow);
          apply isprogram_apply; eauto 3 with slow
        |apply reduces_to_if_step; csunf; simpl; dcwf h; simpl;
         unfold compute_step_comp; simpl; boolvar;[|reflexivity]; try omega]
      |].

    eauto 3 with slow.

  - unfold raises_exception in hv; exrepnd.
    apply computes_to_exception_mk_less in hv1; eauto 2 with slow;
    [|apply wf_less; eauto 2 with slow; apply wf_apply; eauto 2 with slow].
    repndors; exrepnd; repndors; exrepnd.

    + apply bottom_doesnt_raise_an_exception in hv1; tcsp.

    + apply reduces_to_if_isvalue_like in hv2; eauto 3 with slow.
      rw <- @int_zero in hv2; ginv.

      eapply approx_trans;
        [apply approx_mk_less;
          [apply reduces_to_implies_approx2;eauto 2 with slow
          |apply approx_refl; eauto 2 with slow
          |apply approx_refl; eauto 2 with slow
          |apply approx_refl; eauto 2 with slow;
           apply isprogram_mk_less; dands; eauto 2 with slow;
           apply isprogram_apply; eauto 3 with slow]
        |].

      rw <- @int_zero.

      eapply approx_trans;
        [apply reduces_to_implies_approx2;
          [repeat (apply isprogram_mk_less; dands; eauto 2 with slow);
            apply isprogram_apply; eauto 3 with slow
          |apply reduces_to_if_step; csunf; simpl; dcwf h; simpl;
           unfold compute_step_comp; simpl; boolvar; try omega; reflexivity]
        |].

      apply computes_to_exception_mk_less in hv1; eauto 2 with slow;
      [|apply wf_apply; eauto 2 with slow].
      repndors; exrepnd; repndors; exrepnd.

      * eapply reduces_to_eq_val_like in hv0;try (exact hv2); eauto 2 with slow; ginv.
        apply reduces_to_if_isvalue_like in hv4; eauto 3 with slow.
        unfold mk_nat in hv4; ginv.
        try omega.

      * apply bottom_doesnt_raise_an_exception in hv1; tcsp.

      * eapply reduces_to_exception_eq in hv0;[|eauto].
        apply iscancan_doesnt_raise_an_exception in hv0; eauto 2 with slow; tcsp.

      * apply iscancan_doesnt_raise_an_exception in hv2; eauto 2 with slow; tcsp.

    +
Abort.

(**

  Bar induction, where
    X is the proposition
    B is the bar
    ext(s,n,t) = \m. if m=n then t else s m
<<
   H |- squash(X 0 (norm c 0))

     By bar_induction B i a s x m n t

     H, n:nat, s: nat_n -> nat |- (B n s) in Type(i)      // B is a well-formed predicate on finite sequences
     H, s: nat -> nat |- squash(exists n:nat. B n s)      // B is a bar
     H, n:nat, s: nat_n -> nat, m: B n s |- X n s         // Base case: the conclusion is true at the bar
     H, n:nat, s: nat_n -> nat, x: (forall m: nat. X (n + 1) (ext(s,n,m))) |- X n s // induction case
>>

*)

Definition rule_bar_induction_nat {o}
           (f X c B e : @NTerm o)
           (s n m v x : NVar)
           (i : nat)
           (H : barehypotheses) :=
  mk_rule
    (mk_bseq H (mk_conclax (mk_squash (mk_apply2 X mk_zero (mk_seq2kseq c (mk_nat 0) v)))))
    [ mk_bseq (snoc (snoc H (mk_hyp n mk_tnat))
                    (mk_hyp s (mk_natk2nat (mk_var n))))
              (mk_conclax (mk_member (mk_apply2 B (mk_var n) (mk_var s)) (mk_uni i))),
      mk_bseq (snoc H (mk_hyp s mk_nat2nat))
              (mk_conclax (mk_squash
                             (mk_exists mk_tnat
                                        n
                                        (mk_apply2 B (mk_var n) (mk_var s))))),
      mk_bseq (snoc (snoc (snoc H (mk_hyp n mk_tnat))
                          (mk_hyp s (mk_natk2nat (mk_var n))))
                    (mk_hyp m (mk_apply2 B (mk_var n) (mk_var s))))
              (mk_concl (mk_apply2 X (mk_var n) (mk_var s)) e),
      mk_bseq (snoc (snoc (snoc H (mk_hyp n mk_tnat))
                          (mk_hyp s (mk_natk2nat (mk_var n))))
                    (mk_hyp x (mk_all
                                 mk_tnat
                                 m
                                 (mk_squash (mk_apply2 X (mk_plus1 (mk_var n)) (mk_update_seq (mk_var s) (mk_var n) (mk_var m) v))))))
              (mk_conclax (mk_apply2 X (mk_var n) (mk_var s)))
    ]
    [].

Lemma rule_bar_induction_nat_true {o} :
  forall lib (f X c B d e : @NTerm o)
         (s n m v x : NVar)
         (i : nat)
         (H : @barehypotheses o)
         (dxv : x <> v)
         (dsv : s <> v)
         (dnv : n <> v)
         (dnv : m <> v)
         (dnm : n <> m)
         (dsm : s <> m)
         (nvc : !LIn v (free_vars c))
         (nnB : !LIn n (free_vars B))
         (nsB : !LIn s (free_vars B)),
    rule_true lib (rule_bar_induction_nat f X c B e s n m v x i H).
Proof.
  unfold rule_bar_induction_nat, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  destruct Hyp  as [wf1 hyp_wfd].
  destruct Hyp0 as [wf2 hyp_bar].
  destruct Hyp1 as [wf3 hyp_imp].
  destruct Hyp2 as [wf4 hyp_ind].
  destseq; allsimpl; proof_irr; GC.

  unfold closed_extract; simpl.

  exists (@covered_axiom o (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  assert (s <> n
          # s <> x
          # n <> x
          # !LIn x (free_vars c)
          # !LIn s (free_vars c)
          # !LIn n (free_vars c)
          # !LIn x (free_vars X)
          # !LIn s (free_vars X)
          # !LIn n (free_vars X)
          # !LIn m (free_vars X)
          # !LIn x (vars_hyps H)
          # !LIn s (vars_hyps H)
          # !LIn n (vars_hyps H)) as vhyps.

  { clear hyp_wfd hyp_bar hyp_ind hyp_imp.
    dwfseq.
    assert (forall x : NVar, LIn x (free_vars c) -> x <> v -> LIn x (vars_hyps H)) as imp.
    { introv h1 h2.
      apply cg.
      repeat (first [rw remove_nvars_cons_r|rw remove_nvars_app_r]).
      allrw memvar_singleton.
      allrw <- beq_var_refl.
      allrw remove_nvars_nil_r; allrw app_nil_r.
      rw in_remove_nvars; rw in_single_iff; sp. }
    sp; GC;
    try (complete (discover; allapply @subset_hs_vars_hyps; sp)).
  }

  destruct vhyps as [ nsn vhyps ].
  destruct vhyps as [ nsx vhyps ].
  destruct vhyps as [ nnx vhyps ].
  destruct vhyps as [ nxc vhyps ].
  destruct vhyps as [ nsc vhyps ].
  destruct vhyps as [ nnc vhyps ].
  destruct vhyps as [ nxX vhyps ].
  destruct vhyps as [ nsX vhyps ].
  destruct vhyps as [ nnX vhyps ].
  destruct vhyps as [ nmX vhyps ].
  destruct vhyps as [ nxH vhyps ].
  destruct vhyps as [ nsH nnH ].
  (* done with proving these simple facts *)

  vr_seq_true.
  lsubst_tac.

  pose proof (lsubstc_mk_seq2kseq c 0 v w3 s1 c3) as sc1.
  repeat (autodimp sc1 hyp).
  exrepnd.
  rw sc1.

  pose proof (lsubstc_mk_seq2kseq c 0 v w3 s2 c7) as sc2.
  autodimp sc2 hyp.
  exrepnd.
  rw sc2.

  clear sc1 sc2.
  clear_irr.
  clear_wf_hyps.

  rw @tequality_mkc_squash.
  rw @member_mkc_squash.

  assert (!LIn n (dom_csub s1)) as nns1.
  { apply similarity_dom in sim; repnd.
    rw sim0; auto. }

  assert (!LIn n (dom_csub s2)) as nns2.
  { apply similarity_dom in sim; repnd.
    rw sim; auto. }

  assert (!LIn s (dom_csub s1)) as nss1.
  { apply similarity_dom in sim; repnd.
    rw sim0; auto. }

  assert (!LIn s (dom_csub s2)) as nss2.
  { apply similarity_dom in sim; repnd.
    rw sim; auto. }

  assert (!LIn x (dom_csub s1)) as nxs1.
  { apply similarity_dom in sim; repnd.
    rw sim0; auto. }

  assert (!LIn x (dom_csub s2)) as nxs2.
  { apply similarity_dom in sim; repnd.
    rw sim; auto. }

  assert (wf_term B) as wB.
  { clear hyp_wfd.
    allrw @wf_member_iff2.
    allrw <- @wf_apply2_iff; sp.
  }

  assert (cover_vars B s1 # cover_vars B s2) as cB.
  { clear hyp_wfd.
    allrw @covered_member.
    allrw @covered_apply2; repnd.
    allrw @vars_hyps_snoc; allsimpl.
    apply covered_snoc_implies in ct6; auto.
    apply covered_snoc_implies in ct6; auto.
    dands.
    - eapply s_cover_typ1;[exact ct6|exact sim].
    - eapply s_cover_typ1;[exact ct6|].
      apply similarity_sym in sim;[exact sim|]; auto.
  }
  destruct cB as [cB1 cB2].

  assert (forall k seq1 seq2 s1a s2a cB1 cB2,
            similarity lib s1a s2a H
            -> hyps_functionality lib s1a H
            -> eq_kseq lib seq1 seq2 k
            -> tequality
                 lib
                 (mkc_apply2 (lsubstc B wB s1a cB1) (mkc_nat k) seq1)
                 (mkc_apply2 (lsubstc B wB s2a cB2) (mkc_nat k) seq2)) as Bfunc.
  { introv sim0 hf0 eqk.
    vr_seq_true in hyp_wfd.
    pose proof (hyp_wfd
                  (snoc (snoc s1a (n,mkc_nat k)) (s,seq1))
                  (snoc (snoc s2a (n,mkc_nat k)) (s,seq2)))
      as h; clear hyp_wfd.
    repeat (autodimp h hyp).

    { apply hyps_functionality_snoc2; simpl; auto.

      { introv equ' sim'.
        apply similarity_snoc in sim'; simpl in sim'.
        exrepnd; subst; ginv; inj.
        eapply tequality_respects_alphaeqc_left;
          [apply alphaeqc_sym; apply lsubstc_mk_natk2nat_sp2; auto;
           apply similarity_dom in sim'3; repnd; rw sim'0; auto
          |].
        eapply tequality_respects_alphaeqc_right;
          [apply alphaeqc_sym; apply lsubstc_mk_natk2nat_sp2; auto;
           apply similarity_dom in sim'3; repnd; rw sim'3; auto
          |].
        allrw @lsubstc_mkc_tnat.
        apply equality_int_nat_implies_cequivc in sim'1.
        eapply tequality_respects_cequivc_right;
          [apply implies_cequivc_natk2nat; exact sim'1|].
        eauto 3 with slow.
      }

      apply hyps_functionality_snoc2; simpl; auto.

      introv equ' sim'.
      allrw @lsubstc_mkc_tnat.
      apply tnat_type.
    }

    { assert (@wf_term o (mk_natk2nat (mk_var n))) as wfn.
      { apply wf_term_mk_natk2nat; auto. }
      assert (cover_vars (mk_natk2nat (mk_var n)) (snoc s1a (n,mkc_nat k))) as cvn.
      { apply cover_vars_mk_natk2nat.
        apply cover_vars_var.
        rw @dom_csub_snoc.
        rw in_snoc; simpl; sp. }
      sim_snoc.
      dands; auto.

      { pose proof (cover_vars_mk_tnat s1a) as cvs1.
        pose proof (@wf_tnat o) as wftn.
        sim_snoc.
        dands; auto.
        allrw @lsubstc_mkc_tnat.
        apply equality_in_tnat_nat.
      }

      eapply alphaeqc_preserving_equality;
        [|apply alphaeqc_sym;
           apply lsubstc_mk_natk2nat_sp2; auto];
        auto.
      apply similarity_dom in sim0; repnd.
      rw sim1; auto.
    }

    exrepnd.
    lsubst_tac.
    apply tequality_in_uni_implies_tequality in h0; auto.
    apply member_if_inhabited in h1. auto.

  }

  pose proof (bar_induction_meta4
                lib
                (fun_sim_eq lib s1 H B wB)
                (fun_sim_eq lib s1 H X w0)
                (lsubstc B wB s1 cB1)
                (lsubstc X w0 s1 c0)
                (lsubstc c wt s1 ct3)
                v)
    as bi.

  repeat (autodimp bi hyp);
    [idtac
    |idtac
    |idtac
    |pose proof (bi (lsubstc X w0 s2 c5) (seq2kseq (lsubstc c wt s2 ct4) 0 v)) as h;
      allrw <- @mkc_zero_eq;
      repeat (autodimp h hyp);[apply eq_kseq_seq2kseq_0|idtac|repnd; dands; complete auto];
      exists s2 c5;
      dands; complete auto].

  - intros seq1 iss.

    vr_seq_true in hyp_bar.
    pose proof (hyp_bar
                  (snoc s1 (s,seq1))
                  (snoc s1 (s,seq1)))
      as hf; clear hyp_bar.
    repeat (autodimp hf hyp).

    { apply hyps_functionality_snoc2; simpl; auto.

      introv equ' sim'.
      eapply tequality_respects_alphaeqc_left;
        [apply alphaeqc_sym;
          apply lsubstc_mk_nat2nat; auto
        |].
      eapply tequality_respects_alphaeqc_right;
        [apply alphaeqc_sym;
          apply lsubstc_mk_nat2nat; auto
        |].
      apply type_nat2nat.
    }

    { assert (@wf_term o mk_nat2nat) as wfn.
      { apply wf_term_mk_nat2nat; auto. }
      assert (cover_vars mk_nat2nat s1) as cvn.
      { apply cover_vars_mk_nat2nat. }
      sim_snoc.
      dands; auto.
      { eapply similarity_refl; eauto. }
      eapply alphaeqc_preserving_equality;
        [|apply alphaeqc_sym;
           apply lsubstc_mk_nat2nat; auto].
      auto.
    }

    exrepnd.
    clear hf0.
    lsubst_tac.
    apply equality_in_mkc_squash in hf1; exrepnd.
    clear hf0 hf2.
    allunfold @mk_exists.
    lsubst_tac.
    allrw @lsubstc_mkc_tnat.
    apply inhabited_product in hf1; exrepnd.
    clear hf2.

    apply member_tnat_implies_computes in hf1; exrepnd.

    exists k.
    introv eqs fse.
    unfold fun_sim_eq in fse; exrepnd; subst.

    repeat substc_lsubstc_vars3.
    lsubst_tac.
    clear_wf_hyps.
    proof_irr.

    pose proof (Bfunc k seq1 (seq2kseq seq1 k v) s1 s1 cB1 cB1) as h.
    repeat (autodimp h hyp); eauto 3 with slow.
    { eapply similarity_refl; eauto. }

    eapply inhabited_type_cequivc in hf3;
      [|apply implies_cequivc_apply2;
         [apply cequivc_refl
         |apply computes_to_valc_implies_cequivc;eauto
         |apply cequivc_refl]
      ].

    eapply inhabited_type_tequality in hf3;[|eauto].

    dands; auto.

  - intros k seq1 iss sb C seq2 eqs fse.
    clear iss.
    unfold fun_sim_eq in fse; exrepnd; subst.
    unfold meta2_fun_on_seq in sb.
    rename fse0 into sim0.

    assert (cover_vars B s0) as cB0.
    { eapply similarity_cover_vars;[exact sim0|]; auto. }

    pose proof (sb (lsubstc B wB s0 cB0) seq2) as h; clear sb.
    repeat (autodimp h hyp).
    { exists s0 cB0; dands; auto. }
    repnd.

    unfold inhabited_type in h0; exrepnd.
    rename h1 into mem.
    rename h into teq.

    vr_seq_true in hyp_imp.
    pose proof (hyp_imp
                  (snoc (snoc (snoc s1 (n,mkc_nat k)) (s,seq1)) (m,t))
                  (snoc (snoc (snoc s0 (n,mkc_nat k)) (s,seq2)) (m,t)))
      as hf.
    repeat (autodimp hf hyp).

    { apply hyps_functionality_snoc2; simpl; auto.

      { introv equ' sim'.
        apply similarity_snoc in sim'; simpl in sim'.
        exrepnd; subst; ginv; inj.
        apply similarity_snoc in sim'3; simpl in sim'3.
        exrepnd; subst; ginv; inj.
        lsubst_tac.
        allrw @lsubstc_mkc_tnat.
        apply equality_int_nat_implies_cequivc in sim'2.
        eapply alphaeqc_preserving_equality in sim'1;
          [|apply lsubstc_mk_natk2nat_sp2; auto].
        eapply tequality_respects_cequivc_right;
          [apply implies_cequivc_apply2;
            [apply cequivc_refl
            |exact sim'2
            |apply cequivc_refl]
          |].
        auto.
      }

      apply hyps_functionality_snoc2; simpl; auto.

      { introv equ' sim'.
        apply similarity_snoc in sim'; simpl in sim'.
        exrepnd; subst; ginv; cpx.
        assert (!LIn n (dom_csub s2a)) as nns2a.
        { apply similarity_dom in sim'3; repnd.
          rw sim'3; auto. }
        eapply tequality_respects_alphaeqc_left;
          [apply alphaeqc_sym;
            apply lsubstc_mk_natk2nat_sp2; auto
          |].
        eapply tequality_respects_alphaeqc_right;
          [apply alphaeqc_sym;
            apply lsubstc_mk_natk2nat_sp2; auto
          |].
        rw @lsubstc_mkc_tnat in sim'1.
        apply equality_int_nat_implies_cequivc in sim'1.
        eapply tequality_respects_cequivc_right;
          [apply implies_cequivc_natk2nat; exact sim'1|].
        eauto 3 with slow.
      }

      apply hyps_functionality_snoc2; simpl; auto.

      introv equ' sim'.
      allrw @lsubstc_mkc_tnat.
      apply tnat_type.
    }

    { assert (wf_term (mk_apply2 B (mk_var n) (mk_var s))) as wfn.
      { apply wf_apply2; eauto 3 with slow. }
      assert (cover_vars (mk_apply2 B (mk_var n) (mk_var s)) (snoc (snoc s1 (n,mkc_nat k)) (s,seq1))) as cvn.
      { apply cover_vars_apply2.
        repeat (rw @cover_vars_var_iff).
        repeat (rw @dom_csub_snoc); simpl.
        repeat (rw in_snoc).
        dands; tcsp.
        repeat (apply cover_vars_snoc_weak); auto. }
      sim_snoc.
      dands; auto.

      { assert (@wf_term o (mk_natk2nat (mk_var n))) as wfk.
        { apply wf_term_mk_natk2nat; auto. }
        assert (cover_vars (mk_natk2nat (mk_var n)) (snoc s1 (n,mkc_nat k))) as cvk.
        { apply cover_vars_mk_natk2nat.
          apply cover_vars_var_iff.
          repeat (rw @dom_csub_snoc); simpl.
          repeat (rw in_snoc); sp. }
        sim_snoc.
        dands; auto.

        { assert (@wf_term o mk_tnat) as wft.
          { eauto 3 with slow. }
          assert (cover_vars mk_tnat s1) as cvt.
          { apply cover_vars_mk_tnat. }
          sim_snoc.
          dands; auto.
          allrw @lsubstc_mkc_tnat.
          eauto 3 with slow.
        }

        eapply alphaeqc_preserving_equality;
          [|apply alphaeqc_sym; apply lsubstc_mk_natk2nat_sp2; auto].
        auto.
      }

      { lsubst_tac; auto. }
    }

    exrepnd.
    lsubst_tac.
    apply inhabited_type_if_equality in hf1.
    unfold meta_fun_on_seq.
    dands; auto.

  - intros k seq1 iss ind C seq2 eqs fse.
    clear iss.
    unfold fun_sim_eq in fse; exrepnd; subst.

    vr_seq_true in hyp_ind.

    pose proof (hyp_ind
                  (snoc (snoc (snoc s1 (n,mkc_nat k)) (s,seq1)) (x,lam_axiom))
                  (snoc (snoc (snoc s0 (n,mkc_nat k)) (s,seq2)) (x,lam_axiom)))
      as hf; clear hyp_ind.
    repeat (autodimp hf hyp).

    { apply hyps_functionality_snoc2; simpl; auto.

      { introv equ' sim'.
        apply similarity_snoc in sim'; simpl in sim'.
        exrepnd; subst; ginv; inj.
        apply similarity_snoc in sim'3; simpl in sim'3.
        exrepnd; subst; ginv; inj.
        allunfold @mk_all.
        lsubst_tac.
        allrw @lsubstc_mkc_tnat.
        apply equality_int_nat_implies_cequivc in sim'2.
        eapply alphaeqc_preserving_equality in sim'1;
          [|apply lsubstc_mk_natk2nat_sp2; auto].

        apply tequality_function; dands.
        { apply tnat_type. }
        introv en.
        repeat substc_lsubstc_vars3.
        lsubst_tac.
        apply equality_in_tnat in en.
        unfold equality_of_nat in en; exrepnd; spcast.

        apply tequality_mkc_squash.

        eapply tequality_respects_cequivc_left;
          [apply cequivc_sym;
            apply implies_cequivc_apply2;
            [apply cequivc_refl
            |apply cequivc_lsubstc_mk_plus1_sp1;auto
            |apply cequivc_lsubstc_mk_update_seq_sp1;auto;
             exact en1]
          |].

        assert (!LIn n (dom_csub s2a0)) as nin2.
        { apply similarity_dom in sim'4; repnd.
          rw sim'4; auto. }

        assert (!LIn s (dom_csub s2a0)) as nis2.
        { apply similarity_dom in sim'4; repnd.
          rw sim'4; auto. }

        eapply tequality_respects_cequivc_right;
          [apply cequivc_sym;
            apply implies_cequivc_apply2;
            [apply cequivc_refl
            |apply cequivc_lsubstc_mk_plus1_sp2; auto;
             apply cequivc_sym;exact sim'2
            |apply cequivc_lsubstc_mk_update_seq_sp2;auto;
             [exact en0
             |apply cequivc_nat_implies_computes_to_valc;
               apply cequivc_sym;exact sim'2]
            ]
          |].

        pose proof (ind k0) as h; clear ind.
        unfold meta2_fun_on_upd_seq in h.
        unfold meta2_fun_on_seq in h; repnd.

        pose proof (h (lsubstc X w0 s2a0 c27) (update_seq t2 k k0 v)) as q; clear h.
        repeat (autodimp q hyp).
        { apply eq_kseq_update; auto. }
        { exists s2a0 c27; dands; auto. }
        repnd; auto.
      }

      apply hyps_functionality_snoc2; simpl; auto.

      { introv equ' sim'.
        apply similarity_snoc in sim'; simpl in sim'.
        exrepnd; subst; ginv; inj.
        assert (!LIn n (dom_csub s2a)) as nns2a.
        { apply similarity_dom in sim'3; repnd.
          rw sim'3; auto. }
        eapply tequality_respects_alphaeqc_left;
          [apply alphaeqc_sym;
            apply lsubstc_mk_natk2nat_sp2; auto
          |].
        eapply tequality_respects_alphaeqc_right;
          [apply alphaeqc_sym;
            apply lsubstc_mk_natk2nat_sp2; auto
          |].
        rw @lsubstc_mkc_tnat in sim'1.
        apply equality_int_nat_implies_cequivc in sim'1.
        eapply tequality_respects_cequivc_right;
          [apply implies_cequivc_natk2nat; exact sim'1|].
        eauto 3 with slow.
      }

      apply hyps_functionality_snoc2; simpl; auto.

      introv equ' sim'.
      allrw @lsubstc_mkc_tnat.
      apply tnat_type.
    }

    { assert (wf_term (mk_all mk_tnat m
                              (mk_squash
                                 (mk_apply2 X (mk_plus1 (mk_var n))
                                            (mk_update_seq (mk_var s) (mk_var n) (mk_var m) v))))) as wa.
      { apply wf_function; auto.
        apply wf_squash.
        apply wf_apply2; auto. }
      assert (cover_vars (mk_all mk_tnat m
                              (mk_squash
                                 (mk_apply2 X (mk_plus1 (mk_var n))
                                            (mk_update_seq (mk_var s) (mk_var n) (mk_var m) v))))
                         (snoc (snoc s1 (n, mkc_nat k)) (s, seq1))) as ca.
      { apply cover_vars_function; dands; auto.
        { apply cover_vars_mk_tnat. }
        apply cover_vars_upto_squash.
        apply cover_vars_upto_apply2; dands; auto.
        { repeat (rw @csub_filter_snoc).
          allrw memvar_singleton.
          boolvar;tcsp;GC;[].
          repeat (apply cover_vars_upto_snoc_weak).
          apply cover_vars_upto_csub_filter_disjoint; auto.
          apply disjoint_singleton_r; auto. }
        { apply cover_vars_upto_add; dands; eauto 3 with slow.
          repeat (rw @csub_filter_snoc).
          allrw memvar_singleton.
          boolvar;tcsp;GC;[].
          apply cover_vars_upto_var; simpl.
          repeat (rw @dom_csub_snoc).
          repeat (rw in_snoc;simpl).
          sp. }
        { unfold mk_update_seq.
          apply cover_vars_upto_lam.
          rw @csub_filter_swap.
          rw <- @csub_filter_app_r; simpl.
          repeat (rw @csub_filter_snoc).
          allrw memvar_cons; simpl.
          boolvar;tcsp;GC;[].
          apply cover_vars_upto_int_eq; dands.
          { apply cover_vars_upto_var; simpl.
            repeat (rw @dom_csub_snoc).
            repeat (rw in_snoc;simpl).
            sp. }
          { apply cover_vars_upto_var; simpl.
            repeat (rw @dom_csub_snoc).
            repeat (rw in_snoc;simpl).
            sp. }
          { apply cover_vars_upto_var; simpl.
            repeat (rw @dom_csub_snoc).
            repeat (rw in_snoc;simpl).
            sp. }
          { apply cover_vars_upto_apply; dands.
            { apply cover_vars_upto_var; simpl.
              repeat (rw @dom_csub_snoc).
              repeat (rw in_snoc;simpl).
              sp. }
            { apply cover_vars_upto_var; simpl.
              repeat (rw @dom_csub_snoc).
              repeat (rw in_snoc;simpl).
              sp. }
          }
        }
      }
      sim_snoc.
      dands; auto.

      { assert (@wf_term o (mk_natk2nat (mk_var n))) as wfk.
        { apply wf_term_mk_natk2nat; auto. }
        assert (cover_vars (mk_natk2nat (mk_var n)) (snoc s1 (n,mkc_nat k))) as cvk.
        { apply cover_vars_mk_natk2nat.
          apply cover_vars_var_iff.
          repeat (rw @dom_csub_snoc); simpl.
          repeat (rw in_snoc); sp. }
        sim_snoc.
        dands; auto.

        { assert (@wf_term o mk_tnat) as wft.
          { eauto 3 with slow. }
          assert (cover_vars mk_tnat s1) as cvt.
          { apply cover_vars_mk_tnat. }
          sim_snoc.
          dands; auto.
          allrw @lsubstc_mkc_tnat.
          eauto 3 with slow.
        }

        eapply alphaeqc_preserving_equality;
          [|apply alphaeqc_sym; apply lsubstc_mk_natk2nat_sp2; auto].
        auto.
      }

      { unfold mk_all.
        lsubst_tac.
        allrw @lsubstc_mkc_tnat.
        apply equality_in_function.
        dands; auto.

        { apply tnat_type. }

        { introv en.
          repeat substc_lsubstc_vars3.
          lsubst_tac.
          apply equality_in_tnat in en.
          unfold equality_of_nat in en; exrepnd; spcast.

          apply tequality_mkc_squash.

          eapply tequality_respects_cequivc_left;
            [apply cequivc_sym;
              apply implies_cequivc_apply2;
              [apply cequivc_refl
              |apply cequivc_lsubstc_mk_plus1_sp1;auto
              |apply cequivc_lsubstc_mk_update_seq_sp1;auto;
               exact en1]
            |].

          eapply tequality_respects_cequivc_right;
            [apply cequivc_sym;
              apply implies_cequivc_apply2;
              [apply cequivc_refl
              |apply cequivc_lsubstc_mk_plus1_sp2; auto;
               apply cequivc_sym;exact sim'2
              |apply cequivc_lsubstc_mk_update_seq_sp1;auto;
               exact en0]
            |].

          pose proof (ind k0) as h; clear ind.
          unfold meta2_fun_on_upd_seq in h.
          unfold meta2_fun_on_seq in h; repnd.

          pose proof (h (lsubstc X w0 s1 c0) (update_seq seq1 k k0 v)) as q; clear h.
          repeat (autodimp q hyp).
          { apply eq_kseq_update; auto.
            eapply eq_kseq_left; eauto. }
          { exists s1 c0; dands; auto.
            eapply similarity_refl; eauto. }
          repnd; auto.
        }

        { introv en.
          repeat substc_lsubstc_vars3.
          eapply equality_respects_cequivc_left;
            [apply cequivc_sym;apply cequivc_mkc_apply_lam_axiom|].
          eapply equality_respects_cequivc_right;
            [apply cequivc_sym;apply cequivc_mkc_apply_lam_axiom|].

          clear_wf_hyps.
          proof_irr.
          lsubst_tac.

          apply equality_in_mkc_squash; dands; spcast;
          try (apply computes_to_valc_refl; eauto 3 with slow).

          apply equality_in_tnat in en.
          unfold equality_of_nat in en; exrepnd; spcast.

          eapply inhabited_type_cequivc;
            [apply cequivc_sym;
              apply implies_cequivc_apply2;
              [apply cequivc_refl
              |apply cequivc_lsubstc_mk_plus1_sp1;auto
              |apply cequivc_lsubstc_mk_update_seq_sp1;auto;
               exact en1]
            |].

          pose proof (ind k0) as h; clear ind.
          unfold meta2_fun_on_upd_seq in h.
          unfold meta2_fun_on_seq in h; repnd.

          pose proof (h (lsubstc X w0 s1 c0) (update_seq seq1 k k0 v)) as q; clear h.
          repeat (autodimp q hyp).
          { apply eq_kseq_update; auto.
            eapply eq_kseq_left; eauto. }
          { exists s1 c0; dands; auto.
            eapply similarity_refl; eauto. }
          repnd; auto.
        }
      }
    }

    exrepnd.
    lsubst_tac.
    apply inhabited_type_if_equality in hf1.
    dands; auto.
Qed.


(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
From mathcomp Require Import all_ssreflect ssralg fingroup perm finalg matrix.
From mathcomp Require boolp.
From mathcomp Require Import Rstruct.
Require Import Reals. (* Lra Nsatz. *)
Require Import ssrR Reals_ext logb ssr_ext ssralg_ext bigop_ext Rbigop.
Require Import fdist proba.

(******************************************************************************)
(* wip                                                                        *)
(* goal: BN_factorization
   main definitions:
   * RV_equiv
   * univ_types / prod_types
   * preim_vars
   * cinde_preim
   * bayesian network (Koller & Friedmann p 57)
   main theorems:
   * cinde_preim_ok
   * prod_vars1
   * cinde_preim_equiv
   * BN_factorization
 *)
(******************************************************************************)

Local Open Scope tuple_ext_scope.
Local Open Scope fdist_scope.
Local Open Scope proba_scope.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Section ssr_ext.
Lemma tnth_uniq (T : eqType) n (t : n.-tuple T) (i j : 'I_n) :
  uniq t -> (t \_ i == t \_ j) = (i == j).
Proof.
pose a := t \_ i; rewrite 2!(tnth_nth a) => *.
by rewrite nth_uniq // size_tuple.
Qed.

Section boolP.
Variables (p : bool) (R : Type) (T : is_true p -> R) (F : is_true (~~ p) -> R).
Lemma boolPT  (H : is_true p) :
  match boolP p with
  | AltTrue HT => T HT
  | AltFalse HF => F HF
  end = T H.
Proof.
destruct boolP.
- congr T.
  case: p => // in H i *.
  exfalso.
  rewrite H in i.
- by elim: (negP i).
Qed.

Lemma boolPF  (H : is_true (~~ p)) :
  match boolP p with
  | AltTrue HT => T HT
  | AltFalse HF => F HF
  end = F H.
Proof.
destruct boolP.
- by elim: (negP H).
- by congr F.
Qed.
End boolP.
End ssr_ext.

Section fin_img.
Variables (T : finType) (S : eqType) (f : T -> S).

Definition Tfin_img := 'I_(size (fin_img f)).
Definition index_fin_img x (H : x \in fin_img f) : Tfin_img.
apply (@Ordinal _ (index x (fin_img f))).
abstract (by rewrite index_mem).
Defined.
Definition map_fin_img (x : T) : Tfin_img.
refine (@index_fin_img (f x) _).
abstract (by rewrite mem_undup map_f // mem_enum).
Defined.
Definition nth_fin_img (i : Tfin_img) : S := tnth (in_tuple (fin_img f)) i.
Definition rev_fin_img (i : Tfin_img) : T.
refine (iinv (A:=predT) (f:=f) (y:=nth_fin_img i) _).
abstract (move/mem_nth: (ltn_ord i); rewrite -mem_undup; exact).
Defined.
Lemma nth_fin_imgK x : nth_fin_img (map_fin_img x) = f x.
Proof.
rewrite /nth_fin_img /index_fin_img => /=.
by rewrite (tnth_nth (f x)) nth_index // mem_undup map_f // mem_enum.
Qed.
Lemma rev_fin_imgK i : map_fin_img (rev_fin_img i) = i.
Proof.
case: i => i isz; apply val_inj => /=.
by rewrite f_iinv nthK // undup_uniq.
Qed.
Lemma map_fin_imgK x : f (rev_fin_img (map_fin_img x)) = f x.
Proof. by rewrite /rev_fin_img f_iinv nth_fin_imgK. Qed.
Lemma fin_imgP y : reflect (exists x : T, y = f x) (y \in fin_img f).
Proof.
rewrite mem_undup; apply/(iffP mapP) => -[x].
- move=> _ ->. by exists x.
- move=> ->. by exists x; rewrite // mem_enum.
Qed.
End fin_img.

Section proba. (* proba.v ? *)
Variables (U : finType) (P : fdist U).

Definition fdist_choice' : U.
move: (fdist_card_neq0 P).
move He: (enum U) => [|u l] //.
move/(f_equal size): He.
by rewrite -cardE => ->.
Defined.
Definition fdist_choice := Eval hnf in fdist_choice'.

Definition rvar_choice (A : eqType) (X : {RV P -> A}) := X fdist_choice.

Section RV_equiv.
Variables A B : eqType.
Variables (X : {RV P -> A}) (Y : {RV P -> B}).
Definition cancel_both (fg : (A -> B) * (B -> A)) :=
  cancel fg.1 fg.2 /\ cancel fg.2 fg.1.

Definition RV_equiv := {fg | cancel_both fg & Y =1 fg.1 \o X}.
End RV_equiv.

Lemma RV_equivC (A B : eqType) (X : {RV P -> A}) (Y : {RV P -> B}) :
  RV_equiv X Y -> RV_equiv Y X.
Proof.
case=> -[f g] []/= cfg cgf Hf.
exists (g,f) => //.
move=> u /=.
move/(f_equal g): (Hf u).
by rewrite cfg.
Qed.
End proba.

Section univ_types.
(* heterogeneous types *)
Variable n : nat.
Variable types : 'I_n -> eqType.
Definition univ_types := [eqType of {dffun forall i, types i}].

Section prod_types.
(* sets of indices *)
Variable I : {set 'I_n}.

Definition prod_types :=
  [eqType of
   {dffun forall i : 'I_n, if i \in I then types i else unit_finType}].

Lemma prod_types_app i (A B : prod_types) : A = B -> A i = B i.
Proof. by move=> ->. Qed.

Lemma prod_types_out (i : 'I_n) (A B : prod_types) : i \notin I -> A i = B i.
Proof.
move=> Hi.
move: (A i) (B i).
by rewrite (negbTE Hi) => -[] [].
Qed.

Lemma prod_types_neq (A B : prod_types) :
  A != B -> exists i, (i \in I) && (A i != B i).
Proof.
move=> AB.
case /boolP: [forall i, A i == B i].
  move/forallP => /= AB'.
  elim: (negP AB).
  apply/eqP/ffunP => /= x.
  by apply/eqP.
rewrite negb_forall => /existsP [x Hx].
exists x.
rewrite Hx.
case/boolP: (x \in I) => //= xe.
elim: (negP Hx).
move: (A x) (B x) {AB Hx} => /=.
by rewrite (negbTE xe) => -[] [].
Qed.

Definition set_vals' (v : prod_types) (vals : univ_types) : univ_types.
refine [ffun j => _].
case: (j \in I) (v j) => a.
- exact: a.
- exact: vals j.
Defined.
Definition set_vals : prod_types -> univ_types -> univ_types :=
  Eval hnf in set_vals'.

Lemma set_vals_hd vs2 (v : prod_types) vs1 i :
  i \in I -> set_vals v vs1 i = set_vals v vs2 i.
Proof. rewrite !ffunE; by case: (i \in I) (v i). Qed.

Lemma set_vals_tl (v : prod_types) vs i :
  i \notin I -> set_vals v vs i = vs i.
Proof. rewrite !ffunE; by case: (i \in I) (v i). Qed.

Lemma set_vals_id (v : prod_types) vs :
  set_vals v (set_vals v vs) = set_vals v vs.
Proof.
apply/ffunP => i.
case/boolP: (i \in I) => [/set_vals_hd | /set_vals_tl ->]; exact.
Qed.

Definition prod_vals' (vals : univ_types) : prod_types.
refine [ffun i => _].
move: (vals i).
case: (i \in I) => a.
- exact: a.
- exact: tt.
Defined.
Definition prod_vals vals : prod_types := Eval hnf in prod_vals' vals.

Lemma set_vals_prod_vals_id vals i :
  set_vals (prod_vals vals) vals i = vals i.
Proof. rewrite !ffunE; by case: (i \in _) (vals i). Qed.

Lemma set_vals_prod_vals vals vals' i :
  i \in I -> set_vals (prod_vals vals) vals' i = vals i.
Proof. rewrite !ffunE => ie. move: (vals i); by rewrite ie. Qed.

Lemma prod_vals_eqP vals1 vals2 i :
  prod_vals vals1 i = prod_vals vals2 i <-> (i \in I -> vals1 i = vals2 i).
Proof.
split; rewrite !ffunE; case: (i \in I) (vals1 i) (vals2 i) => // v1 v2; exact.
Qed.

Lemma prod_vals_eq (vals1 vals2 : univ_types) i :
  (i \in I -> vals1 i = vals2 i) -> prod_vals vals1 i = prod_vals vals2 i.
Proof. move=> Hi; exact/prod_vals_eqP. Qed.

Lemma set_vals_eq (A B : prod_types) vals i :
  set_vals A vals i == set_vals B vals i = (A i == B i) || (i \notin I).
Proof.
rewrite !ffunE.
case: (i \in I) (A i) (B i) => a b.
- by rewrite orbF.
- by rewrite eqxx orbT.
Qed.

Lemma set_vals_inj (A B : prod_types) vals i :
  set_vals A vals i = set_vals B vals i -> A i = B i.
Proof.
set goal := _ -> _.
case/boolP: (i \in I) => Hi; subst goal.
  move/eqP; rewrite set_vals_eq orbC.
  by move: (A i) (B i); rewrite Hi => a b /= /eqP.
move=> _; exact: prod_types_out.
Qed.

Lemma prod_vals_set_vals (A : prod_types) vals :
  prod_vals (set_vals A vals) = A.
Proof.
apply/ffunP => j.
apply (set_vals_inj (vals := vals)).
case/boolP: (j \in I) => Hj.
  by rewrite set_vals_prod_vals.
by rewrite !set_vals_tl.
Qed.

End prod_types.

Lemma set_vals_prod_vals_join (I J : {set 'I_n}) vals vals' :
  set_vals (prod_vals I vals) (set_vals (prod_vals J vals) vals') =
  set_vals (prod_vals (I :|: J) vals) vals'.
Proof.
apply/ffunP => i.
case/boolP: (i \in I) => iI.
  by rewrite !set_vals_prod_vals // inE iI.
rewrite set_vals_tl //.
case/boolP: (i \in J) => iJ.
  by rewrite !set_vals_prod_vals // inE iJ orbT.
by rewrite !set_vals_tl // inE negb_or iI.
Qed.

Lemma set_valsC I J (A : prod_types I) (B : prod_types J) V :
  [disjoint I & J] -> set_vals A (set_vals B V) = set_vals B (set_vals A V).
Proof.
move/setDidPl/setP => Disj.
apply/ffunP => /= i.
case/boolP: (i \in I) => iI.
  move: (Disj i); rewrite inE iI andbT => /set_vals_tl ->.
  by rewrite (set_vals_hd V).
case/boolP: (i \in J) => iJ.
  by rewrite set_vals_tl //; apply set_vals_hd.
by rewrite !set_vals_tl.
Qed.

Section set_val.
Definition set_val (i : 'I_n) (v : types i) (vals : univ_types) : univ_types :=
  [ffun j : 'I_n =>
    match Nat.eq_dec i j return types j with
    | left ij => eq_rect i (fun i => (types i : Type)) v j (ord_inj ij)
    | right _ => vals j
    end].

Lemma eq_dec_refl i : Nat.eq_dec i i = left (erefl i).
Proof.
case: Nat.eq_dec => Hi; last by elim Hi.
congr left; by rewrite (Eqdep_dec.UIP_refl_nat _ Hi).
Qed.

Definition ord_eq_dec (i j : 'I_n) : {i = j}+{i <> j}.
case (Nat.eq_dec i j); intro ij.
- left; now apply ord_inj.
- right; intro ij'; apply ij; now f_equal.
Defined.

Lemma set_val_hd i (v : types i) vs : set_val v vs i = v.
rewrite ffunE eq_dec_refl -Eqdep_dec.eq_rect_eq_dec //; exact: ord_eq_dec.
Qed.

Lemma set_val_tl i (v : types i) vs j : i <> j -> set_val v vs j = vs j.
rewrite ffunE => nij; case: Nat.eq_dec => ij //; elim nij; exact: ord_inj.
Qed.
End set_val.

End univ_types.

Module BN.
Section bn.
Variable U : finType.
Variable P : fdist U.
Variable n : nat.

Section preim.
Local Open Scope R_scope.
Variable types : 'I_n -> eqType.
Variable vars : forall i, {RV P -> types i}.

Definition vals0 : univ_types types := [ffun i => rvar_choice (vars i)].

Definition wrap_set_vals I := f_equal (set_vals (I:=I) ^~ vals0).

Section prod_vars.
Variable I : {set 'I_n}.

Definition vals_at (u : U) : univ_types types := [ffun i => vars i u].

Definition prod_vars : {RV P -> prod_types types I} :=
  fun u => prod_vals I (vals_at u).

Lemma set_vals_prod_vars vals u i :
  i \in I -> set_vals (prod_vars u) vals i = vars i u.
Proof. move=> Hi; by rewrite set_vals_prod_vals // ffunE. Qed.
End prod_vars.

Lemma prod_vars_inter (I J : {set 'I_n}) vals i u :
  i \in I -> i \in J ->
  set_vals (prod_vars I u) vals i = set_vals (prod_vars J u) vals i.
Proof. move=> *; by rewrite !set_vals_prod_vals. Qed.

Lemma prod_vars1 (i : 'I_n) : RV_equiv (prod_vars [set i]) (vars i).
Proof.
exists ((fun A : prod_types types [set i] => set_vals A vals0 i),
        prod_vals [set i] \o set_val (i:=i) ^~ vals0).
  split => x /=.
    apply/ffunP => /= j.
    apply (set_vals_inj (vals := vals0)).
    case/boolP: (j \in [set i]) => Hj; last by rewrite !set_vals_tl.
    rewrite set_vals_prod_vals //.
    rewrite inE in Hj.
    move/eqP: Hj (set_vals _ _) => -> v.
    by rewrite set_val_hd.
  by rewrite set_vals_prod_vals ?inE // set_val_hd.
move=> u /=.
by rewrite set_vals_prod_vars // inE.
Qed.

Lemma cancel_both_disjoint (I J : {set 'I_n}) :
  [disjoint I & J] ->
  cancel_both
    ((fun A : prod_types types (I :|: J) =>
        (prod_vals I (set_vals A vals0), prod_vals J (set_vals A vals0))),
     (fun A : prod_types types I * prod_types types J =>
        prod_vals (I :|: J) (set_vals (fst A) (set_vals (snd A) vals0)))).
Proof.
move=> Disj; split => [A | [A B]] /=.
  by rewrite set_vals_prod_vals_join !prod_vals_set_vals.
congr pair; last rewrite setUC set_valsC //;
by rewrite -set_vals_prod_vals_join !prod_vals_set_vals.
Qed.

Lemma prod_vars_pair (I J : {set 'I_n}) :
  [disjoint I & J] ->
  RV_equiv (prod_vars (I :|: J)) [% prod_vars I, prod_vars J].
Proof.
move=> Disj.
esplit. exact: cancel_both_disjoint.
move=> u /=.
congr pair; apply/ffunP => i; apply prod_vals_eq => Hi;
  rewrite set_vals_prod_vars ?ffunE //; by rewrite inE Hi ?orbT.
Qed.

Definition preim_vars (I : {set 'I_n}) (vals : forall i, types i) :=
  \bigcap_(i in I) finset (vars i @^-1 (vals i)).

Definition cinde_preim (e f g : {set 'I_n}) :=
  forall vals : univ_types types,
    cinde_events P (preim_vars e vals)
                   (preim_vars f vals)
                   (preim_vars g vals).

Lemma cinde_eventsC A (Q : fdist A) (E F G : {set A}) :
  cinde_events Q E F G -> cinde_events Q F E G.
Proof. rewrite /cinde_events => Hef; by rewrite setIC mulRC. Qed.

Lemma cinde_preimC (e f g : {set 'I_n}) :
  cinde_preim e f g  -> cinde_preim f e g.
Proof. move=> Hef vals; exact: cinde_eventsC. Qed.

Lemma preim_varsP  (I : {set 'I_n}) vals u :
  reflect (forall i, i \in I -> vars i u = vals i) (u \in preim_vars I vals).
Proof. by apply/(iffP bigcapP) => H i /H; rewrite !inE => /eqP. Qed.

Lemma preim_prod_vars (g : {set 'I_n}) (C : prod_types types g) vals :
  finset (prod_vars g @^-1 C) = preim_vars g (set_vals C vals).
Proof.
apply/setP => x; rewrite !inE.
apply/esym/preim_varsP; case: ifP.
- move/eqP => <- i ig.
  by rewrite set_vals_prod_vals // ffunE.
- move/negP => /= Hf Hcap; elim: Hf.
  apply/eqP/ffunP => /= i.
  rewrite /prod_vars (prod_vals_eq (vals2:=set_vals C vals)).
    by rewrite prod_vals_set_vals.
  rewrite ffunE; exact: Hcap.
Qed.

(* Simple version, using singletons *)

Lemma Rxx2 x : x = x * x -> x = 0 \/ x = 1.
Proof.
case/boolP: (x == 0) => Hx.
  rewrite (eqP Hx); by left.
move/(f_equal (Rdiv ^~ x)).
rewrite divRR // /Rdiv -mulRA mulRV // mulR1 => <-; by right.
Qed.

Lemma cinde_preim_ok1 (i j k : 'I_n) :
  cinde_preim [set i] [set j] [set k] <-> P |= (vars i) _|_ (vars j) | (vars k).
Proof.
rewrite /cinde_preim /preim_vars.
split.
- move=> Hpreim.
  apply/cinde_rv_events => a b c.
  set vals := set_val a (set_val c (set_val b vals0)).
  have vi : vals i = a by rewrite /vals set_val_hd.
  move: (erefl vals) {Hpreim} (Hpreim vals).
  rewrite {2}/vals /cinde_events; clearbody vals.
  rewrite !big_set1.
  wlog: c / vals k = c.
    case: (ord_eq_dec i k) c vi.
      move=> <- {k} c vi.
      case ac: (a == c).
        rewrite -(eqP ac); exact.
      move=> _ _ _.
      rewrite (proj2 (cPr_eq0 _ _ _)); last first.
        apply/Pr_set0P => u.
        by rewrite !inE => /andP [] /andP [] /= /eqP ->; rewrite ac.
      rewrite (proj2 (cPr_eq0 _ _ _)); last first.
        apply/Pr_set0P => u.
        by rewrite !inE => /andP [] /= /eqP ->; rewrite ac.
      by rewrite mul0R.
    move=> nik c vi HG Hvals; apply: HG => //.
    by rewrite Hvals set_val_tl // set_val_hd.
  move=> vk.
  wlog: b / vals j = b.
    case: (ord_eq_dec i j) b.
      move=> <- {j} b.
      case ab: (a == b).
        rewrite -(eqP ab); exact.
      move=> _ _.
      rewrite setIid vi vk.
      set x := (X in X = X * X).
      move/Rxx2 => [] Hx.
        rewrite -/x Hx.
        rewrite (proj2 (cPr_eq0 _ _ _)) ?mul0R //.
        apply/Pr_set0P => u.
        by rewrite !inE => /andP [] /andP [] /= /eqP ->; rewrite ab.
      rewrite /cPr.
      set den := (X in _ / X).
      case/boolP: (den == 0) => /eqP Hden.
        by rewrite setIC Pr_domin_setI // setIC Pr_domin_setI // !div0R mul0R.
      set num := (X in _ * (X / _)).
      case/boolP: (num == 0) => /eqP Hnum.
        by rewrite -setIA setIC Pr_domin_setI // Hnum !div0R mulR0.
      elim Hnum.
      apply/Pr_set0P => u.
      rewrite !inE => /andP [] /= Hi Hk.
      move: Hx; subst x.
      move/(f_equal (Rmult ^~ den)).
      move/eqP in Hden.
      rewrite /cPr /Rdiv -mulRA mulVR // mulR1 mul1R.
      move/(f_equal (Rminus den)).
      rewrite subRR setIC -Pr_diff => /Pr_set0P/(_ u).
      rewrite !inE (eqP Hi) Hk eq_sym ab; exact.
    case: (ord_eq_dec k j).
      move=> <- {j} ik b.
      case bc: (b == c).
        rewrite (eqP bc); exact.
      move=> _ _ _.
      rewrite (proj2 (cPr_eq0 _ _ _)); last first.
        apply/Pr_set0P => u.
        by rewrite !inE => /andP [] /andP [] _ /= /eqP ->; rewrite bc.
      rewrite mulRC (proj2 (cPr_eq0 _ _ _)) ?mul0R //.
      by apply/Pr_set0P => u; rewrite !inE => /andP [] /= /eqP ->; rewrite bc.
    move=> nkj nij b HG Hvals; apply: HG => //.
    by rewrite Hvals set_val_tl // set_val_tl // set_val_hd.
  by rewrite vi vk => -> _.
- move=> Hdrv vals.
  move/cinde_rv_events/(_ (vals i) (vals j) (vals k)): Hdrv.
  by rewrite !big_set1.
Qed.

(* Now start the hard version, using sets of variables *)

Lemma preim_vars_set_vals_tl (g e : {set 'I_n}) (A : prod_types types e) vals :
  e :&: g = set0 ->
  preim_vars g (set_vals A vals) = preim_vars g vals.
Proof.
move=> /setP eg.
apply/eq_bigr => /= i ig.
apply/setP => u.
rewrite !inE set_vals_tl //.
move: (eg i); by rewrite !inE ig andbT => ->.
Qed.

Lemma preim_inter (T S : eqType) (e : U -> T) (g : U -> S) (A : T) (C : S) :
  finset (preim (fun x => (e x, g x)) (pred1 (A, C))) =
  finset (preim e (pred1 A)) :&: finset (preim g (pred1 C)).
Proof.
apply/setP => u; rewrite !inE.
apply/andP => /=.
by case: ifPn => [/andP | /negP H /andP /H].
Qed.

Lemma preim_vars_inter (e f : {set 'I_n}) vals :
  preim_vars (e :|: f) vals = preim_vars e vals :&: preim_vars f vals.
Proof. by rewrite /preim_vars bigcap_setU. Qed.

Lemma preim_vars_vals (e : {set 'I_n}) (A : prod_types types e) vals1 vals2 :
  (forall x, x \in e -> vals1 x = vals2 x) ->
  preim_vars e vals1 = preim_vars e vals2.
Proof.
move=> Hvals.
apply/eq_bigr => /= i ie.
apply/setP => u; by rewrite !inE Hvals.
Qed.

Lemma disjoint_preim_vars (e f : {set 'I_n}) (A B : prod_types types f) vals :
  f \subset e -> A != B ->
  [disjoint preim_vars e (set_vals A vals) & preim_vars e (set_vals B vals)].
Proof.
move=> fe AB.
rewrite -setI_eq0.
apply/eqP/setP => u.
rewrite !inE.
apply/negP => /andP [] /preim_varsP /= HA /preim_varsP /= HB.
case: (prod_types_neq AB) => /= i /andP [Hif HAB].
have ie : i \in e by move/subsetP: fe; apply.
move/(_ _ ie)/eqP: HB.
rewrite HA // set_vals_eq => /orP [] H.
- by rewrite H in HAB.
- by rewrite Hif in H.
Qed.

Lemma Pr_preim_vars_sub (e f : {set 'I_n}) (vals : univ_types types) :
  f \subset e ->
  Pr P (preim_vars (e :\: f) vals) =
  \sum_(A : Tfin_img (prod_vars f))
   Pr P (preim_vars e (set_vals (nth_fin_img A) vals)).
Proof.
rewrite /Pr => fe.
rewrite -partition_disjoint_bigcup; last first.
  move=> /= A B.
  rewrite -(tnth_uniq A B (t:=in_tuple _)) ?undup_uniq => // AB.
  exact: disjoint_preim_vars.
apply/eq_bigl => u.
apply/esym/bigcupP/(equivPif idP).
  move=> [A _ /preim_varsP HA].
  apply/preim_varsP => /= i /setDP [/HA -> Hif].
  by rewrite set_vals_tl.
move=> /= /preim_varsP /= Hu.
exists (map_fin_img (prod_vars f) u) => //.
apply/preim_varsP => /= i ie.
case/boolP: (i \in f) => Hif.
  by rewrite nth_fin_imgK set_vals_prod_vars.
by rewrite set_vals_tl // Hu // inE Hif.
Qed.

Ltac cases_in i :=
  rewrite ?inE; do !case: (i \in _) => //=;
  try by do! (move/(_ isT) => // || move=> _).

Lemma cinde_preim_sub (e e' f g : {set 'I_n}) :
  e :&: (f :|: g) \subset e' -> e' \subset e ->
  cinde_preim e f g -> cinde_preim e' f g.
Proof.
rewrite /cinde_preim => ee' e'e Hef vals.
have ee'g : (e :\: e') :&: g = set0.
  apply/setP => i; move/subsetP/(_ i): ee'; by cases_in i.
transitivity (\sum_(A : Tfin_img (prod_vars (e :\: e')))
          let v := set_vals (nth_fin_img A) vals in
          `Pr_P[preim_vars e v :&: preim_vars f v | preim_vars g v]).
  rewrite /cPr -!preim_vars_inter.
  have -> : e' :|: f :|: g = (e :|: f :|: g) :\: (e :\: e').
    apply/setP => i.
    move/subsetP/(_ i): e'e.
    move/subsetP/(_ i): ee'.
    by cases_in i.
  rewrite Pr_preim_vars_sub; last by apply/subsetP=> i; cases_in i.
  rewrite /Rdiv big_distrl; apply eq_bigr => A _ /=.
  by rewrite -!preim_vars_inter (@preim_vars_set_vals_tl g).
under eq_bigr => A _ /=.
  rewrite Hef (@preim_vars_set_vals_tl g) // (@preim_vars_set_vals_tl f).
    over.
  apply/setP => i; move/subsetP/(_ i): ee'; by cases_in i.
rewrite -2!big_distrl /=.
congr (_ / _ * _).
rewrite -preim_vars_inter.
have -> : e' :|: g = (e :|: g) :\: (e :\: e').
  apply/setP => i.
  move/subsetP/(_ i): e'e.
  move/subsetP/(_ i): ee'.
  by cases_in i.
rewrite Pr_preim_vars_sub; last by apply/subsetP=> i; cases_in i.
apply eq_bigr => A _.
by rewrite preim_vars_inter (@preim_vars_set_vals_tl g) //.
Qed.

Lemma cinde_preim_inter e f g :
  cinde_preim e f g -> cinde_preim (e :&: f) (e :&: f) g.
Proof.
move=> Hp.
have Hp2 : cinde_preim (e :\: (e :\: f :\: g)) f g.
  apply (@cinde_preim_sub e) => // ;
    apply/subsetP => j; by cases_in j.
have : cinde_preim (e :\: (e :\: f :\: g)) (f :\: (f :\: e :\: g)) g.
  move/cinde_preimC in Hp2.
  apply/cinde_preimC.
  apply (@cinde_preim_sub f) => // ;
    apply/subsetP => j; by cases_in j.
move=> {}Hp vals.
move/(_ vals): Hp.
rewrite /cinde_events /cPr /Pr -!preim_vars_inter.
rewrite (_ : _ :|: g = (e :&: f) :|: g);
  last by apply/setP => j; cases_in j.
rewrite 2!(_ : _ :\: _ :|: _ = (e :&: f) :|: g);
  try by apply/setP => j; cases_in j.
by rewrite setUid.
Qed.

Section cinde_preim_lemmas.
Variables e f g : {set 'I_n}.
Variables (A : prod_types types e) (B : prod_types types f)
          (C : prod_types types g).
Lemma cinde_events_vals :
  [forall i in (e :&: g), set_vals C vals0 i == set_vals A vals0 i] \/
  cinde_events P (finset (prod_vars e @^-1 A)) (finset (prod_vars f @^-1 B))
                 (finset (prod_vars g @^-1 C)).
Proof.
case /boolP: [forall i in (e :&: g), _].
  by left.
rewrite negb_forall => /existsP [i].
rewrite inE negb_imply => /andP [] /andP [Hie Hig] /eqP Hvi.
right; rewrite /cinde_events.
rewrite (proj2 (cPr_eq0 _ _ _)); last first.
  apply/Pr_set0P => u; rewrite !inE => Hprod; elim: Hvi.
  case/andP: Hprod => /andP[] /eqP <- _ /eqP <-; exact: prod_vars_inter.
rewrite (proj2 (cPr_eq0 _ _ _)) ?mul0R //.
apply/Pr_set0P => u; rewrite !inE => Hprod; elim: Hvi.
case/andP: Hprod => /eqP <- /eqP <-; exact: prod_vars_inter.
Qed.

Lemma cinde_events_cPr1 (i : 'I_n) :
  let vals := set_vals C (set_vals A (set_vals B vals0)) in
  (forall x : 'I_n, x \in e -> vals x = set_vals A vals0 x) ->
  i \in e -> i \in f -> i \notin g ->
  set_vals A vals0 i <> set_vals B vals0 i ->
  `Pr_P[(preim_vars (e :&: f) vals) | (preim_vars g vals)] = 1 ->
  cinde_events P [set x | preim (prod_vars e) (pred1 A) x]
    [set x | preim (prod_vars f) (pred1 B) x]
    [set x | preim (prod_vars g) (pred1 C) x].
Proof.
move=> vals He Hie Hif Hig Hvi.
rewrite /cinde_events /cPr.
set den := (X in _ / X).
case/boolP: (den == 0) => [/eqP|] Hden.
  by rewrite setIC Pr_domin_setI // ?div0R => /esym/R1_neq_R0.
set num := Pr _ _ => Hnum.
have {}Hnum : num = den.
  by rewrite -[RHS]mul1R -Hnum /Rdiv -mulRA mulVR // mulR1.
rewrite -Hnum in Hden.
rewrite (proj2 (Pr_set0P _ _)); last first.
  move=> u; rewrite !inE => /andP[] /andP[] /eqP HA /eqP HB.
  by rewrite -HA -HB !set_vals_prod_vars in Hvi.
suff : `Pr_P[finset (prod_vars f @^-1 B) | finset (prod_vars g @^-1 C)] = 0.
  by rewrite /cPr => ->; rewrite mulR0 div0R.
(* prove incompatibility between B and C *)
apply/cPr_eq0/Pr_set0P => u.
rewrite !inE => /andP [] /eqP HB /eqP HC.
move: Hnum; rewrite /den.
have -> : g = (e :&: f :|: g) :\: ((e :&: f) :\: g).
  by apply/setP => j; cases_in j.
rewrite Pr_preim_vars_sub; last by apply/subsetP => j; cases_in j.
have : prod_vals ((e :&: f) :\: g) vals
                 \in fin_img (prod_vars ((e :&: f) :\: g)).
  case/boolP: (_ \in _) => // /negP HA.
  elim: (negP Hden); rewrite /num -preim_vars_inter.
  have -> : e :&: f :|: g = (e :&: f :\: g) :|: g.
    apply/setP => k; by cases_in k.
  apply/eqP/Pr_set0P => v.
  rewrite preim_vars_inter inE => /andP [/preim_varsP /= HA'].
  elim: HA; apply/fin_imgP.
  exists v; apply/ffunP => k.
  apply/prod_vals_eq => /HA' <-.
  by rewrite ffunE.
case/fin_imgP => v Hv {Hden}.
set a := map_fin_img (prod_vars ((e :&: f) :\: g)) v.
rewrite (bigD1 a) //= nth_fin_imgK -Hv.
rewrite /num (@preim_vars_vals _ (prod_vals (e :&: f :|: g) vals) _ vals);
  last by move=> j; rewrite set_vals_prod_vals_id.
rewrite -preim_vars_inter addRC => /subR_eq; rewrite subRR => /esym Hnum.
have : Pr P (preim_vars (e :&: f :|: g)
      (set_vals (prod_vals (e :&: f :\: g) (set_vals B vals)) vals)) = 0.
  rewrite (_ : prod_vals _ _ = prod_vars (e :&: f :\: g) u); last first.
    apply/ffunP => k; apply/prod_vals_eq => Hk.
    rewrite -HB set_vals_prod_vars ?ffunE //.
    move: Hk; cases_in k.
  rewrite -(@nth_fin_imgK U).
  move/psumR_eq0P: Hnum; apply.
    move => *; by apply sumR_ge0.
  apply/eqP => /(f_equal (fun x => nth_fin_img x)).
  rewrite !nth_fin_imgK => /(prod_types_app i) /prod_vals_eqP Hi.
  elim: Hvi; rewrite -He //.
  have iefg : i \in e :&: f :\: g by move: Hif Hig Hie; cases_in i.
  move/(prod_types_app i)/prod_vals_eqP: Hv => -> //.
  by rewrite -HB set_vals_prod_vars // -Hi // ffunE.
move/Pr_set0P; apply.
apply/preim_varsP => j Hj.
case/boolP: (j \in g) => jg.
  by rewrite set_vals_tl ?inE ?jg // /vals -HC set_vals_prod_vars.
rewrite inE (negbTE jg) orbF in Hj.
rewrite -HB set_vals_prod_vals ?set_vals_prod_vars //.
  move: Hj; by rewrite inE => /andP[].
by rewrite inE Hj jg.
Qed.
End cinde_preim_lemmas.

Lemma cinde_preim_ok (e f g : {set 'I_n}) :
  cinde_preim e f g <-> P |= prod_vars e _|_ prod_vars f | (prod_vars g).
Proof.
split.
- move=> Hpreim.
  apply/cinde_rv_events => A B C.
  set vals := set_vals C (set_vals A (set_vals B vals0)).
  case /boolP: [forall i in e, vals i == set_vals A vals0 i]; last first.
    case: (cinde_events_vals A B C) => // /forallP Heg /negP; elim.
    apply/forallP => i; apply /implyP => Hie.
    case /boolP: (i \in g) => Hig;
      last by rewrite /vals set_vals_tl // (set_vals_hd vals0).
    rewrite /vals (set_vals_hd vals0) //.
    move/implyP: (Heg i); rewrite inE Hie; exact.
  (* A and C are compatible *)
  move/forallP => /= He.
  have {}He x Hx := eqP (implyP (He x) Hx).
  case /boolP: [forall i in f, vals i == set_vals B vals0 i].
    (* A/C and B are compatible *)
    move/forallP => /= Hf.
    have {}Hf x Hx := eqP (implyP (Hf x) Hx).
    move: (Hpreim vals).
    rewrite (preim_vars_vals _ He) // (preim_vars_vals _ Hf) //.
    by rewrite /cinde_events -!preim_prod_vars -!preim_inter.
  move/cinde_preimC in Hpreim.
  move=> HB; apply cinde_eventsC.
  case: (cinde_events_vals B A C) HB => // /forallP Hfg.
  (* A/C and B are incompatible *)
  rewrite negb_forall => /existsP [i].
  rewrite negb_imply /vals => /andP [Hif].
  case /boolP: (i \in g) => Hig.
    (* B and C are incompatible *)
    move: (Hfg i); by rewrite inE Hif Hig /= (set_vals_hd vals0) // => ->.
  case /boolP: (i \in e) => Hie;
    last by rewrite set_vals_tl // set_vals_tl // eqxx.
  (* A and B are incompatible *)
  rewrite set_vals_tl // (set_vals_hd vals0) // => /eqP Hvi.
  apply/cinde_eventsC.
  (* Reduce to intersection *)
  move/cinde_preimC/cinde_preim_inter/(_ vals): Hpreim.
  rewrite {1}/cinde_events -!preim_vars_inter setUid /=.
  case/Rxx2.
    (* cPr = 0 *)
    move/cPr_eq0/Pr_set0P => Hx.
    have HAC :
      Pr P (finset (prod_vars e @^-1 A) :&: finset (prod_vars g @^-1 C)) = 0.
      apply Pr_set0P => u Hu; apply Hx.
      rewrite -preim_vars_inter; apply/preim_varsP => j.
      move: Hu; rewrite !inE.
      rewrite /vals => /andP[] /eqP <- /eqP <-.
      case/boolP: (j \in g) => jg.
        by rewrite set_vals_prod_vars.
      case/boolP: (j \in e) => // je.
      by rewrite set_vals_tl // set_vals_prod_vars.
    rewrite /cinde_events (proj2 (cPr_eq0 _ _ _)).
      by rewrite (proj2 (cPr_eq0 _ _ _)) // mul0R.
    apply/Pr_set0P => u Hu.
    apply(proj1 (Pr_set0P _ _) HAC).
    move: Hu; by rewrite !inE => /andP[] /andP[] -> _ ->.
  (* cPr = 1 *)
  exact: (cinde_events_cPr1 (i:=i)).
- move=> Hdrv vals.
  move/cinde_rv_events: Hdrv.
  move/(_ (prod_vals e vals) (prod_vals f vals) (prod_vals g vals)).
  rewrite -(preim_vars_vals (prod_vals e vals) (set_vals_prod_vals _ vals)).
  rewrite -(preim_vars_vals (prod_vals f vals) (set_vals_prod_vals _ vals)).
  rewrite -(preim_vars_vals (prod_vals g vals) (set_vals_prod_vals _ vals)).
  by rewrite -!preim_prod_vars.
Qed.

Section Imap.
Variable parent : rel 'I_n.

Definition topological := forall i j : 'I_n, parent i j -> (i < j)%nat.

Definition independence (i j : 'I_n) :=
  ~~ closure parent [set i] j ->
  let parents := [set k | closure parent [set k] i] in
  cinde_preim [set i] [set j] parents.
End Imap.

(* Koller and Friedman, Definition 3.1, page 57 *)

Record t := mkBN
  { parent: rel 'I_n;
    topo: topological parent;
    indep: forall i j, independence parent i j
  }.
End preim.

Section equiv.
Variables types1 types2 : 'I_n -> finType.
Variable vars1 : forall i, {RV P -> types1 i}.
Variable vars2 : forall i, {RV P -> types2 i}.
Hypothesis varsE : forall i, RV_equiv (vars1 i) (vars2 i).

Definition vals1to2 (vals1 : univ_types types1) : univ_types types2
 := [ffun i => (sval (varsE i)).1 (vals1 i)].

Lemma preim_vars12 (I : {set 'I_n}) (vals1 : univ_types types1) :
  preim_vars vars2 I (vals1to2 vals1) = preim_vars vars1 I vals1.
Proof.
rewrite /preim_vars.
apply/setP => v.
apply/preim_varsP; case: ifP => /preim_varsP /= H1.
- move=> i iI; rewrite ffunE.
  move/H1: (iI).
  by case: varsE => -[f g] [/= fK gK] /(_ v) -> <-.
- move=> Hv; elim: H1 => /= i iI.
  move/Hv: (iI); rewrite ffunE.
  case: varsE => -[f g] [/= fK gK] /(_ v) -> /(f_equal g).
  by rewrite !fK => ->.
Qed.

Lemma cinde_preim_equiv1 (I J K : {set 'I_n}) :
  cinde_preim vars2 I J K -> cinde_preim vars1 I J K.
Proof.
rewrite /cinde_preim => CI vals1.
move: (CI (vals1to2 vals1)).
by rewrite !preim_vars12.
Qed.
End equiv.

Lemma cinde_preim_equiv (types1 types2 : 'I_n -> finType)
      (vars1 : forall i : 'I_n, {RV P -> types1 i})
      (vars2 : forall i : 'I_n, {RV P -> types2 i}) I J K :
  (forall i : 'I_n, RV_equiv (vars1 i) (vars2 i)) ->
  cinde_preim vars1 I J K <-> cinde_preim vars2 I J K.
Proof. split; apply cinde_preim_equiv1 => // i; by apply RV_equivC. Qed.

End bn.
End BN.

Section Factorization.
Import BN.
Variable U : finType.
Variable P : fdist U.
Variable n : nat.
Variable types : 'I_n -> finType.
Variable vars : forall i, {RV P -> types i}.
Variable bn : t vars.

Local Open Scope R_scope.

(* Theorem 3.1, page 62 *)
Theorem BN_factorization vals :
  Pr P (preim_vars vars setT vals) =
  \prod_(i < n)
   let parents := [set k | closure (parent bn) [set k] i] in
   `Pr_ P [ preim_vars vars [set i] vals | preim_vars vars parents vals ].
Abort.

End Factorization.


Require StlcIso.SpecSyntax.
Require StlcEqui.SpecSyntax.
Require Import StlcEqui.SpecTyping.
Require Import StlcIso.SpecTyping.
Require Import StlcIso.LemmasTyping.
Require Import StlcIso.CanForm.
Require Import StlcIso.SpecEvaluation.
Require Import StlcIso.LemmasEvaluation.
(* Require Import StlcEqui.SpecScoping. *)
(* Require Import StlcEqui.LemmasScoping. *)
(* Require Import StlcEqui.DecideEval. *)
Require Import UValIE.UVal.
Require Import LogRelIE.PseudoType.
Require Import LogRelIE.LemmasPseudoType.
Require Import LogRelIE.LR.
Require Import LogRelIE.LemmasLR.
Require Import Coq.micromega.Lia.
Require Import Coq.Arith.Wf_nat.
Require Import Db.Lemmas.
(* Require Import StlcEqui.Fix. *)

Local Ltac crushLRMatch :=
  match goal with
    | [ |- _ ∧ _ ] => split
    | [ H : valrel _ _ ?τ ?ts ?tu   |- OfType ?τ ?ts ?tu ] => refine (valrel_implies_OfType H)
    | [ H : valrel ?d _ ?τ ?ts ?tu  |- termrel ?d _ ?τ ?ts ?tu ] => apply valrel_in_termrel
    | [ H : valrel ?d ?w ?τ ?ts ?tu |- valrel ?d ?w' ?τ ?ts ?tu ] => refine (valrel_mono _ _ H); try lia
    | [ H : valrel _ _ _ ?ts _ |- I.Value ?ts ] => refine (proj1 (valrel_implies_Value H))
    | [ H : valrel _ _ _ _ ?tu |- E.Value ?tu ] => refine (proj2 (valrel_implies_Value H))
    | [ H : OfType _ ?ts _ |- I.Value ?ts ] => refine (proj1 (OfType_implies_Value H))
    | [ H : OfType _ _ ?tu |- E.Value ?tu ] => refine (proj2 (OfType_implies_Value H))
    | [ |- valrel _ _ _ _ _] => rewrite -> valrel_fixp; unfold valrel'
    | [ |- context[ lev ]] => unfold lev
    | [ H : context[ lev ] |- _ ] => unfold lev in *
    | [ |- exists t1, ?t2 = t1 /\ _ ] => eexists; split; [reflexivity|]
  end.

Local Ltac crush :=
  repeat
    (try assumption;
     simpl;
     destruct_conjs;
     subst*;
     repeat crushLRMatch;
     crushOfType;
     repeat crushValidPTyMatch;
     I.crushTyping;
     E.crushTyping;
     trivial;
     try reflexivity
    ); try lia; eauto.

Section ValueRelation.

  (* Lambda abstraction *)
  Lemma valrel_lambda {d τ'' τ' τ ts tu w} :
    ValidPTy τ → ValidPTy τ' → ValidTy τ'' →
    OfType (ptarr τ' τ) (I.abs (repEmul τ') ts) (E.abs (isToEq τ') tu) →
    ⟪ τ'' ≗ isToEq τ' ⟫ →
    (∀ w' vs vu, w' < w → (d = dir_gt -> E.size vu <= w') -> valrel d w' τ' vs vu → termrel d w' τ (ts [beta1 vs]) (tu [beta1 vu])) →
    valrel d w (ptarr τ' τ) (I.abs (repEmul τ') ts) (E.abs τ'' tu).
  Proof.
    intros.
    rewrite valrel_fixp; unfold valrel'.
    simpl.
    split.
    crush.
    repeat eexists; crush.
    now eapply H4.
  Qed.

  (* Unit *)
  Lemma valrel_unit {d w} :
    valrel d w ptunit I.unit E.unit.
  Proof. crush. Qed.

  (* True *)
  Lemma valrel_true {d w} :
    valrel d w ptbool I.true E.true.
  Proof. crush. Qed.

  (* False *)
  Lemma valrel_false {d w} :
    valrel d w ptbool I.false E.false.
  Proof. crush. Qed.

  (* Pair *)
  Lemma valrel_pair'' {d w τ₁ τ₂ ts₁ ts₂ tu₁ tu₂} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    OfType τ₁ ts₁ tu₁ →
    OfType τ₂ ts₂ tu₂ →
    (forall w', w' < w → valrel d w' τ₁ ts₁ tu₁) →
    (forall w', w' < w → valrel d w' τ₂ ts₂ tu₂) →
    valrel d w (ptprod τ₁ τ₂) (I.pair ts₁ ts₂) (E.pair tu₁ tu₂).
  Proof.
    crush.
  Qed.

  Lemma valrel_pair' {d w τ₁ τ₂ ts₁ ts₂ tu₁ tu₂} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d w τ₁ ts₁ tu₁ →
    valrel d w τ₂ ts₂ tu₂ →
    valrel d (S w) (ptprod τ₁ τ₂) (I.pair ts₁ ts₂) (E.pair tu₁ tu₂).
  Proof.
    crush.
  Qed.

  Lemma valrel_0_pair {d τ₁ τ₂ vs₁ vu₁ vs₂ vu₂} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    OfType τ₁ vs₁ vu₁ →
    OfType τ₂ vs₂ vu₂ →
    valrel d 0 (ptprod τ₁ τ₂) (I.pair vs₁ vs₂) (E.pair vu₁ vu₂).
  Proof.
    crush.
  Qed.

  Lemma valrel_pair {d w τ₁ τ₂ ts₁ ts₂ tu₁ tu₂} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d w τ₁ ts₁ tu₁ →
    valrel d w τ₂ ts₂ tu₂ →
    valrel d w (ptprod τ₁ τ₂) (I.pair ts₁ ts₂) (E.pair tu₁ tu₂).
  Proof.
    crush.
  Qed.

  (* Inl *)
  Lemma valrel_0_inl {d τ₁ τ₂ vs vu} :
    ValidPTy τ₁ → ValidPTy τ₂ →
    OfType τ₁ vs vu →
    valrel d 0 (ptsum τ₁ τ₂) (I.inl vs) (E.inl vu).
  Proof. crush. Qed.

  Lemma valrel_inl {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ → ValidPTy τ₂ →
    valrel d w τ₁ vs vu →
    valrel d w (ptsum τ₁ τ₂) (I.inl vs) (E.inl vu).
  Proof. crush. Qed.

  Lemma valrel_inl' {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ → ValidPTy τ₂ →
    valrel d w τ₁ vs vu →
    valrel d (S w) (ptsum τ₁ τ₂) (I.inl vs) (E.inl vu).
  Proof. crush. Qed.

  Lemma valrel_inl'' {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ → ValidPTy τ₂ →
    OfType τ₁ vs vu →
    (∀ w', w' < w → valrel d w' τ₁ vs vu) →
    valrel d w (ptsum τ₁ τ₂) (I.inl vs) (E.inl vu).
  Proof. crush. Qed.

  (* Inr *)
  Lemma valrel_0_inr {d τ₁ τ₂ vs vu} :
    ValidPTy τ₁ → ValidPTy τ₂ →
    OfType τ₂ vs vu →
    valrel d 0 (ptsum τ₁ τ₂) (I.inr vs) (E.inr vu).
  Proof. crush. Qed.

  Lemma valrel_inr {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ → ValidPTy τ₂ →
    valrel d w τ₂ vs vu →
    valrel d w (ptsum τ₁ τ₂) (I.inr vs) (E.inr vu).
  Proof. crush. Qed.

  Lemma valrel_inr' {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ → ValidPTy τ₂ →
    valrel d w τ₂ vs vu →
    valrel d (S w) (ptsum τ₁ τ₂) (I.inr vs) (E.inr vu).
  Proof. crush. Qed.

  Lemma valrel_inr'' {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ → ValidPTy τ₂ →
    OfType τ₂ vs vu →
    (∀ w', w' < w → valrel d w' τ₂ vs vu) →
    valrel d w (ptsum τ₁ τ₂) (I.inr vs) (E.inr vu).
  Proof. crush. Qed.

  (* double check with Marco that these hypothesis are kosher *)
  Lemma valrel_unk {d w n p vu τ} :
    OfType (pEmulDV n p τ) (unkUVal n) vu → p = imprecise →
    valrel d w (pEmulDV n p τ) (unkUVal n) vu.
  Proof.
    intros eq vvu; subst.
    repeat crushLRMatch.
    - unfold OfType, OfTypeStlcIso, OfTypeStlcEqui in *; split; simpl; split; try trivial;
      eauto using unkUVal_Value, unkUValT; crush.
    - cbn.
      eexists; split; [reflexivity|]; split; [eapply unkUVal_Value|].
      destruct n; [|left]; eauto.
  Qed.

  Lemma valrel_inUnit {d w n p vs vu} :
    vs = I.unit ∧ vu = E.unit →
    valrel d w (pEmulDV (S n) p E.tunit) (I.inl vs) vu.
  Proof.
    destruct 1 as [? ?]; subst.
    repeat crushLRMatch.
    - assert (⟪ empty i⊢ I.unit : tunit ⟫) by constructor.
      unfold OfType, OfTypeStlcIso, OfTypeStlcEqui; split; simpl; crush.
    - crush. right. exists I.unit. crush.
  Qed.

  Lemma valrel_inUnit' {d w n p vs vu} :
    valrel d w ptunit vs vu →
    valrel d w (pEmulDV (S n) p E.tunit) (I.inl vs) vu.
  Proof.
    intros vr.
    rewrite valrel_fixp in vr.
    destruct vr as [_ vr].
    simpl in vr.
    apply valrel_inUnit.
    crush.
  Qed.

  Lemma valrel_inBool {d w n p vs vu} :
    (vs = I.true ∧ vu = E.true) ∨ (vs = I.false ∧ vu = E.false) →
    valrel d w (pEmulDV (S n) p E.tbool) (inBool n vs) vu.
  Proof.
    intros eqs;
    repeat crushLRMatch.
    - assert (⟪ empty i⊢ vs : tbool ⟫);
      destruct eqs as [[? ?]|[? ?]]; subst; eauto with typing;
      unfold OfType, OfTypeStlcIso, OfTypeStlcEqui; simpl;
      eauto using inBool_Value, inBoolT with typing; crush.
    - crush.
      + destruct eqs as [[-> ->]|[-> ->]]; now cbn.
      + right; exists vs; cbn; unfold is_inl; eauto.
  Qed.

  Lemma valrel_inBool' {d w n p vs vu} :
    valrel d w ptbool vs vu →
    valrel d w (pEmulDV (S n) p E.tbool) (inBool n vs) vu.
  Proof.
    intros vr.
    rewrite valrel_fixp in vr.
    destruct vr as [_ vr].
    simpl in vr.
    apply valrel_inBool.
    crush.
  Qed.

  Lemma valrel_inProd {d w n p τ₁ τ₂ vs₁ vs₂ vu₁ vu₂} :
    OfType (pEmulDV n p τ₁) vs₁ vu₁ →
    OfType (pEmulDV n p τ₂) vs₂ vu₂ →
    (forall w', w' < w → valrel d w' (pEmulDV n p τ₁) vs₁ vu₁) →
    (forall w', w' < w → valrel d w' (pEmulDV n p τ₂) vs₂ vu₂) →
    valrel d w (pEmulDV (S n) p (E.tprod τ₁ τ₂)) (inProd n (I.pair vs₁ vs₂)) (E.pair vu₁ vu₂).
  Proof.
    intros ot₁ ot₂ vr₁ vr₂.
    destruct (OfType_implies_Value ot₁).
    destruct (OfType_implies_Value ot₂).
    repeat crushLRMatch.
    - unfold OfType, OfTypeStlcIso, OfTypeStlcEqui in *; crush.
    - crush. right. cbn. exists (I.pair vs₁ vs₂). unfold is_inl; cbn.
      crush.
  Qed.

  Lemma valrel_inProd' {d w n p τ₁ τ₂ vs₁ vs₂ vu₁ vu₂} :
    ValidTy τ₁ -> ValidTy τ₂ ->
    (valrel d w (pEmulDV n p τ₁) vs₁ vu₁) →
    (valrel d w (pEmulDV n p τ₂) vs₂ vu₂) →
    valrel d (S w) (pEmulDV (S n) p (E.tprod τ₁ τ₂)) (inProd n (I.pair vs₁ vs₂)) (E.pair vu₁ vu₂).
  Proof.
    intros vτ₁ vτ₂ vr₁ vr₂.
    eapply valrel_inProd; crush.
 Qed.

  Lemma valrel_inProd'' {d w n p τ₁ τ₂ vs vu} :
    ValidTy τ₁ -> ValidTy τ₂ ->
    valrel d w (ptprod (pEmulDV n p τ₁) (pEmulDV n p τ₂)) vs vu →
    valrel d w (pEmulDV (S n) p (tprod τ₁ τ₂)) (inProd n vs) vu.
  Proof.
    intros vτ₁ vτ₂ vr.
    rewrite valrel_fixp in vr.
    destruct vr as (val & vs2 & eqfolds & vvs & vr).
    rewrite <-eqfolds in *.
    simpl in vr; unfold prod_rel in vr.
    destruct vs; try contradiction.
    destruct vu; try contradiction.
    destruct val as ((? & ?) & (? & ?)).
    destruct vr as (? & ?).
    simpl in H0.
    simpl in H2.
    I.stlcCanForm.
    E.stlcCanForm.
    destruct H as (? & ?).
    eapply valrel_inProd; crush.
  Qed.

  Lemma valrel_inSum_l {d w n p vs vs' vu vu' τl τr} :
    ValidTy τl -> ValidTy τr ->
    OfType (pEmulDV n p τl) vs vu →
    (forall w', w' < w → valrel d w' (pEmulDV n p τl) vs vu) →
    vs' = I.inl vs ∧ vu' = E.inl vu →
    valrel d w (pEmulDV (S n) p (E.tsum τl τr)) (I.inl vs') vu'.
  Proof.
    intros vτl vτr ot vr eq.
    destruct (OfType_implies_Value ot).
    assert (I.Value vs') by (crush).
    assert (E.Value vu') by (crush).
    assert ⟪ empty i⊢ vs' : UValIE n τl r⊎ UValIE n τr ⟫
      by (destruct ot as [[? ?] ?]; crush; now apply UValIE_valid).
    assert ⟪ empty e⊢ vu' : tsum τl τr ⟫
      by (destruct ot as [? [? ?]]; crush).
    repeat crushLRMatch.
    - crush; now apply UValIE_valid.
    - crush. right. exists (I.inl vs). crush.
  Qed.

  Lemma valrel_inSum_r {d w n p vs vs' vu vu' τl τr} :
    ValidTy τl -> ValidTy τr ->
    OfType (pEmulDV n p τr) vs vu →
    (forall w', w' < w → valrel d w' (pEmulDV n p τr) vs vu) →
    vs' = I.inr vs ∧ vu' = E.inr vu →
    valrel d w (pEmulDV (S n) p (E.tsum τl τr)) (I.inl vs') vu'.
  Proof.
    intros vτl vτr ot vr eq.
    destruct (OfType_implies_Value ot).
    assert (I.Value vs') by (crush).
    assert (E.Value vu') by (crush).
    assert ⟪ empty i⊢ vs' : UValIE n τl r⊎ UValIE n τr ⟫
      by (destruct ot as [[? ?] ?]; crush; now apply UValIE_valid).
    assert ⟪ empty e⊢ vu' : tsum τl τr ⟫
      by (destruct ot as [? [? ?]]; crush).
    repeat crushLRMatch.
    - crush; now apply UValIE_valid.
    - crush. right. exists (I.inr vs). crush.
  Qed.

  (* Lemma valrel_inSum {d w n p vs vs' vu vu' τ τ'} : *)
  (*   OfType (pEmulDV n p (I.tsum τ τ')) vs vu → *)
  (*   (forall w', w' < w → valrel d w' (pEmulDV n p (I.tsum τ τ')) vs vu) → *)
  (*   (vs' = F.inl vs ∧ vu' = I.inl vu) ∨ (vs' = F.inr vs ∧ vu' = I.inr vu) → *)
  (*   valrel d w (pEmulDV (S n) p (I.tsum τ τ')) (F.inl vs') vu'. *)
  (* Proof. *)
  (*   intros ot vr eqs. *)
  (*   destruct (OfType_implies_Value ot). *)
  (*   assert (F.Value vs') by (destruct eqs as [[? ?]|[? ?]]; crush). *)
  (*   assert (I.Value vu') by (destruct eqs as [[? ?]|[? ?]]; crush). *)
  (*   destruct ot as [[? ?] [? ?]]. *)
  (*   assert ⟪ F.empty ⊢ vs' : (UValFI n τ) ⊎ (UValFI n τ') ⟫. *)
  (*   destruct eqs as [[? ?]|[? ?]]; crush. *)
  (*     by (destruct eqs as [[? ?]|[? ?]]; crush). *)
  (*   assert ⟨ 0 ⊢ vu' ⟩ *)
  (*          by (destruct eqs as [[? ?]|[? ?]]; crush). *)
  (*   crush. *)
  (*   right. exists vs'. right. right. right. left. *)
  (*   destruct eqs as [[? ?]|[? ?]]; crush. *)
  (* Qed. *)

  Lemma valrel_inSum' {d w n p vs vs' vu vu' τl τr} :
    ValidTy τl -> ValidTy τr ->
    (
      valrel d w (pEmulDV n p τl) vs vu
      ∧ (vs' = I.inl vs ∧ vu' = E.inl vu)
    ) ∨ (
      valrel d w (pEmulDV n p τr) vs vu
      ∧ (vs' = I.inr vs ∧ vu' = E.inr vu)
    ) →
    valrel d (S w) (pEmulDV (S n) p (E.tsum τl τr)) (I.inl vs') vu'.
  Proof.
    intros vτl vτr.
    destruct 1;
    destruct H.
    - refine (valrel_inSum_l _ _ _ _ H0); crush.
    - refine (valrel_inSum_r _ _ _ _ H0); crush.
  Qed.

  Lemma valrel_inSum'' {d w n p vs vu τl τr} :
    ValidTy τl -> ValidTy τr ->
    valrel d w (ptsum (pEmulDV n p τl) (pEmulDV n p τr)) vs vu →
    valrel d w (pEmulDV (S n) p (E.tsum τl τr)) (I.inl vs) vu.
  Proof.
   intros vτl vτr vr.
   rewrite valrel_fixp in vr.
   destruct vr as (val & ? & <- & vval & vr).
   destruct val as ((? & ?) & ? & ?).
   simpl in H0.
   simpl in H2.
   I.stlcCanForm;
   E.stlcCanForm;
     simpl in vr;
     try contradiction.
   - eapply valrel_inSum_l; auto; crush.
   - eapply valrel_inSum_r; auto; crush.
  Qed.

  Lemma valrel_inArr {d w n p vs vu τ₁ τ₂} :
    valrel d w (ptarr (pEmulDV n p τ₁) (pEmulDV n p τ₂)) vs vu →
    valrel d w (pEmulDV (S n) p (E.tarr τ₁ τ₂)) (I.inl vs) vu.
  Proof.
    intros vr.
    crush.
    - destruct (valrel_implies_OfType vr) as [[_ ?] _].
      eauto.
    - destruct (valrel_implies_OfType vr) as (_ & _ & ?).
      crush.
    - right. exists vs. crush.
      rewrite valrel_fixp in vr.
      destruct vr as ([_ ?] & ? & <- & vrarr).
      crush.
  Qed.

  (* Lemma valrel_0_inRec {d n p vs vu τ} : *)
  (*   OfType (pEmulDV (S n) p τ[beta1 (I.trec τ)]) vs vu → *)
  (*   valrel d 0 (pEmulDV (S n) p τ[beta1 (I.trec τ)]) vs vu. *)
  (* Proof. *)
  (*   intro ot. *)
  (*   destruct ot as [[? ?] [? ?]]. *)
  (*   crush. *)
  (*   unfold UValFI in H0. *)
  (*   F.stlcCanForm. *)
  (*   right. *)
  (*   2: destruct p; [right | left; auto]. *)
  (*   revert H2 H4. *)
  (*   generalize τ[beta1 (I.trec τ)] as τ'. *)
  (*   intros τ' H2 H4. *)
  (*   dependent destruction τ'; cbn. *)
  (*   exists x. *)
  (*   crush. *)
  (*   exists unit. *)
  (*   F.stlcCanForm. *)
  (*   I.stlcCanForm. *)
  (*   crush. *)
  (*   exists x. *)
  (*   crush. *)
  (*   unfold sum_rel. *)
  (*   F.stlcCanForm. *)
  (*   dependent induction n. *)
  (*   unfold UValFI in H0. *)

  (* Lemma valrel_inRec {d w n p vs vu τ} : *)
  (*   valrel d w (pEmulDV n p τ[beta1 (I.trec τ)]) vs vu → *)
  (*   valrel d w (pEmulDV (S n) p (I.trec τ)) (F.inl vs) (I.fold_ vu). *)
  (* Proof. *)
  (*   intros vr. *)
  (*   crush. *)
  (*   - destruct (valrel_implies_OfType vr) as [[_ ?] _]. *)
  (*     eauto. *)
  (*   - destruct (valrel_implies_OfType vr) as (_ & _ & ?). *)
  (*     eauto. *)
  (*   - right. exists vs. split. *)
  (*     + crush. *)
  (*     + exists vu. split. reflexivity. *)
  (*       destruct (valrel_implies_OfType vr) as [[? ?] [? ?]]. *)
  (*       dependent induction n. *)
  (*       intro w'; *)
  (*       rewrite valrel_fixp in vr; destruct vr as [[_ ?] vrrec]; *)
  (*       crush. *)
  (*       dependent induction τ; crush. *)
  (* Qed. *)
  (* Lemma valrel_0_inRec {n dir p vs vu τ} : *)
  (*   OfType (pEmulDV (S n) p (E.trec τ)) (I.inl (fold_ vs)) vu → *)
  (*   valrel dir 0 (pEmulDV (S n) p (E.trec τ)) (I.inl (fold_ vs)) vu. *)
  (* Proof. *)
  (*   rewrite valrel_fixp; *)
  (*   unfold valrel'; *)
  (*   split; *)
  (*   destruct 0 as [[? ?] [? ?]]; *)
  (*   crush; *)
  (*   right. *)
  (*   exists vs; crush. *)
  (*   exists vu; crush. *)
  (* Qed. *)

  Lemma valrel_inRec {d w n p vs vu τ} :
    ValidTy (trec τ) →
    valrel d w (pEmulDV n p τ[beta1 (trec τ)]) vs vu →
    valrel d w (pEmulDV n p (trec τ)) vs vu.
  Proof.
    intros [clτ crτ] vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr; cbn in vr.
    change (τ[beta1 (E.trec τ)]) with (unfoldOnce (trec τ)) in vr.
    rewrite (LMC_unfoldOnce (trec τ)) in vr; try assumption; [|cbn;eauto with arith].
    cbn in vr.
    rewrite valrel_fixp; unfold valrel'; cbn.
    destruct vr as [ot vr].
    split; [|assumption].
    destruct ot as ((vvs & tys) & (vvu & tyu));
    crush;
    cbn in tys, tyu.
    rewrite UValIE_trec; try assumption.
    now inversion crτ.
    refine (WtEq _ _ _ _ tyu); try assumption.
    eapply EqMuR, tyeq_refl.
    now eapply E.ValidTy_unfold_trec.
    crushValidTy.
  Qed.
End ValueRelation.

Ltac valrelIntro :=
  match goal with
    | |- valrel _ _ (ptarr ?τ _) (I.abs (repEmul ?τ) _) (E.abs (isToEq ?τ) _) => eapply valrel_lambda
    | |- valrel _ _ ptunit I.unit E.unit => apply valrel_unit
    (* | |- valrel _ _ ptbool F.true I.true => apply valrel_true *)
    (* | |- valrel _ _ ptbool F.false I.false => apply valrel_false *)
    (* | |- valrel _ ?w (ptprod _ _) (F.pair _ _) (I.pair _ _) => *)
    (*   match w with *)
    (*     | O   => apply valrel_0_pair *)
    (*     | S _ => apply valrel_pair' *)
    (*     | _   => apply valrel_pair *)
    (*   end *)
    | |- valrel _ ?w (ptsum _ _) (I.inl _) (E.inl _) =>
      match w with
        | O   => apply valrel_0_inl
        | S _ => apply valrel_inl'
        | _   => apply valrel_inl
      end
    | |- valrel _ ?w (ptsum _ _) (I.inr _) (E.inr _) =>
      match w with
        | O   => apply valrel_0_inr
        | S _ => apply valrel_inr'
        | _   => apply valrel_inr
      end
    | [ H : valrel ?d _ ?τ ?ts ?tu |- valrel ?d _ ?τ ?ts ?tu ] =>
      refine (valrel_mono _ H); try lia
  end.

Section TermRelation.

  (* Eval context *)
  (* related terms plugged in related contexts are still related (lemma 20 in TR) *)
  Lemma termrel_ectx {d w τ₁ τ₂ ts Cs tu Cu} (eCs : I.ECtx Cs) (eCu : E.ECtx Cu) :
    termrel d w τ₁ ts tu →
    (∀ w' (fw' : w' ≤ w) vs vu, valrel d w' τ₁ vs vu → termrel d w' τ₂ (I.pctx_app vs Cs) (E.pctx_app vu Cu)) →
    termrel d w τ₂ (I.pctx_app ts Cs) (E.pctx_app tu Cu).
  Proof.
    intros tr cr Cs' Cu' eCs' eCu' cr'.
    rewrite <- I.pctx_cat_app.
    rewrite <- E.pctx_cat_app.
    refine (tr (I.pctx_cat Cs Cs') (E.pctx_cat Cu Cu') _ _ _); eauto using I.ectx_cat, E.ectx_cat.
    intros w' fw' vs vu vr.
    destruct (valrel_implies_Value vr) as [vvs vvu].
    rewrite -> I.pctx_cat_app.
    rewrite -> E.pctx_cat_app.
    refine (cr w' fw' vs vu vr Cs' Cu' eCs' eCu' _).
    refine (contrel_mono fw' cr').
  Qed.

  Lemma termrel_ectx' {d w τ₁ τ₂ ts Cs tu ts' tu' Cu} :
    termrel d w τ₁ ts tu →
    (∀ w' (fw' : w' ≤ w) vs vu, valrel d w' τ₁ vs vu → termrel d w' τ₂ (I.pctx_app vs Cs) (E.pctx_app vu Cu)) →
    ts' = I.pctx_app ts Cs →
    tu' = E.pctx_app tu Cu →
    I.ECtx Cs → E.ECtx Cu →
    termrel d w τ₂ ts' tu'.
  Proof.
    intros; subst; eauto using termrel_ectx.
  Qed.

  (* Application *)
  Lemma valrel_app {d w τ₁ τ₂ vs₁ vs₂ vu₁ vu₂} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d w (ptarr τ₁ τ₂) vs₁ vu₁ →
    valrel d w τ₁ vs₂ vu₂ →
    termrel d w τ₂ (I.app vs₁ vs₂) (E.app vu₁ vu₂).
  Proof.
    (* destruct assumptions *)
    intros vτ₁ vτ₂ vr₁ vr₂.
    rewrite -> valrel_fixp in vr₁.
    destruct vr₁ as (ot & ? & <- & vvs1 & hyp); subst; cbn in hyp.
    apply OfType_inversion_ptarr in ot.
    destruct ot as (tsb & tub & τ₁' & eqs & equ & eqτ & tytsb & tytub); subst.
    destruct (valrel_implies_Value vr₂) as [vvs₂ vvu₂].

    eapply termrel_size_right'.
    intros szvs.

    (* beta-reduce *)
    assert (es : I.eval (I.app (I.abs (repEmul τ₁) tsb) vs₂) (tsb [beta1 vs₂])) by
        (refine (I.eval_ctx₀ I.phole _ I); refine (I.eval_beta vvs₂)).
    assert (es1 : I.evaln (I.app (I.abs (repEmul τ₁) tsb) vs₂) (tsb [beta1 vs₂]) 1) by
        (unfold I.evaln; eauto with eval; lia).
    assert (eu : E.eval (E.app (E.abs τ₁' tub) vu₂) (tub [beta1 vu₂])) by
        (refine (E.eval_ctx₀ E.phole _ I); refine (E.eval_beta vvu₂)).
    assert (eu1 : E.evaln (E.app (E.abs τ₁' tub) vu₂) (tub [beta1 vu₂]) 1) by
        (unfold E.evaln; eauto with eval).
    destruct w; try apply termrel_zero.
    refine (termrel_antired w es1 eu1 _ _ _); unfold lev in *; simpl; try lia.

    (* use assumption for function body *)
    destruct hyp as (tsb' & tub' & τ₁'' & τ₂' & eq1 & eq2 & hyp).
    inversion eq1; inversion eq2; subst.
    eapply hyp; try lia; eauto using valrel_mono.
    intros ->.
    specialize (szvs eq_refl).
    cbn in szvs.
    lia.
    assumption.
    assumption.
  Qed.

  Lemma termrel_app {d w τ₁ τ₂ ts₁ ts₂ tu₁ tu₂} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    termrel d w (ptarr τ₁ τ₂) ts₁ tu₁ →
    (∀ w', w' ≤ w → termrel d w' τ₁ ts₂ tu₂) →
    termrel d w τ₂ (I.app ts₁ ts₂) (E.app tu₁ tu₂).
  Proof.
    intros vτ₁ vτ₂ tr₁ tr₂.
    change (I.app _ _) with (I.pctx_app ts₁ (I.papp₁ I.phole ts₂)).
    change (E.app _ _) with (E.pctx_app tu₁ (E.papp₁ E.phole tu₂)).
    refine (termrel_ectx _ _ tr₁ _); crush.
    destruct (valrel_implies_Value H) as [vvs vvu].
    change (I.app _ _) with (I.pctx_app ts₂ (I.papp₂ vs I.phole)).
    change (E.app _ _) with (E.pctx_app tu₂ (E.papp₂ vu E.phole)).
    refine (termrel_ectx _ _ (tr₂ w' fw')  _); crush.
    refine (valrel_app _ _ _ H0); crush.
  Qed.

  Lemma termrel_ite {d w τ ts₁ ts₂ ts₃ tu₁ tu₂ tu₃} :
    termrel d w ptbool ts₁ tu₁ →
    (∀ w', w' ≤ w → termrel d w' τ ts₂ tu₂) →
    (∀ w', w' ≤ w → termrel d w' τ ts₃ tu₃) →
    termrel d w τ (I.ite ts₁ ts₂ ts₃) (E.ite tu₁ tu₂ tu₃).
  Proof.
    intros tr₁ tr₂ tr₃.

    (* first evaluate ts₁ and tu₁ *)
    change (I.ite _ _ _) with (I.pctx_app ts₁ (I.pite₁ I.phole ts₂ ts₃)).
    change (E.ite _ _ _) with (E.pctx_app tu₁ (E.pite₁ E.phole tu₂ tu₃)).
    refine (termrel_ectx _ _ tr₁ _); crush.

    (* then evaluate the if-statement *)
    rewrite -> valrel_fixp in H.
    destruct H as (ot & ? & <- & _ & [[? ?]|[? ?]]); subst; clear ot.
    - assert (I.eval (I.ite I.true ts₂ ts₃) ts₂) by
          (apply (I.eval_ctx₀ I.phole); try refine (I.eval_ite_true _ _); simpl; intuition).
      assert (esn : I.evaln (I.ite I.true ts₂ ts₃) ts₂ 1) by (unfold I.evaln; eauto with eval).
      assert (E.eval (E.ite E.true tu₂ tu₃) tu₂) by
          (apply (E.eval_eval₀); try refine E.eval_ite_true; simpl; intuition).
      assert (eun : E.evaln (E.ite E.true tu₂ tu₃) tu₂ 1) by (unfold E.evaln; eauto with eval).
      refine (termrel_antired w' esn eun _ _ _); crush.
    - assert (I.eval (I.ite I.false ts₂ ts₃) ts₃) by
          (apply (I.eval_ctx₀ I.phole); try refine I.eval_ite_false; simpl; intuition).
      assert (esn : I.evaln (I.ite I.false ts₂ ts₃) ts₃ 1) by (unfold I.evaln; eauto with eval).
      assert (E.eval (E.ite E.false tu₂ tu₃) tu₃) by
          (apply (E.eval_eval₀); try refine E.eval_ite_false; simpl; intuition).
      assert (eun : E.evaln (E.ite E.false tu₂ tu₃) tu₃ 1) by (unfold E.evaln; eauto with eval).
      refine (termrel_antired w' esn eun _ _ _); crush.
  Qed.

  (* Pair *)
  Lemma termrel_pair {d w τ₁ τ₂ ts₁ ts₂ tu₁ tu₂} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    termrel d w τ₁ ts₁ tu₁ →
    (∀ w', w' ≤ w → termrel d w' τ₂ ts₂ tu₂) →
    termrel d w (ptprod τ₁ τ₂) (I.pair ts₁ ts₂) (E.pair tu₁ tu₂).
  Proof.
    intros vτ₁ vτ₂ tr₁ tr₂.
    change (I.pair _ _) with (I.pctx_app ts₁ (I.ppair₁ I.phole ts₂)).
    change (E.pair _ _) with (E.pctx_app tu₁ (E.ppair₁ E.phole tu₂)).
    refine (termrel_ectx _ _ tr₁ _); crush.
    destruct (valrel_implies_Value H) as [vvs₂ vvu₂].
    change (I.pair _ _) with (I.pctx_app ts₂ (I.ppair₂ vs I.phole)).
    change (E.pair _ _) with (E.pctx_app tu₂ (E.ppair₂ vu E.phole)).
    refine (termrel_ectx _ _ (tr₂ w' fw')  _); crush.
    eauto using valrel_in_termrel, valrel_mono, valrel_pair.
  Qed.

  (* Proj₁ *)
  Lemma termrel_proj₁ {d w τ₁ τ₂ ts tu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    termrel d w (ptprod τ₁ τ₂) ts tu →
    termrel d w τ₁ (I.proj₁ ts) (E.proj₁ tu).
  Proof.
    intros vτ₁ vτ₂ tr.

    (* first evaluate ts and tu *)
    change (I.proj₁ _) with (I.pctx_app ts (I.pproj₁ I.phole)).
    change (E.proj₁ _) with (E.pctx_app tu (E.pproj₁ E.phole)).
    refine (termrel_ectx _ _ tr _); crush.

    (* then evaluate the projection *)
    rewrite -> valrel_fixp in H.
    destruct H as [ot hyp]; subst; cbn in hyp.
    apply OfType_inversion_ptprod in ot; eauto.
    destruct ot as (vs₁ & vu₁ & vs₂ & vu₂ & ? & ? & ot₁ & ot₂); subst.
    destruct (OfType_implies_Value ot₁) as [vvs₁ vvs₂].
    destruct (OfType_implies_Value ot₂) as [vvu₁ vvu₂].
    destruct hyp as (? & <- & _ & vr₁ & vr₂).

    assert (I.eval (I.proj₁ (I.pair vs₁ vs₂)) vs₁) by
        (apply (I.eval_ctx₀ I.phole); try refine (I.eval_proj₁ _ _); simpl; intuition).
    assert (esn : I.evaln (I.proj₁ (I.pair vs₁ vs₂)) vs₁ 1) by (unfold I.evaln; eauto with eval).
    assert (E.eval (E.proj₁ (E.pair vu₁ vu₂)) vu₁) by
        (apply (E.eval_eval₀); try refine (E.eval_proj₁ _ _); simpl; intuition).
    assert (eun : E.evaln (E.proj₁ (E.pair vu₁ vu₂)) vu₁ 1) by (unfold E.evaln; eauto with eval).
    destruct w'; try apply termrel_zero.
    refine (termrel_antired w' esn eun _ _ _); crush.

    (* then conclude *)
    apply valrel_in_termrel.
    apply vr₁; intuition; lia.
  Qed.

  Lemma termrel₀_proj₁ {d w τ₁ τ₂ ts tu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d (S w) (ptprod τ₁ τ₂) ts tu →
    termrel₀ d w τ₁ (I.proj₁ ts) (E.proj₁ tu).
  Proof.
    intros vτ₁ vτ₂ vr.

    rewrite -> valrel_fixp in vr.
    destruct vr as [ot hyp]; subst; cbn in hyp.
    apply OfType_inversion_ptprod in ot; eauto.
    destruct ot as (vs₁ & vu₁ & vs₂ & vu₂ & ? & ? & ot₁ & ot₂); subst.
    destruct (OfType_implies_Value ot₁) as [vvs₁ vvs₂].
    destruct (OfType_implies_Value ot₂) as [vvu₁ vvu₂].
    destruct hyp as (? & <- & _ & vr₁ & vr₂).

    assert (I.eval (I.proj₁ (I.pair vs₁ vs₂)) vs₁) by
        (apply (I.eval_ctx₀ I.phole); try refine (I.eval_proj₁ _ _); simpl; crush).
    assert (esn : clos_refl_trans_1n I.Tm I.eval (I.proj₁ (I.pair vs₁ vs₂)) vs₁) by (eauto with eval).
    assert (E.eval (E.proj₁ (E.pair vu₁ vu₂)) vu₁) by
        (apply (E.eval_eval₀); try refine (E.eval_proj₁ _ _); simpl; intuition).
    assert (eun : E.evalStar (E.proj₁ (E.pair vu₁ vu₂)) vu₁)
      by (unfold E.evalStar; eauto with eval).
    refine (termrel₀_antired_star esn eun _); crush.

    eapply valrel_in_termrel₀.
    apply vr₁; crush.
  Qed.

  Lemma termrel₀_proj₂ {d w τ₁ τ₂ ts tu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d (S w) (ptprod τ₁ τ₂) ts tu →
    termrel₀ d w τ₂ (I.proj₂ ts) (E.proj₂ tu).
  Proof.
    intros vτ₁ vτ₂ vr.

    rewrite -> valrel_fixp in vr.
    destruct vr as [ot hyp]; subst; cbn in hyp.
    apply OfType_inversion_ptprod in ot; eauto.
    destruct ot as (vs₁ & vu₁ & vs₂ & vu₂ & ? & ? & ot₁ & ot₂); subst.
    destruct (OfType_implies_Value ot₁) as [vvs₁ vvs₂].
    destruct (OfType_implies_Value ot₂) as [vvu₁ vvu₂].
    destruct hyp as (? & <- & _ & vr₁ & vr₂).

    assert (I.eval (I.proj₂ (I.pair vs₁ vs₂)) vs₂) by
        (apply (I.eval_ctx₀ I.phole); try refine (I.eval_proj₂ _ _); simpl; intuition).
    assert (esn : clos_refl_trans_1n I.Tm I.eval (I.proj₂ (I.pair vs₁ vs₂)) vs₂) by (eauto with eval).
    assert (E.eval (E.proj₂ (E.pair vu₁ vu₂)) vu₂) by
        (apply (E.eval_eval₀); try refine (E.eval_proj₂ _ _); simpl; intuition).
    assert (eun : E.evalStar (E.proj₂ (E.pair vu₁ vu₂)) vu₂)
      by (unfold E.evalStar; eauto with eval).
    refine (termrel₀_antired_star esn eun _); crush.

    eapply valrel_in_termrel₀.
    apply vr₂; crush.
  Qed.

  (* Proj₂ *)
  Lemma termrel_proj₂ {d w τ₁ τ₂ ts tu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    termrel d w (ptprod τ₁ τ₂) ts tu →
    termrel d w τ₂ (I.proj₂ ts) (E.proj₂ tu).
  Proof.
    intros vτ₁ vτ₂ tr.

    (* first reduce ts and tu *)
    change (I.proj₂ _) with (I.pctx_app ts (I.pproj₂ I.phole)).
    change (E.proj₂ _) with (E.pctx_app tu (E.pproj₂ E.phole)).
    refine (termrel_ectx _ _ tr _); crush.

    (* then evaluate the projection *)
    rewrite -> valrel_fixp in H.
    destruct H as [ot hyp]; subst; cbn in hyp.
    apply OfType_inversion_ptprod in ot; eauto.
    destruct ot as (vs₁ & vu₁ & vs₂ & vu₂ & ? & ? & ot₁ & ot₂); subst.
    destruct (OfType_implies_Value ot₁) as [vvs₁ vvs₂].
    destruct (OfType_implies_Value ot₂) as [vvu₁ vvu₂].
    destruct hyp as (? & <- & _ & vr₁ & vr₂).

    assert (I.eval (I.proj₂ (I.pair vs₁ vs₂)) vs₂) by
        (apply (I.eval_ctx₀ I.phole); try refine (I.eval_proj₂ _ _); simpl; intuition).
    assert (esn : I.evaln (I.proj₂ (I.pair vs₁ vs₂)) vs₂ 1) by (unfold I.evaln; eauto with eval).
    assert (E.eval (E.proj₂ (E.pair vu₁ vu₂)) vu₂) by
        (apply E.eval_eval₀; try refine (E.eval_proj₂ _ _); simpl; intuition).
    assert (eun : E.evaln (E.proj₂ (E.pair vu₁ vu₂)) vu₂ 1)
      by (unfold E.evaln; eauto with eval).
    destruct w'; try apply termrel_zero.
    refine (termrel_antired w' esn eun _ _ _); crush.

    apply valrel_in_termrel.
    apply vr₂; crush.
  Qed.

  (* Inl *)
  Lemma termrel_inl {d w τ₁ τ₂ ts tu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    termrel d w τ₁ ts tu →
    termrel d w (ptsum τ₁ τ₂) (I.inl ts) (E.inl tu).
  Proof.
    intros vτ₁ vτ₂ tr.
    change (I.inl ts) with (I.pctx_app ts (I.pinl I.phole)).
    change (E.inl tu) with (E.pctx_app tu (E.pinl E.phole)).
    refine (termrel_ectx _ _ tr _); crush.
    apply valrel_in_termrel; crush.
  Qed.

  (* Inr *)
  Lemma termrel_inr {d w τ₁ τ₂ ts tu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    termrel d w τ₂ ts tu →
    termrel d w (ptsum τ₁ τ₂) (I.inr ts) (E.inr tu).
  Proof.
    intros vτ₁ vτ₂ tr.
    change (I.inr ts) with (I.pctx_app ts (I.pinr I.phole)).
    change (E.inr tu) with (E.pctx_app tu (E.pinr E.phole)).
    refine (termrel_ectx _ _ tr _); crush.
    apply valrel_in_termrel; crush.
  Qed.

  (* Caseof *)
  Lemma termrel_caseof {d w τ τ₁ τ₂ ts₁ ts₂ ts₃ tu₁ tu₂ tu₃} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    termrel d w (ptsum τ₁ τ₂) ts₁ tu₁ →
    (∀ w' vs₁ vu₁, w' < w → valrel d w' τ₁ vs₁ vu₁ → termrel d w' τ (ts₂ [beta1 vs₁]) (tu₂ [ beta1 vu₁])) →
    (∀ w' vs₂ vu₂, w' < w → valrel d w' τ₂ vs₂ vu₂ → termrel d w' τ (ts₃ [beta1 vs₂]) (tu₃ [ beta1 vu₂])) →
    termrel d w τ (I.caseof ts₁ ts₂ ts₃) (E.caseof tu₁ tu₂ tu₃).
  Proof.
    intros vτ₁ vτ₂ tr₁ tr₂ tr₃.

    (* first evaluate ts₁ and tu₁ *)
    change (I.caseof _ _ _) with (I.pctx_app ts₁ (I.pcaseof₁ I.phole ts₂ ts₃)).
    change (E.caseof _ _ _) with (E.pctx_app tu₁ (E.pcaseof₁ E.phole tu₂ tu₃)).
    refine (termrel_ectx _ _ tr₁ _); crush.

    (* then evaluate the caseof *)
    rewrite -> valrel_fixp in H.
    destruct H as (ot & ? & <- & _ & hyp); subst; cbn in hyp.
    apply OfType_inversion_ptsum in ot; eauto.
    destruct ot as (vs' & vu' & [(? & ? & ot)|[(? & ?)|[(? & ?)|(? & ? & ot)]]]);
      subst; cbn in *; try contradiction;
      destruct (OfType_implies_Value ot) as [vvs vvu]; clear ot.
    - assert (I.eval (I.caseof (I.inl vs') ts₂ ts₃) (ts₂ [beta1 vs'])) by
          (apply (I.eval_ctx₀ I.phole); try refine (I.eval_case_inl _); simpl; intuition).
      assert (esn : I.evaln (I.caseof (I.inl vs') ts₂ ts₃) (ts₂ [beta1 vs']) 1) by (unfold I.evaln; eauto with eval).
      assert (E.eval (E.caseof (E.inl vu') tu₂ tu₃) (tu₂ [beta1 vu'])) by
          (apply (E.eval_ctx₀ E.phole); try refine (E.eval_case_inl _); simpl; intuition).
      assert (eun : E.evaln (E.caseof (E.inl vu') tu₂ tu₃) (tu₂ [beta1 vu']) 1) by (unfold E.evaln; eauto with eval).
      destruct w'; try apply termrel_zero.
      refine (termrel_antired w' esn eun _ _ _); crush.
    - assert (I.eval (I.caseof (I.inr vs') ts₂ ts₃) (ts₃ [beta1 vs'])) by
          (apply (I.eval_ctx₀ I.phole); try refine (I.eval_case_inr _); simpl; intuition).
      assert (esn : I.evaln (I.caseof (I.inr vs') ts₂ ts₃) (ts₃ [beta1 vs']) 1) by (unfold I.evaln; eauto with eval).
      assert (E.eval (E.caseof (E.inr vu') tu₂ tu₃) (tu₃ [beta1 vu'])) by
          (apply (E.eval_ctx₀ E.phole); try refine (E.eval_case_inr _); simpl; intuition).
      assert (eun : E.evaln (E.caseof (E.inr vu') tu₂ tu₃) (tu₃ [beta1 vu']) 1) by (unfold E.evaln; eauto with eval).
      destruct w'; try apply termrel_zero.
      refine (termrel_antired w' esn eun _ _ _); crush.
  Qed.

  Lemma termreli₀_caseof {d dfc w τ τ₁ τ₂ vs₁ ts₂ ts₃ vu₁ tu₂ tu₃} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d (S w) (ptsum τ₁ τ₂) vs₁ vu₁ →
    (∀ vs₁ vu₁, valrel d w τ₁ vs₁ vu₁ → termreli₀ d dfc (S w) τ (ts₂ [beta1 vs₁]) (tu₂ [ beta1 vu₁])) →
    (∀ vs₂ vu₂, valrel d w τ₂ vs₂ vu₂ → termreli₀ d dfc (S w) τ (ts₃ [beta1 vs₂]) (tu₃ [ beta1 vu₂])) →
    termreli₀ d dfc (S w) τ (I.caseof vs₁ ts₂ ts₃) (E.caseof vu₁ tu₂ tu₃).
  Proof.
    intros vτ₁ vτ₂ vr₁ tr₂ tr₃.

    (* then evaluate the caseof *)
    rewrite -> valrel_fixp in vr₁.
    destruct vr₁ as (ot & ? & <- & _ & hyp); subst; cbn in hyp.
    apply OfType_inversion_ptsum in ot; eauto.
    destruct ot as (vs' & vu' & [(? & ? & ot)|[(? & ?)|[(? & ?)|(? & ? & ot)]]]);
      subst; cbn in *; try contradiction;
      destruct (OfType_implies_Value ot) as [vvs vvu]; clear ot.
    - assert (I.eval (I.caseof (I.inl vs') ts₂ ts₃) (ts₂ [beta1 vs'])) by
          (apply (I.eval_ctx₀ I.phole); try refine (I.eval_case_inl _); simpl; intuition).
      assert (esn : clos_refl_trans_1n I.Tm I.eval (I.caseof (I.inl vs') ts₂ ts₃) (ts₂ [beta1 vs'])) by (eauto with eval).
      assert (E.eval (E.caseof (E.inl vu') tu₂ tu₃) (tu₂ [beta1 vu'])) by
          (apply (E.eval_ctx₀ E.phole); try refine (E.eval_case_inl _); simpl; intuition).
      assert (eun : E.evalStar (E.caseof (E.inl vu') tu₂ tu₃) (tu₂ [beta1 vu'])) by (unfold E.evalStar; eauto with eval).
      refine (termreli₀_antired_star esn eun _); crush.
    - assert (I.eval (I.caseof (I.inr vs') ts₂ ts₃) (ts₃ [beta1 vs'])) by
          (apply (I.eval_ctx₀ I.phole); try refine (I.eval_case_inr _); simpl; intuition).
      assert (esn : clos_refl_trans_1n I.Tm I.eval (I.caseof (I.inr vs') ts₂ ts₃) (ts₃ [beta1 vs'])) by (eauto with eval).
      assert (E.eval (E.caseof (E.inr vu') tu₂ tu₃) (tu₃ [beta1 vu'])) by
          (apply (E.eval_ctx₀ E.phole); try refine (E.eval_case_inr _); simpl; intuition).
      assert (eun : E.evalStar (E.caseof (E.inr vu') tu₂ tu₃) (tu₃ [beta1 vu'])) by (unfold E.evalStar; eauto with eval).
      refine (termreli₀_antired_star esn eun _); crush.
  Qed.

  (* Seq *)
  Lemma termrel_seq {d w τ ts₁ ts₂ tu₁ tu₂} :
    ValidPTy τ ->
    termrel d w ptunit ts₁ tu₁ →
    (∀ w', w' ≤ w → termrel d w' τ ts₂ tu₂) →
    termrel d w τ (I.seq ts₁ ts₂) (E.seq tu₁ tu₂).
  Proof.
    intros vτ tr₁ tr₂.

    (* first evaluate ts₁ and tu₁ *)
    change (I.seq _ _) with (I.pctx_app ts₁ (I.pseq₁ I.phole ts₂)).
    change (E.seq _ _) with (E.pctx_app tu₁ (E.pseq₁ E.phole tu₂)).
    refine (termrel_ectx _ _ tr₁ _); crush.

    (* then reduce to ts₂ and tu₂ *)
    rewrite -> valrel_fixp in H.
    destruct H as (ot & ? & <- & _ & eq₁ & eq₂); subst.
    assert (I.eval (I.seq I.unit ts₂) ts₂) by
        (apply (I.eval_ctx₀ I.phole); try refine (I.eval_seq_next _); simpl; intuition).
    assert (esn : I.evaln (I.seq I.unit ts₂) ts₂ 1) by (unfold I.evaln; eauto with eval).
    assert (E.eval (E.seq E.unit tu₂) tu₂) by
        (apply (E.eval_ctx₀ E.phole); try refine (E.eval_seq_next _); simpl; intuition).
    assert (eun : E.evaln (E.seq E.unit tu₂) tu₂ 1) by (unfold E.evaln; eauto with eval).

    (* assert (∀ Cu, E.ECtx Cu → E.eval (E.pctx_app (E.seq E.unit tu₂) Cu) (E.pctx_app tu₂ Cu)) by  *)
    (*     (intros Cu eCu; apply (E.eval_ctx₀ Cu); try refine (E.eval_seq_next _); simpl; intuition). *)
    (* assert (eun : ∀ Cu, E.ECtx Cu → E.evaln (E.pctx_app (E.seq E.unit tu₂) Cu) (E.pctx_app tu₂ Cu) 1) by eauto using E.evaln. *)

    (* attempt at using evalMax instead of doing manual labor *)
    (* pose (e := evalMax 2 (E.seq E.unit (var 0)) nil (idm UTm · tu₂) I). *)

    refine (termrel_antired w' esn eun _ _ _); try lia.

    (* conclude *)
    apply tr₂; intuition.
  Qed.

  (* unfold_ *)
  Lemma termrel_unfold_ {d w τ ts tu} :
    ValidPTy (ptrec τ) ->
    termrel d w (ptrec τ) ts tu →
    termrel d w (τ [beta1 (ptrec τ)]) (unfold_ ts) tu.
  Proof.
    intros vτ tr.

    (* first evaluate the two terms *)
    change (I.unfold_ ts) with (I.pctx_app ts (I.punfold I.phole)).
    change tu with (E.pctx_app tu E.phole).
    refine (termrel_ectx _ _ tr _); crush.

    (* then evaluate the unfold_ *)
    rewrite ->valrel_fixp in H.
    destruct H as (ot & ? & (vs2 & -> & eqfolds) & vvs2 & vr); subst.
    change (pUnfoldn (LMC_pty (ptrec τ)) (ptrec τ)) with (pUnfoldn (LMC_pty τ) (τ [ beta1 (ptrec τ )])) in *.

    assert (I.eval (I.unfold_ (I.fold_ vs2)) vs2) as eval_fold.
    { apply (I.eval_ctx₀ I.phole); [|now cbn].
      eapply I.eval_fold_unfold.
      simpl; intuition.
    }
    eapply (termrel_antired_eval_left eval_fold).

    apply valrel_in_termrel.
    rewrite ->valrel_fixp.
    split.
    - crush.
    - eexists x.
      replace (LMC_pty τ[beta1 (ptrec τ)]) with (LMC_pty τ) in *.
      split; [assumption|].
      split; [now cbn in vvs2|].
      exact vr.
      symmetry.
      refine (LMC_pUnfoldOnce (ptrec τ) _ _).
      now constructor.
      cbn; now lia.
  Qed.

  (* fold_ *)
  Lemma valrel_fold_ {d w τ vs vu} :
    ValidPTy (ptrec τ) ->
    valrel d w (τ [beta1 (ptrec τ)]) vs vu →
    valrel d w (ptrec τ) (fold_ vs) vu.
  Proof.
    intros vμτ vvs.
    rewrite valrel_fixp.
    split.
    - crush.
    - rewrite valrel_fixp in vvs.
      destruct vvs as ( tvs & vs' & unfolds & vvs & rel).
      destruct vμτ as (wsμτ & cμτ).
      assert (LMC_pty τ [beta1 (ptrec τ)] = LMC_pty τ) as eq.
      { refine (LMC_pUnfoldOnce (ptrec τ) cμτ _); cbn; lia. }
      rewrite eq in unfolds.
      exists vs'.
      split; [exists vs; intuition|].
      split; crush.
      now rewrite eq in rel.
  Qed.

  Lemma termrel_fold_ {d w τ ts tu} :
    ValidPTy (ptrec τ) ->
    termrel d w (τ [beta1 (ptrec τ)]) ts tu →
    termrel d w (ptrec τ) (fold_ ts) tu.
  Proof.
    intros vτ tr.

    (* first evaluate the two terms *)
    change (I.fold_ ts) with (I.pctx_app ts (I.pfold I.phole)).
    change tu with (E.pctx_app tu E.phole).
    refine (termrel_ectx _ _ tr _); crush.

    apply valrel_in_termrel.
    eapply valrel_fold_; crush.
  Qed.

End TermRelation.