(*

  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_induction_cterm.
Require Export subst_tacs.
Require Export per_props_equality.
Require Export lsubstc_vars.

(**

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

*)

Definition rule_bar_induction_nout {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_natk2nout (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_nat2nout))
              (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_natk2nout (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_natk2nout (mk_var n))))
                    (mk_hyp x (mk_all
                                 mk_nout
                                 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_nout_true {o} :
  forall lib (f X c B 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_nout f X c B e s n m v x i H).
Proof.
  unfold rule_bar_induction_nout, 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_nout 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_natk2nout_sp2; auto;
           apply similarity_dom in sim'3; repnd; rw sim'0; auto
          |].
        eapply tequality_respects_alphaeqc_right;
          [apply alphaeqc_sym; apply lsubstc_mk_natk2nout_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_natk2nout; 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_natk2nout (mk_var n))) as wfn.
      { apply wf_term_mk_natk2nout; auto. }
      assert (cover_vars (mk_natk2nout (mk_var n)) (snoc s1a (n,mkc_nat k))) as cvn.
      { apply cover_vars_mk_natk2nout.
        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_natk2nout_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_cterm_meta
                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_nout_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'.
      allrw @lsubstc_mk_nat2nout.
      apply type_nat2nout.
    }

    { assert (@wf_term o mk_nat2nout) as wfn.
      { apply wf_term_mk_nat2nout; auto. }
      assert (cover_vars mk_nat2nout s1) as cvn.
      { apply cover_vars_mk_nat2nout. }
      sim_snoc.
      dands; auto.
      { eapply similarity_refl; eauto. }
      allrw @lsubstc_mk_nat2nout.
      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 nout_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_natk2nout_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_natk2nout_sp2; auto
          |].
        eapply tequality_respects_alphaeqc_right;
          [apply alphaeqc_sym;
            apply lsubstc_mk_natk2nout_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_natk2nout; 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_natk2nout (mk_var n))) as wfk.
        { apply wf_term_mk_natk2nout; auto. }
        assert (cover_vars (mk_natk2nout (mk_var n)) (snoc s1 (n,mkc_nat k))) as cvk.
        { apply cover_vars_mk_natk2nout.
          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_natk2nout_sp2; auto].
        auto.
      }

      { lsubst_tac; auto. }
    }

    exrepnd.
    lsubst_tac.
    apply inhabited_type_if_equality in hf1.
    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.
        allrw @lsubstc_mk_nout.
        apply equality_int_nat_implies_cequivc in sim'2.
        eapply alphaeqc_preserving_equality in sim'1;
          [|apply lsubstc_mk_natk2nout_sp2; auto].

        apply tequality_function; dands.
        { apply type_mkc_nout. }
        introv en.
        repeat substc_lsubstc_vars3.
        lsubst_tac.
        apply equality_in_nout 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_sp0;auto]
          |].

        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_sp3;auto;
             apply cequivc_sym;eauto
            ]
          |].

        eapply tequality_respects_cequivc_left;
          [apply cequivc_sym;
            apply implies_cequivc_apply2;
            [apply cequivc_refl
            |apply cequivc_refl
            |apply implies_cequivc_update_seq_nout;eauto
            ]
          |].

        eapply tequality_respects_cequivc_right;
          [apply cequivc_sym;
            apply implies_cequivc_apply2;
            [apply cequivc_refl
            |apply cequivc_refl
            |apply implies_cequivc_update_seq_nout;eauto
            ]
          |].

        pose proof (ind (cterm2cnterm u en1)) as h; clear ind.
        unfold nout_on_upd_seq in h.
        unfold nout_on_seq in h; repnd.
        allunfold @cnout_cterm.
        allrw @cnterm2cterm2cnterm.

        pose proof (h (lsubstc X w0 s2a0 c28) (update_seq_nout t2 k u v)) as q; clear h.
        repeat (autodimp q hyp); repnd; auto;[|].
        { apply eq_kseq_nout_update2; auto. }
        { exists s2a0 c28; dands; 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_natk2nout_sp2; auto
          |].
        eapply tequality_respects_alphaeqc_right;
          [apply alphaeqc_sym;
            apply lsubstc_mk_natk2nout_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_natk2nout; 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_nout 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_nout 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_natk2nout (mk_var n))) as wfk.
        { apply wf_term_mk_natk2nout; auto. }
        assert (cover_vars (mk_natk2nout (mk_var n)) (snoc s1 (n,mkc_nat k))) as cvk.
        { apply cover_vars_mk_natk2nout.
          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_natk2nout_sp2; auto].
        auto.
      }

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

        { apply type_mkc_nout. }

        { introv en.
          repeat substc_lsubstc_vars3.
          lsubst_tac.
          apply equality_in_nout 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_sp0;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_sp0;auto]
            |];[].

          eapply tequality_respects_cequivc_left;
            [apply cequivc_sym;
              apply implies_cequivc_apply2;
              [apply cequivc_refl
              |apply cequivc_refl
              |apply implies_cequivc_update_seq_nout;eauto
              ]
            |].

          eapply tequality_respects_cequivc_right;
            [apply cequivc_sym;
              apply implies_cequivc_apply2;
              [apply cequivc_refl
              |apply cequivc_refl
              |apply implies_cequivc_update_seq_nout;eauto
              ]
            |].

          pose proof (ind (cterm2cnterm u en1)) as h; clear ind.
          unfold nout_on_upd_seq in h.
          unfold nout_on_seq in h; repnd.
          allunfold @cnout_cterm.
          allrw @cnterm2cterm2cnterm.

          pose proof (h (lsubstc X w0 s1 c0) (update_seq_nout seq1 k u v)) as q; clear h.
          repeat (autodimp q hyp); repnd; auto;[|].
          { apply eq_kseq_nout_update2; auto.
            eapply equality_refl; eauto. }
          { exists s1 c0; dands; auto.
            eapply similarity_refl; eauto. }
        }

        { 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_nout 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_sp0;auto]
            |];[].

          eapply inhabited_type_cequivc;
            [apply cequivc_sym;
              apply implies_cequivc_apply2;
              [apply cequivc_refl
              |apply cequivc_refl
              |apply implies_cequivc_update_seq_nout;eauto
              ]
            |];[].

          pose proof (ind (cterm2cnterm u en1)) as h; clear ind.
          unfold nout_on_upd_seq in h.
          unfold nout_on_seq in h; repnd.
          allunfold @cnout_cterm.
          allrw @cnterm2cterm2cnterm.

          pose proof (h (lsubstc X w0 s1 c0) (update_seq_nout seq1 k u v)) as q; clear h.
          repeat (autodimp q hyp); repnd; auto;[|].
          { apply eq_kseq_nout_update2; auto.
            eapply equality_refl; eauto. }
          { exists s1 c0; dands; auto.
            eapply similarity_refl; eauto. }
        }
      }
    }

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


(** * LogRel.DeclarativeInstance: proof that declarative typing is an instance of generic typing. *)
From Coq Require Import CRelationClasses.
From LogRel.AutoSubst Require Import core unscoped Ast Extra.
From LogRel Require Import Utils BasicAst Notations Context NormalForms UntypedReduction UntypedValues Weakening GenericTyping DeclarativeTyping.

Import DeclarativeTypingData.

(** ** Generation *)

(** The generation lemma (the name comes from the PTS literature), gives a
stronger inversion principle on typing derivations, that give direct access
to the last non-conversion rule, and bundle together all conversions.

Note that because we do not yet know that [Γ |- t : T] implies [Γ |- T],
we cannot use reflexivity in the case where the last rule was not a conversion
one, and we get the slightly clumsy disjunction of either an equality or a
conversion proof. We get a better version of generation later on, once we have
this implication. *)

Definition termGenData (Γ : context) (t T : term) : Type :=
  match t with
    | tRel n => ∑ decl, [× T = decl, [|- Γ]& in_ctx Γ n decl]
    | tProd A B =>  [× T = U, [Γ |- A : U] & [Γ,, A |- B : U]]
    | tLambda A t => ∑ B, [× T = tProd A B, [Γ |- A] & [Γ,, A |- t : B]]
    | tApp f a => ∑ A B, [× T = B[a..], [Γ |- f : tProd A B] & [Γ |- a : A]]
    | tSort _ => False
    | tNat => T = U
    | tZero => T = tNat
    | tSucc n => T = tNat × [Γ |- n : tNat]
    |  tNatElim P hz hs n =>
      [× T = P[n..], [Γ,, tNat |- P], [Γ |- hz : P[tZero..]], [Γ |- hs : elimSuccHypTy P] & [Γ |- n : tNat]]
    | tEmpty => T = U
    | tEmptyElim P e =>
      [× T = P[e..], [Γ,, tEmpty |- P] & [Γ |- e : tEmpty]]
  end.

Lemma termGen Γ t A :
  [Γ |- t : A] ->
  ∑ A', (termGenData Γ t A') × ((A' = A) + [Γ |- A' ≅ A]).
Proof.
  induction 1.
  all: try (eexists ; split ; [..|left ; reflexivity] ; cbn ; by_prod_splitter).
  + destruct IHTypingDecl as [? [? [-> | ]]].
    * prod_splitter; tea; now right.
    * prod_splitter; tea; right; now eapply TypeTrans.
Qed.

Lemma prod_ty_inv Γ A B :
  [Γ |- tProd A B] ->
  [Γ |- A] × [Γ,, A |- B].
Proof.
  intros Hty.
  inversion Hty ; subst ; clear Hty.
  1: easy.
  eapply termGen in H as (?&[-> ]&_).
  split ; now econstructor.
Qed.

(** ** Stability by weakening *)

Lemma subst_ren_wk_up {Γ Δ P A} {ρ : Γ ≤ Δ}: forall n, P[n..]⟨ρ⟩ = P⟨wk_up A ρ⟩[n⟨ρ⟩..].
Proof. intros; now bsimpl. Qed.

Lemma shift_up_ren {Γ Δ t} (ρ : Δ ≤ Γ) : t⟨ρ⟩⟨↑⟩ = t⟨↑ >> up_ren ρ⟩.
Proof. now asimpl. Qed.

Section TypingWk.

  Let PCon (Γ : context) := True.
  Let PTy (Γ : context) (A : term) := forall Δ (ρ : Δ ≤ Γ), [|- Δ ] -> [Δ |- A⟨ρ⟩].
  Let PTm (Γ : context) (A t : term) := forall Δ (ρ : Δ ≤ Γ), [|- Δ ] ->
    [Δ |- t⟨ρ⟩ : A⟨ρ⟩].
  Let PTyEq (Γ : context) (A B : term) := forall Δ (ρ : Δ ≤ Γ), [|- Δ ] ->
    [Δ |- A⟨ρ⟩ ≅ B⟨ρ⟩].
  Let PTmEq (Γ : context) (A t u : term) := forall Δ (ρ : Δ ≤ Γ), [|- Δ ] ->
    [Δ |- t⟨ρ⟩ ≅ u⟨ρ⟩ : A⟨ρ⟩].

  Theorem typing_wk : WfDeclInductionConcl PCon PTy PTm PTyEq PTmEq.
  Proof.
    subst PCon PTy PTm PTyEq PTmEq.
    apply WfDeclInduction.
    - trivial.
    - trivial.
    - intros ? ? IH.
      now econstructor.
    - intros Γ A B HA IHA HB IHB Δ ρ HΔ.
      econstructor ; fold ren_term.
      1: now eapply IHA.
      eapply IHB with (ρ := wk_up _ ρ).
      now constructor.
    - intros; now constructor.
    - intros; now constructor.
    - intros * _ IHA ? * ?.
      econstructor.
      now eapply IHA.
    - intros * _ IHΓ Hnth ? * ?.
      eapply typing_meta_conv.
      1: econstructor ; tea.
      1: eapply in_ctx_wk ; tea.
      reflexivity.
    - intros * _ IHA _ IHB ? ρ ?.
      cbn.
      econstructor.
      1: now eapply IHA.
      eapply IHB with (ρ := wk_up _ ρ).
      econstructor ; tea.
      econstructor.
      now eapply IHA.
    - intros * _ IHA _ IHt ? ρ ?.
      econstructor.
      1: now eapply IHA.
      eapply IHt with (ρ := wk_up _ ρ).
      econstructor ; tea.
      now eapply IHA.
    - intros * _ IHf _ IHu ? ρ ?.
      cbn.
      red in IHf.
      cbn in IHf.
      eapply typing_meta_conv.
      1: econstructor.
      1: now eapply IHf.
      1: now eapply IHu.
      now asimpl.
    - intros; now constructor.
    - intros; now constructor.
    - intros; cbn; econstructor; eauto.
    - intros * ? ihP ? ihhz ? ihhs ? ihn **; cbn.
      erewrite subst_ren_wk_up; eapply wfTermNatElim.
      * eapply ihP; econstructor; tea; now econstructor.
      * eapply typing_meta_conv.
        1: now eapply ihhz.
        now erewrite subst_ren_wk_up.
      * rewrite wk_elimSuccHypTy.
        now eapply ihhs.
      * now eapply ihn.
    - intros; now constructor.
    - intros * ? ihP ? ihe **; cbn.
      erewrite subst_ren_wk_up; eapply wfTermEmptyElim.
      * eapply ihP; econstructor; tea; now econstructor.
      * now eapply ihe.
    - intros * _ IHt _ IHAB ? ρ ?.
      econstructor.
      1: now eapply IHt.
      now eapply IHAB.
    - intros Γ A A' B B' _ IHA _ IHAA' _ IHBB' ? ρ ?.
      cbn.
      econstructor.
      + now eapply IHA.
      + now eapply IHAA'.
      + eapply IHBB' with (ρ := wk_up _ ρ).
        econstructor ; tea.
        now eapply IHA.
    - intros * _ IHA ? ρ ?.
      eapply TypeRefl.
      now eapply IHA.
    - intros * _ IH ? ρ ?.
      econstructor.
      now eapply IH.
    - intros * _ IH ? ρ ?.
      now econstructor ; eapply IH.
    - intros * _ IHA _ IHB ? ρ ?.
      eapply TypeTrans.
      + now eapply IHA.
      + now eapply IHB.
    - intros Γ u t A B _ IHA _ IHt _ IHu ? ρ ?.
      cbn.
      eapply convtm_meta_conv.
      1: econstructor.
      + now eapply IHA.
      + eapply IHt with (ρ := wk_up _ ρ).
        econstructor ; tea.
        now eapply IHA.
      + now eapply IHu.
      + now asimpl.
      + now asimpl.
    - intros Γ A A' B B' _ IHA _ IHAA' _ IHBB' ? ρ ?.
      cbn.
      econstructor.
      + now eapply IHA.
      + now eapply IHAA'.
      + eapply IHBB' with (ρ := wk_up _ ρ).
        pose (IHA _ ρ H).
        econstructor; tea; now econstructor.
    - intros Γ u u' f f' A B _ IHf _ IHu ? ρ ?.
      cbn.
      red in IHf.
      cbn in IHf.
      eapply convtm_meta_conv.
      1: econstructor.
      + now eapply IHf.
      + now eapply IHu.
      + now asimpl.
      + now asimpl.
    - intros Γ f f' A B _ IHA _ IHf _ IHg _ IHe ? ρ ?.
      cbn.
      econstructor.
      1-3: easy.
      specialize (IHe _ (wk_up _ ρ)).
      cbn in IHe.
      repeat rewrite renRen_term in IHe.
      cbn in * ; refold.
      do 2 rewrite shift_up_ren.
      erewrite <- wk_up_ren_on.
      eapply IHe.
      econstructor ; tea.
      now eapply IHA.
    - intros * ? ih **; cbn; constructor; now apply ih.
    - intros * ? ihP ? ihhz ? ihhs ? ihn **; cbn.
      erewrite subst_ren_wk_up.
      eapply TermNatElimCong.
      * eapply ihP; constructor; tea; now constructor.
      * eapply convtm_meta_conv.
        1: now eapply ihhz.
        2: reflexivity.
        now erewrite subst_ren_wk_up.
      * rewrite wk_elimSuccHypTy.
        now eapply ihhs.
      * now eapply ihn.
    - intros * ? ihP ? ihhz ? ihhs **.
      erewrite subst_ren_wk_up.
      eapply TermNatElimZero; fold ren_term.
      * eapply ihP; constructor; tea; now constructor.
      * eapply typing_meta_conv.
        1: now eapply ihhz.
        now erewrite subst_ren_wk_up.
      * rewrite wk_elimSuccHypTy.
        now eapply ihhs.
    - intros * ? ihP ? ihhz ? ihhs ? ihn **.
      erewrite subst_ren_wk_up.
      eapply TermNatElimSucc; fold ren_term.
      * eapply ihP; constructor; tea; now constructor.
      * eapply typing_meta_conv.
        1: now eapply ihhz.
        now erewrite subst_ren_wk_up.
      * rewrite wk_elimSuccHypTy.
        now eapply ihhs.
      * now eapply ihn.
    - intros * ? ihP ? ihe **; cbn.
      erewrite subst_ren_wk_up.
      eapply TermEmptyElimCong.
      * eapply ihP; constructor; tea; now constructor.
      * now eapply ihe.
    - intros * _ IHt ? ρ ?.
      now econstructor.
    - intros * _ IHt _ IHA ? ρ ?.
      now econstructor.
    - intros * _ IHt ? ρ ?.
      now econstructor.
    - intros * _ IHt _ IHt' ? ρ ?.
      now econstructor.
  Qed.

End TypingWk.

(** ** A first set of boundary conditions *)

(** These lemmas assert that various boundary conditions, ie that if a certain typing-like relation
holds, some of its components are themselves well-formed. For instance, if [Γ |- t ⇒* u : A] then
[Γ |- t : A ]. The tactic boundary automates usage of these lemmas. *)

(** We cannot prove yet that all boundaries are well-typed: this needs stability of typing
by substitution and injectivity of type constructors, which we get from the logical relation.*)

Section Boundaries.
  Import DeclarativeTypingData.

  Definition boundary_ctx_ctx {Γ A} : [|- Γ,, A] -> [|- Γ].
  Proof.
    now inversion 1.
  Qed.

  Definition boundary_ctx_tip {Γ A} : [|- Γ,, A] -> [Γ |- A].
  Proof.
    now inversion 1.
  Qed.

  Definition boundary_tm_ctx {Γ} {t A} :
      [ Γ |- t : A ] ->
      [ |- Γ ].
  Proof.
    induction 1 ; now eauto using boundary_ctx_ctx.
  Qed.

  Definition boundary_ty_ctx {Γ} {A} :
      [ Γ |- A ] ->
      [ |- Γ ].
  Proof.
    induction 1; now eauto using boundary_tm_ctx.
  Qed.

  Definition boundary_tm_conv_ctx {Γ} {t u A} :
      [ Γ |- t ≅ u : A ] ->
      [ |- Γ ].
  Proof.
      induction 1 ; now eauto using boundary_tm_ctx.
  Qed.

  Definition boundary_ty_conv_ctx {Γ} {A B} :
      [ Γ |- A ≅ B ] ->
      [ |- Γ ].
  Proof.
    induction 1 ; now eauto using boundary_ty_ctx, boundary_tm_conv_ctx.
  Qed.

  Definition boundary_ored_l {Γ t u K} :
    [ Γ |- t ⇒ u ∈ K ] ->
    match K with istype => [ Γ |- t ] | isterm A => [ Γ |- t : A ] end.
  Proof.
    induction 1.
    all: econstructor ; eauto.
    1,3: now econstructor.
    econstructor; now eapply boundary_tm_ctx.
  Qed.

  Definition boundary_ored_tm_l {Γ t u A} :
    [ Γ |- t ⇒ u : A] ->
    [ Γ |- t : A ].
  Proof.
  apply @boundary_ored_l with (K := isterm A).
  Qed.

  Definition boundary_ored_ty_l {Γ A B} :
    [ Γ |- A ⇒ B ] ->
    [ Γ |- A ].
  Proof.
  apply @boundary_ored_l with (K := istype).
  Qed.

  Definition boundary_red_l {Γ t u K} :
    [ Γ |- t ⇒* u ∈ K] ->
    match K with istype => [ Γ |- t ] | isterm A => [ Γ |- t : A ] end.
  Proof.
    induction 1; eauto.
    now eapply boundary_ored_l.
  Qed.

  Definition boundary_red_tm_l {Γ t u A} :
    [ Γ |- t ⇒* u : A] ->
    [ Γ |- t : A ].
  Proof.
    apply @boundary_red_l with (K := isterm A).
  Qed.

  Definition boundary_red_ty_l {Γ A B} :
    [ Γ |- A ⇒* B ] ->
    [ Γ |- A ].
  Proof.
    apply @boundary_red_l with (K := istype).
  Qed.

End Boundaries.

#[export] Hint Resolve
  boundary_ctx_ctx boundary_ctx_tip boundary_tm_ctx
  boundary_ty_ctx boundary_tm_conv_ctx boundary_ty_conv_ctx
  boundary_ored_tm_l boundary_ored_ty_l boundary_red_tm_l
  boundary_red_ty_l : boundary.

(** ** Inclusion of the various reductions in conversion *)

Definition RedConv {Γ} {t u : term} {K} :
  [Γ |- t ⇒ u ∈ K] ->
  match K with istype => [Γ |- t ≅ u] | isterm A => [Γ |- t ≅ u : A] end.
Proof.
induction 1.
1,4,5: now econstructor.
all: econstructor; tea; now econstructor.
Qed.

Definition RedConvTe {Γ} {t u A : term} :
    [Γ |- t ⇒ u : A] ->
    [Γ |- t ≅ u : A].
Proof.
apply @RedConv with (K := isterm A).
Qed.

Definition RedConvC {Γ} {t u : term} {K} :
    [Γ |- t ⇒* u ∈ K] ->
    match K with istype => [Γ |- t ≅ u] | isterm A => [Γ |- t ≅ u : A] end.
Proof.
  induction 1.
  - destruct K; now constructor.
  - now eapply RedConv.
  - destruct K; [now eapply TypeTrans|now eapply TermTrans].
Qed.

Definition RedConvTeC {Γ} {t u A : term} :
    [Γ |- t ⇒* u : A] ->
    [Γ |- t ≅ u : A].
Proof.
apply @RedConvC with (K := isterm A).
Qed.

Definition RedConvTy {Γ} {A B : term} :
    [Γ |- A ⇒ B] ->
    [Γ |- A ≅ B].
Proof.
apply @RedConv with (K := istype).
Qed.

Definition RedConvTyC {Γ} {A B : term} :
    [Γ |- A ⇒* B] ->
    [Γ |- A ≅ B].
Proof.
apply @RedConvC with (K := istype).
Qed.

Lemma oredtm_meta_conv (Γ : context) (t u u' A A' : term) :
  [Γ |- t ⇒ u : A] ->
  A' = A ->
  u' = u ->
  [Γ |- t ⇒ u' : A'].
Proof.
  now intros ? -> ->.
Qed.

(** ** Weakenings of reduction *)

Lemma oreddecl_wk {Γ Δ t u K} (ρ : Δ ≤ Γ) :
  [|- Δ ] -> [Γ |- t ⇒ u ∈ K] ->
  match K with istype => [Δ |- t⟨ρ⟩ ⇒ u⟨ρ⟩] | isterm A => [Δ |- t⟨ρ⟩ ⇒ u⟨ρ⟩ : A⟨ρ⟩] end.
Proof.
  intros ? red.
  induction red as [| | | | | | |]; refold.
  - cbn in *.
    eapply oredtm_meta_conv.
    1: econstructor.
    + now eapply typing_wk.
    + eapply typing_wk with (ρ := wk_up _ ρ) ; tea.
      econstructor ; tea.
      now eapply typing_wk.
    + now eapply typing_wk.
    + apply subst_ren_wk_up.
    + unshelve eapply subst_ren_wk_up; tea.
  - cbn in *.
    eapply oredtm_meta_conv.
    1: econstructor.
    + now eauto.
    + now eapply typing_wk.
    + now asimpl.
    + reflexivity.
  - cbn. erewrite subst_ren_wk_up.
    eapply natElimSubst; tea.
    * erewrite <- wk_up_ren_on.
      refine (fst (snd typing_wk) _ _ w _ (wk_up _ ρ) _).
      constructor; tea; now constructor.
    * eapply typing_meta_conv.
      1: now eapply typing_wk.
      symmetry; unshelve eapply subst_ren_wk_up; tea.
    * unshelve erewrite <- wk_up_ren_on; tea.
      rewrite wk_elimSuccHypTy.
      now eapply typing_wk.
    Unshelve. all: tea.
  - cbn. erewrite subst_ren_wk_up.
    eapply natElimZero; tea.
    * erewrite <- wk_up_ren_on.
      refine (fst (snd typing_wk) _ _ w _ (wk_up _ ρ) _).
      constructor; tea; now constructor.
    * eapply typing_meta_conv.
      1: now eapply typing_wk.
      symmetry; unshelve eapply subst_ren_wk_up; tea.
    * unshelve erewrite <- wk_up_ren_on; tea.
      rewrite wk_elimSuccHypTy.
      now eapply typing_wk.
    Unshelve. all: tea.
  - cbn. erewrite (subst_ren_wk_up (A := tNat)).
    eapply natElimSucc.
    * erewrite <- wk_up_ren_on.
      refine (fst (snd typing_wk) _ _ w _ (wk_up _ ρ) _).
      constructor; tea; now constructor.
    * eapply typing_meta_conv.
      1: now eapply typing_wk.
      symmetry; unshelve eapply subst_ren_wk_up; tea.
    * unshelve erewrite <- wk_up_ren_on; tea.
      rewrite wk_elimSuccHypTy.
      now eapply typing_wk.
    * change tNat with tNat⟨ρ⟩; now eapply typing_wk.
  - cbn. erewrite subst_ren_wk_up.
    eapply (@emptyElimSubst _); tea.
    * erewrite <- wk_up_ren_on.
      refine (fst (snd typing_wk) _ _ w _ (wk_up _ ρ) _).
      constructor; tea; now constructor.
    Unshelve. all: tea.
  - econstructor.
    1: eassumption.
    now eapply typing_wk.
  - now econstructor.
Qed.

Lemma oredtmdecl_wk {Γ Δ t u A} (ρ : Δ ≤ Γ) :
  [|- Δ ] -> [Γ |- t ⇒ u : A] -> [Δ |- t⟨ρ⟩ ⇒ u⟨ρ⟩ : A⟨ρ⟩].
Proof.
apply @oreddecl_wk with (K := isterm A).
Qed.

Lemma redtmdecl_wk {Γ Δ t u A} (ρ : Δ ≤ Γ) :
  [|- Δ ] -> [Γ |- t ⇒* u : A] -> [Δ |- t⟨ρ⟩ ⇒* u⟨ρ⟩ : A⟨ρ⟩].
Proof.
  intros * ?.
  induction 1.
  - econstructor ; now apply typing_wk.
  - econstructor ; now eapply oredtmdecl_wk.
  - now econstructor.
Qed.

Lemma oredtydecl_wk {Γ Δ A B} (ρ : Δ ≤ Γ) :
  [|- Δ ] -> [Γ |- A ⇒ B] -> [Δ |- A⟨ρ⟩ ⇒ B⟨ρ⟩].
Proof.
apply @oreddecl_wk with (K := istype).
Qed.

Lemma redtydecl_wk {Γ Δ A B} (ρ : Δ ≤ Γ) :
  [|- Δ ] -> [Γ |- A ⇒* B] -> [Δ |- A⟨ρ⟩ ⇒* B⟨ρ⟩].
Proof.
  intros * ?.
  induction 1.
  - now econstructor ; apply typing_wk.
  - now econstructor ; eapply oredtydecl_wk.
  - now econstructor.
Qed.

(** ** Derived rules for multi-step reduction *)

Lemma redtmdecl_app Γ A B f f' t :
  [ Γ |- f ⇒* f' : tProd A B ] ->
  [ Γ |- t : A ] ->
  [ Γ |- tApp f t ⇒* tApp f' t : B[t..] ].
Proof.
  intros Hf ?.
  remember (tProd A B) as T in *.
  induction Hf.
  + subst.
    now do 2 econstructor.
  + subst.
    now do 2 econstructor.
  + now econstructor.
Qed.

Lemma redtmdecl_conv Γ t u A A' :
  [Γ |- t ⇒* u : A] ->
  [Γ |- A ≅ A'] ->
  [Γ |- t ⇒* u : A'].
Proof.
  intros Ht ?.
  induction Ht.
  + now do 2 econstructor.
  + now do 2 econstructor.
  + now econstructor.
Qed.

Lemma redtydecl_term Γ A B :
  [ Γ |- A ⇒* B : U] -> [Γ |- A ⇒* B ].
Proof.
  remember U as T.
  induction 1 ; subst.
  + now do 2 econstructor.
  + now do 2 econstructor.
  + now econstructor.
Qed.

#[export] Instance RedTermTrans Γ A : Transitive (red_tm Γ A).
Proof.
  now econstructor.
Qed.

#[export] Instance RedTypeTrans Γ : Transitive (red_ty Γ).
Proof.
  now econstructor.
Qed.

(** ** Bundling the properties together in an instance *)

Module DeclarativeTypingProperties.
  Export DeclarativeTypingData UntypedValues.WeakValuesProperties.

  #[export, refine] Instance WfCtxDeclProperties : WfContextProperties (ta := de) := {}.
  Proof.
    1-2: now constructor.
    all: boundary.
  Qed.

  #[export, refine] Instance WfTypeDeclProperties : WfTypeProperties (ta := de) := {}.
  Proof.
    all: try now econstructor.
    - intros.
      now eapply typing_wk.
    - easy.
  Qed.

  #[export, refine] Instance TypingDeclProperties : TypingProperties (ta := de) := {}.
  Proof.
    all: try (intros; now econstructor).
    - intros.
      now eapply typing_wk.
    - easy.
    - intros.
      econstructor ; tea.
      now apply TypeSym, RedConvTyC.
  Qed.

  #[export, refine] Instance ConvTypeDeclProperties : ConvTypeProperties (ta := de) := {}.
  Proof.
  - now econstructor.
  - intros.
    constructor ; red ; intros.
    all: now econstructor.
  - intros.
    now apply typing_wk.
  - easy.
  - intros.
    eapply TypeTrans ; [eapply TypeTrans | ..].
    2: eassumption.
    2: eapply TypeSym.
    all: now eapply RedConvTyC.
  - econstructor.
    now econstructor.
  - now econstructor.
  - now do 2 econstructor.
  - now repeat econstructor.
  Qed.

  #[export, refine] Instance ConvTermDeclProperties : ConvTermProperties (ta := de) := {}.
  Proof.
  - intros.
    constructor ; red ; intros.
    all: now econstructor.
  - intros.
    now econstructor.
  - intros.
    now eapply typing_wk.
  - easy.
  - intros.
    econstructor.
    2: now eapply TypeSym, RedConvTyC.
    eapply TermTrans ; [eapply TermTrans |..].
    2: eassumption.
    2: eapply TermSym.
    all: now eapply RedConvTeC.
  - intros. eassumption.
  - intros.
    now econstructor.
  - intros.
    now econstructor.
  - now do 2 econstructor.
  - now do 2 econstructor.
  - now econstructor.
  - now do 2 econstructor.
  Qed.

  #[export, refine] Instance ConvNeuDeclProperties : ConvNeuProperties (ta := de) := {}.
  Proof.
  - split ; red ; intros.
    all: now econstructor.
  - intros.
    now econstructor.
  - intros.
    now eapply typing_wk.
  - easy.
  - intros.
    now econstructor.
  - intros.
    now econstructor.
  - now econstructor.
  - now econstructor.
  Qed.

  #[export, refine] Instance OneStepRedTermDeclProperties : OneStepRedTermProperties (ta := de) := {}.
  Proof.
    all: intros; now econstructor.
  Qed.

  #[export, refine] Instance RedTermDeclProperties : RedTermProperties (ta := de) := {}.
  Proof.
  - intros.
    now eapply redtmdecl_wk.
  - easy.
  - intros. now eapply boundary_red_tm_l.
  - intros. now constructor.
  - intros.
    now eapply redtmdecl_app.
  - intros Γ P hz hs n n' HP Hhz Hhs Hn Hr Hcong.
    revert Hcong; induction Hr; intros Hcong.
    + apply red_id.
      now econstructor.
    + apply red_red.
      now constructor.
    + eapply red_trans.
      * apply IHHr1; [assumption|].
        intros w Hw.
        eapply TypeTrans; [apply TypeSym|]; eapply Hcong; [eassumption|].
        now transitivity t'.
      * eapply redtmdecl_conv; [eapply IHHr2|].
        -- now eapply boundary_red_tm_l.
        -- intros w Hw; now apply Hcong.
        -- eapply TypeTrans; [apply TypeSym|]; apply Hcong; [assumption|].
          now transitivity t'.
  - intros Γ P n n' HP Hn Hr Hcong.
    revert Hcong; induction Hr; intros Hcong.
    + apply red_id.
      now econstructor.
    + apply red_red.
      now constructor.
    + eapply red_trans.
      * apply IHHr1; [assumption|].
        intros w Hw.
        eapply TypeTrans; [apply TypeSym|]; eapply Hcong; [eassumption|].
        now transitivity t'.
      * eapply redtmdecl_conv; [eapply IHHr2|].
        -- now eapply boundary_red_tm_l.
        -- intros w Hw; now apply Hcong.
        -- eapply TypeTrans; [apply TypeSym|]; apply Hcong; [assumption|].
          now transitivity t'.
  - intros.
    now eapply redtmdecl_conv.
  - intros.
    now econstructor.
  Qed.

  #[export, refine] Instance RedTypeDeclProperties : RedTypeProperties (ta := de) := {}.
  Proof.
  - intros.
    now eapply redtydecl_wk.
  - easy.
  - intros. now eapply boundary_red_ty_l.
  - intros.
    now eapply redtydecl_term.
  - intros.
    now econstructor.
  Qed.

  #[export] Instance DeclarativeTypingProperties : GenericTypingProperties de _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ := {}.

End DeclarativeTypingProperties.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Export List.
Require Export BinPos.

Open Scope positive_scope.

Ltac clean := try (simpl; congruence).
Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t.

Functional Scheme Pcompare_ind := Induction for Pcompare Sort Prop.

Lemma Gt_Eq_Gt : forall p q cmp,
       (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt.
apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt));
simpl;auto;congruence.
Qed.

Lemma Gt_Lt_Gt : forall p q cmp,
       (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt.
apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt));
simpl;auto;congruence.
Qed.

Lemma Gt_Psucc_Eq: forall p q,
  (p ?= Psucc q) Gt = Gt -> (p ?= q) Eq = Gt.
intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence.
intro;apply Gt_Eq_Gt;auto.
apply Gt_Lt_Gt.
Qed.

Lemma Eq_Psucc_Gt: forall p q,
  (p ?= Psucc q) Eq = Eq -> (p ?= q) Eq = Gt.
intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence.
intro H;elim (Pcompare_not_Eq p (Psucc q));tauto.
intro H;apply Gt_Eq_Gt;auto.
intro H;rewrite Pcompare_Eq_eq with p q;auto.
generalize q;clear q IHq p H;induction q;simpl;auto.
intro H;elim (Pcompare_not_Eq p q);tauto.
Qed.

Lemma Gt_Psucc_Gt : forall n p cmp cmp0,
 (n?=p) cmp = Gt -> (Psucc n?=p) cmp0 = Gt.
induction n;intros [ | p | p];simpl;try congruence.
intros; apply IHn with cmp;trivial.
intros; apply IHn with Gt;trivial.
intros;apply Gt_Lt_Gt;trivial.
intros [ | | ] _ H.
apply Gt_Eq_Gt;trivial.
apply Gt_Lt_Gt;trivial.
trivial.
Qed.

Lemma Gt_Psucc: forall p q,
       (p ?= Psucc q) Eq = Gt -> (p ?= q) Eq = Gt.
intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence.
apply Gt_Psucc_Eq.
intro;apply Gt_Eq_Gt;apply IHq;auto.
apply Gt_Eq_Gt.
apply Gt_Lt_Gt.
Qed.

Lemma Psucc_Gt : forall p,
       (Psucc p ?= p) Eq = Gt.
induction p;simpl.
apply Gt_Eq_Gt;auto.
generalize p;clear p IHp.
induction p;simpl;auto.
reflexivity.
Qed.

Fixpoint pos_eq (m n:positive) {struct m} :bool :=
match m, n with
  xI mm, xI nn => pos_eq mm nn
| xO mm, xO nn => pos_eq mm nn
| xH, xH => true
| _, _ => false
end.

Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n.
induction m;simpl;intro n;destruct n;congruence ||
(intro e;apply f_equal;auto).
Defined.

Theorem refl_pos_eq : forall m, pos_eq m m = true.
induction m;simpl;auto.
Qed.

Definition pos_eq_dec : forall (m n:positive), {m=n}+{m<>n} .
fix 1;intros [mm|mm|] [nn|nn|];try (right;congruence).
case (pos_eq_dec mm nn).
intro e;left;apply (f_equal xI e).
intro ne;right;congruence.
case (pos_eq_dec mm nn).
intro e;left;apply (f_equal xO e).
intro ne;right;congruence.
left;reflexivity.
Defined.

Theorem pos_eq_dec_refl : forall m, pos_eq_dec m m = left _ (refl_equal m).
fix 1;intros [mm|mm|].
simpl; rewrite  pos_eq_dec_refl; reflexivity.
simpl; rewrite  pos_eq_dec_refl; reflexivity.
reflexivity.
Qed.

Theorem pos_eq_dec_ex : forall m n,
 pos_eq m n =true -> exists h:m=n,
 pos_eq_dec m n = left _ h.
fix 1;intros [mm|mm|] [nn|nn|];try (simpl;congruence).
simpl;intro e.
elim (pos_eq_dec_ex _ _ e).
intros x ex; rewrite ex.
exists (f_equal xI x).
reflexivity.
simpl;intro e.
elim (pos_eq_dec_ex _ _ e).
intros x ex; rewrite ex.
exists (f_equal xO x).
reflexivity.
simpl.
exists (refl_equal xH).
reflexivity.
Qed.

Fixpoint nat_eq (m n:nat) {struct m}: bool:=
match m, n with
O,O => true
| S mm,S nn => nat_eq mm nn
| _,_ => false
end.

Theorem nat_eq_refl : forall m n, nat_eq m n = true -> m = n.
induction m;simpl;intro n;destruct n;congruence ||
(intro e;apply f_equal;auto).
Defined.

Theorem refl_nat_eq : forall n, nat_eq n n = true.
induction n;simpl;trivial.
Defined.

Fixpoint Lget (A:Set) (n:nat) (l:list A) {struct l}:option A :=
match l with nil => None
| x::q =>
match n with O => Some x
| S m => Lget A m q
end end .

Implicit Arguments Lget [A].

Lemma map_app : forall (A B:Set) (f:A -> B) l m,
List.map  f (l ++ m) = List.map  f  l ++ List.map  f  m.
induction l.
reflexivity.
simpl.
intro m ; apply f_equal;apply IHl.
Qed.

Lemma length_map : forall (A B:Set) (f:A -> B) l,
length (List.map  f l) = length l.
induction l.
reflexivity.
simpl; apply f_equal;apply IHl.
Qed.

Lemma Lget_map : forall (A B:Set) (f:A -> B) i l,
Lget i (List.map  f l) =
match Lget i l with Some a =>
Some (f a) | None => None end.
induction i;intros [ | x l ] ;trivial.
simpl;auto.
Qed.

Lemma Lget_app : forall (A:Set) (a:A) l i,
Lget i (l ++ a :: nil) = if nat_eq i (length l) then Some a else Lget i l.
induction l;simpl Lget;simpl length.
intros [ | i];simpl;reflexivity.
intros [ | i];simpl.
reflexivity.
auto.
Qed.

Lemma Lget_app_Some : forall (A:Set) l delta i (a: A),
Lget i l = Some a ->
Lget i (l ++ delta) = Some a.
induction l;destruct i;simpl;try congruence;auto.
Qed.

Section Store.

Variable A:Type.

Inductive Poption : Type:=
  PSome : A -> Poption
| PNone : Poption.

Inductive Tree : Type :=
   Tempty : Tree
 | Branch0 : Tree -> Tree -> Tree
 | Branch1 : A -> Tree -> Tree -> Tree.

Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption :=
  match T with
    Tempty => PNone
  | Branch0 T1 T2 =>
    match p with
      xI pp => Tget pp T2
    | xO pp => Tget pp T1
    | xH => PNone
    end
  | Branch1 a T1 T2 =>
    match p with
      xI pp => Tget pp T2
    | xO pp => Tget pp T1
    | xH => PSome a
    end
end.

Fixpoint Tadd (p:positive) (a:A) (T:Tree) {struct p}: Tree :=
 match T with
   | Tempty =>
       match p with
       | xI pp => Branch0 Tempty (Tadd pp a Tempty)
       | xO pp => Branch0 (Tadd pp a Tempty) Tempty
       | xH => Branch1 a Tempty Tempty
       end
   | Branch0 T1 T2 =>
       match p with
       | xI pp => Branch0 T1 (Tadd pp a T2)
       | xO pp => Branch0 (Tadd pp a T1) T2
       | xH => Branch1 a T1 T2
       end
   | Branch1 b T1 T2 =>
       match p with
       | xI pp => Branch1 b T1 (Tadd pp a T2)
       | xO pp => Branch1 b (Tadd pp a T1) T2
       | xH => Branch1 a T1 T2
       end
   end.

Definition mkBranch0 (T1 T2:Tree) :=
  match T1,T2 with
    Tempty ,Tempty => Tempty
  | _,_ => Branch0 T1 T2
  end.

Fixpoint Tremove (p:positive) (T:Tree) {struct p}: Tree :=
   match T with
      | Tempty => Tempty
      | Branch0 T1 T2 =>
        match p with
        | xI pp => mkBranch0 T1 (Tremove pp T2)
        | xO pp => mkBranch0 (Tremove pp T1) T2
        | xH => T
        end
      | Branch1 b T1 T2 =>
        match p with
        | xI pp => Branch1 b T1 (Tremove pp T2)
        | xO pp => Branch1 b (Tremove pp T1) T2
        | xH => mkBranch0 T1 T2
        end
      end.

Theorem Tget_Tempty: forall (p : positive), Tget p (Tempty) = PNone.
destruct p;reflexivity.
Qed.

Theorem Tget_Tadd: forall i j a T,
       Tget i (Tadd j a T) =
       match (i ?= j) Eq with
         Eq => PSome a
       | Lt => Tget i T
       | Gt => Tget i T
       end.
intros i j.
caseq ((i ?= j) Eq).
intro H;rewrite (Pcompare_Eq_eq _ _ H);intros a;clear i H.
induction j;destruct T;simpl;try (apply IHj);congruence.
generalize i;clear i;induction j;destruct T;simpl in H|-*;
destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence.
generalize i;clear i;induction j;destruct T;simpl in H|-*;
destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence.
Qed.

Record Store : Type :=
mkStore  {index:positive;contents:Tree}.

Definition empty := mkStore xH Tempty.

Definition push a  S :=
mkStore (Psucc (index S)) (Tadd (index S) a (contents S)).

Definition get i S := Tget i (contents S).

Lemma get_empty : forall i, get i empty = PNone.
intro i; case i; unfold empty,get; simpl;reflexivity.
Qed.

Inductive Full : Store -> Type:=
    F_empty : Full empty
  | F_push : forall a S, Full S -> Full (push a S).

Theorem get_Full_Gt : forall S, Full S ->
       forall i, (i ?= index S) Eq = Gt -> get i S = PNone.
intros S W;induction W.
unfold empty,index,get,contents;intros;apply Tget_Tempty.
unfold index,get,push;simpl contents.
intros i e;rewrite Tget_Tadd.
rewrite (Gt_Psucc _ _ e).
unfold get in IHW.
apply IHW;apply Gt_Psucc;assumption.
Qed.

Theorem get_Full_Eq : forall S, Full S -> get (index S) S = PNone.
intros [index0 contents0] F.
case F.
unfold empty,index,get,contents;intros;apply Tget_Tempty.
unfold index,get,push;simpl contents.
intros a S.
rewrite Tget_Tadd.
rewrite Psucc_Gt.
intro W.
change (get (Psucc (index S)) S =PNone).
apply get_Full_Gt; auto.
apply Psucc_Gt.
Qed.

Theorem get_push_Full :
  forall i a S, Full S ->
  get i (push a S) =
  match (i ?= index S) Eq with
    Eq => PSome a
  | Lt => get i S
  | Gt => PNone
end.
intros i a S F.
caseq ((i ?= index S) Eq).
intro e;rewrite (Pcompare_Eq_eq _ _ e).
destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd.
rewrite Pcompare_refl;reflexivity.
intros;destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd.
simpl index in H;rewrite H;reflexivity.
intro H;generalize H;clear H.
unfold get,push;simpl index;simpl contents.
rewrite Tget_Tadd;intro e;rewrite e.
change (get i S=PNone).
apply get_Full_Gt;auto.
Qed.

Lemma Full_push_compat : forall i a S, Full S ->
forall x, get i S = PSome x ->
 get i (push a S) = PSome x.
intros i a S F x H.
caseq ((i ?= index S) Eq);intro test.
rewrite (Pcompare_Eq_eq _ _ test) in H.
rewrite (get_Full_Eq _ F) in H;congruence.
rewrite <- H.
rewrite (get_push_Full i a).
rewrite test;reflexivity.
assumption.
rewrite (get_Full_Gt _ F) in H;congruence.
Qed.

Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty.
intros [ind cont] F one; inversion F.
reflexivity.
simpl index in one;assert (h:=Psucc_not_one (index S)).
congruence.
Qed.

Lemma push_not_empty: forall a S, (push a S) <> empty.
intros a [ind cont];unfold push,empty.
simpl;intro H;injection H; intros _ ; apply Psucc_not_one.
Qed.

Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop :=
match F with
F_empty => False
| F_push a SS FF => x=a \/ In x SS FF
end.

Lemma get_In : forall (x:A) (S:Store) (F:Full S) i ,
get i S = PSome x -> In x S F.
induction F.
intro i;rewrite get_empty; congruence.
intro i;rewrite get_push_Full;trivial.
caseq ((i ?= index S) Eq);simpl.
left;congruence.
right;eauto.
congruence.
Qed.

End Store.

Implicit Arguments PNone [A].
Implicit Arguments PSome [A].

Implicit Arguments Tempty [A].
Implicit Arguments Branch0 [A].
Implicit Arguments Branch1 [A].

Implicit Arguments Tget [A].
Implicit Arguments Tadd [A].

Implicit Arguments Tget_Tempty [A].
Implicit Arguments Tget_Tadd [A].

Implicit Arguments mkStore [A].
Implicit Arguments index [A].
Implicit Arguments contents [A].

Implicit Arguments empty [A].
Implicit Arguments get [A].
Implicit Arguments push [A].

Implicit Arguments get_empty [A].
Implicit Arguments get_push_Full [A].

Implicit Arguments Full [A].
Implicit Arguments F_empty [A].
Implicit Arguments F_push [A].
Implicit Arguments In [A].

Section Map.

Variables A B:Set.

Variable f: A -> B.

Fixpoint Tmap (T: Tree A) : Tree B :=
match T with
Tempty => Tempty
| Branch0 t1 t2 => Branch0 (Tmap t1) (Tmap t2)
| Branch1 a t1 t2 => Branch1 (f a) (Tmap t1) (Tmap t2)
end.

Lemma Tget_Tmap: forall T i,
Tget i (Tmap T)= match Tget i T with PNone => PNone
| PSome a => PSome (f a) end.
induction T;intro i;case i;simpl;auto.
Defined.

Lemma Tmap_Tadd: forall i a T,
Tmap (Tadd i a T) = Tadd i (f a) (Tmap T).
induction i;intros a T;case T;simpl;intros;try (rewrite IHi);simpl;reflexivity.
Defined.

Definition map (S:Store A) : Store B :=
mkStore (index S) (Tmap (contents S)).

Lemma get_map: forall i S,
get i (map S)= match get i S with PNone => PNone
| PSome a => PSome (f a) end.
destruct S;unfold get,map,contents,index;apply Tget_Tmap.
Defined.

Lemma map_push: forall a S,
map (push a S) = push (f a) (map S).
intros a S.
case S.
unfold push,map,contents,index.
intros;rewrite Tmap_Tadd;reflexivity.
Defined.

Theorem Full_map : forall S, Full S -> Full (map S).
intros S F.
induction F.
exact F_empty.
rewrite map_push;constructor 2;assumption.
Defined.

End Map.

Implicit Arguments Tmap [A B].
Implicit Arguments map [A B].
Implicit Arguments Full_map [A B f].

Notation "hyps \ A" := (push A hyps) (at level 72,left associativity).


Definition Sk2_cf0_0 (n_ k_ : int) : rat :=
let n : rat := n_%:~R in
let k : rat := k_%:~R in
(- rat_of_Z 1 * (n + rat_of_Z 2 + k) * (- n + k + rat_of_Z 1) * (n + rat_of_Z 1 + k)^2 * (- n + k)^2) / (((k + rat_of_Z 1) * (k + rat_of_Z 2)^5)).

Definition Sk2_cf0_1 (n_ k_ : int) : rat :=
let n : rat := n_%:~R in
let k : rat := k_%:~R in
((n + rat_of_Z 2 + k) * (- n + k + rat_of_Z 1) * (rat_of_Z 2 * k^3 + rat_of_Z 8 * k^2 + rat_of_Z 11 * k + rat_of_Z 5 + - k * n + - k * n^2 + - rat_of_Z 2 * n^2 + - rat_of_Z 2 * n)) / ((k + rat_of_Z 2)^5).

Definition Sk2 (v : int -> int -> rat) := forall (n_ k_ : int), precond.Sk2 n_ k_ ->
v n_ (int.shift 2 k_) = Sk2_cf0_0 n_ k_ * v n_ k_ + Sk2_cf0_1 n_ k_ * v n_ (int.shift 1 k_).

Definition SnSk_cf0_0 (n_ k_ : int) : rat :=
let n : rat := n_%:~R in
let k : rat := k_%:~R in
((n + rat_of_Z 2 + k) * (- n + k) * (n + rat_of_Z 1 + k)^2) / ((k + rat_of_Z 1)^4).

Definition SnSk_cf1_0 (n_ k_ : int) : rat :=
let n : rat := n_%:~R in
let k : rat := k_%:~R in
((n + rat_of_Z 2 + k)^2 * (- n + - rat_of_Z 1 + k)^2) / ((k + rat_of_Z 1)^4).

Definition SnSk_cf0_1 (n_ k_ : int) : rat :=
let n : rat := n_%:~R in
let k : rat := k_%:~R in
(- n + - rat_of_Z 2 + - k) / ((- n + k)).

Definition SnSk (v : int -> int -> rat) := forall (n_ k_ : int), precond.SnSk n_ k_ ->
v (int.shift 1 n_) (int.shift 1 k_) = SnSk_cf0_0 n_ k_ * v n_ k_ + SnSk_cf1_0 n_ k_ * v (int.shift 1 n_) k_ + SnSk_cf0_1 n_ k_ * v n_ (int.shift 1 k_).

Definition Sn2_cf0_0 (n_ k_ : int) : rat :=
let n : rat := n_%:~R in
let k : rat := k_%:~R in
(- rat_of_Z 1 * (n + rat_of_Z 2 + k) * (rat_of_Z 2 + rat_of_Z 9 * n^2 + - rat_of_Z 3 * k * n + rat_of_Z 6 * k^2 + n^4 + rat_of_Z 5 * n^3 + rat_of_Z 6 * k^3 + k * n^3 + - k * n^2 + - rat_of_Z 4 * k^2 * n^2 + - rat_of_Z 2 * k^2 * n + rat_of_Z 4 * k^3 * n + k + rat_of_Z 7 * n) * (n + rat_of_Z 1 + k)^2) / (((n + rat_of_Z 2)^3 * (- n + - rat_of_Z 1 + k)^2 * (k + - n + - rat_of_Z 2)^2)).

Definition Sn2_cf1_0 (n_ k_ : int) : rat :=
let n : rat := n_%:~R in
let k : rat := k_%:~R in
((rat_of_Z 2 * n + rat_of_Z 3) * (n^2 + rat_of_Z 3 * n + rat_of_Z 3) * (n + rat_of_Z 2 + k)^2) / (((n + rat_of_Z 2)^3 * (k + - n + - rat_of_Z 2)^2)).

Definition Sn2_cf0_1 (n_ k_ : int) : rat :=
let n : rat := n_%:~R in
let k : rat := k_%:~R in
(rat_of_Z 2 * k * (rat_of_Z 2 * n + rat_of_Z 3) * (k + rat_of_Z 1)^5 * (n + rat_of_Z 2 + k)) / (((n + rat_of_Z 2)^3 * (- n + k) * (- n + - rat_of_Z 1 + k)^2 * (k + - n + - rat_of_Z 2)^2)).

Definition Sn2 (v : int -> int -> rat) := forall (n_ k_ : int), precond.Sn2 n_ k_ ->
v (int.shift 2 n_) k_ = Sn2_cf0_0 n_ k_ * v n_ k_ + Sn2_cf1_0 n_ k_ * v (int.shift 1 n_) k_ + Sn2_cf0_1 n_ k_ * v n_ (int.shift 1 k_).

Definition P_cf0 (n_ : int) : rat :=
let n : rat := n_%:~R in
((rat_of_Z 2 * n + rat_of_Z 7) * (rat_of_Z 928 + rat_of_Z 1266 * n + rat_of_Z 643 * n^2 + rat_of_Z 144 * n^3 + rat_of_Z 12 * n^4) * (n + rat_of_Z 1)^6).

Definition P_cf1 (n_ : int) : rat :=
let n : rat := n_%:~R in
(- rat_of_Z 1 * (rat_of_Z 2 * n + rat_of_Z 3) * (rat_of_Z 2 * n + rat_of_Z 7) * (rat_of_Z 408 * n^9 + rat_of_Z 7956 * n^8 + rat_of_Z 68086 * n^7 + rat_of_Z 336284 * n^6 + rat_of_Z 1058890 * n^5 + rat_of_Z 2209767 * n^4 + rat_of_Z 3063206 * n^3 + rat_of_Z 2724789 * n^2 + rat_of_Z 1413006 * n + rat_of_Z 325664)).

Definition P_cf2 (n_ : int) : rat :=
let n : rat := n_%:~R in
((rat_of_Z 2 * n + rat_of_Z 5) * (rat_of_Z 13896 * n^10 + rat_of_Z 347400 * n^9 + rat_of_Z 3868998 * n^8 + rat_of_Z 25269960 * n^7 + rat_of_Z 107159724 * n^6 + rat_of_Z 308199360 * n^5 + rat_of_Z 608681313 * n^4 + rat_of_Z 814935630 * n^3 + rat_of_Z 707785777 * n^2 + rat_of_Z 360083510 * n + rat_of_Z 81495208)).

Definition P_cf3 (n_ : int) : rat :=
let n : rat := n_%:~R in
(- rat_of_Z 1 * (rat_of_Z 2 * n + rat_of_Z 3) * (rat_of_Z 2 * n + rat_of_Z 7) * (rat_of_Z 408 * n^9 + rat_of_Z 10404 * n^8 + rat_of_Z 117046 * n^7 + rat_of_Z 761526 * n^6 + rat_of_Z 3153520 * n^5 + rat_of_Z 8607233 * n^4 + rat_of_Z 15461616 * n^3 + rat_of_Z 17602001 * n^2 + rat_of_Z 11509566 * n + rat_of_Z 3291016)).

Definition P_cf4 (n_ : int) : rat :=
let n : rat := n_%:~R in
((rat_of_Z 2 * n + rat_of_Z 3) * (rat_of_Z 12 * n^4 + rat_of_Z 96 * n^3 + rat_of_Z 283 * n^2 + rat_of_Z 364 * n + rat_of_Z 173) * (n + rat_of_Z 4)^6).

Definition P_flat (v : int -> rat) (n_ : int) : rat :=
P_cf0 n_ * v n_ + P_cf1 n_ * v (int.shift 1 n_) + P_cf2 n_ * v (int.shift 2 n_) + P_cf3 n_ * v (int.shift 3 n_) + P_cf4 n_ * v (int.shift 4 n_).

Definition P_seq := [:: P_cf0; P_cf1; P_cf2; P_cf3; P_cf4].

Definition P_horner := punk.horner_seqop P_seq.

Definition Q_cf0_0 (n_ k_ : int) : rat :=
let n : rat := n_%:~R in
let k : rat := k_%:~R in
(rat_of_Z 4 * k * (rat_of_Z 2 * n + rat_of_Z 5) * (rat_of_Z 2 * n + rat_of_Z 3) * (rat_of_Z 2 * n + rat_of_Z 7) * (rat_of_Z 1744402215 * k^2 * n^14 + - rat_of_Z 390926048 * k * n^15 + - rat_of_Z 1797543582 * k * n^14 + - rat_of_Z 27184619520 * n^2 + rat_of_Z 25107052032 * k * n + rat_of_Z 2077567488 * k^2 + - rat_of_Z 332796611328 * n^4 + - rat_of_Z 120646983168 * n^3 + - rat_of_Z 6189000960 * k^3 + - rat_of_Z 3452904576 * k^4 + rat_of_Z 258088741728 * k * n^3 + rat_of_Z 102524693760 * k * n^2 + rat_of_Z 121546930272 * k^2 * n^2 + rat_of_Z 23906184192 * k^2 * n + - rat_of_Z 47918897056 * k^3 * n + - rat_of_Z 453776761464 * k^4 * n^6 + - rat_of_Z 34208713762 * k^6 * n^4 + - rat_of_Z 29608827881 * k^6 * n^3 + rat_of_Z 5592448786 * k^8 * n + rat_of_Z 14155092397 * k^8 * n^2 + - rat_of_Z 616679187165 * k^3 * n^7 + rat_of_Z 2863226880 * k + - rat_of_Z 2863226880 * n + - rat_of_Z 673265061944 * k^3 * n^4 + - rat_of_Z 30134039386 * k^7 * n^2 + - rat_of_Z 328103820800 * n^10 + - rat_of_Z 859845193968 * n^8 + - rat_of_Z 591626761600 * n^9 + - rat_of_Z 998105211488 * n^7 + - rat_of_Z 10833443724 * k^7 * n + - rat_of_Z 911577929600 * n^6 + - rat_of_Z 639897370880 * n^5 + rat_of_Z 255690672 * k^9 + - rat_of_Z 409497350480 * k^3 * n^3 + - rat_of_Z 176289543184 * k^3 * n^2 + rat_of_Z 445980429568 * k * n^4 + rat_of_Z 779418105800 * k^2 * n^4 + rat_of_Z 372081953600 * k^2 * n^3 + - rat_of_Z 27857118128 * k^4 * n + rat_of_Z 555594416928 * k * n^5 + - rat_of_Z 405743014925 * k^4 * n^4 + - rat_of_Z 247666013854 * k^4 * n^3 + rat_of_Z 182888462394 * k^5 * n^3 + rat_of_Z 81436213660 * k^5 * n^2 + - rat_of_Z 18444006265 * k^6 * n^2 + - rat_of_Z 7247159210 * k^6 * n + - rat_of_Z 105299641272 * k^4 * n^2 + rat_of_Z 22679880432 * k^5 * n + - rat_of_Z 1333959512 * k^6 + - rat_of_Z 1822888416 * k^7 + rat_of_Z 1023021688 * k^8 + rat_of_Z 2997847184 * k^5 + rat_of_Z 63848152 * k^11 * n + - rat_of_Z 1719699936 * k^10 * n^3 + rat_of_Z 139771620 * k^11 * n^3 + rat_of_Z 123447892 * k^11 * n^2 + rat_of_Z 102640379 * k^11 * n^4 + rat_of_Z 17466166 * k^11 * n^6 + rat_of_Z 51093252 * k^11 * n^5 + - rat_of_Z 87428804 * k^10 * n^7 + - rat_of_Z 311211346 * k^10 * n^6 + - rat_of_Z 783589496 * k^10 * n^5 + - rat_of_Z 1394901560 * k^10 * n^4 + - rat_of_Z 674057028 * k^10 * n + - rat_of_Z 1397856374 * k^10 * n^2 + rat_of_Z 2124 * k^11 * n^10 + - rat_of_Z 5808 * k^10 * n^11 + - rat_of_Z 900 * k^9 * n^12 + rat_of_Z 14016 * k^8 * n^13 + - rat_of_Z 9660 * k^7 * n^14 + - rat_of_Z 7440 * k^6 * n^15 + rat_of_Z 13044 * k^5 * n^16 + - rat_of_Z 3456 * k^4 * n^17 + - rat_of_Z 3648 * k^3 * n^18 + rat_of_Z 3072 * k^2 * n^19 + rat_of_Z 53916 * k^11 * n^9 + - rat_of_Z 168060 * k^10 * n^10 + - rat_of_Z 7968 * k^9 * n^11 + rat_of_Z 439032 * k^8 * n^12 + - rat_of_Z 342996 * k^7 * n^13 + - rat_of_Z 234732 * k^6 * n^14 + rat_of_Z 482568 * k^5 * n^15 + - rat_of_Z 147696 * k^4 * n^16 + - rat_of_Z 144048 * k^3 * n^17 + rat_of_Z 128928 * k^2 * n^18 + - rat_of_Z 32256 * k * n^19 + rat_of_Z 610071 * k^11 * n^8 + - rat_of_Z 2193376 * k^10 * n^9 + rat_of_Z 154863 * k^9 * n^10 + rat_of_Z 6305692 * k^8 * n^11 + - rat_of_Z 5568967 * k^7 * n^12 + - rat_of_Z 3398600 * k^6 * n^13 + rat_of_Z 8280997 * k^5 * n^14 + - rat_of_Z 2912340 * k^4 * n^15 + - rat_of_Z 2673124 * k^3 * n^16 + rat_of_Z 2543776 * k^2 * n^17 + - rat_of_Z 631552 * k * n^18 + rat_of_Z 4050412 * k^11 * n^7 + - rat_of_Z 17034532 * k^10 * n^8 + rat_of_Z 3467507 * k^9 * n^9 + rat_of_Z 55016357 * k^8 * n^10 + - rat_of_Z 54855522 * k^7 * n^11 + - rat_of_Z 29964918 * k^6 * n^12 + rat_of_Z 87494875 * k^5 * n^13 + - rat_of_Z 35252851 * k^4 * n^14 + - rat_of_Z 31003896 * k^3 * n^15 + rat_of_Z 31367368 * k^2 * n^16 + - rat_of_Z 7645312 * k * n^17 + - rat_of_Z 252131679 * k^3 * n^14 + rat_of_Z 271060288 * k^2 * n^15 + - rat_of_Z 63952392 * k * n^16 + - rat_of_Z 3685794720 * n^14 + - rat_of_Z 681771968 * n^15 + - rat_of_Z 97183888 * n^16 + - rat_of_Z 10296800 * n^17 + - rat_of_Z 768 * n^20 + - rat_of_Z 35328 * n^19 + - rat_of_Z 763360 * n^18 + rat_of_Z 325582047 * k^8 * n^9 + - rat_of_Z 366581765 * k^7 * n^10 + - rat_of_Z 180195424 * k^6 * n^11 + rat_of_Z 637095193 * k^5 * n^12 + - rat_of_Z 293786083 * k^4 * n^13 + rat_of_Z 1381460896 * k^8 * n^8 + - rat_of_Z 1759973356 * k^7 * n^9 + - rat_of_Z 785707110 * k^6 * n^10 + rat_of_Z 3390299217 * k^5 * n^11 + - rat_of_Z 1790786379 * k^4 * n^12 + - rat_of_Z 1528641105 * k^3 * n^13 + rat_of_Z 4329005311 * k^8 * n^7 + - rat_of_Z 6267925410 * k^7 * n^8 + - rat_of_Z 2584329138 * k^6 * n^9 + rat_of_Z 13641244822 * k^5 * n^10 + - rat_of_Z 8275822234 * k^4 * n^11 + - rat_of_Z 7171164950 * k^3 * n^12 + rat_of_Z 8671244945 * k^2 * n^13 + rat_of_Z 10157899122 * k^8 * n^6 + - rat_of_Z 16846739030 * k^7 * n^7 + - rat_of_Z 6608736882 * k^6 * n^8 + rat_of_Z 42343375448 * k^5 * n^9 + - rat_of_Z 29644875275 * k^4 * n^10 + - rat_of_Z 26657515127 * k^3 * n^11 + rat_of_Z 34074345499 * k^2 * n^12 + - rat_of_Z 6281404994 * k * n^13 + rat_of_Z 17873852947 * k^8 * n^5 + - rat_of_Z 34403563419 * k^7 * n^6 + - rat_of_Z 13486898969 * k^6 * n^7 + rat_of_Z 102510705804 * k^5 * n^8 + - rat_of_Z 83411422057 * k^4 * n^9 + - rat_of_Z 79729894768 * k^3 * n^10 + rat_of_Z 107414839637 * k^2 * n^11 + - rat_of_Z 16511136494 * k * n^12 + rat_of_Z 23326085212 * k^8 * n^4 + - rat_of_Z 53241708152 * k^7 * n^5 + - rat_of_Z 22441935459 * k^6 * n^6 + rat_of_Z 194292424443 * k^5 * n^7 + - rat_of_Z 185590186906 * k^4 * n^8 + - rat_of_Z 193594433821 * k^3 * n^9 + rat_of_Z 273992904577 * k^2 * n^10 + - rat_of_Z 31057152218 * k * n^11 + - rat_of_Z 383034928990 * k^3 * n^8 + rat_of_Z 567647259943 * k^2 * n^9 + - rat_of_Z 34242238930 * k * n^10 + - rat_of_Z 15710071840 * n^13 + - rat_of_Z 147311006048 * n^11 + - rat_of_Z 53560818048 * n^12 + - rat_of_Z 146056688 * k^10 + rat_of_Z 954502237105 * k^2 * n^8 + rat_of_Z 9342208346 * k * n^9 + - rat_of_Z 768 * k * n^20 + rat_of_Z 134837704206 * k * n^8 + - rat_of_Z 490926362370 * k^4 * n^5 + rat_of_Z 286016170951 * k^5 * n^4 + rat_of_Z 506405609304 * k * n^6 + rat_of_Z 1197029877604 * k^2 * n^5 + - rat_of_Z 802371636049 * k^3 * n^6 + - rat_of_Z 832398382758 * k^3 * n^5 + rat_of_Z 329600901794 * k * n^7 + rat_of_Z 1295827185263 * k^2 * n^7 + rat_of_Z 1405464163068 * k^2 * n^6 + rat_of_Z 1211927256 * k^9 * n + rat_of_Z 3251918342 * k^9 * n^3 + rat_of_Z 2579633352 * k^9 * n^2 + rat_of_Z 2693929255 * k^9 * n^4 + rat_of_Z 31316929 * k^9 * n^8 + rat_of_Z 169665992 * k^9 * n^7 + rat_of_Z 612974365 * k^9 * n^6 + rat_of_Z 1536374559 * k^9 * n^5 + rat_of_Z 14685520 * k^11 + - rat_of_Z 61627367257 * k^7 * n^4 + - rat_of_Z 326900137446 * k^4 * n^7 + - rat_of_Z 51889742508 * k^7 * n^3 + rat_of_Z 329102354583 * k^5 * n^5 + rat_of_Z 21970944881 * k^8 * n^3 + rat_of_Z 287538055025 * k^5 * n^6 + - rat_of_Z 30741445978 * k^6 * n^5)) / (((- n + - rat_of_Z 1 + k)^2 * (- n + - rat_of_Z 4 + k)^2 * (n + rat_of_Z 3)^3 * (n + rat_of_Z 2)^3 * (k + - n + - rat_of_Z 3)^2 * (- n + - rat_of_Z 2 + k)^2)).

Definition Q_cf1_0 (n_ k_ : int) : rat :=
let n : rat := n_%:~R in
let k : rat := k_%:~R in
(- rat_of_Z 4 * (rat_of_Z 2 * n + rat_of_Z 5) * (rat_of_Z 2 * n + rat_of_Z 3) * (rat_of_Z 2 * n + rat_of_Z 7) * (- rat_of_Z 768 * k^2 * n^14 + rat_of_Z 3456 * k * n^15 + rat_of_Z 128352 * k * n^14 + - rat_of_Z 67908067008 * n^2 + rat_of_Z 9099997808 * k * n + rat_of_Z 310664672 * k^2 + - rat_of_Z 175893838000 * n^4 + - rat_of_Z 131207942960 * n^3 + - rat_of_Z 169882072 * k^3 + rat_of_Z 16459280 * k^4 + rat_of_Z 52615736598 * k * n^3 + rat_of_Z 27869086208 * k * n^2 + rat_of_Z 4186382212 * k^2 * n^2 + rat_of_Z 1686931392 * k^2 * n + - rat_of_Z 944024994 * k^3 * n + rat_of_Z 114305270 * k^4 * n^6 + - rat_of_Z 693288259 * k^3 * n^7 + rat_of_Z 1381092384 * k + - rat_of_Z 21794233216 * n + - rat_of_Z 3964985038 * k^3 * n^4 + - rat_of_Z 3448870336 * n^10 + - rat_of_Z 34419976280 * n^8 + - rat_of_Z 12314690524 * n^9 + - rat_of_Z 75583675964 * n^7 + - rat_of_Z 130014624048 * n^6 + - rat_of_Z 173414173068 * n^5 + - rat_of_Z 3754252403 * k^3 * n^3 + - rat_of_Z 2412870465 * k^3 * n^2 + rat_of_Z 68467857071 * k * n^4 + rat_of_Z 6286099260 * k^2 * n^4 + rat_of_Z 6267688586 * k^2 * n^3 + rat_of_Z 88023212 * k^4 * n + rat_of_Z 65027372713 * k * n^5 + rat_of_Z 316850268 * k^4 * n^4 + rat_of_Z 318395514 * k^4 * n^3 + rat_of_Z 215308166 * k^4 * n^2 + - rat_of_Z 1240448 * n^14 + - rat_of_Z 63984 * n^15 + - rat_of_Z 1536 * n^16 + rat_of_Z 768 * k^4 * n^12 + - rat_of_Z 1728 * k^3 * n^13 + rat_of_Z 21912 * k^4 * n^11 + - rat_of_Z 57072 * k^3 * n^12 + - rat_of_Z 20472 * k^2 * n^13 + rat_of_Z 284200 * k^4 * n^10 + - rat_of_Z 861540 * k^3 * n^11 + - rat_of_Z 229168 * k^2 * n^12 + rat_of_Z 2207580 * k * n^13 + rat_of_Z 2216476 * k^4 * n^9 + - rat_of_Z 7872580 * k^3 * n^10 + - rat_of_Z 1284268 * k^2 * n^11 + rat_of_Z 23327476 * k * n^12 + rat_of_Z 11581872 * k^4 * n^8 + - rat_of_Z 48600970 * k^3 * n^9 + - rat_of_Z 2229148 * k^2 * n^10 + rat_of_Z 169390270 * k * n^11 + - rat_of_Z 214150124 * k^3 * n^8 + rat_of_Z 19636326 * k^2 * n^9 + rat_of_Z 895491960 * k * n^10 + - rat_of_Z 14858072 * n^13 + - rat_of_Z 747916132 * n^11 + - rat_of_Z 123087048 * n^12 + rat_of_Z 178983116 * k^2 * n^8 + rat_of_Z 3561379481 * k * n^9 + rat_of_Z 10853226951 * k * n^8 + rat_of_Z 223378412 * k^4 * n^5 + rat_of_Z 46548168958 * k * n^6 + rat_of_Z 4425270962 * k^2 * n^5 + - rat_of_Z 1670758425 * k^3 * n^6 + - rat_of_Z 2999441626 * k^3 * n^5 + rat_of_Z 25562116926 * k * n^7 + rat_of_Z 780005826 * k^2 * n^7 + rat_of_Z 2218767840 * k^2 * n^6 + - rat_of_Z 3268333056 + rat_of_Z 42741626 * k^4 * n^7) * k^4) / (((- n + - rat_of_Z 2 + k)^2 * (- n + - rat_of_Z 4 + k)^2 * (n + rat_of_Z 2)^3 * (n + rat_of_Z 3)^3 * (k + - n + - rat_of_Z 3)^2)).

Definition Q_cf0_1 (n_ k_ : int) : rat :=
let n : rat := n_%:~R in
let k : rat := k_%:~R in
(- rat_of_Z 4 * k * (rat_of_Z 2 * n + rat_of_Z 5) * (rat_of_Z 2 * n + rat_of_Z 3) * (rat_of_Z 2 * n + rat_of_Z 7) * (k + rat_of_Z 1)^5 * (rat_of_Z 285984 * k^2 * n^14 + - rat_of_Z 157920 * k * n^15 + - rat_of_Z 3026048 * k * n^14 + rat_of_Z 74867424768 * n^2 + - rat_of_Z 44680889088 * k * n + rat_of_Z 5162764032 * k^2 + rat_of_Z 241822754048 * n^4 + rat_of_Z 161603596032 * n^3 + - rat_of_Z 1744849824 * k^3 + - rat_of_Z 744986544 * k^4 + - rat_of_Z 281708015936 * k * n^3 + - rat_of_Z 142716403296 * k * n^2 + rat_of_Z 96887337056 * k^2 * n^2 + rat_of_Z 32825580096 * k^2 * n + - rat_of_Z 10344114032 * k^3 * n + - rat_of_Z 3469900135 * k^4 * n^6 + - rat_of_Z 1842594317 * k^6 * n^4 + - rat_of_Z 2262462688 * k^6 * n^3 + - rat_of_Z 13217484828 * k^3 * n^7 + - rat_of_Z 6512113152 * k + rat_of_Z 21458165760 * n + - rat_of_Z 54560718080 * k^3 * n^4 + rat_of_Z 123447892 * k^7 * n^2 + rat_of_Z 10042207744 * n^10 + rat_of_Z 75468444096 * n^8 + rat_of_Z 30900177104 * n^9 + rat_of_Z 146266755504 * n^7 + rat_of_Z 63848152 * k^7 * n + rat_of_Z 223624806496 * n^6 + rat_of_Z 266328825472 * n^5 + - rat_of_Z 47534432700 * k^3 * n^3 + - rat_of_Z 28334986440 * k^3 * n^2 + - rat_of_Z 384634123200 * k * n^4 + rat_of_Z 220377639732 * k^2 * n^4 + rat_of_Z 176090065112 * k^2 * n^3 + - rat_of_Z 3766672224 * k^4 * n + - rat_of_Z 385205224120 * k * n^5 + - rat_of_Z 11108830969 * k^4 * n^4 + - rat_of_Z 11977447248 * k^4 * n^3 + rat_of_Z 11326819614 * k^5 * n^3 + rat_of_Z 8499441560 * k^5 * n^2 + - rat_of_Z 1832048202 * k^6 * n^2 + - rat_of_Z 880287004 * k^6 * n + - rat_of_Z 8659675144 * k^4 * n^2 + rat_of_Z 3824239688 * k^5 * n + - rat_of_Z 190113248 * k^6 + rat_of_Z 14685520 * k^7 + rat_of_Z 780109264 * k^5 + - rat_of_Z 6720 * k^3 * n^14 + rat_of_Z 7488 * k^2 * n^15 + - rat_of_Z 3840 * k * n^16 + rat_of_Z 8872992 * n^14 + rat_of_Z 695008 * n^15 + rat_of_Z 33792 * n^16 + rat_of_Z 768 * n^17 + rat_of_Z 2124 * k^7 * n^10 + - rat_of_Z 7932 * k^6 * n^11 + rat_of_Z 8772 * k^5 * n^12 + - rat_of_Z 372 * k^4 * n^13 + rat_of_Z 53916 * k^7 * n^9 + - rat_of_Z 228348 * k^6 * n^10 + rat_of_Z 285576 * k^5 * n^11 + - rat_of_Z 24444 * k^4 * n^12 + - rat_of_Z 236508 * k^3 * n^13 + rat_of_Z 610071 * k^7 * n^8 + - rat_of_Z 2965195 * k^6 * n^9 + rat_of_Z 4228061 * k^5 * n^10 + - rat_of_Z 563929 * k^4 * n^11 + - rat_of_Z 3845816 * k^3 * n^12 + rat_of_Z 5069472 * k^2 * n^13 + rat_of_Z 4050412 * k^7 * n^7 + - rat_of_Z 22915157 * k^6 * n^8 + rat_of_Z 37634766 * k^5 * n^9 + - rat_of_Z 7062201 * k^4 * n^10 + - rat_of_Z 38297128 * k^3 * n^11 + rat_of_Z 55326472 * k^2 * n^12 + - rat_of_Z 35860680 * k * n^13 + rat_of_Z 17466166 * k^7 * n^6 + - rat_of_Z 117046206 * k^6 * n^7 + rat_of_Z 224250307 * k^5 * n^8 + - rat_of_Z 56308591 * k^4 * n^9 + - rat_of_Z 260924075 * k^3 * n^10 + rat_of_Z 415735739 * k^2 * n^11 + - rat_of_Z 294146400 * k * n^12 + rat_of_Z 51093252 * k^7 * n^5 + - rat_of_Z 414703096 * k^6 * n^6 + rat_of_Z 942042570 * k^5 * n^7 + - rat_of_Z 308693091 * k^4 * n^8 + - rat_of_Z 1286667926 * k^3 * n^9 + rat_of_Z 2278300097 * k^2 * n^10 + - rat_of_Z 1770637850 * k * n^11 + - rat_of_Z 4735827930 * k^3 * n^8 + rat_of_Z 9406632852 * k^2 * n^9 + - rat_of_Z 8090727306 * k * n^10 + rat_of_Z 78742896 * n^13 + rat_of_Z 2576225456 * n^11 + rat_of_Z 515413184 * n^12 + rat_of_Z 29795852850 * k^2 * n^8 + - rat_of_Z 28624383652 * k * n^9 + - rat_of_Z 79238310868 * k * n^8 + - rat_of_Z 7286006265 * k^4 * n^5 + rat_of_Z 10083400273 * k^5 * n^4 + - rat_of_Z 292723611810 * k * n^6 + rat_of_Z 201162981114 * k^2 * n^5 + - rat_of_Z 28108959555 * k^3 * n^6 + - rat_of_Z 45328273270 * k^3 * n^5 + - rat_of_Z 172186812834 * k * n^7 + rat_of_Z 73002514895 * k^2 * n^7 + rat_of_Z 138352054849 * k^2 * n^6 + rat_of_Z 102640379 * k^7 * n^4 + - rat_of_Z 1211427691 * k^4 * n^7 + rat_of_Z 139771620 * k^7 * n^3 + rat_of_Z 6319292362 * k^5 * n^5 + rat_of_Z 2859841811 * k^5 * n^6 + - rat_of_Z 1039509631 * k^6 * n^5 + rat_of_Z 2863226880)) / (((- n + k) * (k + - n + - rat_of_Z 3)^2 * (- n + - rat_of_Z 4 + k)^2 * (- n + - rat_of_Z 1 + k)^2 * (n + rat_of_Z 3)^3 * (n + rat_of_Z 2)^3 * (- n + - rat_of_Z 2 + k)^2)).

Definition Q_flat (v : int -> int -> rat) (n_ k_ : int) : rat :=
Q_cf0_0 n_ k_ * v n_ k_ + Q_cf1_0 n_ k_ * v (int.shift 1 n_) k_ + Q_cf0_1 n_ k_ * v n_ (int.shift 1 k_).

Definition Q_seq := [:: [:: Q_cf0_0; Q_cf1_0]; [:: Q_cf0_1]].

Definition Q_horner := punk.biv_horner_seqop2 Q_seq.


(* Copyright (c) 2014, Robert Dockins *)

Require Import List.
Require Import NArith.

Require Import basics.
Require Import categories.
Require Import preord.
Require Import sets.
Require Import finsets.
Require Import esets.
Require Import effective.
Require Import plotkin.
Require Import profinite.
Require Import embed.
Require Import joinable.
Require Import directed.
Require Import cont_functors.
Require Import bilimit.

(**  * Sum and product functors

     Here we define the functors for sum and produce in the category
     of embeddings and show that they are continuous.
  *)

Section prod_functor.
  Variable hf:bool.
  Variables A B C D:ob (EMBED hf).

  Variable f:A ⇀ B.
  Variable g:C ⇀ D.

  Program Definition prod_fmap : PLT.prod A C ⇀ PLT.prod B D
    := Embedding hf (PLT.prod A C) (PLT.prod B D) (fun x => (f (fst x), g (snd x)))
         _ _ _ _.
  Next Obligation.
    intros. destruct a as [a c]. destruct a' as [a' c']. simpl.
    destruct H. simpl in *.
    split; simpl; apply embed_mono; auto.
  Qed.
  Next Obligation.
    intros. destruct a as [a c]. destruct a' as [a' c']. simpl.
    destruct H. simpl in *.
    split; simpl.
    apply embed_reflects in H. auto.
    apply embed_reflects in H0. auto.
  Qed.
  Next Obligation.
    intros [b d]. simpl.
    destruct hf. auto.
    simpl.
    destruct (embed_directed0 f b).
    destruct (embed_directed0 g d).
    exists (x,x0). simpl. split; auto.
  Qed.
  Next Obligation.
    intros.
    destruct a as [a c].
    destruct b as [a' c']. simpl in *.
    destruct (embed_directed2 f (fst y) a a') as [p [?[??]]].
    destruct H; auto. destruct H0; auto.
    destruct (embed_directed2 g (snd y) c c') as [q [?[??]]].
    destruct H; auto. destruct H0; auto.
    exists (p,q). simpl.
    repeat split; auto.
  Qed.

End prod_functor.

Program Definition prodF hf
  : functor (PROD (EMBED hf) (EMBED hf)) (EMBED hf) :=

  Functor (PROD (EMBED hf) (EMBED hf)) (EMBED hf)
     (fun (AB:ob (PROD (EMBED hf) (EMBED hf))) =>
         PLT.prod (@obl (EMBED hf) (EMBED hf) AB)
                  (@obr (EMBED hf) (EMBED hf) AB))
     (fun (AB CD:ob (PROD (EMBED hf) (EMBED hf))) (f:AB → CD) =>
       prod_fmap hf _ _ _ _
         (@homl (EMBED hf) (EMBED hf) AB CD f)
         (@homr (EMBED hf) (EMBED hf) AB CD f))
     _ _ _.
Next Obligation.
  simpl; intros.
  destruct f; simpl in *.
  apply embed_lift'; simpl; intros.
  destruct x as [x y]. simpl.
  destruct H. simpl in *.
  destruct H; destruct H0; split; split; simpl; auto.
  apply H. apply H0. apply H1. apply H2.
Qed.
Next Obligation.
  simpl; intros.
  destruct f; simpl in *.
  destruct g; simpl in *.
  destruct h; simpl in *.
  destruct H; simpl in *.
  apply embed_lift'; simpl; intros.
  split; split; simpl.
  rewrite H. auto.
  rewrite H0; auto.
  rewrite H; auto.
  rewrite H0; auto.
Qed.
Next Obligation.
  simpl; intros.
  destruct f; simpl in *.
  destruct g; simpl in *.
  destruct H; simpl in *.
  apply embed_lift'; simpl; intros.
  split; split; simpl.
  rewrite H. auto.
  rewrite H0; auto.
  rewrite H; auto.
  rewrite H0; auto.
Qed.

Lemma prodF_continuous hf : continuous_functor (prodF hf).
Proof.
  hnf; intros.
  apply decompose_is_colimit.
  simpl. intros.
  destruct x as [x y].
  generalize (fstF_continuous _ _ I DS CC X). intros.
  generalize (sndF_continuous _ _ I DS CC X). intros.
  destruct (colimit_decompose hf I _ _ X0 x) as [i [x' ?]].
  destruct (colimit_decompose hf I _ _ X1 y) as [j [y' ?]].
  simpl in *.
  destruct (choose_ub I i j) as [k [??]].
  exists k.
  exists (homl (ds_hom DS i k H) x', homr (ds_hom DS j k H0) y').
  simpl.
  generalize (cocone_commute CC i k H).
  generalize (cocone_commute CC j k H0).
  intros. destruct H1. destruct H2.
  rewrite H2 in e.
  rewrite H3 in e0.
  simpl in *.
  destruct e; destruct e0; split; split; auto.
Qed.

Section sum_functor.
  Variable hf:bool.
  Variables A B C D:ob (EMBED hf).

  Variable f:A ⇀ B.
  Variable g:C ⇀ D.

  Definition sum_fmap_func (x:A+C) : B+D :=
    match x with
    | inl a => inl (f a)
    | inr b => inr (g b)
    end.

  Program Definition sum_fmap : PLT.sum A C ⇀ PLT.sum B D
    := Embedding hf (PLT.sum A C) (PLT.sum B D) sum_fmap_func _ _ _ _.
  Next Obligation.
    intros. destruct a as [a|c]. destruct a' as [a'|c']; simpl.
    apply embed_mono; auto.
    elim H.
    destruct a' as [a'|c']; simpl.
    elim H.
    apply embed_mono; auto.
  Qed.
  Next Obligation.
    intros.
    destruct a as [a|c].
    destruct a' as [a'|c']. simpl.
    simpl in H. red in H. simpl in H.
    apply embed_reflects in H. auto.
    elim H.
    destruct a' as [a'|c']. simpl.
    destruct H.
    red in H. simpl in H.
    apply embed_reflects in H. auto.
  Qed.
  Next Obligation.
    intro y. simpl in *. unfold sum_fmap_func.
    destruct hf. auto.
    destruct y as [b|d]. simpl.
    destruct (embed_directed0 f b).
    exists (inl x). auto.
    destruct (embed_directed0 g d).
    exists (inr x). auto.
  Qed.
  Next Obligation.
    intros.
    destruct y as [y|y].
    destruct a as [a|a]. 2: elim H.
    destruct b as [b|b]. 2: elim H0.
    unfold sum_fmap_func in *.
    destruct (embed_directed2 f y a b) as [p [?[??]]]; auto.
    exists (inl p). auto.
    destruct a as [a|a]. elim H.
    destruct b as [b|b]. elim H0.
    unfold sum_fmap_func in *.
    destruct (embed_directed2 g y a b) as [p [?[??]]]; auto.
    exists (inr p). auto.
  Qed.
End sum_functor.

Program Definition sumF hf
  : functor (PROD (EMBED hf) (EMBED hf)) (EMBED hf) :=

  Functor (PROD (EMBED hf) (EMBED hf)) (EMBED hf)
     (fun (AB:ob (PROD (EMBED hf) (EMBED hf))) =>
         PLT.sum (@obl (EMBED hf) (EMBED hf) AB)
                 (@obr (EMBED hf) (EMBED hf) AB))
     (fun (AB CD:ob (PROD (EMBED hf) (EMBED hf))) (f:AB → CD) =>
       sum_fmap hf _ _ _ _
         (@homl (EMBED hf) (EMBED hf) AB CD f)
         (@homr (EMBED hf) (EMBED hf) AB CD f))
     _ _ _.
Next Obligation.
  simpl; intros.
  destruct f; simpl in *.
  apply embed_lift'; simpl; intros.
  destruct x as [x|x]. simpl.
  destruct H. simpl in *.
  destruct H; split. apply H. apply H1.
  simpl.
  destruct H. simpl in *.
  destruct H0. split. apply H0. apply H1.
Qed.
Next Obligation.
  simpl; intros.
  destruct f; simpl in *.
  destruct g; simpl in *.
  destruct h; simpl in *.
  destruct H; simpl in *.
  apply embed_lift'; simpl; intros.
  unfold sum_fmap_func.
  destruct x as [x|x].
  destruct H; split.
  apply H. apply H1.
  destruct H0; split.
  apply H0. apply H1.
Qed.
Next Obligation.
  simpl; intros.
  destruct f; simpl in *.
  destruct g; simpl in *.
  destruct H; simpl in *.
  apply embed_lift'; simpl; intros.
  unfold sum_fmap_func.
  destruct x as [x|x].
  destruct H; split.
  apply H. apply H1.
  destruct H0; split.
  apply H0. apply H1.
Qed.

Lemma sumF_continuous hf : continuous_functor (sumF hf).
Proof.
  hnf; intros.
  apply decompose_is_colimit.
  simpl. intros.
  destruct x as [x|x].
  generalize (fstF_continuous _ _ I DS CC X). intros.
  destruct (colimit_decompose hf I _ _ X0 x) as [i [x' ?]].
  exists i. exists (inl x').
  simpl. destruct e; auto.
  generalize (sndF_continuous _ _ I DS CC X). intros.
  destruct (colimit_decompose hf I _ _ X0 x) as [i [x' ?]].
  exists i. exists (inr x').
  simpl. destruct e; auto.
Qed.


Require Import Decidable.
Require Import References.
Require Import AccessRights.
Require Import FSets.
Require Import OrderedTypeEx.
(* type_remove *)
Require Import AccessEdge.

Module Make (R: ReferenceType) : AccessEdgeType R.

  Module AccessArrow := !PairOrderedType R AccessRight.

  Module AccessEdge := !PairOrderedType R AccessArrow.

  Definition mkEdge (src tgt:R.t) (rgt:accessRight): AccessEdge.t :=
    (pair src (pair tgt rgt)).

  Definition source (edge : AccessEdge.t) := fst edge.
  Definition target (edge : AccessEdge.t) := fst (snd edge).
  Definition right (edge : AccessEdge.t) := snd (snd edge).

  Theorem eq_equal : forall edge edge',
    AccessEdge.eq edge edge' <-> edge = edge'.
  Proof.
    intros.
    split; intros.
    destruct edge as [src arrow]; destruct arrow as [tgt rgt]; destruct edge' as [src' arrow']; destruct arrow' as [tgt' rgt'].
    unfold AccessEdge.eq in H.
    destruct H as [H H0]; simpl in H;
    destruct H0 as [H0 H1]; simpl in H0; simpl in H1.
    unfold R.eq in *; unfold AccessRight.eq in *.
    rewrite H; rewrite H0; rewrite H1.
    trivial.
    unfold AccessEdge.eq.
    rewrite H.
    unfold AccessArrow.eq; unfold AccessRight.eq; unfold R.eq;
    auto.
  Qed.

  Theorem eq_source : forall edge edge':AccessEdge.t,
    AccessEdge.eq edge edge' -> R.eq (source edge) (source edge').
  Proof.
    intros.
    unfold AccessEdge.eq in H.
    destruct H.
    unfold AccessArrow.eq in H0.
    destruct H0.
    assumption.
  Qed.

  Theorem eq_target : forall edge edge':AccessEdge.t,
    AccessEdge.eq edge edge' -> R.eq (target edge) (target edge').
  Proof.
    intros.
    unfold AccessEdge.eq in H.
    destruct H.
    unfold AccessArrow.eq in H0.
    destruct H0.
    assumption.
  Qed.

  Theorem eq_right : forall edge edge':AccessEdge.t,
    AccessEdge.eq edge edge' -> AccessRight.eq (right edge) (right edge').
  Proof.
    intros.
    unfold AccessEdge.eq in H.
    destruct H.
    unfold AccessArrow.eq in H0.
    destruct H0.
    assumption.
  Qed.

(*  Hint Resolve eq_source eq_target eq_right. *)

  Theorem edge_equal : forall (src src' tgt tgt':R.t) (rgt rgt':accessRight),
    R.eq src src' -> R.eq tgt tgt' -> AccessRight.eq rgt rgt' -> AccessEdge.eq (mkEdge src tgt rgt) (mkEdge src' tgt' rgt').
  Proof.
    intros.
    unfold mkEdge.
    unfold AccessEdge.eq.
    unfold AccessArrow.eq.
    unfold AccessRight.eq.
    simpl.
    split;[eauto|split;eauto].
  Qed.

  Theorem edge_rewrite : forall edge:AccessEdge.t,
    mkEdge (source edge) (target edge) (right edge) = edge.
  Proof.
    intros.
    destruct edge as [src arrow].
    destruct arrow as [tgt rgt].
    eauto.
  Qed.

  Hint Rewrite edge_rewrite : caps_rewrite.

  Theorem source_rewrite: forall src tgt rgt,
    (source (mkEdge src tgt rgt)) = src.
  Proof.
    intuition.
  Qed.
  Theorem target_rewrite: forall src tgt rgt,
    (target (mkEdge src tgt rgt)) = tgt.
  Proof.
    intuition.
  Qed.
  Theorem right_rewrite: forall src tgt rgt,
    (right (mkEdge src tgt rgt)) = rgt.
  Proof.
    intuition.
  Qed.

  Hint Rewrite source_rewrite right_rewrite target_rewrite : caps_rewrite.

End Make.


Inductive SimpParamItrp D (G:DCtx D) (F:Typ D) : list nat->forall T:Typ G,(forall g,F (dctx_d G g)->T g)->Type :=
	spItrpNil : SimpParamItrp D G F nil (typMap (dctx_d G) F) (fun g f=>tr (fun X=>X g) (typMapEq _ F) f) |
	spItrpCons a la P (a':AtCtx G a P) B la' :
		SimpParamItrp D G F la (pi P B) la'->
		SimpParamItrp D G F (a :: la) (typMap (fun g=>existT _ g (ctxProj a' g)) B)
			(fun g f=>tr (fun X=>X g) (typMapEq _ B) (la' g f (ctxProj a' g))).
Implicit Arguments SimpParamItrp [D].

Inductive SimpFamItrp D (G:DCtx D) : simpFam->Typ G->Type :=
	sfItrpNil : SimpFamItrp D G nil (uv G) |
	sfItrpCons f la T (F:Typ D) (f':AtCtx D f F) la' T' :
		SimpParamItrp G F la (uv G) la'->
		SimpFamItrp D (extDCtx G (fun g=>la' g (ctxProj f' (dctx_d G g)))) T T'->
		SimpFamItrp D G ((f,la) :: T) (pi _ T').

Inductive SimpFCtxItrp : list simpFam->Ctx->Type :=
	sfcItrpNil : SimpFCtxItrp nil empCtx |
	sfcItrpCons F D D' F' :
		SimpFCtxItrp D D'->
		SimpFamItrp D' (empDCtx D') F F'->
		SimpFCtxItrp (F :: D) (extCtx D' F').

Inductive SimpPCtxItrp D : list (nat * list nat)->DCtx D->Type :=
	spcItrpNil : SimpPCtxItrp D nil (empDCtx D) |
	spcItrpCons f la G G' (F:Typ D) (f':AtCtx D f F) la' :
		SimpPCtxItrp D G G'->
		SimpParamItrp G' F la (uv G') la'->
		SimpPCtxItrp D ((f,la) :: G) (extDCtx G' (fun g=>la' g (ctxProj f' (dctx_d G' g)))).