(*

  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: Abhishek Anand & Vincent Rahli

*)

Require Export sequents_tacs.
Require Export sequents_useful.
Require Export per_props_equality.
Require Export per_props_pertype.
Require Export sequents_equality.
Require Export list. (* why *)
(** printing |- $\vdash$ *)
(** printing ->  $\rightarrow$ *)
(* begin hide *)

(* end hide *)

(**

  We now prove the truth of several rules about the intensional PER type.

*)

(* [14] ============ IPERTYPE MEMBER EQUALITY ============ *)

(**

  The following rule is called the ``ipertype member equality'' rule.
  It allows one to prove that terms are well-formed partial
  equivalence relations, i.e., members of a ``ipertype'' type.
<<
   H |- t1 = t2 in ipertype(R)

     By ipertypeMemberEquality i

     H |- ipertype(R) in Type(i)
     H |- R t1 t2
     H |- t1 in Base
>>
 *)

Definition rule_ipertype_member_equality {o}
           (t1 t2 R e : NTerm)
           (i : nat)
           (H : @barehypotheses o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality t1 t2 (mk_ipertype R))))
    [ mk_baresequent H (mk_conclax (mk_member (mk_ipertype R) (mk_uni i))),
      mk_baresequent H (mk_concl (mk_apply2 R t1 t2) e),
      mk_baresequent H (mk_conclax (mk_member t1 mk_base))
    ]
    [].

Lemma rule_ipertype_member_equality_true {o} :
  forall lib (t1 t2 R e : NTerm),
  forall i : nat,
  forall H : @barehypotheses o,
    rule_true lib (rule_ipertype_member_equality
                 t1 t2 R e
                 i
                 H).
Proof.
  unfold rule_ipertype_member_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  rename Hyp2 into hyp3.
  destseq; allsimpl; proof_irr; GC.

  exists (@covered_axiom o (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  lift_lsubst.
  rw @member_eq.
  rw <- @member_equality_iff.

  vr_seq_true in hyp1.
  generalize (hyp1 s1 s2); intro h.
  repeat (autodimp h hyp); exrepnd.
  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_member_iff.
  apply tequality_in_uni_implies_tequality in h0; auto.
  (* allapply @member_in_uni. *)

  generalize (teq_and_eq_if_equality
                lib (mk_ipertype R) t1 t2 s1 s2 H wT w1 w2 c1 c3 c2 c4 cT cT0
                eqh sim); intro k; lsubst_tac; apply k; clear k; auto.

  clear dependent s1.
  clear dependent s2.
  introv hf sim.
  lsubst_tac.

  generalize (hyp1 s1 s2 hf sim); clear hyp1; intro hyp1; exrepnd.

  vr_seq_true in hyp2.
  generalize (hyp2 s1 s2 hf sim); clear hyp2; intro hyp2; exrepnd.

  vr_seq_true in hyp3.
  generalize (hyp3 s1 s2 hf sim); clear hyp3; intro hyp3; exrepnd.

  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_member_iff.
  allrw @tequality_mkc_member_base.
  assert (type lib (mkc_ipertype (lsubstc R w0 s1 c1))).
     { allapply @member_in_uni. auto. }
  apply tequality_in_uni_implies_tequality in hyp0; auto.

  allapply @inhabited_type_if_equality.
  rw @tequality_mkc_ipertype in hyp0; repnd.
  spcast.

  rw @equality_in_mkc_ipertype2; dands; auto.
  apply @inhabited_type_tequality with (a := mkc_apply2 (lsubstc R w0 s1 c1)
                                                       (lsubstc t1 w1 s1 ca1)
                                                       (lsubstc t2 w2 s1 c3)); auto.
  apply @tequality_trans with (t2 := mkc_apply2 (lsubstc R w0 s2 c0)
                                               (lsubstc t1 w1 s2 ct2)
                                               (lsubstc t2 w2 s2 cb2)); auto.
  apply @tequality_sym.
  apply @tequality_respects_cequivc_left with (T1 := mkc_apply2 (lsubstc R w0 s1 c1)
                                                                (lsubstc t1 w1 s2 ct2)
                                                                (lsubstc t2 w2 s2 cb2)); auto.
  apply implies_cequivc_apply2; sp.
  apply cequivc_sym; auto.

Qed.

(* begin hide *)

(* end hide *)

(* [15] ============ IPERTYPE ELIMINATION ============ *)

(**

  We can state the ipertype elimination rule as follows:
<<
   H, x : t1 = t2 in ipertype(R), J |- C ext e

     By ipertypeElimination i z

     H, x : t1 = t2 in ipertype(R), [z : R t1 t2], J |- C ext e
     H |- R t1 t2 in Type(i)
>>
 *)

Definition rule_ipertype_elimination {o}
           (R t1 t2 C e : NTerm)
           (x z : NVar)
           (i : nat)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_equality t1 t2 (mk_ipertype R))) ++ J)
       (mk_concl C e))
    [ mk_baresequent
        (snoc (snoc H (mk_hyp x (mk_equality t1 t2 (mk_ipertype R))))
              (mk_hhyp z (mk_apply2 R t1 t2))
              ++ J)
        (mk_concl C e),
      mk_baresequent
        H
        (mk_conclax (mk_member (mk_apply2 R t1 t2) (mk_uni i)))
    ]
    [sarg_var z].

Lemma rule_ipertype_elimination_true {o} :
  forall lib (R t1 t2 C e : NTerm),
  forall x z : NVar,
  forall i : nat,
  forall H J : @barehypotheses o,
    rule_true lib (rule_ipertype_elimination
                 R t1 t2 C e
                 x z
                 i
                 H J).
Proof.
  unfold rule_ipertype_elimination, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1; rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.

  assert (covered e
                  (nh_vars_hyps
                     (snoc H (mk_hyp x (mk_equality t1 t2 (mk_ipertype R))) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # !LIn x (free_vars t1)
           # !LIn x (free_vars t2)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1.
  dwfseq.
  sp;
    try (complete (discover; repeat(first[progress(allrw in_app_iff)|progress(allrw in_snoc)]); sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp)).

  destruct vhyps as [ nixr vhyps ].
  destruct vhyps as [ nixt1 vhyps ].
  destruct vhyps as [ nixt2 vhyps ].
  destruct vhyps as [ nizc  vhyps ].
  destruct vhyps as [ nize  vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  rw @equality_in_mkc_equality in sim2; repnd.
  rw @equality_in_mkc_ipertype in sim0; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim7; exrepnd.
  generalize (hyp1 ((snoc (snoc s1a0 (x, t0)) (z, t)) ++ s1b)
                   ((snoc (snoc s2a0 (x, t3)) (z, t)) ++ s2b));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
  apply app_split in sim7; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  rw @similarity_snoc in sim14; simpl in sim14; exrepnd; subst; cpx.
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t0)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.
  rewrite substitute_hyps_snoc_sub_weak in sim10; sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  rw @eq_hyps_app; simpl.
  exists (snoc (snoc s1a (x, t6)) (z, t4))
         s1b
         (snoc (snoc s2a1 (x, t7)) (z, t5))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  assert (cover_vars (mk_apply2 R t1 t2) (snoc s2a1 (x, t7)))
         as cv
         by (apply cover_vars_apply2; sp;
             try (apply cover_vars_var);
             repeat (apply cover_vars_snoc_weak); sp;
             repeat (rw dom_csub_snoc); simpl; repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x, t6)) (snoc s2a1 (x, t7)) t4 t5 w3 p0 cv;
    dands; try (complete sp).

  lsubst_tac.

(*
rw @tequality_mkc_equality in j0; repnd.
rw @tequality_mkc_ipertype in j2; repnd.
destruct j5 as [j5 | j5].
rw @equality_in_mkc_ipertype in j5; repnd.
*)

  vr_seq_true in hyp2.
  generalize (hyp2 s1a s2a1); clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.
  generalize (hyps_functionality_init_seg_snoc
                lib s1a t6 t7 H (mk_hyp x (mk_equality t1 t2 (mk_ipertype R))) w4 p1);
    simpl; intro k.
  apply k; sp.

  apply hyps_functionality_init_seg with (s3 := s2b1) in eqh; sp.
  rw @substitute_hyps_snoc_sub_weak in sim10; sp.

  rw @similarity_snoc in sim15; simpl in sim15; exrepnd; cpx.
  lsubst_tac; sp.

  rw @similarity_snoc in sim15; simpl in sim15; exrepnd; cpx.
  lsubst_tac.
  eapply tequality_in_uni_implies_tequality. exact hyp0.
  eapply member_if_inhabited. exact hyp1.

  apply sub_eq_hyps_snoc_weak; sp.

  (* similarity *)
  rw @similarity_app; simpl.
  exists (snoc (snoc s1a0 (x, t0)) (z, t))
         s1b
         (snoc (snoc s2a0 (x, t3)) (z, t))
         s2b; repeat (rw length_snoc); sp.

  assert (wf_term (mk_apply2 R t1 t2))
         as wfap by (apply wf_apply2; sp).

  assert (cover_vars (mk_apply2 R t1 t2) (snoc s1a0 (x, t0)))
         as cvap
         by (apply cover_vars_snoc_weak;rw @cover_vars_apply2; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x, t0)) (snoc s2a0 (x, t3)) t t wfap cvap; sp.

  lsubst_tac.
  rw @member_eq; sp.

  rewrite substitute_hyps_snoc_sub_weak; sp.
  (* similarity proved *)

  assert (lsubstc C wfct (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pC0
          = lsubstc C wfct (snoc s1a0 (x, t0) ++ s1b) pC1)
         as eq1
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc C wfct (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pC3
          = lsubstc C wfct (snoc s2a0 (x, t3) ++ s2b) pC2)
         as eq2
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pt0
          = lsubstc e wfce (snoc s1a0 (x, t0) ++ s1b) pt1)
         as eq3
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pt3
          = lsubstc e wfce (snoc s2a0 (x, t3) ++ s2b) pt2)
         as eq4
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  rw eq1 in hyp0.
  rw eq1 in hyp1.
  rw eq2 in hyp0.
  rw eq3 in hyp1.
  rw eq4 in hyp1.
  sp.
Qed.

(* begin hide *)

Lemma rule_ipertype_elimination_true_ex {o} :
  forall lib i z R t1 t2 C e x H J,
    rule_true_if lib (@rule_ipertype_elimination o
                 R t1 t2 C e
                 x z
                 i
                 H J).
Proof.
  intros.
  generalize (rule_ipertype_elimination_true lib R t1 t2 C e x z i H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)

(**

  This is a variant of [rule_ipertype_elimination] but where the
  well-formedness goal is stated using a ``type'' sequent.  Also it
  allows one to use all the hypotheses:
<<
   H, x : t1 = t2 in ipertype(R), J |- C ext e

     By ipertypeElimination i z

     H, x : t1 = t2 in ipertype(R), [z : R t1 t2], J |- C ext e
     H, x : t1 = t2 in ipertype(R), J |- R t1 t2 is a type
>>
 *)

Definition rule_ipertype_elimination_t {o}
           (R t1 t2 C e : NTerm)
           (x z : NVar)
           (i : nat)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_equality t1 t2 (mk_ipertype R))) ++ J)
       (mk_concl C e))
    [ mk_baresequent
        (snoc (snoc H (mk_hyp x (mk_equality t1 t2 (mk_ipertype R))))
              (mk_hhyp z (mk_apply2 R t1 t2))
              ++ J)
        (mk_concl C e),
      mk_baresequent
        (snoc H (mk_hyp x (mk_equality t1 t2 (mk_ipertype R))) ++ J)
        (mk_concl_t (mk_apply2 R t1 t2))
    ]
    [sarg_var z].

Lemma rule_ipertype_elimination_t_true {o} :
  forall lib (R t1 t2 C e : NTerm),
  forall x z : NVar,
  forall i : nat,
  forall H J : @barehypotheses o,
    rule_true lib (rule_ipertype_elimination_t
                 R t1 t2 C e
                 x z
                 i
                 H J).
Proof.
  unfold rule_ipertype_elimination_t, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.

  assert (covered e
                  (nh_vars_hyps
                     (snoc H (mk_hyp x (mk_equality t1 t2 (mk_ipertype R))) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # !LIn x (free_vars t1)
           # !LIn x (free_vars t2)
           # disjoint (free_vars R) (vars_hyps J)
           # disjoint (free_vars t1) (vars_hyps J)
           # disjoint (free_vars t2) (vars_hyps J)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
    try (complete (allunfold @disjoint; introv p; discover; allrw in_app_iff; allrw in_snoc; sp));
    try (complete (discover; repeat (first [ progress (allrw in_app_iff) | progress (allrw in_snoc) ]); sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp));
    try (complete (unfold disjoint; unfold disjoint in wfh13; introv k l; discover;
                   repeat (first [ progress (allrw in_app_iff) | progress (allrw in_snoc) ]); sp)).

  destruct vhyps as [ nixr vhyps ].
  destruct vhyps as [ nixt1 vhyps ].
  destruct vhyps as [ nixt2 vhyps ].
  destruct vhyps as [ nizc  vhyps ].
  destruct vhyps as [ nize  vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  rw @equality_in_mkc_equality in sim2; repnd.
  rw @equality_in_mkc_ipertype in sim0; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim7; exrepnd.
  generalize (hyp1 ((snoc (snoc s1a0 (x, t0)) (z, t)) ++ s1b)
                   ((snoc (snoc s2a0 (x, t3)) (z, t)) ++ s2b));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
  apply app_split in sim7; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  rw @similarity_snoc in sim14; simpl in sim14; exrepnd; subst; cpx.
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t0)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.
  rewrite substitute_hyps_snoc_sub_weak in sim10; sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  rw @eq_hyps_app; simpl.
  exists (snoc (snoc s1a (x, t6)) (z, t4))
         s1b
         (snoc (snoc s2a1 (x, t7)) (z, t5))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  assert (cover_vars (mk_apply2 R t1 t2) (snoc s2a1 (x, t7)))
         as cv
         by (apply cover_vars_apply2; sp;
             try (apply cover_vars_var);
             repeat (apply cover_vars_snoc_weak); sp;
             repeat (rw dom_csub_snoc); simpl; repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x, t6)) (snoc s2a1 (x, t7)) t4 t5 wfct0 p0 cv;
    dands; try (complete sp).

  lsubst_tac.

  vr_seq_true in hyp2.
  generalize (hyp2 (snoc s1a  (x, t6) ++ s1b)
                   (snoc s2a1 (x, t7) ++ s2b));
    clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.

  rw @similarity_app; simpl.
  exists (snoc s1a (x,t6)) s1b (snoc s2a1 (x,t7)) s2b; repeat (rw length_snoc); sp.
  lsubst_tac.
  auto.

  apply sub_eq_hyps_snoc_weak; sp.

  (* similarity *)
  rw @similarity_app; simpl.
  exists (snoc (snoc s1a0 (x, t0)) (z, t))
         s1b
         (snoc (snoc s2a0 (x, t3)) (z, t))
         s2b; repeat (rw length_snoc); sp.

  assert (wf_term (mk_apply2 R t1 t2))
         as wfap by (apply wf_apply2; sp).

  assert (cover_vars (mk_apply2 R t1 t2) (snoc s1a0 (x, t0)))
         as cvap
         by (apply cover_vars_snoc_weak;rw @cover_vars_apply2; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x, t0)) (snoc s2a0 (x, t3)) t t wfap cvap; sp.

  lsubst_tac.
  rw @member_eq; sp.

  rewrite substitute_hyps_snoc_sub_weak; sp.
  (* similarity proved *)

  assert (lsubstc C wfct (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pC0
          = lsubstc C wfct (snoc s1a0 (x, t0) ++ s1b) pC1)
         as eq1
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc C wfct (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pC3
          = lsubstc C wfct (snoc s2a0 (x, t3) ++ s2b) pC2)
         as eq2
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pt0
          = lsubstc e wfce (snoc s1a0 (x, t0) ++ s1b) pt1)
         as eq3
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pt3
          = lsubstc e wfce (snoc s2a0 (x, t3) ++ s2b) pt2)
         as eq4
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  rw eq1 in hyp0.
  rw eq1 in hyp1.
  rw eq2 in hyp0.
  rw eq3 in hyp1.
  rw eq4 in hyp1.
  sp.
Qed.

(* begin hide *)

Lemma rule_ipertype_elimination_t_true_ex {o} :
  forall lib i z R t1 t2 C e x H J,
    rule_true_if lib (@rule_ipertype_elimination_t o
                 R t1 t2 C e
                 x z
                 i
                 H J).
Proof.
  intros.
  generalize (rule_ipertype_elimination_t_true lib R t1 t2 C e x z i H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)

(* [16] ============ IPERTYPE EQUALITY ============ *)

(**

  We can state the ipertype equality rule as follows:
<<
   H |- ipertype(R1) = ipertype(R2) in Type(i)

     By ipertypeMemberEquality x y z u v

     H, x : Base, y : Base |- R1 x y = R2 x y in Type(i)
     H, x : Base, y : Base, z : R1 x y |- R1 y x
     H, x : Base, y : Base, z : Base, u : R1 z y, v : R1 y z |- R1 x z
>>
 *)

Definition rule_ipertype_equality {o}
           (R1 R2 e1 e2 : NTerm)
           (x y z u v : NVar)
           (i : nat)
           (H : @barehypotheses o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality (mk_ipertype R1) (mk_ipertype R2) (mk_uni i))))
    [ mk_baresequent
        (snoc (snoc H (mk_hyp x mk_base)) (mk_hyp y mk_base))
        (mk_conclax (mk_equality
                       (mk_apply2 R1 (mk_var x) (mk_var y))
                       (mk_apply2 R2 (mk_var x) (mk_var y))
                       (mk_uni i))),
      mk_baresequent
        (snoc (snoc (snoc H (mk_hyp x mk_base))
                    (mk_hyp y mk_base))
              (mk_hyp z (mk_apply2 R1 (mk_var x) (mk_var y))))
        (mk_concl (mk_apply2 R1 (mk_var y) (mk_var x)) e1),
      mk_baresequent
        (snoc (snoc (snoc (snoc (snoc H (mk_hyp x mk_base))
                                (mk_hyp y mk_base))
                          (mk_hyp z mk_base))
                    (mk_hyp u (mk_apply2 R1 (mk_var x) (mk_var y))))
              (mk_hyp v (mk_apply2 R1 (mk_var y) (mk_var z))))
        (mk_concl (mk_apply2 R1 (mk_var x) (mk_var z)) e2)
    ]
    [].

Lemma rule_ipertype_equality_true {o} :
  forall lib (R1 R2 e1 e2 : NTerm),
  forall x y z u v : NVar,
  forall i : nat,
  forall H : @barehypotheses o,
    rule_true lib (rule_ipertype_equality
                 R1 R2 e1 e2
                 x y z u v
                 i
                 H).
Proof.
  unfold rule_ipertype_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1; rename Hyp1 into hyp2; rename Hyp2 into hyp3.
  destseq; allsimpl; proof_irr; GC.

  allunfold @closed_type; allunfold @closed_extract; allsimpl.

  exists (@covered_axiom o (nh_vars_hyps H)).

  dup hyp1 as hypmem.
  apply sequent_equality_implies_member in hypmem; exrepnd.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R1)
           # !LIn y (free_vars R1)
           # !LIn z (free_vars R1)
           # !LIn u (free_vars R1)
           # !LIn v (free_vars R1)
           # !LIn x (free_vars R2)
           # !LIn y (free_vars R2)
           # !LIn z (free_vars R2)
           # !LIn u (free_vars R2)
           # !LIn v (free_vars R2)
           # !LIn x (vars_hyps H)
           # !LIn y (vars_hyps H)
           # !LIn z (vars_hyps H)
           # !x = y
           # !x = z
           # !y = z) as vhyps.

  clear hyp1 hyp2 hyp3 hypmem0.
  dwfseq.
  sp.

  destruct vhyps as [ nixr1 vhyps ].
  destruct vhyps as [ niyr1 vhyps ].
  destruct vhyps as [ nizr1 vhyps ].
  destruct vhyps as [ niur1 vhyps ].
  destruct vhyps as [ nivr1 vhyps ].
  destruct vhyps as [ nixr2 vhyps ].
  destruct vhyps as [ niyr2 vhyps ].
  destruct vhyps as [ nizr2 vhyps ].
  destruct vhyps as [ niur2 vhyps ].
  destruct vhyps as [ nivr2 vhyps ].
  destruct vhyps as [ nixh vhyps ].
  destruct vhyps as [ niyh vhyps ].
  destruct vhyps as [ nizh vhyps ].
  destruct vhyps as [ nxy vhyps ].
  destruct vhyps as [ nxz nyz ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  lsubst_tac.
  rw @member_eq.
  rw <- @member_equality_iff.

  generalize (teq_and_eq_if_equality
                lib (mk_uni i) (mk_ipertype R1) (mk_ipertype R2) s1 s2 H
                wT w1 w2 c1 c4 c2 c5 cT cT0
                eqh sim);
    intro k; repeat (autodimp k hyp); lsubst_tac; auto; try (apply @tequality_mkc_uni).

  clear dependent s1; clear dependent s2.
  introv hf sim; lsubst_tac.

  assert (cover_vars R1 s2)
    as cvr12
      by (apply cover_vars_change_sub with (sub1 := s1); auto;
          allapply @similarity_dom; repnd; allrw; sp).

  assert (cover_vars R2 s1)
    as cvr21
      by (apply cover_vars_change_sub with (sub1 := s2); auto;
          allapply @similarity_dom; repnd; allrw; sp).

  generalize (membership_apply2_eq
                lib H R1 R2 x y i s1 s2 w0 w3
                c1 cvr12 cvr21 c0 (wfh2, (wfct2, wfce), (ct1, ce1))
                hyp1 hf sim);
    introv fty.
  repeat (autodimp fty hyp).

  repeat (rw @mkc_ipertype_equality_in_uni); dands.

  introv.
  generalize (fty x0 y0); intro k; repnd.
  apply equality_commutes in k0; auto.

  allunfold @is_per_type; repnd; dands.

  generalize (is_sym_type
                lib R1 H i x y z e1 s1 s2 w0 c1
                wc' (wfh1, (wfct1, wfce1), (ct0, ce0))).
  intro j; repeat (destimp j hyp).

  generalize (is_trans_type
                lib R1 H i x y z u v e2 s1 s2 w0 c1
                wc' (wfh0, (wfct0, wfce0), (ct, ce))).
  intro j; repeat (destimp j hyp).
Qed.

(* begin hide *)

(* end hide *)

(* [20] ============ IPERTYPE ELIMINATION 2 ============ *)

(**

  Let us now provide another ipertype elimination rule.  This version
  is stated in terms of a ipertype hypothesis and not an equality in a
  ipertype:

<<
   H, x : ipertype(R), J |- C ext e

     By ipertypeElimination i z

     H, x : ipertype(R), [z : R x x], J |- C ext e
     H, x : ipertype(R) |- R x x in Type(i)
>>
 *)

Definition rule_ipertype_elimination2 {o}
           (R C e : NTerm)
           (x z : NVar)
           (i : nat)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_ipertype R)) ++ J)
       (mk_concl C e))
    [ mk_baresequent
        (snoc (snoc H (mk_hyp x (mk_ipertype R)))
              (mk_hhyp z (mk_apply2 R (mk_var x) (mk_var x)))
              ++ J)
        (mk_concl C e),
      mk_baresequent
        (snoc H (mk_hyp x (mk_ipertype R)))
        (mk_conclax (mk_member
                       (mk_apply2 R (mk_var x) (mk_var x))
                       (mk_uni i)))
    ]
    [sarg_var z].

Lemma rule_ipertype_elimination2_true {o} :
  forall lib (R C e : NTerm),
  forall x z : NVar,
  forall i : nat,
  forall H J : @barehypotheses o,
    rule_true lib (rule_ipertype_elimination2
                 R C e
                 x z
                 i
                 H J).
Proof.
  unfold rule_ipertype_elimination2, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1; rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.

  assert (covered e (nh_vars_hyps (snoc H (mk_hyp x (mk_ipertype R)) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # !LIn x (vars_hyps H)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
    try (complete (discover; allrw in_snoc; sp));
    try (complete (generalize (wg9 x); allrw remove_nvars_nil_l; allrw app_nil_r; sp));
    try (complete (generalize (wfh6 z); allrw in_snoc; sp));
    try (complete (generalize (cg z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (wfh z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp)).

  destruct vhyps as [ nixr vhyps ].
  destruct vhyps as [ nixh vhyps ].
  destruct vhyps as [ nizc vhyps ].
  destruct vhyps as [ nize vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  applydup @equality_refl in sim2 as simt1.
  rw @equality_in_mkc_ipertype in sim2; repnd.
  rw @equality_in_mkc_ipertype in simt1; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim0; exrepnd.
  unfold inhabited_type in simt0; destruct simt0 as [t' simt0].
  generalize (hyp1 ((snoc (snoc s1a0 (x, t1)) (z, t')) ++ s1b)
                   ((snoc (snoc s2a0 (x, t2)) (z, t')) ++ s2b));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
  apply app_split in sim0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  rw @similarity_snoc in sim12; simpl in sim12; exrepnd; subst; cpx.
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t1)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.
  rewrite substitute_hyps_snoc_sub_weak in sim8; sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  rw @eq_hyps_app; simpl.
  exists (snoc (snoc s1a (x, t4)) (z, t0))
         s1b
         (snoc (snoc s2a1 (x, t5)) (z, t3))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s2a1 (x, t5)))
         as cv
         by (apply cover_vars_apply2; sp;
             try (apply cover_vars_var);
             repeat (apply cover_vars_snoc_weak); sp;
             repeat (rw @dom_csub_snoc); simpl; repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x, t4)) (snoc s2a1 (x, t5)) t0 t3 w0 p0 cv;
    dands; try (complete sp).

  lsubst_tac.

  vr_seq_true in hyp2.
  generalize (hyp2 (snoc s1a (x,t4)) (snoc s2a1 (x,t5))); clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.

  apply hyps_functionality_init_seg with (s3 := s2b) in eqh; sp.

  lsubst_tac.
  apply @tequality_in_uni_implies_tequality with (i := i); sp.
  eapply member_if_inhabited. exact hyp1.

  apply sub_eq_hyps_snoc_weak; sp.

  (* similarity *)
  rw @similarity_app; simpl.
  exists (snoc (snoc s1a0 (x, t1)) (z, t'))
         s1b
         (snoc (snoc s2a0 (x, t2)) (z, t'))
         s2b; repeat (rw length_snoc); sp.

  assert (wf_term (mk_apply2 R (mk_var x) (mk_var x)))
         as wfap by (apply wf_apply2; sp).

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s1a0 (x, t1)))
         as cvap
         by (rw @cover_vars_apply2; sp;
             try (complete (apply cover_vars_snoc_weak; sp));
             apply cover_vars_var; rw @dom_csub_snoc; simpl; rw in_snoc; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x, t1)) (snoc s2a0 (x, t2)) t' t' wfap cvap; sp.

  lsubst_tac.
  rw @member_eq; sp.

  rewrite substitute_hyps_snoc_sub_weak; sp.
  (* similarity proved *)

  assert (lsubstc C wfct (snoc (snoc s1a0 (x, t1)) (z, t') ++ s1b) pC0
          = lsubstc C wfct (snoc s1a0 (x, t1) ++ s1b) pC1)
         as eq1
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc C wfct (snoc (snoc s2a0 (x, t2)) (z, t') ++ s2b) pC3
          = lsubstc C wfct (snoc s2a0 (x, t2) ++ s2b) pC2)
         as eq2
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s1a0 (x, t1)) (z, t') ++ s1b) pt0
          = lsubstc e wfce (snoc s1a0 (x, t1) ++ s1b) pt1)
         as eq3
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s2a0 (x, t2)) (z, t') ++ s2b) pt3
          = lsubstc e wfce (snoc s2a0 (x, t2) ++ s2b) pt2)
         as eq4
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  rw eq1 in hyp0.
  rw eq1 in hyp1.
  rw eq2 in hyp0.
  rw eq3 in hyp1.
  rw eq4 in hyp1.
  sp.
Qed.

(* begin hide *)

Lemma rule_ipertype_elimination2_true_ex {o} :
  forall lib i z R C e x H J,
    rule_true_if lib (@rule_ipertype_elimination2 o
                 R C e
                 x z
                 i
                 H J).
Proof.
  intros.
  generalize (rule_ipertype_elimination2_true lib R C e x z i H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)

(* [21] ============ IPERTYPE ELIMINATION 3 ============ *)

(**

  We state yet another ipertype elimination rule.  This one is similar
  to the second one presented above but does not require us to provide
  a level for [R x x]:

<<
   H, x : ipertype(R), J |- C ext e

     By ipertypeElimination i z

     H, x : ipertype(R), [z : R x x], J |- C ext e
     H, x : ipertype(R) |- (R x x) is a type
>>
 *)

Definition rule_ipertype_elimination3 {o}
           (R C e : NTerm)
           (x z : NVar)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent (snoc H (mk_hyp x (mk_ipertype R)) ++ J)
                   (mk_concl C e))
    [ mk_baresequent (snoc (snoc H (mk_hyp x (mk_ipertype R)))
                          (mk_hhyp z (mk_apply2 R (mk_var x) (mk_var x)))
                          ++ J)
                   (mk_concl C e),
      mk_baresequent (snoc H (mk_hyp x (mk_ipertype R)))
                    (mk_concl_t (mk_apply2 R (mk_var x) (mk_var x)))
    ]
    [sarg_var z].

Lemma rule_ipertype_elimination3_true {o} :
  forall lib (R C e : NTerm),
  forall x z : NVar,
  forall H J : @barehypotheses o,
    rule_true lib (rule_ipertype_elimination3
                 R C e
                 x z
                 H J).
Proof.
  unfold rule_ipertype_elimination3, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  generalize (hyps (mk_baresequent
                      (snoc (snoc H (mk_hyp x (mk_ipertype R)))
                            (mk_hhyp z (mk_apply2 R (mk_var x) (mk_var x))) ++ J)
                      (mk_concl C e))
                   (inl eq_refl))
             (hyps (mk_baresequent
                      (snoc H (mk_hyp x (mk_ipertype R)))
                      (mk_concl_t (mk_apply2 R (mk_var x) (mk_var x))))
                   (inr (inl eq_refl)));
    simpl; intros hyp1 hyp2.
  destruct hyp1 as [ ws1 hyp1 ].
  destruct hyp2 as [ ws2 hyp2 ].
  destseq; allsimpl; proof_irr; GC.

  assert (covered e (nh_vars_hyps (snoc H (mk_hyp x (mk_ipertype R)) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # !LIn x (vars_hyps H)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
    try (complete (discover; allrw in_snoc; sp));
    try (complete (generalize (wg9 x); allrw remove_nvars_nil_l; allrw app_nil_r; sp));
    try (complete (generalize (wfh6 z); allrw in_snoc; sp));
    try (complete (generalize (cg z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (wfh z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp)).

  destruct vhyps as [ nixr  vhyps ].
  destruct vhyps as [ nixh  vhyps ].
  destruct vhyps as [ nizc  vhyps ].
  destruct vhyps as [ nize  vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  applydup @equality_refl in sim2 as simt1.
  rw @equality_in_mkc_ipertype in sim2; repnd.
  rw @equality_in_mkc_ipertype in simt1; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim0; exrepnd.
  unfold inhabited_type in simt0; destruct simt0 as [t' simt0].
  generalize (hyp1 ((snoc (snoc s1a0 (x, t1)) (z, t')) ++ s1b)
                   ((snoc (snoc s2a0 (x, t2)) (z, t')) ++ s2b));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
  apply app_split in sim0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  rw @similarity_snoc in sim12; simpl in sim12; exrepnd; subst; cpx.
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t1)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.
  rewrite substitute_hyps_snoc_sub_weak in sim8; sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  rw @eq_hyps_app; simpl.
  exists (snoc (snoc s1a (x, t4)) (z, t0))
         s1b
         (snoc (snoc s2a1 (x, t5)) (z, t3))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s2a1 (x, t5)))
         as cv
         by (apply cover_vars_apply2; sp;
             try (apply cover_vars_var);
             repeat (apply cover_vars_snoc_weak); sp;
             repeat (rw @dom_csub_snoc); simpl; repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x, t4)) (snoc s2a1 (x, t5)) t0 t3 wfct0 p0 cv;
    dands; try (complete sp).

  lsubst_tac.

  vr_seq_true in hyp2.
  generalize (hyp2 (snoc s1a (x,t4)) (snoc s2a1 (x,t5))); clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.

  apply hyps_functionality_init_seg with (s3 := s2b) in eqh; sp.

  lsubst_tac; sp.

  apply sub_eq_hyps_snoc_weak; sp.

  (* similarity *)
  rw @similarity_app; simpl.
  exists (snoc (snoc s1a0 (x, t1)) (z, t'))
         s1b
         (snoc (snoc s2a0 (x, t2)) (z, t'))
         s2b; repeat (rw length_snoc); sp.

  assert (wf_term (mk_apply2 R (mk_var x) (mk_var x)))
         as wfap by (apply wf_apply2; sp).

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s1a0 (x, t1)))
         as cvap
         by (rw @cover_vars_apply2; sp;
             try (complete (apply cover_vars_snoc_weak; sp));
             apply cover_vars_var; rw @dom_csub_snoc; simpl; rw in_snoc; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x, t1)) (snoc s2a0 (x, t2)) t' t' wfap cvap; sp.

  lsubst_tac.
  rw @member_eq; sp.

  rewrite substitute_hyps_snoc_sub_weak; sp.
  (* similarity proved *)

  assert (lsubstc C wfct (snoc (snoc s1a0 (x, t1)) (z, t') ++ s1b) pC0
          = lsubstc C wfct (snoc s1a0 (x, t1) ++ s1b) pC1)
         as eq1
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc C wfct (snoc (snoc s2a0 (x, t2)) (z, t') ++ s2b) pC3
          = lsubstc C wfct (snoc s2a0 (x, t2) ++ s2b) pC2)
         as eq2
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s1a0 (x, t1)) (z, t') ++ s1b) pt0
          = lsubstc e wfce (snoc s1a0 (x, t1) ++ s1b) pt1)
         as eq3
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s2a0 (x, t2)) (z, t') ++ s2b) pt3
          = lsubstc e wfce (snoc s2a0 (x, t2) ++ s2b) pt2)
         as eq4
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  rw eq1 in hyp0.
  rw eq1 in hyp1.
  rw eq2 in hyp0.
  rw eq3 in hyp1.
  rw eq4 in hyp1.
  sp.
Qed.

(* begin hide *)

Lemma rule_ipertype_elimination3_true_ex {o} :
  forall lib z R C e x H J,
    rule_true_if lib (@rule_ipertype_elimination3 o
                 R C e
                 x z
                 H J).
Proof.
  intros.
  generalize (rule_ipertype_elimination3_true lib R C e x z H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)

(* [21] ============ IPERTYPE ELIMINATION 4 ============ *)

(**

  We state yet another ipertype elimination rule.  This one is similar
  to the third one presented above but [R x x] is now the last hypothesis
  in the first subgoal:

<<
   H, x : ipertype(R), J |- C ext e

     By ipertypeElimination i z

     H, x : ipertype(R), J, [z : R x x] |- C ext e
     H, x : ipertype(R) |- (R x x) is a type
>>
 *)

Definition rule_ipertype_elimination4 {o}
           (R C e : NTerm)
           (x z : NVar)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent (snoc H (mk_hyp x (mk_ipertype R)) ++ J)
                   (mk_concl C e))
    [ mk_baresequent (snoc ((snoc H (mk_hyp x (mk_ipertype R))) ++ J)
                           (mk_hhyp z (mk_apply2 R (mk_var x) (mk_var x))))
                   (mk_concl C e),
      mk_baresequent (snoc H (mk_hyp x (mk_ipertype R)))
                    (mk_concl_t (mk_apply2 R (mk_var x) (mk_var x)))
    ]
    [sarg_var z].

Lemma rule_ipertype_elimination4_true {o} :
  forall lib (R C e : NTerm),
  forall x z : NVar,
  forall H J : @barehypotheses o,
    rule_true lib (rule_ipertype_elimination4
                 R C e
                 x z
                 H J).
Proof.
  unfold rule_ipertype_elimination4, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.

  assert (covered e (nh_vars_hyps (snoc H (mk_hyp x (mk_ipertype R)) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # disjoint (free_vars R) (vars_hyps J)
           # !LIn x (vars_hyps H)
           # !LIn x (vars_hyps J)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
    try (complete (allunfold @disjoint; discover; allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (wg9 x); allrw remove_nvars_nil_l; allrw app_nil_r; sp));
    try (complete (generalize (wfh3 z); allrw in_snoc; sp));
    try (complete (generalize (wfh6 z); allrw in_snoc; sp));
    try (complete (generalize (cg z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (wfh z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp));
    try (complete (unfold disjoint; unfold disjoint in wfh11; introv k;
                   discover; auto)).

  destruct vhyps as [ nixr vhyps ].
  destruct vhyps as [ disjRJ vhyps ].
  destruct vhyps as [ nixh vhyps ].
  destruct vhyps as [ nixj vhyps ].
  destruct vhyps as [ nizc vhyps ].
  destruct vhyps as [ nize vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  applydup @equality_refl in sim2 as simt1.
  rw @equality_in_mkc_ipertype in sim2; repnd.
  rw @equality_in_mkc_ipertype in simt1; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim0; exrepnd.
  unfold inhabited_type in simt0; destruct simt0 as [t' simt0].
  generalize (hyp1 (snoc (snoc s1a0 (x, t1) ++ s1b) (z, t'))
                   (snoc (snoc s2a0 (x, t2) ++ s2b) (z, t')));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_snoc in sim; simpl in sim; exrepnd; subst; cpx.
  rw @similarity_app in sim10; simpl in sim10; exrepnd; subst; cpx.
  apply app_split in sim0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t1)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x))
                     (snoc s2a1 (x,t5) ++ s2b1))
    as cv
      by (apply cover_vars_apply2; sp;
          try (apply cover_vars_var);
          try (apply cover_vars_app_weak);
          repeat (apply cover_vars_snoc_weak); sp;
          repeat (rw @dom_csub_app); simpl;
          repeat (rw @dom_csub_snoc); simpl;
          repeat (rw in_app_iff);
          repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x,t4) ++ s1b) (snoc s2a1 (x,t5) ++ s2b1) t0 t3
         wfct0 p0 cv; repeat (rw length_snoc); dands; try (complete sp).

  rw @eq_hyps_app; simpl.
  exists (snoc s1a (x, t4))
         s1b
         (snoc s2a1 (x, t5))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  lsubst_tac.

rw @tequality_mkc_ipertype in j0; repnd.

  vr_seq_true in hyp2.
  generalize (hyp2 (snoc s1a (x,t4)) (snoc s2a1 (x,t5))); clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.

  apply hyps_functionality_init_seg with (s3 := s2b) in eqh; sp.

  lsubst_tac; sp.

  (* similarity *)
  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s1a0 (x,t1) ++s1b))
         as cvap
           by (rw @cover_vars_apply2; sp;
               try (complete (apply cover_vars_app_weak; apply cover_vars_snoc_weak; sp));
               apply cover_vars_var; rw @dom_csub_app; rw @dom_csub_snoc; simpl; rw in_app_iff; rw in_snoc; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x,t1) ++ s1b) (snoc s2a0 (x,t2) ++ s2b) t' t'
         wfct0 cvap; sp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t1))
         s1b
         (snoc s2a0 (x, t2))
         s2b; repeat (rw length_snoc); sp.

  lsubst_tac.
  rw @member_eq; sp.
  (* similarity proved *)

  lsubst_tac.
  sp.
Qed.

(* begin hide *)

Lemma rule_ipertype_elimination4_true_ex {o} :
  forall lib z R C e x H J,
    rule_true_if lib (@rule_ipertype_elimination4 o
                 R C e
                 x z
                 H J).
Proof.
  intros.
  generalize (rule_ipertype_elimination4_true lib R C e x z H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)


(** * Case Study: Place usage for list machines *)

From Undecidability Require Import ProgrammingTools.
From Complexity Require Export SpaceBounds PrettyBounds.
From Undecidability Require Import CaseNat CaseList.
From Undecidability Require Import ListTM.

(** This really ougth to be global *)
Global Arguments size : simpl never.

Lemma Constr_S_size_nice :
  forall (n : nat) (s : nat),
    pred s + size(S n) = max (size n + s) (size (S n)).
Proof.
  intros. rewrite !Encode_nat_hasSize. nia.
Qed.

(** We only apply the size function of [CaseNat], which is [S], if [n>0]. For [n=0], we just have the identity. See [CaseNat_Rel]. *)
Lemma CaseNat_size_nice :
  forall (n : nat) (s : nat),
    (* let k := s + size (S n) in *)
    1 <= n ->
    S s + size (pred n) = s + size n.
    (* (S s + size (pred n) = k). *)
Proof.
  intros.
  ring_simplify. rewrite !Encode_nat_hasSize. ring_simplify. replace (pred (1 + n)) with n by nia.
  nia.
Qed.

Section CaseList_nice.
  Variable (sigX X : Type) (cX : codable sigX X).

  Lemma CaseList_size0_nice (x : X) (xs : list X) (s : nat) :
    CaseList_size0 x s + size xs = s + size (x :: xs).
  Proof. cbn. unfold CaseList_size0. rewrite !Encode_list_hasSize; cbn. nia. Qed.

  (** This lemma looks more reasonable. Note that this kind of the case is actually like a constructor. *)
  Lemma CaseList_size1_nice (x : X) (s : nat) :
    CaseList_size1 x s + size x = max (pred s) (size x).
  Proof. intros. cbn. unfold CaseList_size1. cbn. nia. Qed.

  (** We can move the [+1] inside the [max] *)
  (** This is, because the tape is initial empty, and a start symbol had to be added. If there was already a start symbol, we don't need to allocate new memory for this *)
  Lemma CaseList_size1_nice' (x : X) (s : nat) :
    CaseList_size1 x s + size x + 1 = max s (size x + 1).
  Proof. intros. cbn. unfold CaseList_size1. cbn. nia. Qed.

  Lemma Constr_cons_size_nice (xs : list X) (x : X) (s : nat) :
    Constr_cons_size x s + size (x::xs) = max (size xs + s) (size (x::xs)).
  Proof. unfold Constr_cons_size. rewrite Encode_list_hasSize; cbn. rewrite <- !Encode_list_hasSize. ring_simplify. nia. Qed.

End CaseList_nice.

Section Copy_size_nice.
  Variable (sigX X : Type) (cX : codable sigX X).

  Lemma CopyValue_size_nice :
    forall (x : X) (s : nat), CopyValue_size x s + size x = max (pred s) (size x).
  Proof. intros. unfold CopyValue_size. nia. Qed.

  Lemma CopyValue_size_nice' :
    forall (x : X) (s : nat), CopyValue_size x s + size x + 1 = max s (size x + 1).
  Proof. intros. unfold CopyValue_size. nia. Qed.

  (** We can't simplify a lot here; [Reset] isn't nicer *)
  Lemma Reset_size_nice :
    forall (x : X) (s : nat), Reset_size x s = (s + size x) + 1.
  Proof. intros. unfold Reset_size. nia. Qed.

  (** Same as [Reset_size] *)
  Lemma MoveValue_size_x_nice :
    forall (x : X) (s : nat), MoveValue_size_x x s = (s + size x) + 1.
  Proof. intros. apply Reset_size_nice. Qed.

  Variable (sigY Y : Type) (cY : codable sigY Y).

  (** Replace [y] by [x] *)
  Lemma MoveValue_size_y_nice :
    forall (x : X) (y : Y) (s : nat), MoveValue_size_y x y s + size x = max (s + size y) (size x).
  Proof. intros. unfold MoveValue_size_y. nia. Qed.

End Copy_size_nice.

Section CasePair_size_nice.
  Variable (sigX sigY X Y : Type) (cX : codable sigX X) (cY : codable sigY Y).

  Lemma CasePair_size0_nice (x : X) (y : Y) (s0 : nat) :
    CasePair_size0 x s0 + size y = s0 + size (x,y).
  Proof. unfold CasePair_size0. rewrite Encode_pair_hasSize; cbn. nia. Qed.

  Lemma CasePair_size1_nice (x : X) (s1 : nat) :
    CasePair_size1 x s1 + size x = max (pred s1) (size x).
  Proof. unfold CasePair_size1. nia. Qed.

  (** The same issue as for [CaseList_size1_nice'] *)
  Lemma CasePair_size1_nice' (x : X) (s1 : nat) :
    CasePair_size1 x s1 + size x + 1 = max s1 (size x + 1).
  Proof. unfold CasePair_size1. nia. Qed.

  Lemma Constr_pair_size_nice (x : X) (y : Y) (s : nat) :
    Constr_pair_size x s + size (x,y) = max (s + size y) (size (x,y)).
  Proof. unfold Constr_pair_size. rewrite Encode_pair_hasSize; cbn. ring_simplify. nia. Qed.

End CasePair_size_nice.

Lemma size_S (n : nat) :
  size (S n) = S (size n).
Proof. now rewrite !Encode_nat_hasSize. Qed.

Lemma Forall2_map (A B C D : Type) (f : A -> C) (g : B -> D) (P : C -> D -> Prop) (xs : list A) (ys : list B) :
  Forall2 (fun a b => P (f a) (g b)) xs ys ->
  Forall2 P (map f xs) (map g ys).
Proof. induction 1; cbn; constructor; auto. Qed.

Lemma Forall_Forall2 (A : Type) (P : A -> A -> Prop) (xs : list A) :
  (Forall (fun x => P x x) xs) ->
  Forall2 P xs xs.
Proof. induction 1; constructor; auto. Qed.

(** ** Common combinations *)

(** Deteach the head and delete the tail *)
Lemma CaseList_size0_Reset_nice (sigX X : Type) (cX : codable sigX X) :
  forall (x : X) (xs : list X) (s : nat), (CaseList_size0 x >> Reset_size xs) s = s + size (x :: xs) + 1. (* plus one, because the tape is emptied *)
Proof.
  intros. cbn. rewrite Reset_size_nice. rewrite CaseList_size0_nice. rewrite !Encode_list_hasSize; cbn. nia.
Qed.

(** Remove the copied head *)
Lemma CaseList_size1_Reset_nice (sigX X : Type) (cX : codable sigX X) :
  forall (x : X) (s : nat), (CaseList_size1 x >> Reset_size x) s = Init.Nat.max s (size x + 1).
Proof.
  intros. cbn.
  rewrite Reset_size_nice.
  now rewrite CaseList_size1_nice'.
Qed.

(** Delete the first part of the tuple after copying it *)
Lemma CasePair_size1_Reset_nice (sigX X : Type) (cX : codable sigX X) :
  forall (x : X) (s : nat), (CasePair_size1 x >> Reset_size x) s = max s (size x + 1).
(* (* works: *) Proof. intros. cbn. unfold Reset_size, CasePair_size1. ring_simplify. nia. *)
Proof. intros. cbn. rewrite Reset_size_nice. rewrite CasePair_size1_nice. nia. Qed.

(** Delete the second part of the tuple removing the first part *)
Lemma CasePair_size0_Reset_nice (sigX X sigY Y : Type) (cX : codable sigX X) (cY : codable sigY Y) :
  forall (x : X) (y : Y) (s : nat), (CasePair_size0 x >> Reset_size y) s = s + size (x, y) + 1.
Proof. intros. cbn. rewrite Reset_size_nice. now rewrite CasePair_size0_nice. Qed.

(** ** Simple List functions *)

Section Length_size_nice.
  Variable (sigX X : Type) (cX : codable sigX X).

  (** There is only the [cons] case *)
  Lemma Length_Step_size_nice :
    (forall (x : X) (xs : list X) (s0 : nat), Length_Step_size x @>Fin0 s0 + size xs    = s0 + size (x::xs)) /\
    (forall (x : X) (n : nat) (s1 : nat),       Length_Step_size x @>Fin1 s1 + size (S n) = max (size n + s1) (size (S n))) /\
    (forall (x : X) (s2 : nat),               Length_Step_size x @>Fin2 s2              = max s2 (size x + 1)).
  Proof.
    repeat split; unfold Length_Step_size; cbn; intros.
    - now rewrite CaseList_size0_nice.
    - now rewrite Constr_S_size_nice.
    - apply CaseList_size1_Reset_nice.
  Qed.

  Local Arguments Length_Step_size : simpl never.

  Lemma Length_Loop_size_nice (xs : list X) :
    (forall (s0 : nat),         Length_Loop_size xs @>Fin0 s0 + size (@nil X)             = s0 + size xs) /\
    (forall (n : nat) (s1 : nat), Length_Loop_size xs @>Fin1 s1 + size (n + length xs) = max (size n + s1) (size (n + length xs)))  /\
    (forall (s2 : nat),         Length_Loop_size xs @>Fin2 s2                        = max_list_rec s2 (map (fun x => size x + 1) xs)).
  Proof.
    induction xs as [ | x xs (IH0&IH1&IH2)].
    {
      repeat split; cbn; intros.
      - rewrite !Encode_nat_hasSize. ring_simplify. cbv [id]. ring_simplify. nia.
    }
    {
      repeat split; cbn; intros.
      - rewrite IH0. projk_rewrite Length_Step_size_nice 0. rewrite !Encode_list_hasSize; cbn. nia.
      - replace (n + S (|xs|)) with (S n + |xs|) by lia.
        rewrite IH1. rewrite Nat.add_comm. cbn.
        projk_rewrite (Length_Step_size_nice) 1.
        rewrite !Encode_nat_hasSize. cbn. nia.
      - rewrite IH2. projk_rewrite (Length_Step_size_nice) 2. f_equal. nia.
    }
  Qed.

  Lemma Length_size_nice (xs : list X) :
    (forall (s0 : nat), Length_size xs @>Fin0 s0                        = s0) /\ (* Input tape doesn't change *)
    (forall (s1 : nat), Length_size xs @>Fin1 s1 + size (length xs) + 1 = max s1 (size (length xs) + 1)) /\ (* I think we have to add [+1] here, because this is an output tape; the tape was empty before and contains a value afterwards *)
    (forall (s2 : nat), Length_size xs @>Fin2 s2                        = max_list_rec s2 (map (fun x => size x + 1) xs)) /\ (* Internal tape: allocate no more memory than needed *)
    (forall (s3 : nat), Length_size xs @>Fin3 s3                        = max s3 (size xs + 1)). (* Internal tape *)
  Proof.
    unfold Length_size; cbn. repeat split; intros; auto.
    - change (|xs|) with (0 + |xs|). projk_rewrite (Length_Loop_size_nice xs) 1. unfold Constr_O_size. cbn.
      rewrite !Encode_nat_hasSize. nia.
    - projk_rewrite (Length_Loop_size_nice xs) 2. cbn. auto.
    - rewrite Reset_size_nice.
      projk_rewrite (Length_Loop_size_nice xs) 0.
      now rewrite CopyValue_size_nice'.
  Qed.

End Length_size_nice.


(* * Natural Deduction *)

From Undecidability.Synthetic Require Import Definitions DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
From Undecidability.FOL Require Import Syntax.Facts Syntax.Theories Syntax.Asimpl.
From Undecidability.FOL Require Export Deduction.FragmentND.
From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.
Require Import Lia.
Require Import EqdepFacts.
Import FragmentSyntax.

Set Default Proof Using "Type".

Local Set Implicit Arguments.
Local Unset Strict Implicit.

#[local] Ltac comp := repeat (progress (cbn in *; autounfold in *)).

Section ND_def.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Context {ff : falsity_flag}.
  Context {p : peirce}.

  Lemma impl_prv A B phi :
    (rev B ++ A) ⊢ phi -> A ⊢ (B ==> phi).
  Proof.
    revert A; induction B; intros A; cbn; simpl_list; intros.
    - firstorder.
    - eapply II. now eapply IHB.
  Qed.

  Theorem Weak A B phi :
    A ⊢ phi -> A <<= B -> B ⊢ phi.
  Proof.
    intros H. revert B.
    induction H; intros B HB; try unshelve (solve [econstructor; intuition]); try now econstructor.
  Qed.

  Hint Constructors prv : core.

  Theorem subst_Weak A phi xi :
    A ⊢ phi -> [phi[xi] | phi ∈ A] ⊢ phi[xi].
  Proof.
    induction 1 in xi |-*; comp.
    1-7:eauto using in_map.
    - apply AllI. setoid_rewrite map_map in IHprv. erewrite map_map, map_ext.
      apply IHprv. intros ?. cbn. now rewrite up_form.
    - specialize (IHprv xi). apply AllE with (t := t`[xi]) in IHprv. rewrite subst_comp in *.
      erewrite subst_ext; try apply IHprv. intros [|]; cbn; trivial.
      unfold funcomp. now setoid_rewrite subst_term_shift.
  Qed.

  Definition cycle_shift n x :=
    if Dec (n = x) then $0 else $(S x).
  Lemma cycle_shift_shift n phi :
    bounded n phi -> phi[cycle_shift n] = phi[↑].
  Proof.
    intros H. apply (bounded_subst H). intros k. unfold cycle_shift. destruct (Dec _); trivial; lia.
  Qed.

  Lemma cycle_shift_subject n phi :
    bounded (S n) phi -> phi[$n..][cycle_shift n] = phi.
  Proof.
    intros H. erewrite subst_comp, (bounded_subst H), subst_id; trivial.
    intros []; cbn; unfold cycle_shift; destruct (Dec _); trivial; lia.
  Qed.

  Lemma nameless_equiv_all' A phi n :
    bounded_L n A -> bounded (S n) phi -> [f[↑] | f ∈ A] ⊢ phi <-> A ⊢ phi[$n..].
  Proof.
    intros H1 H2. split; intros H.
    - apply (subst_Weak ($n..)) in H. rewrite map_map in *.
      erewrite map_ext, map_id in H; try apply H. intros. apply subst_shift.
    - apply (subst_Weak (cycle_shift n)) in H. rewrite (map_ext_in _ (subst_form ↑)) in H.
      + now rewrite cycle_shift_subject in H.
      + intros psi HP. now apply cycle_shift_shift, H1.
  Qed.

  Lemma nameless_equiv_all A phi :
    { t : nat | map (subst_form ↑) A ⊢ phi <-> A ⊢ phi[$t..] }.
  Proof.
    destruct (find_bounded_L (phi::A)) as [n H].
    exists n. apply nameless_equiv_all'.
    - intros ? ?. apply H. auto.
    - eapply bounded_up; try apply H; auto.
  Qed.

  Lemma AllI_named (A : list form) (phi : form) :
    (forall t, A ⊢ phi[t..]) -> A ⊢ ∀phi.
  Proof.
    intros H. apply AllI.
    destruct (nameless_equiv_all A phi) as [t Ht].
    apply Ht, H.
  Qed.

  Lemma imps T phi psi :
    T ⊢ (phi → psi) <-> (phi :: T) ⊢ psi.
  Proof.
    split; try apply II.
    intros H. apply IE with phi; auto. apply (Weak H). auto.
  Qed.

  Lemma big_imps A B phi : (A ++ B) ⊢ phi <-> B ⊢ (impl A phi).
  Proof.
    induction A as [|psi A IH] in B,phi|-*; cbn; try tauto.
    split; intros Hprv.
    - apply II. apply IH. eapply Weak. 1: apply Hprv.
      intros x [->|[HA|HB]%in_app_iff]; apply in_app_iff.
      + right; now left.
      + now left.
      + right; now right.
    - eapply Weak. 1: apply (IH (psi::B)).
      + eapply IE. 1: eapply Weak; [apply Hprv|firstorder]. apply Ctx; now left.
      + intros x [HA|[->|HB]]%in_app_iff.
        * right. apply in_app_iff. now left.
        * now left.
        * right. apply in_app_iff. now right.
  Qed.

  Lemma big_imps_nil A phi : A ⊢ phi <-> [] ⊢ (impl A phi).
  Proof.
    specialize (big_imps A nil phi). rewrite <- (app_nil_end). easy.
  Qed.

  Lemma subst_forall_prv phi {N Gamma} :
    Gamma ⊢ (forall_times N phi) -> bounded N phi -> forall sigma, Gamma ⊢ phi[sigma].
  Proof.
    induction N in phi |-*; intros ?? sigma; cbn in *.
    - change sigma with (iter up 0 sigma).
      now rewrite (subst_bounded 0).
    - specialize (IHN (∀ phi) ).
      rewrite <-up_decompose.
      apply AllE. apply IHN. unfold forall_times.
      now rewrite <-iter_switch.
      now apply bounded_S_quant.
  Qed.

  Lemma prv_cut A B phi :
    A ⊢ phi -> (forall psi, psi el A -> B ⊢ psi) -> B ⊢ phi.
  Proof.
    induction A in phi |- *; intros H1 H2.
    - eapply Weak; eauto.
    - rewrite <- imps in H1. apply IHA in H1; auto. apply IE with a; trivial. now apply H2.
  Qed.

  Lemma prv_intu_peirce T φ : T ⊢I φ -> T ⊢ φ.
  Proof using.
    remember intu. induction 1. all: now eauto.
  Qed.

End ND_def.

Local Hint Constructors prv : core.

(* ** Rudimentary tactics for ND manipulations *)

Ltac subsimpl_in H :=
  rewrite ?up_term, ?subst_term_shift in H.

Ltac subsimpl :=
  rewrite ?up_term, ?subst_term_shift.

Ltac assert1 H :=
  match goal with |- (?phi :: ?T) ⊢ _ => assert (H : (phi :: T) ⊢ phi) by auto end.

Ltac assert2 H :=
  match goal with |- (?phi :: ?psi :: ?T) ⊢ _ => assert (H : (phi :: psi :: T) ⊢ psi) by auto end.

Ltac assert3 H :=
  match goal with |- (?phi :: ?psi :: ?theta :: ?T) ⊢ _ => assert (H : (phi :: psi :: theta :: T) ⊢ theta) by auto end.

Ltac assert4 H :=
  match goal with |- (?f :: ?phi :: ?psi :: ?theta :: ?T) ⊢ _ => assert (H : (f :: phi :: psi :: theta :: T) ⊢ theta) by auto end.

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

(* ** Custom induction principle *)
Lemma prv_ind_full {Σ_funcs : funcs_signature} {Σ_preds : preds_signature} :
  forall P : peirce -> list (form falsity_on) -> (form falsity_on) -> Prop,
    (forall (p : peirce) (A : list form) (phi psi : form),
        (phi :: A) ⊢ psi -> P p (phi :: A) psi -> P p A (phi → psi)) ->
    (forall (p : peirce) (A : list form) (phi psi : form),
        A ⊢ (phi → psi) -> P p A (phi → psi) -> A ⊢ phi -> P p A phi -> P p A psi) ->
    (forall (p : peirce) (A : list form) (phi : form),
        (map (subst_form ↑) A) ⊢ phi -> P p (map (subst_form ↑) A) phi -> P p A (∀ phi)) ->
    (forall (p : peirce) (A : list form) (t : term) (phi : form),
        A ⊢ (∀ phi) -> P p A (∀ phi) -> P p A (phi[t..])) ->
    (forall (p : peirce) (A : list form) (phi : form), A ⊢ ⊥ -> P p A ⊥ -> P p A phi) ->
    (forall (p : peirce) (A : list form) (phi : form), phi el A -> P p A phi) ->
    (forall (A : list form) (phi psi : form), P class A (((phi → psi) → phi) → phi)) ->
    forall (p : peirce) (l : list form) (f14 : form), l ⊢ f14 -> P p l f14.
Proof.
  intros. specialize (@prv_ind _ _ (fun ff => match ff with falsity_on => P | _ => (fun _ _ _ => True) end)). intros H'.
  apply H' with (ff := falsity_on); clear H'. all: intros; try destruct ff; trivial. all: intuition eauto 2.
Qed.

(* ** Enumerability of proofs *)

Section Enumerability.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Variable list_Funcs : nat -> list syms.
  Hypothesis enum_Funcs' : list_enumerator__T list_Funcs syms.

  Variable list_Preds : nat -> list preds.
  Hypothesis enum_Preds' : list_enumerator__T list_Preds preds.

  Hypothesis eq_dec_Funcs : eq_dec syms.
  Hypothesis eq_dec_Preds : eq_dec preds.

  Instance eqdec_binop : eq_dec binop.
  Proof.
    intros x y. unfold dec. decide equality.
  Qed.

  Instance eqdec_quantop : eq_dec quantop.
  Proof.
    intros x y. unfold dec. decide equality.
  Qed.

  Definition list_binop (n : nat) := [Impl].

  Instance enum_binop :
    list_enumerator__T list_binop binop.
  Proof.
    intros []; exists 0; cbn; tauto.
  Qed.

  Definition list_quantop (n : nat) := [All].

  Instance enum_quantop :
    list_enumerator__T list_quantop quantop.
  Proof.
    intros []; exists 0; cbn; tauto.
  Qed.

  Lemma enumT_binop :
    enumerable__T binop.
  Proof.
    apply enum_enumT. exists list_binop. apply enum_binop.
  Qed.

  Lemma enumT_quantop :
    enumerable__T quantop.
  Proof.
    apply enum_enumT. exists list_quantop. apply enum_quantop.
  Qed.

  Instance enum_term' :
    list_enumerator__T (L_term _) term :=
    enum_term _.

  Instance enum_form' {ff : falsity_flag} :
    list_enumerator__T (L_form _ _ _ _) form :=
    enum_form _ _ _ _.

  Fixpoint L_ded {p : peirce} {b : falsity_flag} (A : list form) (n : nat) : list form :=
    match n with
    | 0 => A
    | S n =>   L_ded A n ++
    (* II *)   concat ([ [ phi → psi | psi ∈ L_ded (phi :: A) n ] | phi ∈ L_T form n ]) ++
    (* IE *)   [ psi | (phi, psi) ∈ (L_ded A n × L_T form n) , (phi → psi el L_ded A n) ] ++
    (* AllI *) [ ∀ phi | phi ∈ L_ded (map (subst_form ↑) A) n ] ++
    (* AllE *) [ phi[t..] | (phi, t) ∈ (L_T form n × L_T term n), (∀ phi) el L_ded A n ] ++
    (* Exp *)  (match b with falsity_on => fun A =>
                [ phi | phi ∈ L_T form n, ⊥ el @L_ded _ falsity_on A n ]
                | _ => fun _ => nil end A) ++
    (* Pc *)   (if p then
                [ (((phi → psi) → phi) → phi) | (pair phi psi) ∈ (L_T form n × L_T form n) ]
                else nil)
    end.

  Opaque in_dec.

  Lemma enum_prv {p : peirce} {b : falsity_flag} A :
    list_enumerator (L_ded A) (prv A).
  Proof with try (eapply cum_ge'; eauto; lia).
    split.
    - rename x into phi. induction 1; try congruence; subst.
      + destruct IHprv as [m1], (el_T phi) as [m2]. exists (1 + m1 + m2). cbn. in_app 2.
        eapply in_concat_iff. eexists. split. 2:in_collect phi... in_collect psi...
      + destruct IHprv1 as [m1], IHprv2 as [m2], (el_T psi) as [m3]; eauto.
        exists (1 + m1 + m2 + m3).
        cbn. in_app 3. in_collect (phi, psi)...
      + destruct IHprv as [m]. exists (1 + m). cbn. in_app 4. in_collect phi...
      + destruct IHprv as [m1], (el_T t) as [m2], (el_T phi) as [m3]. exists (1 + m1 + m2 + m3).
        cbn. in_app 5. in_collect (phi, t)...
      + destruct IHprv as [m1], (el_T phi) as [m2]. exists (1 + m1 + m2). cbn. in_app 6. in_collect phi...
      + now exists 0.
      + destruct (el_T phi) as [m1], (el_T psi) as [m2]. exists (1 + m1 + m2). cbn. in_app 7. in_collect (phi, psi)...
    - intros [m]; induction m in A, x, H |-*; cbn in *.
      + now apply Ctx.
      + destruct p, b; inv_collect. all: eauto 3.
        * eapply IE; apply IHm; eauto.
        * eapply IE; apply IHm; eauto.
        * eapply IE; apply IHm; eauto.
        * eapply IE; apply IHm; eauto.
  Qed.

  Fixpoint L_con `{falsity_flag} (L : nat -> list form) (n : nat) : list (list form) :=
    match n with
    | 0 => [ nil ]
    | S n => L_con L n ++ [ phi :: A | (pair phi A) ∈ (L n × L_con L n) ]
    end.

  Lemma enum_el X (p : X -> Prop) L x :
    list_enumerator L p -> p x -> exists m, x el L m.
  Proof.
    firstorder.
  Qed.
  Arguments enum_el {X p L} x _ _.

  Lemma enum_p X (p : X -> Prop) L x m :
    list_enumerator L p -> x el L m -> p x.
  Proof.
    firstorder.
  Qed.

  Definition containsL `{falsity_flag} A (T : form -> Prop) :=
    forall psi, psi el A -> T psi.

  Lemma enum_containsL `{falsity_flag} T L :
    cumulative L -> list_enumerator L T -> list_enumerator (L_con L) (fun A => containsL A T).
  Proof with try (eapply cum_ge'; eauto; lia).
    intros HL He. split.
    - induction x as [| phi A]; intros HT.
      + exists 0. firstorder.
      + destruct IHA as [m1], (enum_el phi He) as [m2]. 1,2,3: firstorder.
        exists (1 + m1 + m2). cbn. in_app 2. in_collect (phi, A)...
    - intros [m]. induction m in x, H0 |-*; cbn in *.
      + destruct H0 as [<- | []]. firstorder.
      + inv_collect. apply IHm in H2. apply (enum_p He) in H0. unfold containsL in *. firstorder congruence.
  Qed.

  Fixpoint L_tded {p : peirce} {b : falsity_flag} (L : nat -> list form) (n : nat) : list form :=
    match n with
    | 0 => nil
    | S n => L_tded L n ++ concat ([ L_ded A n | A ∈ L_con L n ])
    end.

  Lemma enum_tprv {p : peirce} {b : falsity_flag} T L :
    list_enumerator L T -> list_enumerator (L_tded (cumul L)) (tprv T).
  Proof with try (eapply cum_ge'; eauto; lia).
    intros He.
    assert (HL : list_enumerator (cumul L) T) by now apply list_enumerator_to_cumul.
    split.
    - intros (A & [m1] % (enum_el A (@enum_containsL _ _ (cumul L) (to_cumul_cumulative L) HL)) & [m2] % (enum_el x (enum_prv A))).
      exists (1 + m1 + m2). cbn. in_app 2. eapply in_concat_iff. eexists. split. 2: in_collect A... idtac...
    - intros [m]. induction m in x, H |-*; cbn in *. 1: contradiction. inv_collect. exists x1. split.
      + eapply (enum_p (enum_containsL (to_cumul_cumulative L) HL)); eauto.
      + eapply (enum_p (enum_prv x1)); eassumption.
  Qed.

End Enumerability.

Section TheoryManipulation.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {p : peirce} {ff : falsity_flag}.
  Context {HF : eq_dec syms} {HP : eq_dec preds}.
  Lemma prv_T_impl T phi psi :
    (T ⋄ phi) ⊢T psi -> T ⊢T (phi → psi).
  Proof using HF HP ff p Σ_funcs Σ_preds.
    intros (A & HA1 & HA2). exists (remove (dec_form _ _ _ _) phi A); split.
    - intros f [[] % HA1 Hf2] % in_remove; subst; intuition.
    - eapply II, Weak. 1: apply HA2. transitivity (phi :: A). 1: eauto. intros a [-> | Ha].
      + now left.
      + destruct (dec_form _ _ _ _ a phi) as [->|Hr]. 1:now left.
        right. now eapply in_in_remove.
  Qed.

  Lemma prv_T_remove T phi psi :
    T ⊢T phi -> T ⋄ phi ⊢T psi -> T ⊢T psi.
  Proof using HF HP ff p Σ_funcs Σ_preds.
    intros (A & HA1 & HA2) (B & HB1 & HB2) % prv_T_impl.
    use_theory (A ++ B).
    - now intros psi1 [H1|H2]%in_app_iff; [apply HA1 | apply HB1].
    - eapply IE; eapply Weak. 1,3: eassumption.
      all: intros x Hx; apply in_app_iff; eauto.
  Qed.

  Lemma prv_T_comp T phi psi xi :
    T ⋄ phi ⊢T xi -> T ⋄ psi ⊢T phi -> T ⋄ psi ⊢T xi.
  Proof using HF HP.
    intros (A & HA1 & HA2) % prv_T_impl (B & HB1 & HB2) % prv_T_impl.
    use_theory (psi :: A ++ B).
    - now intros psi1 [->|[H1|H2]%in_app_iff]; [now right | |]; left; [apply HA1 | apply HB1].
    - eapply IE. 1: eapply Weak. 1: apply HA2. 2: eapply IE.
      2-3: eapply Weak. 2: eapply HB2. 3: apply (@Ctx _ _ _ _ (psi::nil)); now left.
      + intros a Ha; right; apply in_app_iff; now left.
      + intros b Hb; right; apply in_app_iff; now right.
      + intros x [->|[]]; now left.
  Qed.

  Lemma elem_prv T phi :
    phi ∈ T -> T ⊢T phi.
  Proof.
    intros ?. use_theory [phi]. 2:apply Ctx; now left.
    intros psi [->|[]]. apply H.
  Qed.

  Lemma Weak_T T1 T2 phi :
    T1 ⊢T phi -> T1 ⊑ T2 -> T2 ⊢T phi.
  Proof.
    intros (A & HA1 & HA2) HT2. exists A. split. 2:easy. intros psi H; now apply HT2, HA1.
  Qed.
End TheoryManipulation.

Section Closedness.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {p : peirce} {ff : falsity_flag}.

  Definition capture_subs n x := $(x + n).

  Lemma capture_extract n A phi :
    A ⊢ subst_form (capture_subs n) (capture All n phi) -> A ⊢ subst_form (capture_subs 0) phi.
  Proof.
    induction n; comp; intuition. apply IHn. apply (AllE (var n)) in H. rewrite subst_comp in H.
    erewrite subst_ext. 1: apply H. intros [| x]; unfold capture_subs; cbn; f_equal; lia.
  Qed.

  Context {Funcs_eq_dec : eq_dec Σ_funcs}.
  Context {Preds_eq_dec : eq_dec Σ_preds}.

  Lemma close_extract A phi :
    A ⊢ close All phi -> A ⊢ phi.
  Proof.
    intros H. assert (Hclosed : closed (close All phi)) by apply close_closed.
    unfold close in *. destruct (find_bounded phi) as [n Hn]; cbn in *.
    erewrite <- subst_id with (sigma := fun x => $x) in H.
    erewrite (@bounded_subst _ _ _ _ _ _ _ (capture_subs n)) in H.
    2: exact Hclosed. 3:easy. 2: lia.
    apply capture_extract in H. rewrite subst_id in H; intuition. unfold capture_subs. f_equal. lia.
  Qed.

End Closedness.

Section DNFacts.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Lemma DN A phi: A ⊢C (¬ (¬ phi)) -> A ⊢C phi.
  Proof.
    intros H. eapply IE. 1: apply Pc. eapply II.
    apply Exp. eapply IE. 2: apply Ctx; now left.
    eapply Weak. 1: apply H. intros a Ha; now right.
  Qed.
  Lemma DN_into {p:peirce} A phi: A ⊢ phi -> A ⊢ (¬ (¬ phi)).
  Proof.
    intros H. apply II. eapply IE. 1: apply Ctx; now left. eapply Weak; [apply H|].
    firstorder.
  Qed.

  Lemma XMc A (phi chi : form) : (phi::A) ⊢C chi -> ((¬ phi)::A) ⊢C chi -> A ⊢C chi.
  Proof.
    intros HA HB. eapply IE with ((phi → chi) → (¬phi → chi) → chi).
    - eapply II. eapply IE. 1: eapply IE. 1: apply Ctx; now left.
      1-2: eapply Weak; [eapply II|]. 1: apply HA. 2: apply HB. 1-2: intros a Ha; now right.
    - eapply DN. apply II. eapply IE. 1: apply Ctx; now left. eapply II. eapply II.
      eapply IE. 1: apply Ctx; now left.
      eapply II. eapply IE. 1: apply Ctx; do 3 right; now left. do 2 eapply II.
      eapply IE. 1: apply Ctx; right; now left.
      apply Ctx; now eauto.
  Qed.

  Lemma DN_T T phi : T ⊢TC (¬¬phi) -> T ⊢TC phi.
  Proof.
    intros (A & HT & HA). exists A. split; [apply HT|now apply DN].
  Qed.

End DNFacts.

Section RefutationComp.
  Context {Σ_funcs : funcs_signature} {Σ_preds : preds_signature}.
  Context {HF : eq_dec Σ_funcs} {HP : eq_dec Σ_preds}.

  Lemma refutation_prv T phi :
    T ⊢TC phi <-> (T ⋄ ¬ phi) ⊢TC ⊥.
  Proof using HF HP.
    split.
    - intros (A & HA1 & HA2). use_theory (¬ phi :: A).
      + intros psi [<-|Ha]. 1: now right. left. now apply HA1.
      + eapply IE. 1: apply Ctx; now left. eapply Weak. 1: apply HA2. intros a Ha; now right.
    - intros (A & HA1 & HA2) % prv_T_impl. use_theory A. now apply DN.
  Qed.
End RefutationComp.

Section FlagsTransport.
  Context {Σ_funcs : funcs_signature} {Σ_preds : preds_signature}.
  Context {p : peirce}.
  Context {ff : falsity_flag}.

  Lemma prv_transport_to_falsity  A phi :
    A ⊢ phi -> (map to_falsity A) ⊢ (to_falsity phi).
  Proof.
    intros H; induction H.
    - cbn. apply II. apply IHprv.
    - cbn. eapply IE. 1: now apply IHprv1. now apply IHprv2.
    - cbn. apply AllI. rewrite map_map in *.
      erewrite map_ext. 1: now apply IHprv.
      intros a. rewrite <- ! subst_falsity_id.
      rewrite subst_falsity_comm. now cbn.
    - rewrite <- subst_falsity_id.
      change (⊥) with (⊥[t..]). rewrite <- subst_falsity_comm.
      apply AllE. rewrite subst_falsity_id. now apply IHprv.
    - apply Exp. apply IHprv.
    - apply Ctx. now apply in_map.
    - apply Pc.
  Qed.

  Lemma prv_transport_to_class A phi :
    A ⊢ phi -> A ⊢C phi.
  Proof.
    induction 1.
    - now apply II.
    - eapply IE. 1: apply IHprv1. easy.
    - now apply AllI.
    - now apply AllE.
    - now apply Exp.
    - now apply Ctx.
    - apply Pc.
  Qed.
(*
  Ltac resolve_existT :=
    inversion 1; subst;
    repeat match goal with
             H : existT _ _ _ = existT _ _ _ |- _ => try apply Eqdep_dec.inj_pair2_eq_dec in H; [|try decide equality]
           end.

  Lemma prv_transport_from_falsity'
    {ff1 ff2 : falsity_flag}
    A' (phi' : @form _ _ _ ff2)
    A (phi : @form _ _ _ ff1)
    (Heqn : ff2 = falsity_on) : A' ⊢ phi' -> match ff2
      as ff return list (@form _ _ _ ff) -> @form _ _ _ ff -> Prop
      with falsity_off => fun A' phi' => False
         | falsity_on => fun A' phi' => A' = map to_falsity A -> phi' = to_falsity phi -> A ⊢ phi
    end A' phi'.
  Proof.
    induction 1 in A,phi,Heqn|-*; try (destruct ff; try congruence); intros HeqA Heqphi.
    - destruct phi as [|t1 t2|ff [] phi psi'|ff [] phi]; cbn in Heqphi; try congruence.
      apply II. apply IHprv. 1:easy. cbn. f_equal. 2: easy.
      all: injection Heqphi; intros He1 He2.
      all: apply Eqdep_dec.inj_pair2_eq_dec in He1; [|decide equality].
      all: apply Eqdep_dec.inj_pair2_eq_dec in He2; [|decide equality].
      all: congruence.
    - eapply IE. *)
End FlagsTransport.

Section NegativeTranslation.
  Context {Σ_funcs : funcs_signature} {Σ_preds : preds_signature}.

  Fixpoint negative_translation {ff:falsity_flag} (phi : @form _ _ _ ff) : @form _ _ _ falsity_on := match phi with
    falsity => falsity
  | atom P v => ¬¬(atom P v)
  | bin Impl phi psi => (negative_translation phi) → (negative_translation psi)
  | quant All phi => ∀ (negative_translation phi)
  end.

  Lemma nt_impl {ff:falsity_flag} A phi : negative_translation (impl A phi) = impl (map negative_translation A) (negative_translation phi).
  Proof.
    induction A as [|psi A IH]; cbn; congruence.
  Qed.

  Lemma nt_subst {ff:falsity_flag} phi σ : negative_translation (phi[σ]) = (negative_translation phi)[σ].
  Proof.
    induction phi as [| |?[]|?[]] in σ|-*; try easy.
    - cbn. now rewrite IHphi1, IHphi2.
    - cbn. now rewrite IHphi.
  Qed.

  Lemma nt_dn_float' {p:peirce} {ff:falsity_flag} A phi:
   A ⊢ ((¬¬negative_translation phi) → negative_translation phi).
  Proof.
  revert A. induction phi as [| |?[]|?[]]; intros A; cbn.
  - apply II. eapply IE. 1: apply Ctx; now left. apply II. apply Ctx; now left.
  - apply II. apply II. eapply IE. 1: apply Ctx; right; now left.
    apply II. eapply IE. 1: apply Ctx; now left. apply Ctx; right; now left.
  - apply II. apply II. eapply IE. 1: apply IHphi2. apply II.
    eapply IE. 1: apply Ctx; right; right; now left. apply II.
    eapply IE. 1: apply Ctx; right; now left.
    eapply IE. 1: apply Ctx; now left.
    apply Ctx; right; right; now left.
  - apply II. apply AllI. cbn. eapply IE. 1: apply IHphi.
    apply II. eapply IE. 1: apply Ctx; right; now left.
    apply II. eapply IE. 1: apply Ctx; right; now left.
    assert ((negative_translation phi)[up ↑][$0..] = negative_translation phi) as <- by now asimpl.
    apply AllE. apply Ctx; left; now asimpl.
  Qed.

  Lemma nt_dn_float {p:peirce} {ff:falsity_flag} A phi :
    A ⊢ (¬¬negative_translation phi) -> A ⊢ negative_translation phi.
  Proof.
    intros H. eapply IE. 1: apply nt_dn_float'. easy.
  Qed.

  Lemma nt_peirce {p:peirce} {ff:falsity_flag} A phi psi:
    A ⊢ negative_translation (((phi → psi) → phi) → phi).
  Proof.
    cbn. apply II.
    apply nt_dn_float.
    apply II. eapply IE. 1: apply Ctx; now left.
    eapply IE. 1: apply Ctx; right; now left.
    apply II. apply Exp. eapply IE. 1: apply Ctx; right; now left.
    apply Ctx. now left.
  Qed.

  Lemma nt_Cprv_to_Iprv {p1 : peirce} {ff:falsity_flag} A phi :
    A ⊢C phi -> (map negative_translation A) ⊢ (negative_translation phi).
  Proof.
    remember class as p2. induction 1; cbn in *.
    all: try specialize (IHprv Heqp2).
    all: try specialize (IHprv1 Heqp2).
    all: try specialize (IHprv2 Heqp2).
    - eapply II. now apply IHprv.
    - eapply IE. 1: apply IHprv1. apply IHprv2.
    - eapply AllI. rewrite map_map in *. erewrite map_ext. 1: apply IHprv.
      intros a; cbn. now rewrite nt_subst.
    - rewrite nt_subst. eapply AllE. apply IHprv.
    - eapply Exp. apply IHprv.
    - eapply Ctx. now apply in_map.
    - apply nt_peirce.
  Qed.

  Lemma nt_Cprv_equiv A phi :
    A ⊢C phi <-> A ⊢C (negative_translation phi).
  Proof.
    revert A. induction phi as [| |[]|[]] using form_ind_falsity; intros A; cbn; split; intros Hprv.
    - easy.
    - easy.
    - eapply DN_into. easy.
    - eapply DN. easy.
    - apply II. apply IHphi2. eapply IE. 1: eapply Weak; [apply Hprv|firstorder].
      apply IHphi1. apply Ctx; now left.
    - apply II. apply IHphi2. eapply IE. 1: eapply Weak; [apply Hprv|firstorder].
      apply IHphi1. apply Ctx; now left.
    - apply (subst_Weak ↑) in Hprv. asimpl in Hprv.
      eapply (AllE $0) in Hprv. asimpl in Hprv.
      apply AllI. apply IHphi. apply Hprv.
    - apply (subst_Weak ↑) in Hprv. asimpl in Hprv.
      eapply (AllE $0) in Hprv. asimpl in Hprv.
      apply AllI. apply IHphi. apply Hprv.
  Qed.

  Lemma nt_bounded {ff:falsity_flag} n phi : bounded n phi -> bounded n (negative_translation phi).
  Proof.
    induction 1; cbn.
    - solve_bounds. now econstructor.
    - destruct binop. now solve_bounds.
    - destruct quantop. now solve_bounds.
    - solve_bounds.
  Qed.

  #[local] Existing Instance falsity_on.
  Lemma nt_correct A phi:
    (map negative_translation A) ⊢I negative_translation phi -> A ⊢C phi.
  Proof.
    intros H.
    apply big_imps_nil. apply nt_Cprv_equiv.
    eapply prv_transport_to_class.
    rewrite nt_impl. apply big_imps_nil in H. apply H.
  Qed.

  Lemma nt_correct_theory T phi:
    (tmap negative_translation T) ⊢TI negative_translation phi -> T ⊢TC phi.
  Proof.
    intros (? & (A & -> & HA1) % tmap_contains_L & HA2 % nt_correct).
    now exists A.
  Qed.

End NegativeTranslation.


From Tealeaves.Classes Require Export
  Traversable.Functor
  Kleisli.Traversable.Functor.

#[local] Generalizable Variables A B C.

Export Kleisli.Traversable.Functor.ToFunctor.

(** * Traversable Functors: Kleisli to Algebraic *)
(******************************************************************************)

(** ** Operations *)
(******************************************************************************)
Module Operations.
  Section with_kleisli.

    Context
      (W : Type)
      (T : Type -> Type)
      `{Traverse T}.

    #[export] Instance Dist_Traverse: Dist T := fun G _ _ _ A => traverse T G (@id (G A)).

  End with_kleisli.
End Operations.

Import Operations.

(** ** Instances *)
(******************************************************************************)
Module Instances.

  Context
    (W : Type)
    (T : Type -> Type)
    `{Kleisli.Traversable.Functor.TraversableFunctor T}.

  (** *** Traversable functor instance *)
  (******************************************************************************)
  Lemma dist_natural_T : forall (G : Type -> Type) (H2 : Fmap G) (H3 : Pure G) (H4 : Mult G),
      Applicative G -> Natural (@dist T _ G H2 H3 H4).
  Proof.
    intros. constructor.
    - typeclasses eauto.
    - typeclasses eauto.
    - intros. unfold_ops @Fmap_compose @Dist_Traverse @Fmap_Traverse.
      rewrite (trf_traverse_traverse T G (fun A => A)); try typeclasses eauto.
      change (traverse T G (@id (G B))) with (fmap (fun A => A) (traverse T G (@id (G B)))).
      rewrite (trf_traverse_traverse T (fun A => A) G); try typeclasses eauto.
      fequal. rewrite Mult_compose_identity1, Mult_compose_identity2.
      reflexivity.
  Qed.

  Lemma dist_morph_T : forall (G1 G2 : Type -> Type) (H2 : Fmap G1) (H3 : Pure G1) (H4 : Mult G1) (H5 : Fmap G2)
                         (H6 : Pure G2) (H7 : Mult G2) (ϕ : forall A : Type, G1 A -> G2 A),
      ApplicativeMorphism G1 G2 ϕ -> forall A : Type, dist T G2 ∘ fmap T (ϕ A) = ϕ (T A) ∘ dist T G1.
  Proof.
    intros. unfold_ops @Dist_Traverse @Fmap_Traverse.
    change (traverse T G2 (@id (G2 A))) with (fmap (fun A => A) (traverse T G2 (@id (G2 A)))).
    inversion H1.
    rewrite (trf_traverse_traverse T (fun A => A) G2); try typeclasses eauto.
    change (fmap (fun A => A) id ∘ ?f) with f.
    rewrite (trf_traverse_morphism T).
    fequal. now rewrite Mult_compose_identity2.
  Qed.

  Lemma dist_unit_T : forall A : Type,
      dist T (fun A0 : Type => A0) = @id (T A).
  Proof.
    intros. unfold_ops @Dist_Traverse.
    apply (trf_traverse_id T).
  Qed.

  Lemma dist_linear_T : forall (G1 : Type -> Type) (H2 : Fmap G1) (H3 : Pure G1) (H4 : Mult G1),
      Applicative G1 ->
      forall (G2 : Type -> Type) (H6 : Fmap G2) (H7 : Pure G2) (H8 : Mult G2),
        Applicative G2 -> forall A : Type, dist T (G1 ∘ G2) (A := A) = fmap G1 (dist T G2) ∘ dist T G1.
  Proof.
    intros. unfold_ops @Dist_Traverse.
    rewrite (trf_traverse_traverse T G1); try typeclasses eauto.
    rewrite (fun_fmap_id G1).
    reflexivity.
  Qed.

  #[export] Instance: Traversable.Functor.TraversableFunctor T :=
    {| dist_natural := dist_natural_T;
       dist_morph := dist_morph_T;
       dist_unit := dist_unit_T;
       dist_linear := dist_linear_T;
    |}.

End Instances.

#[local] Generalizable Variables T.

Module AlgebraicToKleisli.

  Context
    `{fmapT : Fmap T}
    `{distT : Dist T}
    `{! Traversable.Functor.TraversableFunctor T}.

  #[local] Instance traverse' : Traverse T := ToKleisli.Traverse_dist T.

  Definition fmap' : Fmap T := ToFunctor.Fmap_Traverse T.
  Definition dist' : Dist T := Dist_Traverse T.

  Goal fmapT = fmap'.
  Proof.
    unfold fmap'. unfold_ops @Fmap_Traverse.
    unfold traverse, traverse'.
    unfold_ops @ToKleisli.Traverse_dist.
    ext A B f.
    rewrite (dist_unit T).
    reflexivity.
  Qed.

  Goal distT = dist'.
  Proof.
    unfold dist'. unfold_ops @Dist_Traverse.
    unfold traverse, traverse'.
    unfold_ops @ToKleisli.Traverse_dist.
    ext G Hmap Hpure Hmult. ext A.
    rewrite (fun_fmap_id T).
    reflexivity.
  Qed.

End AlgebraicToKleisli.

Module KleisliToAlgebraic.

  Context
    `{traverseT : Traverse T}
    `{@Classes.Kleisli.Traversable.Functor.TraversableFunctor T _}.

  #[local] Instance fmap' : Fmap T := Fmap_Traverse T.
  #[local] Instance dist' : Dist T := Dist_Traverse T.

  Definition traverse' : Traverse T := ToKleisli.Traverse_dist T.

  Goal forall G `{Applicative G}, @traverseT G _ _ _ = @traverse' G _ _ _.
  Proof.
    intros.
    unfold traverse'. unfold_ops @ToKleisli.Traverse_dist.
    unfold fmap, fmap', dist, dist'.
    ext A B f.
    unfold_ops @Dist_Traverse.
    unfold_ops @Fmap_Traverse.
    change (traverse T G (@id (G B))) with (fmap (fun A => A) (traverse T G (@id (G B)))).
    rewrite (trf_traverse_traverse T (fun A => A) G);
      try typeclasses eauto.
    rewrite (fun_fmap_id (fun A => A)).
    change (id ∘ f) with f.
    change_left (traverse T G f).
    fequal.
    now rewrite (Mult_compose_identity2).
  Qed.

End KleisliToAlgebraic.


From mathcomp Require Import ssreflect.
From stdpp Require Import gmap option strings.
From esop Require Import corecalculus.

Definition subst_ectx_item σ i :=
  match i with
  | EAppL e => EAppL (subst σ e)
  | EAppR e => EAppR (subst σ e)
  | EIfL e e' => EIfL (subst σ e) (subst σ e')
  | EIfM e e' => EIfM (subst σ e) (subst σ e')
  | EIfR e e' => EIfR (subst σ e) (subst σ e')
  | EAlloc => EAlloc
  | ERead => ERead
  | EWriteL e => EWriteL (subst σ e)
  | EWriteR e => EWriteR (subst σ e)
  | EWait => EWait
  | EPost => EPost
  | ERec f x => ERec f x
  end.
Definition subst_ectx σ (K: list ectx_item) := subst_ectx_item σ <$> K.

Definition of_ectx_item i :=
  match i return option ctx_item with
  | EAppL e => Some (CAppL e)
  | EAppR e => CAppR <$> to_val e
  | EIfL e e' => Some (CIf e e')
  | EIfM _ _ => None
  | EIfR _ _ => None
  | EAlloc => Some CAlloc
  | ERead => Some CRead
  | EWriteL e => Some (CWriteL e)
  | EWriteR e => CWriteR <$> to_val e
  | EWait => Some CWait
  | EPost => None
  | ERec f x => None
  end.
Fixpoint of_ectx K :=
  match K return option (list ctx_item) with
  | [] => Some []
  | i::K => of_ectx_item i ≫= λ i', (i' ::) <$> of_ectx K
  end.

Variant reduced (X: gset string): expr → Prop :=
| red_const (c: const): reduced X c
| red_lambda (f x: binder) (e: expr) (eclosed: Closed ({[?f]} ∪ {[?x]} ∪ X) e):
    reduced X (Rec f x e)
| red_var (x: string) (inx: x ∈ X): reduced X x.

Lemma reduced_to_val e: reduced ∅ e → is_Some (to_val e).
Proof.
  destruct 1; eauto.
  - rewrite right_id in eclosed * => [eclosed].
    rewrite /= decide_left; eauto.
  - set_solver.
Qed.
Lemma reduced_of_val v: reduced ∅ (of_val v).
Proof. destruct v; constructor; rewrite ?right_id //. Qed.

Variant reduced_ectx_item (X: gset string): ectx_item → Prop :=
| REIAppL e: reduced_ectx_item X (EAppL e)
| REIAppR e (red: reduced X e): reduced_ectx_item X (EAppR e)
| REIAppIf e e': reduced_ectx_item X (EIfL e e')
| REIAlloc: reduced_ectx_item X EAlloc
| REIRead: reduced_ectx_item X ERead
| REIWriteL e: reduced_ectx_item X (EWriteL e)
| REIWriteR e (red: reduced X e): reduced_ectx_item X (EWriteR e)
| REIWait: reduced_ectx_item X EWait.

Lemma of_ectx_item_reduced i: reduced_ectx_item ∅ i → is_Some (of_ectx_item i).
Proof.
  destruct 1; cbn; eauto.
  all: apply reduced_to_val in red; destruct red as [? ->]; eauto.
Qed.

Definition to_ectx_item i :=
  match i return ectx_item with
  | CAppL e => EAppL e
  | CAppR v => EAppR (of_val v)
  | CIf e e' => EIfL e e'
  | CAlloc => EAlloc
  | CRead => ERead
  | CWriteL e => EWriteL e
  | CWriteR v => EWriteR (of_val v)
  | CWait => EWait
  end.
Lemma of_to_ectx_item i: of_ectx_item (to_ectx_item i) = Some i.
Proof.
  destruct i; try done.
  all: by rewrite /= to_of_val.
Qed.
Lemma to_ectx_item_reduced i: reduced_ectx_item ∅ (to_ectx_item i).
Proof.
  destruct i; rewrite /=; constructor.
  all: apply reduced_of_val.
Qed.
Lemma to_of_ectx_item i i': of_ectx_item i = Some i' → to_ectx_item i' = i.
Proof.
  destruct i; simplify_eq 1.
  all: try by intros <-.
  all: rewrite fmap_Some => [[v [eqv ->]]].
  all: by rewrite /= (of_to_val e v).
Qed.

Definition to_ectx (K: list _): list _ := to_ectx_item <$> K.
Definition reduced_ectx X := Forall (reduced_ectx_item X).

Lemma subst_fill_ectx_item σ i e X: reduced_ectx_item X i →
  subst σ (fill_ectx_item e i) =
  fill_ectx_item (subst σ e) (subst_ectx_item σ i).
Proof. by destruct 1. Qed.

Lemma subst_fill_ectx X σ K e: reduced_ectx X K →
  subst σ (fill_ectx e K) =
  fill_ectx (subst σ e) (subst_ectx σ K).
Proof.
  intro red; revert e.
  induction red; intro; rewrite /= //.
  rewrite IHred (subst_fill_ectx_item σ _ _ X); done.
Qed.

Lemma fill_of_ectx_item i i' (eqi: of_ectx_item i = Some i') e:
  fill_ectx_item e i = fill_ctx_item e i'.
Proof.
  destruct i; simplify_eq eqi; intro eqi'; subst; try done.
  all: rewrite fmap_Some in eqi' * => [[v [eqv ->]]].
  all: rewrite /= (of_to_val _ _ eqv) //.
Qed.

Lemma fill_of_ectx K K' (eqi: of_ectx K = Some K') e:
  fill_ectx e K = fill_ctx e K'.
Proof.
  revert e K' eqi.
  induction K as [|i K IH]; rewrite /= =>[e K' eqK'].
  { by injection eqK' as <-. }
  rewrite bind_Some in eqK' * => [[i' [eqi eqK']]].
  rewrite fmap_Some in eqK' * => [[K'' [eqK ->]]].
  rewrite /= (IH _ _ eqK) (fill_of_ectx_item _ _ eqi) //.
Qed.

Lemma reduced_ectx_of_ectx K: reduced_ectx ∅ K → is_Some (of_ectx K).
Proof.
  induction 1; cbn; eauto.
  destruct (of_ectx_item_reduced _ H) as [i' ->].
  destruct IHForall as [K' ->].
  eauto.
Qed.

Lemma reduced_closed X X' e: reduced X e → Closed X' e → reduced X' e.
Proof. destruct 1; inversion_clear 1; by constructor. Qed.

Lemma fmap_delete' `(f: A → B) b m: delete' b (f <$> m) = f <$> (delete' b m).
Proof.
  destruct b; first done.
  rewrite /= fmap_delete //.
Qed.

Lemma dom_delete' {A} b (m: gmap string A):
  dom (gset string) (delete' b m) = (dom _ m) ∖ {[? b ]}.
Proof.
  destruct b; simpl.
  - set_solver.
  - apply leibniz_equiv.
    rewrite dom_delete //.
Qed.

Lemma subst_closed' X X' σ e: map_Forall (λ k e', k ∈ X → Closed X' e') σ →
                              X ⊆ X' ∪ dom _ σ →
                              Closed X e → Closed X' (subst σ e).
Proof.
  intros good_subst bound closed.
  revert X' σ good_subst bound.
  induction closed; rewrite /= => [X' σ good_subst bound]; try constructor; auto.
  - destruct (σ !! x) eqn:inx.
    + apply (good_subst x e); auto.
    + constructor.
      rewrite -(not_elem_of_dom (D:=gset string)) in inx * => [notindom].
      set_solver.
  - apply IHclosed.
    + intros x' e'.
      rewrite !lookup_delete' !elem_of_union !elem_of_singleton'.
      intros [neqf [neqx mt]] [[case|case]|inx'].
      1,2: contradiction.
      apply good_subst in mt.
      eapply closed_mono.
      2: done.
      2: eauto.
      clear; set_solver.
    + intro y.
      rewrite !elem_of_union !dom_delete' !elem_of_difference !elem_of_singleton'.
      specialize (bound y); rewrite elem_of_union in bound *.
      intuition.
      destruct (decide (BNamed y = f)); auto.
      destruct (decide (BNamed y = x)); auto.
Qed.

Lemma reduced_subst_val σ e: reduced (dom _ σ) e → reduced ∅ (subst (of_val <$> σ) e).
Proof.
  intro red.
  destruct red; rewrite /=.
  - constructor.
  - constructor.
    rewrite !fmap_delete'.
    apply (subst_closed' ({[?f]} ∪ {[?x]} ∪ dom _ σ)); auto.
    + intros x' e'.
      rewrite lookup_fmap fmap_Some => [[v [lookup ->]]].
      rewrite !lookup_delete' in lookup * => [[neqf [neqx lookup]] _].
      eapply (closed_mono ∅).
      * clear; set_solver.
      * done.
      * apply val_closed.
    + clear; rewrite dom_fmap !dom_delete'.
      intro y.
      rewrite !elem_of_union !elem_of_difference !elem_of_empty.
      destruct (decide (y ∈ {[?f]})); auto.
      destruct (decide (y ∈ {[?x]})); auto.
      tauto.
  - rewrite lookup_fmap.
    rewrite elem_of_dom in inx * => [[v ->]].
    apply reduced_of_val.
Qed.

Lemma reduced_subst_ectx_item_val σ i:
  reduced_ectx_item (dom _ σ) i → reduced_ectx_item ∅ (subst_ectx_item (of_val <$> σ) i).
Proof. destruct 1; cbn; constructor; auto using reduced_subst_val. Qed.
Lemma reduced_subst_ectx_val σ K:
  reduced_ectx (dom _ σ) K → reduced_ectx ∅ (subst_ectx (of_val <$> σ) K).
Proof. induction 1; constructor; auto using reduced_subst_ectx_item_val. Qed.

Lemma of_to_ectx K: of_ectx (to_ectx K) = Some K.
Proof.
  induction K as [|i K IH]; first done.
  rewrite /= of_to_ectx_item IH //.
Qed.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj3synthconj4 : forall  (lv0 : natural) (lv1 : lst), (@eq natural (len (Cons lv0 lv1)) (Succ (len lv1))).
Admitted.
QuickChick conj3synthconj4.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^174 - 17
Base: 24 + 6/7
***)

Definition curve : CurveParameters :=
  {|
    sz := 7%nat;
    base := 24 + 6/7;
    bitwidth := 32;
    s := 2^174;
    c := [(1, 17)];
    carry_chains := Some [seq 0 (pred 7); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


From Coq Require Import ZArith String List.
From QuickChick Require Export Show.

Global Open Scope string_scope.

From Cofq.BaseExpressions Require Import PrimOps.

Variant Precedence :=
| PrecOuter
| PrecMult
| PrecAdd
| PrecSub
| PrecApp
| PrecInner
.

Definition prec_value (p : Precedence) : N :=
  match p with
  | PrecOuter => 0
  | PrecAdd => 1
  | PrecSub => 1
  | PrecMult => 2
  | PrecApp => 3
  | PrecInner => 4
  end.

Definition parens (outer inner : Precedence) (s : string) :=
  if N.leb (prec_value outer) (prec_value inner)
  then s
  else "(" ++ s ++ ")".

Definition intersperse (sep : string) (l : list string) : string
  := fold_left (fun acc s => if eqb "" acc then s else s ++ sep ++ acc) l "".

Instance showPrimOp : Show PrimOp :=
  {| show :=
       fun (op : PrimOp) =>
         match op with
         | Mul => "*"
         | Add => "+"
         | Sub => "-"
         end
  |}.

Definition op_prec (op : PrimOp) : Precedence
  := match op with
     | Mul => PrecMult
     | Add => PrecAdd
     | Sub => PrecSub
     end.