Require Export Dynamic.
Require Import SyntaxProp.

Lemma step_preserves_this :
  forall id H H' n n' e e' l L Q,
    (exists e, heapLookup H id = Some (l, L, Q, e)) ->
    id / (H, n); e ==> (H', n'); e' ->
    exists L' Q' e'', heapLookup H' id = Some (l, L', Q', e'').
Proof with hauto.
  introv Hex Hstep.
  gen e'.
  inv Hex as [e' Hlookup].
  expr_cases (induction e) Case; intros; inv Hstep;
  try solve[inv_ctx]...
Qed.

Lemma monotonic_heap :
  forall id H H' n n' e e',
    id / (H, n); e ==> (H', n'); e' ->
    length H <= length H'.
Proof with hauto.
  introv Hstep.
  gen Hstep. gen e'.
  expr_cases(induction e) Case; intros; inv Hstep;
  try rewrite heapUpdate_length;
  try solve[inv_ctx]...
Qed.

Lemma monotonic_local_heap :
  forall id id' H H' n n' e e' L L' l,
    id / (H, n); e ==> (H', n'); e' ->
    LH H id' = Some L ->
    LH H' id' = Some L' ->
    In l L ->
    In l L'.
Proof with (hauto; eauto using in_cons).
  introv Hstep HLH1 HLH2 HIn.
  gen e'.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx;
    try rewrite_and_invert...
  + Case "ENew".
    rewrite_and_invert.
Qed.

Lemma new_locs_in_local_heap :
  forall id H H' n n' L L' e e',
    id / (H, n); e ==> (H', n'); e' ->
    LH H id = Some L ->
    LH H' id = Some L' ->
    (forall l, In l (freeLocs e) -> In l L) ->
    (forall l, In l (freeLocs e') -> In l L').
Proof with eauto using in_or_app.
  introv Hstep HLH1 HLH2 HIn HIn'.
  assert (forall l, In l L -> In l L') as Hmono.
    intros; eapply monotonic_local_heap...
  gen e'. gen l.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx;
    try contradiction;
    simpls;
    try solve [
          first [apply in_app_or in HIn'|
                 apply freeLocs_subst_in in HIn'];
          inv HIn'; eauto using in_or_app]...
  + Case "ENew".
    inv HIn'; try contradiction.
    hauto. constructors...
Qed.

Lemma new_ids_in_heap :
  forall id H H' n n' e e',
    id / (H, n); e ==> (H', n'); e' ->
    (forall id, In id (freeIds e) -> id < length H) ->
    (forall id', In id' (freeIds e') -> id' < length H').
Proof with eauto using in_or_app, monotonic_heap.
  introv Hstep Hid HIn.
  assert (length H <= length H') as Hmono...
  gen e'. gen id'. gen id.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx;
    try rewrite_and_invert; simpls;
    try (first [apply in_app_or in HIn
               |apply freeIds_subst_in in HIn];
         inv HIn);
    try contradiction;
    try (assert (id' < length H) by eauto using in_or_app; omega);
    hauto...
Qed.

Lemma bid_actors_in_heap :
  forall id id' H H' n n' e e' l,
    id / (H, n); e ==> (H', n'); e' ->
    id < length H ->
    (forall l id'', In (l, id'') (freeBIds e) -> id'' < length H) ->
    In (l, id') (freeBIds e') ->
    id' < length H.
Proof with eauto using in_or_app, monotonic_heap.
  introv Hstep Hlt HBId HIn.
  gen e'. gen id'. gen id.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx; simpls;
    try contradiction;
    try solve[
          first[apply in_app_or in HIn
               |apply freeBIds_subst_in in HIn];
          inv HIn; eauto using in_or_app]...
  + Case "EBes". inv HIn... inv H. omega.
Qed.

Lemma bid_loc_in_local_heap :
  forall id id' H H' n n' e e' l L L' L'',
    id / (H, n); e ==> (H', n'); e' ->
    (forall l', In l' (freeLocs e) -> In l' L'') ->
    (forall l' id'',
        In (l', id'') (freeBIds e) ->
        id'' < length H /\
        LH H id'' = Some L -> In l' L) ->
    In (l, id') (freeBIds e') ->
    LH H id' = Some L ->
    LH H' id' = Some L' ->
    LH H id = Some L'' ->
    In l L'.
Proof with eauto using in_or_app.
  introv Hstep Hloc HBId HIn HLH HLH' HLH''.
  gen e'. gen id'. gen id. gen L''.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx; simpls;
    try contradiction;
    try rewrite_and_invert;
    try solve[apply in_app_or in HIn;
              inv HIn;
              try solve[eapply IHe1 with (L'' := L'');
                        eauto using in_or_app
                       |eapply IHe2 with (L'' := L'');
                        eauto using in_or_app];
              try eapply monotonic_local_heap;
              try eapply HBId;
              eauto using in_or_app]...
  + Case "EApp".
    eapply freeBIds_subst_in in HIn. inv HIn; eapply HBId...
  + Case "EBes".
    inv HIn; try contradiction.
    inv H...
    repeat rewrite_and_invert...
Qed.

Lemma step_footprint :
  forall id id' H H' n n' e e' e'' l L Q,
    id / (H, n); e ==> (H', n'); e' ->
    heapLookup H' id' = Some (l, L, Q, e'') ->
    (exists L Q, heapLookup H id' = Some (l, L, Q, e'')) \/
    e'' = EUnit /\ In l L.
Proof with hauto.
  introv Hstep Hlookup.
  gen e'. gen id'. gen id.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx...
  + Case "ENew".
    right. splits... constructors...
Qed.

Lemma step_local_heap_neq :
  forall id id' H H' n n' e e' L,
    id / (H, n); e ==> (H', n'); e' ->
    LH H' id' = Some L ->
    id <> id' ->
    id' < length H ->
    LH H id' = Some L.
Proof with hauto.
  introv Hstep HLH Hneq Hlt.
  gen e'. gen H.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx;
    hauto;
    try contradiction;
    try omega...
Qed.

Lemma step_id_lt :
  forall id id' H H' n n' e e' L,
    id / (H, n); e ==> (H', n'); e' ->
    LH H' id' = Some L ->
    id' < length H \/ id' = length H /\ L = n :: nil.
Proof with hauto.
  introv Hstep HLH.
  gen e'. gen L.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx...
Qed.

Lemma step_single_allocation :
  forall id id' H H' n n' e e',
    id / (H, n); e ==> (H', n'); e' ->
    length H < length H' ->
    id' < length H ->
    LH H' id' = LH H id'.
Proof with (hauto; try omega).
  introv Hstep Hlt Hlt'.
  gen e'. gen H.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx...
Qed.

Lemma step_allocates_n :
  forall id id' H H' n n' e e' L,
    id / (H, n); e ==> (H', n'); e' ->
    LH H id' = Some L ->
    LH H' id' = Some L \/ LH H' id' = Some (n :: L).
Proof with hauto.
  introv Hstep HLH.
  gen e'. gen H.
  expr_cases (induction e) Case;
    intros; inv Hstep;
    try inv_ctx...
Qed.

Lemma monotonic_fresh :
  forall id H H' n n' e e',
    id / (H, n); e ==> (H', n'); e' ->
    n <= n'.
Proof with eauto.
  introv Hstep.
  gen e'.
  expr_cases (induction e) Case;
    intros; inv Hstep; simpls;
    try inv_ctx...
Qed.


Require Import Util MoreList Get Option OptionMap Filter.

Set Implicit Arguments.

Fixpoint replace_if X (p:X -> bool) (L:list X) (L':list X) :=
  match L with
  | x::L => if p x then
              match L' with
              | y::L' => y::replace_if p L L'
              | _ => nil
              end
            else
              x::replace_if p L L'
  | _ => nil
  end.

Lemma replace_if_get_inv X (p:X -> bool) L L' n x
  : get (replace_if p L L') n x
    -> exists l , get L n l /\
            ((p l /\ exists l' n', get L' n' l' /\ x = l')
              \/ (~ p l /\ x = l)).
Proof.
  intros; general induction L; destruct L'; simpl in *; isabsurd.
  - cases in H; isabsurd. inv H.
    + exists x; split; eauto using get.
      right; split; eauto. rewrite <- Heq. eauto.
    + edestruct IHL; eauto; dcr.
      eexists; split; eauto using get.
  - cases in H; isabsurd.
    + inv H.
      * eexists; split; eauto using get.
        left. rewrite <- Heq; eauto using get.
      * edestruct IHL; eauto using get; dcr.
        eexists; split; eauto using get.
        destruct H2; dcr; isabsurd. left; eauto 20 using get.
        right; eauto using get.
    + inv H.
      * eexists; split; eauto using get.
        right. rewrite <- Heq; eauto using get.
      * edestruct IHL; eauto; dcr.
        eexists; split; eauto using get.
Qed.


(*

  Copyright 2014 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/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export rules_useful.
Require Export sequents_useful.

Unset Regular Subst Tactic.

(** printing |- $\vdash$ *)
(** printing ->  $\rightarrow$ *)
(* begin hide *)

(* end hide *)

(**

  We now prove the truth of several structural rules.

*)

(* [1] ============ THIN HYPS ============ *)

(**

  The following rule says that we can always thin any tail of a list of hypotheses:
<<
   H, J |- C ext t

     By thinHyps ()

     H |- C ext t
>>
 *)
Definition rule_thin_hyps {o}
           (H J  : @barehypotheses o)
           (C t  : NTerm) :=
  mk_rule
    (mk_baresequent (H ++ J) (mk_concl C t))
    [ mk_baresequent H (mk_concl C t) ]
    [].

Lemma rule_thin_hyps_true {o} :
  forall lib (H J  : @barehypotheses o)
         (C t  : NTerm),
    rule_true lib (rule_thin_hyps H J C t).
Proof.
  intros.
  unfold rule_thin_hyps, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  duplicate wfh as wfh'.
  allapply @vswf_hypotheses_nil_implies.
  allrw @wf_hypotheses_app.
  destruct wfh as [ wfh wfj ].
  generalize (hyps (mk_baresequent H (mk_concl C t)) (inl eq_refl));
    intro hyp1; clear hyps.
  destruct hyp1 as [ ws1 hyp1 ].
  destseq; allsimpl.
  proof_irr.

  assert (closed_extract (H ++ J) (mk_concl C t)) as ws
         by (wfseq; apply covered_app_weak_l; auto).
  exists ws.

  (* We prove some simple facts on our sequents *)
  assert (covered C (vars_hyps H)
          # covered t (nh_vars_hyps H)
          # disjoint (free_vars C) (vars_hyps J)
          # disjoint (free_vars t) (vars_hyps J)) as vhyps.

  clear hyp1.
  dwfseq; sp;
  try (complete (rw fold_subset in ct;
                 apply subset_disjoint with (l3 := vars_hyps J) in ct; sp)).
  try (complete (rw fold_subset in ce;
                 apply subset_disjoint with (l1 := nh_vars_hyps H) in wfj0; sp;
                 apply subset_disjoint with (l3 := vars_hyps J) in ce; sp)).

  destruct vhyps as [ cch vhyps ].
  destruct vhyps as [ cth vhyps ].
  destruct vhyps as [ dcj dtj ].
  (* done with proving these simple facts *)

  (* we can now start proving that the rule is true *)
  vr_seq_true.

  vr_seq_true in hyp1.

  allrw @similarity_app; exrepd; subst.

  generalize (hyp1 s1a s2a); clear hyp1; intro hyp1.

  autodimp hyp1 hyp.
  intros s2 sim.
  apply @hyps_functionality_init_seg with (s1b := s1b) (J := J) (s3 := s2b) in sim; auto.

  autodimp hyp1 hyp; exrepd.

  assert (disjoint (free_vars C) (dom_csub s1b)) as d1
         by (allapply @similarity_dom; sp;
             rterm (dom_csub s1b); rewrite vars_hyps_substitute_hyps; sp).
  assert (disjoint (free_vars C) (dom_csub s2b)) as d2
         by (allapply @similarity_dom; sp;
             rterm (dom_csub s2b); rewrite vars_hyps_substitute_hyps; sp).

  assert (disjoint (free_vars t) (dom_csub s1b)) as dt1
         by (allapply @similarity_dom; sp;
             rterm (dom_csub s1b); rewrite vars_hyps_substitute_hyps; sp).
  assert (disjoint (free_vars t) (dom_csub s2b)) as dt2
         by (allapply @similarity_dom; sp;
             rterm (dom_csub s2b); rewrite vars_hyps_substitute_hyps; sp).

  generalize (subset_free_vars_lsubstc_app_ex C s1a s1b wfct pC1 d1); intro; exrepd; clear_irr.
  rewrite e0; clear e0.

  generalize (subset_free_vars_lsubstc_app_ex C s2a s2b wfct pC2 d2); intro; exrepd; clear_irr.
  rewrite e0; clear e0.

  generalize (subset_free_vars_lsubstc_app_ex t s1a s1b wfce pt1 dt1); intro; exrepd; clear_irr.
  rewrite e0; clear e0.

  generalize (subset_free_vars_lsubstc_app_ex t s2a s2b wfce pt2 dt2); intro; exrepd; clear_irr.
  rewrite e0; clear e0.

  auto.
Qed.

(* begin hide *)

Lemma rule_thin_hyps_true_ex {o} :
  forall lib (H : @bhyps o) J c t,
    rule_true_if lib (rule_thin_hyps H J c t).
Proof.
  intros.
  generalize (rule_thin_hyps_true lib H J c t); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

Lemma rule_thin_hyps_true2 {o} :
  forall lib (H : @bhyps o) J c t,
    rule_true2 lib (rule_thin_hyps H J c t).
Proof.
  intros.
  generalize (rule_thin_hyps_true lib H J c t); intro rt.
  apply rule_true_iff_rule_true2; sp.
Qed.

Lemma rule_thin_hyps_wf {o} :
  forall (H : @bhyps o) J c t,
    covered c (vars_hyps H)
    -> wf_rule (rule_thin_hyps H J c t).
Proof.
  intros.
  introv pwf m; allsimpl; repdors; subst; sp.
  allunfold @pwf_sequent; wfseq; sp.
  allapply @vswf_hypotheses_nil_implies.
  allrw @wf_hypotheses_app; sp.
  allapply @vswf_hypotheses_nil_if; sp.
Qed.

(* end hide *)

(* [2] ============ UNHIDE EQUALITY ============ *)

(**

  The following rule says that we can always unhide an hypothesis if
  the conclusion is an equality (in general this is true if the
  conclusion has a trivial extract):
<<
   H [x : A] J |- t1 = t2 in C

     By equalityUnhide hyp(i) ()

     H x : A J |- t1 = t2 in C
>>
 *)

Definition rule_unhide_equality {o}
           (H J  : @barehypotheses o)
           (A C t1 t2 : NTerm)
           (x    : NVar) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hhyp x A) ++ J)
       (mk_conclax (mk_equality t1 t2 C)))
    [ mk_baresequent
        (snoc H (mk_hyp x A) ++ J)
        (mk_conclax (mk_equality t1 t2 C)) ]
    [].

Lemma rule_unhide_equality_true {o} :
  forall (lib : library)
         (H J  : @barehypotheses o)
         (A C t1 t2 : NTerm)
         (x    : NVar),
    rule_true lib (rule_unhide_equality H J A C t1 t2 x).
Proof.
  intros.
  unfold rule_unhide_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  duplicate wfh as wfh'.
  allapply @vswf_hypotheses_nil_implies.
  allrw @wf_hypotheses_app; allrw @wf_hypotheses_snoc; allsimpl.
  destruct wfh as [ wfh wfj ].
  destruct wfh as [ ipa wfh ].
  destruct wfh as [ nixh wfh ].
  allrw @vars_hyps_snoc; allsimpl.
  generalize (hyps (mk_baresequent (snoc H (mk_hyp x A) ++ J)
                                  (mk_conclax (mk_equality t1 t2 C)))
                   (inl eq_refl));
    clear hyps; allsimpl; intro hyp1.
  destruct hyp1 as [ ws1 hyp1 ].
  destseq; allsimpl; proof_irr.

  exists (@covered_axiom o (nh_vars_hyps (snoc H (mk_hhyp x A) ++ J))).

  (* We prove some simple facts on our sequents *)
  assert (covered (mk_equality t1 t2 C) (snoc (vars_hyps H) x ++ vars_hyps J))
    as vhyps.

  clear hyp1.
  dwfseq; sp.
  allrw in_app_iff; allrw in_snoc; sp;
  apply_in_hyp p; allrw in_app_iff; allrw in_snoc; sp.
  (* done with proving these simple facts *)

  (* we can now start proving that the rule is true *)
  vr_seq_true.

  vr_seq_true in hyp1.

  generalize (hyp1 s1 s2); clear hyp1; intro hyp1.
  autodimp hyp1 hyp.

  intros s3 sim3.
  rw @similarity_hhyp in sim3; rw @eq_hyps_hhyp.
  apply eqh; sp.

  autodimp hyp1 hyp; exrepd; clear_irr; auto.
  rw @similarity_hhyp; auto.
Qed.

(* begin hide *)

(* end hide *)

(* [4] ============ HYPOTHESIS EQUALITY ============ *)

(**

  The following rule is the standard ``hypothesis'' rule:
<<
   G, x : A, J |- x = x in A

     By hypothesisEquality hyp(i) ()

     no subgoals
>>
 *)

Definition rule_hypothesis_equality {o}
             (G J : @barehypotheses o)
             (A   : NTerm)
             (x   : NVar) :=
  mk_rule
    (mk_baresequent
       (snoc G (mk_hyp x A) ++ J)
       (mk_conclax (mk_equality (mk_var x) (mk_var x) A)))
    []
    [].

Lemma rule_hypothesis_equality_true {o} :
  forall lib (G J : @barehypotheses o)
         (A : NTerm)
         (x : NVar),
    rule_true lib (rule_hypothesis_equality G J A x).
Proof.
  intros.
  unfold rule_hypothesis_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  duplicate wfh as wfh'.
  allunfold @closed_type; allunfold @closed_extract; allsimpl.
  allapply @vswf_hypotheses_nil_implies.
  allrw @wf_hypotheses_app.
  destruct wfh as [ wfh wfj ].
  allrw @wf_hypotheses_snoc.
  destruct wfh as [ ispvg wfh ].
  destruct wfh as [ nixg wfg ].
  allrw @nh_vars_hyps_snoc; allsimpl.
  allrw @vars_hyps_snoc; allsimpl.
  duplicate cg as ceq.
  allrw @covered_equality.
  destruct cg as [ cx ct ].
  destruct ct as [ cx2 ca ]; GC.
  allrw @vars_hyps_app; allsimpl.
  allrw @vars_hyps_snoc; allsimpl.
  duplicate wfct as wfct'.
  rw <- @wf_equality_iff in wfct.
  destruct wfct as [ wa wtt ].
  destruct wtt as [ wb wtA ].

  exists (@covered_axiom o (nh_vars_hyps (snoc G (mk_hyp x A) ++ J))).

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars A)
          # !LIn x (vars_hyps J)
          # subset (free_vars A) (vars_hyps G)
          # disjoint (free_vars A) (vars_hyps J)) as vhyps.

  dwfseq.
  sp;
  try (complete (apply subset_disjoint with (l1 := free_vars A) in wfj2; auto;
                 apply subset_snoc_r; sp)).

  destruct vhyps as [ nixa vhyps ].
  destruct vhyps as [ nixj vhyps ].
  destruct vhyps as [ sag daj ].
  (* done with proving these simple facts *)

  vr_seq_true.

  lift_lsubst.

  repeat (rewrite fold_mkc_member).
  rewrite member_eq.
  rw <- @member_member_iff.
  rw @tequality_mkc_member.

  applydup eqh in sim; clear eqh.
  allrw @similarity_app; exrepd; subst; cpx.
  allrw @similarity_snoc; exrepd; subst; cpx.
  revert c1 cT c0 cT0; rewrite hvar_mk_hyp; intros.
  allrw @eq_hyps_app; exrepd; simphyps; cpx.
  apply app_split in e; repd; subst; allrewrite length_snoc; try omega; cpx; GC.
  apply app_split in e0; repd; subst; allrewrite length_snoc; try omega; cpx; GC.
  allrw @eq_hyps_snoc; exrepd; cpx; simphyps; cpx; GC; clear_irr.

  assert (disjoint (free_vars (@mk_var o x)) (dom_csub s1b0)) as dxs1
         by (simpl; rw disjoint_singleton_l;
             allapply @similarity_dom; repd; rterm (dom_csub s1b0);
             rewrite vars_hyps_substitute_hyps; auto).

  assert (disjoint (free_vars (@mk_var o x)) (dom_csub s2b0)) as dxs2
         by (simpl; rw disjoint_singleton_l;
             allapply @similarity_dom; repd; rterm (dom_csub s2b0);
             rewrite vars_hyps_substitute_hyps; auto).

  assert (disjoint (free_vars A) (dom_csub s1b0)) as das1
         by (allapply @similarity_dom; repd; rterm (dom_csub s1b0);
             rewrite vars_hyps_substitute_hyps; auto).

  assert (disjoint (free_vars A) (dom_csub s2b0)) as das2
         by (allapply @similarity_dom; repd; rterm (dom_csub s2b0);
             rewrite vars_hyps_substitute_hyps; auto).

  generalize (subset_free_vars_lsubstc_app_ex
                (mk_var x)
                (snoc s1a (x, t0)) s1b0
                w1 c1 dxs1); intro; exrepd; rewrite e; clear e.

  generalize (subset_free_vars_lsubstc_app_ex
                (mk_var x)
                (snoc s2a (x, t3)) s2b0
                w1 c0 dxs2); intro; exrepd; rewrite e; clear e.

  generalize (subset_free_vars_lsubstc_app_ex
                A
                (snoc s1a (x, t0)) s1b0
                wtA cT das1); intro; exrepd; rewrite e; clear e.

  generalize (subset_free_vars_lsubstc_app_ex
                A
                (snoc s2a (x, t3)) s2b0
                wtA cT0 das2); intro; exrepd; rewrite e; clear e.

  lsubst_tac.

  applydup @equality_refl in e3; sp.

  split; sp; GC.
  apply @tequality_preserving_equality with (A := lsubstc A wtA s1a p1); auto.
  rewrite member_eq.
  apply equality_sym in e3.
  apply equality_refl in e3; sp.
Qed.

(* begin hide *)

(* end hide *)

(* [5] ============ INTRODUCTION ============ *)

(**

  The following rule says that to prove a conclusion [C] one can
  always provide an evidence [t] for that type and prove instead that
  [t] is a member of [C]:
<<
   H |- C ext t

     By introduction t

     H |- t = t in C
>>
*)

Definition rule_introduction {o}
             (H : @barehypotheses o)
             (C t : NTerm) :=
  mk_rule
    (mk_baresequent H (mk_concl C t))
    [ mk_baresequent H (mk_conclax (mk_equality t t C)) ]
    [ sarg_term t ].

Lemma rule_introduction_true {o} :
  forall
    lib
    (H : @barehypotheses o)
    (C t : NTerm),
    rule_true lib (rule_introduction H C t).
Proof.
  intros.
  unfold rule_introduction, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  unfold args_constraints in cargs; allsimpl.
  generalize (cargs (sarg_term t) (inl eq_refl)); clear cargs; intro arg1.
  unfold arg_constraints in arg1.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  generalize (hyps (mk_baresequent H (mk_conclax (mk_equality t t C)))
                   (inl eq_refl));
    simpl; intros hyp1; clear hyps.
  destruct hyp1 as [ ws1 hyp1 ].
  destseq; allsimpl; proof_irr; GC.

  duplicate ct as ct1.
  allrw @covered_equality.
  destruct ct as [ cth ct ].
  destruct ct as [ cth2 cch ]; GC.

  assert (covered t (nh_vars_hyps H)) as ws by sp.
  exists ws; GC.

  vr_seq_true.

  vr_seq_true in hyp1.

  generalize (hyp1 s1 s2); clear hyp1; intro hyp1.
  autodimp hyp1 h.
  autodimp hyp1 h.
  exrepd.

  lift_lsubst in t0; lift_lsubst in e; clear_irr.

  rw @tequality_mkc_equality in t0; sp.

  allrewrite @lsubstc_mk_axiom.
  allrewrite @member_eq.
  allrewrite @fold_mkc_member.
  rw <- @member_member_iff in e.

  spcast; apply @equality_respects_cequivc_right with (t2 := lsubstc t wfce s1 pt1); sp.
Qed.

(* begin hide *)

(* end hide *)

(* [6] ============ HYPOTHESIS ============ *)

(**

  The following rule is another form of the standard ``hypothesis''
  rule:
<<
   G, x : A, J |- A ext x

     By hypothsis hyp(i) ()

     no subgoals
>>
 *)

Definition rule_hypothesis {o}
             (G J : @barehypotheses o)
             (A   : NTerm)
             (x   : NVar) :=
  mk_rule
    (mk_baresequent (snoc G (mk_hyp x A) ++ J) (mk_concl A (mk_var x)))
    []
    [].

Lemma rule_hypothesis_true {o} :
  forall lib (G J : @barehypotheses o)
         (A : NTerm)
         (x : NVar),
    rule_true lib (rule_hypothesis G J A x).
Proof.
  intros.

  generalize (rule_introduction_true
                lib
                (snoc G (mk_hyp x A) ++ J)
                A
                (mk_var x)).

  intro h.
  rw <- @rule_true_eq_ex in h.
  unfold rule_true_ex, rule_true_if in h; exrepd.

  unfold rule_true; allsimpl; sp.
  clear cargs hyps.

  assert (closed_extract_baresequent
            (mk_baresequent (snoc G (mk_hyp x A) ++ J) (mk_concl A (mk_var x))))
    as ce by prove_seq.
  exists ce; sp.

  apply s; try (complete prove_seq).

  sp; subst.

  generalize (rule_hypothesis_equality_true lib G J A x).

  intro h.
  rw <- @rule_true_eq_ex in h.
  unfold rule_true_ex, rule_true_if in h; exrepd.

  apply s0; try (complete prove_seq).
Qed.

(* begin hide *)

(* end hide *)

(* [7] ============ THIN ============ *)

(**

  The following rule says that one can always delete (or thin) an
  hypothesis (as long as [J] does not depend on [x], because [H, J]
  has to be well-formed):

<<
   H, x : A, J |- C ext t

     By thin hyp(i) ()

     H, J |- C ext t
>>

 *)

Definition rule_thin {o}
           (G J : @barehypotheses o)
           (A C t : NTerm)
           (x   : NVar) :=
  mk_rule
    (mk_baresequent (snoc G (mk_hyp x A) ++ J) (mk_concl C t))
    [ mk_baresequent (G ++ J) (mk_concl C t) ]
    [].

Lemma rule_thin_true {o} :
  forall lib (G J : @barehypotheses o)
         (A C t : NTerm)
         (x   : NVar),
    rule_true lib (rule_thin G J A C t x).
Proof.
  intros.
  unfold rule_thin, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  duplicate wfh as wfh'.
  allapply @vswf_hypotheses_nil_implies.
  allrw @wf_hypotheses_app.
  destruct wfh as [ wfh wfj ].
  allrw @wf_hypotheses_snoc.
  destruct wfh as [ ispvg wfh ].
  destruct wfh as [ nixg wfg ].
  allrw @vars_hyps_app; allsimpl.
  allrw @vars_hyps_snoc; allsimpl; GC.

  generalize (hyps (mk_baresequent (G ++ J) (mk_concl C t)) (inl (eq_refl)));
    clear hyps; intro hyp1.
  destruct hyp1 as [ ws1 hyp1 ].
  destseq; allsimpl; proof_irr; GC.

  assert (covered t (nh_vars_hyps (snoc G (mk_hyp x A) ++ J))) as ws
         by (clear hyp1; prove_seq; apply covered_snoc_app_weak; auto).
  exists ws; GC.

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

  clear hyp1.
  dwfseq.
  sp;
    try (complete (apply ct in X; allrw in_app_iff; sp));
    try (complete (apply ce in X; allrw in_app_iff; sp;
                   generalize (subvars_hs_vars_hyps G); intro sv1; allrw subvars_prop;
                   generalize (subvars_hs_vars_hyps J); intro sv2; allrw subvars_prop; sp));
    try (complete (apply wfh in X; allrw in_app_iff; sp)).

  destruct vhyps as [ nixc vhyps ].
  destruct vhyps as [ nixt vhyps ].
  destruct vhyps as [ nixj1 vhyps ].
  destruct vhyps as [ nixj2 nixj3 ].
  (* done with proving these simple facts *)

  vr_seq_true.

  rw @similarity_app in sim; exrepd; subst; cpx.
  rw @similarity_snoc in s; exrepd; subst; allsimpl; cpx.

  vr_seq_true in hyp1.

  generalize (hyp1 (s1a0 ++ s1b) (s2a0 ++ s2b)); clear hyp1; intro hyp1.
  autodimp hyp1 hyp.

  intros s3 sim3.
  rw @similarity_app in sim3; exrepnd; subst.
  apply app_split in sim0; sp; subst;
  try (complete (allapply @similarity_length; sp; omega)).
  generalize (eqh (snoc s2a (x, t1) ++ s2b0)); intro h.
  autodimp h hyp.

  rw @similarity_app.
  exists (snoc s1a (x, t1)) s1b0 (snoc s2a (x, t1)) s2b0; simpl; sp;
  allrewrite length_snoc; sp.

  rw @similarity_snoc; simpl.
  exists s1a s2a t1 t1 w p; sp.
  rewrite member_eq.
  allapply @equality_refl; sp.

  rewrite substitute_hyps_snoc_sub_weak; sp.

  rw @eq_hyps_app in h; exrepnd.
  apply app_split in h0; apply app_split in h2; sp; subst;
  allrewrite length_snoc; sp;
  try (complete (allapply @similarity_length; sp; omega)).
  allrw @eq_hyps_snoc; exrepnd; allsimpl; cpx; GC.

  rw @eq_hyps_app.
  exists s1a0 s1b s2a1 s2b1; sp.
  apply sub_eq_hyps_snoc_weak_iff in h1; sp.

  clear_irr.
  autodimp hyp1 hyp.
  rw @similarity_app.
  exists s1a0 s1b s2a0 s2b; sp.
  rewrite substitute_hyps_snoc_sub_weak in s0; sp.
  exrepd; clear_irr.

  assert (lsubstc C wfct (snoc s1a0 (x, t1) ++ s1b) pC1
          = lsubstc C wfct (s1a0 ++ s1b) pC0) as eq1;
    try (rewrite eq1).

  apply lsubstc_eq_if_csubst; sp.
  apply subset_free_vars_csub_snoc_app; sp.

  assert (lsubstc C wfct (snoc s2a0 (x, t2) ++ s2b) pC2
          = lsubstc C wfct (s2a0 ++ s2b) pC3) as eq2;
    try (rewrite eq2).

  apply lsubstc_eq_if_csubst; sp.
  apply subset_free_vars_csub_snoc_app; sp.

  assert (lsubstc t wfce (snoc s1a0 (x, t1) ++ s1b) pt1
          = lsubstc t wfce (s1a0 ++ s1b) pt0) as eq3;
    try (rewrite eq3).

  apply lsubstc_eq_if_csubst; sp.
  apply subset_free_vars_csub_snoc_app; sp.

  assert (lsubstc t wfce (snoc s2a0 (x, t2) ++ s2b) pt2
          = lsubstc t wfce (s2a0 ++ s2b) pt3) as eq4;
    try (rewrite eq4).

  apply lsubstc_eq_if_csubst; sp.
  apply subset_free_vars_csub_snoc_app; sp.

  sp.
Qed.

(* begin hide *)

(* end hide *)

(* [13] ============ WIDENING ============ *)

(**

  The following rule state that if we are trying to prove a goal under
  the assumption that [x] has type [T], then it suffices to prove the
  goal under the hypothesis that [x] has type [U], as long as we can
  prove that [T] is a subtype of [U], and [T] respects the equality of
  [U] on the elements of [T]:

<<
  H, x : T, J |- C ext t

     By widening y z i

     H, x : U, J |- C ext t
     H, x : T, y : U, z : x = y in U |- x = y in T
     H, x : T |- x in U
>>
 *)

Definition rule_widening {o}
           (T U C t : @NTerm o)
           (x y z : NVar)
           (i : nat)
           (H J : barehypotheses) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x T) ++ J)
       (mk_concl C t))
    [ mk_baresequent (snoc H (mk_hyp x U) ++ J)
                    (mk_concl C t),
      mk_baresequent (snoc (snoc (snoc H (mk_hyp x T))
                                (mk_hyp y U))
                          (mk_hyp z (mk_equality (mk_var x) (mk_var y) U)))
                    (mk_conclax (mk_equality (mk_var x) (mk_var y) T)),
      mk_baresequent (snoc H (mk_hyp x T))
                    (mk_conclax (mk_member (mk_var x) U))
    ]
    [sarg_var y, sarg_var z].

Lemma rule_widening_true {o} :
  forall lib (T U C t : NTerm)
         (x y z : NVar)
         (i : nat)
         (H J : @barehypotheses o),
    rule_true lib
              (rule_widening
                 T U C t
                 x y z
                 i
                 H J).
Proof.
  unfold rule_widening, 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 H (mk_hyp x U) ++ J)
                      (mk_concl C t))
                   (inl eq_refl))
             (hyps (mk_baresequent
                      (snoc (snoc (snoc H (mk_hyp x T)) (mk_hyp y U))
                            (mk_hyp z (mk_equality (mk_var x) (mk_var y) U)))
                      (mk_conclax (mk_equality (mk_var x) (mk_var y) T)))
                   (inr (inl eq_refl)))
             (hyps (mk_baresequent
                      (snoc H (mk_hyp x T))
                      (mk_conclax (mk_member (mk_var x) U)))
                   (inr (inr (inl eq_refl))));
    simpl; intros hyp1 hyp2 hyp3.
  destruct hyp1 as [ ws1 hyp1 ].
  destruct hyp2 as [ ws2 hyp2 ].
  destruct hyp3 as [ ws3 hyp3 ].
  destseq; allsimpl; proof_irr; GC.
  clear hyps.

  assert (covered t (nh_vars_hyps (snoc H (mk_hyp x T) ++ J)))
    as co
      by (duplicate ce1 as ce2;
          allrw @nh_vars_hyps_app;
          allrw @nh_vars_hyps_snoc;
          allsimpl; sp).

  exists co; GC.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (vars_hyps H)
           # !LIn x (free_vars T)
           # !LIn x (free_vars U)
           # !(x = y)
           # !LIn y (vars_hyps H)
           # !LIn y (free_vars T)
           # !LIn y (free_vars U)
           # !LIn z (vars_hyps H)
           # !LIn z (free_vars T)
           # !LIn z (free_vars U)
           # wf_term U
           # covered T (vars_hyps H)
           # covered U (vars_hyps H)) as vhyps.

  clear hyp1 hyp2 hyp3.
  dwfseq.

  sp; try (complete (unfold covered; rw subvars_prop; sp)).

  destruct vhyps as [ nixH vhyps ].
  destruct vhyps as [ nixT vhyps ].
  destruct vhyps as [ nixU vhyps ].
  destruct vhyps as [ nixy vhyps ].
  destruct vhyps as [ niyH vhyps ].
  destruct vhyps as [ niyT vhyps ].
  destruct vhyps as [ niyU vhyps ].
  destruct vhyps as [ nizH vhyps ].
  destruct vhyps as [ nizT vhyps ].
  destruct vhyps as [ nizU vhyps ].
  destruct vhyps as [ wfu vhyps ].
  destruct vhyps as [ covTH covUH ].
  (* done with proving these simple facts *)

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

  (* we split s1 and s2 *)
  allrw @similarity_app; exrepd; subst; cpx.
  allrw @similarity_snoc; exrepd; subst; cpx.
  allsimpl.

  (* we use our 1st subgoal to prove that tequality *)
  vr_seq_true in hyp1.

  generalize (hyp1 (snoc s1a0 (x, t1) ++ s1b)
                   (snoc s2a0 (x, t2) ++ s2b));
    clear hyp1; intro hyp1.

  autodimp hyp1 h.

  introv sim.
  allrw @similarity_app; exrepd; subst; allsimpl; cpx.
  apply app_split in e; exrepd; allrw length_snoc; try (complete (allrw; sp)); subst; cpx.
  repeat (allrw @similarity_snoc; exrepd; subst; allsimpl; cpx; GC).

  rw @eq_hyps_app; simpl.
  exists (snoc s1a (x, t0)) s1b0 (snoc s2a1 (x, t3)) s2b0;
    allrw length_snoc; allrw; sp.

  assert (cover_vars U s2a1)
         as c2
         by (apply @cover_vars_dom_csub_eq with (s1 := s1a); sp;
             allrw @dom_csub_snoc; simpl;
             allapply @similarity_dom; repd; allrw; sp).

  rw @eq_hyps_snoc; simpl.
  exists s1a s2a1 t0 t3 w0 p0 c2; sp.

  generalize (eqh (snoc s2a1 (x, t2) ++ s2b)); intro imp.
  autodimp imp hyp.
  rw @similarity_app; simpl.
  exists (snoc s1a (x, t0)) s1b0 (snoc s2a1 (x, t2)) s2b; repeat (rw length_snoc); sp.
  rw @similarity_snoc; simpl.
  exists s1a s2a1 t0 t2 w p; sp.

  rw @eq_hyps_app in imp; exrepnd.
  apply app_split in imp0; exrepd; allrw length_snoc; try (complete (allrw; sp)); subst; cpx.
  apply app_split in imp2; exrepd; allrw length_snoc; try (complete (allrw; sp)); subst; cpx.
  rw @eq_hyps_snoc in imp5; exrepnd; sp; cpx.

  generalize (eqh (snoc s2a1 (x, t2) ++ s2b)); intro imp.
  autodimp imp hyp.
  rw @similarity_app; simpl.
  exists (snoc s1a (x, t0)) s1b0 (snoc s2a1 (x, t2)) s2b; repeat (rw length_snoc); sp.
  rw @similarity_snoc; simpl.
  exists s1a s2a1 t0 t2 w p; sp.

  rw @eq_hyps_app in imp; exrepnd.
  apply app_split in imp0; exrepd; allrw length_snoc; try (complete (allrw; sp)); subst; cpx.
  apply app_split in imp2; exrepd; allrw length_snoc; try (complete (allrw; sp)); subst; cpx.
  rw @eq_hyps_snoc in imp5; exrepnd; sp; cpx; allsimpl; cpx; clear_irr.

  (* from imp0 and sequent 3 *)
  generalize (subtype_tequality lib s1a0 s2a H T U x t1 t4 w w0 p1 p0 c2 (wfh0, (wfct0, wfce1), (ct, ce)));
    intro j; repeat (autodimp j hyp).
  apply hyps_functionality_init_seg with (s3 := s2b1) in eqh; sp.

  assert (cover_vars T s2a1)
    as c2
      by (apply @cover_vars_dom_csub_eq with (s1 := s1a); sp;
          allrw @dom_csub_snoc; simpl;
          allapply @similarity_dom; repd; allrw; sp).

  generalize (eqh (snoc s2a1 (x, t3) ++ s2b0)); intro j; autodimp j hyp.
  rw @similarity_app; simpl.
  exists (snoc s1a (x, t0)) s1b0 (snoc s2a1 (x, t3)) s2b0; allrw length_snoc; sp.
  rw @similarity_snoc; simpl.
  exists s1a s2a1 t0 t3 w p; sp.

  generalize (strong_subtype_equality lib s1a s2a1 t0 t2 t3 T U w w0 p p0 c2 H x y z
                                      (wfh0, (wfct0, wfce1), (ct, ce))
                                      (wfh1, (wfct1, wfce1), (ct0, ce0)));
    intro q; repeat (destimp q hyp).
  repnd.
  apply hyps_functionality_init_seg with (s3 := s2b) in eqh; sp.
  apply @equality_commutes4 with (U := lsubstc T w s2a1 c2) (a2 := t0) (a3 := t2); sp.

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

  (* we're done proving the hyps_functionality part for sequent 1 *)

  (* we now have to prove the similarity part *)

  autodimp hyp1 h.

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

  assert (cover_vars U s1a0)
    as c1 by (allrw @cover_vars_covered; allapply @similarity_dom; exrepnd; allrw; sp).

  exists s1a0 s2a0 t1 t2 wfu c1; sp.

  generalize (subtype_equality lib t1 t2 T U  s1a0 s2a0 w wfu p c1 H x
                               (wfh0, (wfct0, wfce1), (ct, ce)));
    intro j; repeat (autodimp j hyp).
  apply hyps_functionality_init_seg with (s3 := s2b) in eqh; sp.

  exrepnd; clear_irr; sp.
Qed.

(* begin hide *)

(* end hide *)

(* [18] ============ CUT ============ *)

(**

  The following rule is the standard cut rule:
<<
   H |- C ext t[x\u]

     By cut x B

     H |- B ext u
     H, x : B |- C ext t
>>
 *)

Definition rule_cut {o}
             (H : @barehypotheses o)
             (B C t u : NTerm)
             (x   : NVar) :=
  mk_rule
    (mk_baresequent H (mk_concl C (subst t x u)))
    [ mk_baresequent H (mk_concl B u),
      mk_baresequent (snoc H (mk_hyp x B)) (mk_concl C t)
    ]
    [sarg_var x].

Lemma rule_cut_true {o} :
  forall
    lib
    (H : @barehypotheses o)
    (B C t u : NTerm)
    (x : NVar)
    (bc : disjoint (free_vars u) (bound_vars t)),
    rule_true lib (rule_cut H B C t u x).
Proof.
  unfold rule_cut, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  generalize (hyps (mk_baresequent H (mk_concl B u))
                   (inl eq_refl))
             (hyps (mk_baresequent (snoc H (mk_hyp x B)) (mk_concl C t))
                   (inr (inl eq_refl)));
    simpl; intros hyp1 hyp2; clear hyps.
  destruct hyp1 as [ ws1 hyp1 ].
  destruct hyp2 as [ ws2 hyp2 ].
  destseq; allsimpl; clear_irr; GC.

  assert (covered (subst t x u) (vars_hyps (filter is_nh H))) as cv.
  clear hyp1 hyp2.
  dwfseq.
  introv i.
  generalize (eqvars_free_vars_disjoint t [(x,u)]); intro eqv.
  rw eqvars_prop in eqv.
  rw @fold_subst in eqv.
  rw eqv in i.
  rw in_app_iff in i; rw in_remove_nvars in i; allsimpl; sp.
  apply not_over_or in p; sp.
  apply ce in p0.
  apply in_snoc in p0; sp.
  allapply @in_sub_free_vars; sp.
  destruct (memvar x (free_vars t)); allsimpl; sp; cpx.

  exists cv.

  (* We prove some simple facts on our sequents *)
  assert (! LIn x (free_vars B)
          /\ ! LIn x (free_vars C)
          /\ ! LIn x (free_vars u)
          /\ ! LIn x (vars_hyps H)
          /\ wf_term u
          /\ wf_term B
          /\  covered u (nh_vars_hyps H)
          /\  covered B (vars_hyps H)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
  try (complete (generalize (ce0 x); sp;
                 generalize (subset_hs_vars_hyps H); intro k;
                 apply k in X0; sp));
  try (complete (rw subvars_eq; unfold subset; sp)).

  destruct vhyps as [ nixb vhyps ].
  destruct vhyps as [ nixc vhyps ].
  destruct vhyps as [ nixu vhyps ].
  destruct vhyps as [ nixh vhyps ].
  destruct vhyps as [ wu vhyps ].
  destruct vhyps as [ wb vhyps ].
  destruct vhyps as [ cuh cbh ].
  (* done with proving these simple facts *)

  vr_seq_true.

  vr_seq_true in hyp2.

  assert (cover_vars u s1)
         as cu1
         by (rw @cover_vars_eq;
             unfold covered in ce0;
             insub;
             apply subvars_trans with (vs2 := nh_vars_hyps H); sp).

  assert (cover_vars u s2)
         as cu2
         by (rw @cover_vars_eq;
             unfold covered in ce0;
             insub;
             apply subvars_trans with (vs2 := nh_vars_hyps H); sp).

  generalize (hyp2
                (snoc s1 (x, lsubstc u wfce1 s1 cu1))
                (snoc s2 (x, lsubstc u wfce1 s2 cu2))); clear hyp2; intro hyp2.

  autodimp hyp2 hyp.
  generalize (hyps_functionality_snoc lib H (mk_hyp x B) s1 (lsubstc u wfce1 s1 cu1)).
  intro imp; apply imp; thin imp; try (complete auto).
  introv eq sim'; allsimpl.

  vr_seq_true in hyp1.
  generalize (hyp1 s1 s'); clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd; clear_irr; sp.

  assert (cover_vars B s1) as cvbs1 by (rw @cover_vars_eq; insub).

  autodimp hyp2 hyp.
  rw @similarity_snoc; simpl.
  exists s1 s2 (lsubstc u wfce1 s1 cu1) (lsubstc u wfce1 s2 cu2) wfct1 cvbs1; sp.

  vr_seq_true in hyp1.
  generalize (hyp1 s1 s2); clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd; clear_irr; sp.

  exrepnd.

  assert (lsubstc t wfce0 (snoc s1 (x, lsubstc u wfce1 s1 cu1)) pt0
          = lsubstc (subst t x u) wfce s1 pt1) as eq1.

  symmetry; apply lsubstc_eq_if_csubst.
  unfold csubst, subst.
  rw @csub2sub_snoc; simpl.
  rw <- @lsubst_swap;
    try (complete (sp; allapply @in_csub2sub; sp));
    try (complete (apply @isprogram_csubst; sp; rw @nt_wf_eq; sp));
    try (complete (rw @dom_csub_eq; insub)).
  rw @simple_lsubst_lsubst;
    try (complete (simpl; sp; cpx));
    try (complete (sp; allapply @in_csub2sub; sp)).

  assert (lsubstc t wfce0 (snoc s2 (x, lsubstc u wfce1 s2 cu2)) pt3
          = lsubstc (subst t x u) wfce s2 pt2) as eq2.

  symmetry; apply lsubstc_eq_if_csubst.
  unfold csubst, subst.
  rw @csub2sub_snoc; simpl.
  rw <- @lsubst_swap;
    try (complete (sp; allapply @in_csub2sub; sp));
    try (complete (apply @isprogram_csubst; sp; rw @nt_wf_eq; sp));
    try (complete (rw @dom_csub_eq; insub)).
  rw @simple_lsubst_lsubst;
    try (complete (simpl; sp; cpx));
    try (complete (sp; allapply @in_csub2sub; sp)).

  rw eq1 in hyp2; rw eq2 in hyp2.
  lsubst_tac; sp.
Qed.

(* begin hide *)

Lemma rule_cut_true_ex {o} :
  forall lib (H : @bhyps o) B C t u x
         (bc : disjoint (free_vars u) (bound_vars t)),
    rule_true_if lib (rule_cut H B C t u x).
Proof.
  intros.
  generalize (rule_cut_true lib H B C t u x bc); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)

(* [19] ============ CUTH ============ *)

(**

  This rule is similar to the cut rule, but is valid only if [x] is
  not free in the extract:

<<
   H |- C ext t

     By cutH x B

     H |- B ext u
     H, [x : B] |- C ext t
>>
 *)

Definition rule_cutH {o}
             (H : @barehypotheses o)
             (B C t u : NTerm)
             (x   : NVar) :=
  mk_rule
    (mk_baresequent H (mk_concl C t))
    [ mk_baresequent H (mk_concl B u),
      mk_baresequent (snoc H (mk_hhyp x B)) (mk_concl C t)
    ]
    [sarg_var x].

Lemma rule_cutH_true {o} :
  forall
    lib
    (H : @barehypotheses o)
    (B C t u : NTerm)
    (x : NVar),
    rule_true lib (rule_cutH H B C t u x).
Proof.
  unfold rule_cutH, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  generalize (hyps (mk_baresequent H (mk_concl B u))
                   (inl eq_refl))
             (hyps (mk_baresequent (snoc H (mk_hhyp x B)) (mk_concl C t))
                   (inr (inl eq_refl)));
    simpl; intros hyp1 hyp2; clear hyps.
  destruct hyp1 as [ ws1 hyp1 ].
  destruct hyp2 as [ ws2 hyp2 ].
  destseq; allsimpl; proof_irr; GC.

  assert (covered t (vars_hyps (filter is_nh H))) as cv.
  clear hyp1 hyp2.
  dwfseq.
  introv i.
  apply ce in i; sp.

  exists cv.

  (* We prove some simple facts on our sequents *)
  assert (! LIn x (free_vars B)
          /\ ! LIn x (free_vars C)
          /\ ! LIn x (free_vars u)
          /\ ! LIn x (vars_hyps H)
          /\ ! LIn x (free_vars t)
          /\ wf_term u
          /\ wf_term B
          /\  covered u (nh_vars_hyps H)
          /\  covered B (vars_hyps H)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
  try (complete (generalize (ce0 x); sp;
                 generalize (subset_hs_vars_hyps H); intro k;
                 apply k in X0; sp));
  try (complete (generalize (ce x); sp;
                 generalize (subset_hs_vars_hyps H); intro k;
                 apply k in X0; sp));
  try (complete (rw subvars_eq; unfold subset; sp)).

  destruct vhyps as [ nixb vhyps ].
  destruct vhyps as [ nixc vhyps ].
  destruct vhyps as [ nixu vhyps ].
  destruct vhyps as [ nixh vhyps ].
  destruct vhyps as [ nixt vhyps ].
  destruct vhyps as [ wu vhyps ].
  destruct vhyps as [ wb vhyps ].
  destruct vhyps as [ cuh cbh ].
  (* done with proving these simple facts *)

  vr_seq_true.

  vr_seq_true in hyp2.

  assert (cover_vars u s1)
         as cu1
         by (rw @cover_vars_eq;
             unfold covered in ce0;
             insub;
             apply subvars_trans with (vs2 := nh_vars_hyps H); sp).

  assert (cover_vars u s2)
         as cu2
         by (rw @cover_vars_eq;
             unfold covered in ce0;
             insub;
             apply subvars_trans with (vs2 := nh_vars_hyps H); sp).

  generalize (hyp2
                (snoc s1 (x, lsubstc u wfce1 s1 cu1))
                (snoc s2 (x, lsubstc u wfce1 s2 cu2))); clear hyp2; intro hyp2.

  autodimp hyp2 hyp.
  generalize (hyps_functionality_snoc lib H (mk_hhyp x B) s1 (lsubstc u wfce1 s1 cu1)).
  intro imp; apply imp; thin imp; try (complete auto).
  introv eq sim'; allsimpl.

  vr_seq_true in hyp1.
  generalize (hyp1 s1 s'); clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd; clear_irr; sp.

  assert (cover_vars B s1) as cvbs1 by (rw @cover_vars_eq; insub).

  autodimp hyp2 hyp.
  rw @similarity_snoc; simpl.
  exists s1 s2 (lsubstc u wfce1 s1 cu1) (lsubstc u wfce1 s2 cu2) wfct1 cvbs1; sp.

  vr_seq_true in hyp1.
  generalize (hyp1 s1 s2); clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd; clear_irr; sp.

  exrepnd.
  lsubst_tac; sp.
Qed.

(* begin hide *)

Lemma rule_cutH_true_ex {o} :
  forall lib (H : @bhyps o) B C t u x,
    rule_true_if lib (rule_cutH H B C t u x).
Proof.
  intros.
  generalize (rule_cutH_true lib H B C t u x); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntax_ott
               rules_inf
               Infrastructure.

Require Import List. Import ListNotations.
Require Import Strings.String.

Lemma Typing_chk: forall G e A,
  Typing G e Inf A ->
  exists B, Typing G e Chk B.
Proof.
  introv Typ.
  inductions Typ; eauto.
Qed.

Lemma Typing_chk2: forall G e A,
  Typing G e Chk A ->
  exists B, Typing G e Inf B.
Proof.
  introv Typ.
  inductions Typ; eauto.
Qed.

(* Check Mode *)
Lemma Typing_chk2inf: forall G v A,
    Typing G v Chk A -> exists B, Typing G v Inf B /\ sim B A.
Proof.
  intros G v A Typ.
  inductions Typ; try solve [inverts Val].
  exists.
  split*.
Qed.

(* Common Lemmas *)
Lemma Typing_regular_1 : forall e G dir A,
    Typing G e dir A -> lc_exp e.
Proof.
  intros e G dir A H.
  induction H;
    eauto.
Qed.

Lemma gtyping_regular_1 : forall e G dir A,
    gtyping G e dir A -> lc_exp e.
Proof.
  intros e G dir A H.
  inductions H;
    eauto.
Qed.

Lemma Typing_regular_2 : forall G e dir T,
    Typing G e dir T -> uniq G.
Proof.
  intros. induction* H.
  pick fresh y.
  assert (uniq ((y, A) :: G)) by auto.
  solve_uniq.
Qed.

Lemma Typing_weaken : forall G E F e dir T,
    Typing (E ++ G) e dir T ->
    uniq (E ++ F ++ G) ->
    Typing (E ++ F ++ G) e dir T.
Proof.
  introv Typ; gen F;
    inductions Typ; introv Ok; autos*.
    + (* abs *)
      pick fresh x and apply Typ_abs; eauto.
      rewrite_env (([(x, A)] ++ E) ++ F ++ G).
      apply~ H0.
      solve_uniq.
Qed.

Lemma Typing_weakening : forall (E F : ctx) e dir T,
    Typing E e dir T ->
    uniq (F ++ E) ->
    Typing (F ++ E) e dir T.
Proof.
  intros.
  rewrite_env (nil ++ F ++ E).
  apply~ Typing_weaken.
Qed.

(** Typing is preserved by substitution. *)

Lemma fv_in_dom: forall G e dir T,
    Typing G e dir T -> fv_exp e [<=] dom G.
Proof.
  intros G e dir T H.
  induction H; simpl; try fsetdec.
  - Case "typing_var".
    apply binds_In in H0.
    fsetdec.
  - Case "typing_abs".
    pick fresh x.
    assert (Fx : fv_exp (e ^ x) [<=] dom ([(x,A)] ++ G))
      by eauto.
    simpl in Fx.
    assert (Fy : fv_exp e [<=] fv_exp (e ^ x)) by
        eapply fv_exp_open_exp_wrt_exp_lower.
    fsetdec.
Qed.

Lemma value_no_fv : forall v dir T,
    Typing [] v dir T -> fv_exp v [<=] empty.
Proof.
  intro v.
  pose proof (fv_in_dom [] v).
  intuition eauto.
Qed.

Lemma fvalue_no_fv : forall v dir T,
    Typing [] v dir T -> fv_exp v [<=] empty.
Proof.
  intro v.
  pose proof (fv_in_dom [] v).
  intuition eauto.
Qed.

Lemma subst_value : forall v T dir z u,
    Typing [] v dir T -> subst_exp u z v = v.
Proof.
  intros v dir T z u Typ.
  lets* Fv: value_no_fv Typ.
  forwards*: subst_exp_fresh_eq.
  rewrite Fv.
  fsetdec.
Qed.

Lemma subst_fvalue : forall v T dir z u,
    Typing [] v dir T -> subst_exp u z v = v.
Proof.
  intros v dir T z u Typ.
  lets* Fv: fvalue_no_fv Typ.
  forwards*: subst_exp_fresh_eq.
  rewrite Fv.
  fsetdec.
Qed.

Lemma Typing_subst_1 : forall (E F : ctx) e u S dir T (z : atom),
    Typing (F ++ [(z,S)] ++ E) e dir T ->
    Typing E u Inf S ->
    Typing (F ++ E) ([z ~> u] e) dir T.
Proof.
  intros.
  remember (F ++ [(z,S)] ++ E) as E'.
  generalize dependent F.
  induction H; intros F Eq; subst; simpl; autos*;
    lets Lc  : Typing_regular_1 H0;
    lets Uni : Typing_regular_2 H0.
  -
    case_if*.
    substs.
    assert (A = S).
    eapply binds_mid_eq; eauto.
    substs.
    apply~ Typing_weakening.
    solve_uniq.
  -
    pick fresh x and apply Typ_abs; eauto.
    rewrite subst_exp_open_exp_wrt_exp_var; auto.
    rewrite_env (([(x, A)] ++ F) ++ E).
    apply~ H1.
  - forwards*: subst_fvalue H2.
    rewrite H4.
    eapply Typ_save; eauto.
Qed.

Lemma typing_c_subst_simpl : forall E e u S dir T z,
  Typing ([(z,S)] ++ E) e dir T ->
  Typing E u Inf S ->
  Typing E ([z ~> u] e) dir T.
Proof.
  intros E e u S dir T z H1 H2.
  rewrite_env (nil ++ E).
  eapply Typing_subst_1.
    simpl_env. apply H1.
    apply H2.
Qed.

(* stronger than inf unique *)
Lemma Typing_strenthening : forall G e A1 A2,
    []  ⊢ e ⇒ A1 ->
    G ⊢ e ⇒ A2 ->
    A1 = A2.
Proof.
  introv Ty1.
  gen_eq Dir : Inf.
  gen A2 G.
  inductions Ty1; introv Eq Ty2; try (inverts* Eq); try (inverts* Ty2).
  - (* t_var *)
    inverts H0.
  - (* t_app *)
    forwards * : IHTy1_1 H2.
    inverts* H.
Qed.

Lemma inference_unique : forall G e A1 A2,
    Typing G e Inf A1 ->
    Typing G e Inf A2 ->
    A1 = A2.
Proof.
  introv Ty1.
  gen_eq Dir : Inf.
  gen A2.
  induction Ty1; introv Eq Ty2; try (inverts* Eq); try (inverts* Ty2).
  - (* t_var *)
    forwards*: binds_unique H0 H4.
  - (* t_app *)
    forwards * : IHTy1_1 H2.
    inverts* H.
Qed.


Require Import universe.

Inductive void : [univ] := .

(* ========= Here is a constuctive iff ======== *)

(*Definition t_iff A B := (A -> B) # (B -> A).*)

Inductive t_iff (A B : [univ]) : [univ] :=
 | t_iff_cons : (A -> B) -> (B -> A) -> t_iff A B.

Notation "x <=> y" := (iff x y) (at level 95, no associativity).

Lemma tiff_trans :
  forall a b c, (a <=> b) -> (b <=> c) -> (a <=> c).
Proof.
  intros a b c i1 i2.
  destruct i1 as [i11 i12].
  destruct i2 as [i21 i22].
  split; intro k.
  apply i11 in k; apply i21 in k; auto.
  apply i22 in k; apply i12 in k; auto.
Qed.

Ltac dtiff :=
  match goal with
      [ H : ?x <=> ?y |- _ ] => destruct H
  end.

Ltac dtiffs := repeat dtiff.

Ltac dprod :=
  match goal with
      [ H : ?x # ?y |- _ ] => destruct H
  end.

Ltac dprods := repeat dprod.

Ltac dsum :=
  match goal with
      [ H : ?x [+] ?y |- _ ] => destruct H
  end.

Ltac dsums := repeat dsums.

Ltac dall :=
  repeat match goal with
           | [ H : ?x <=> ?y |- _ ] => destruct H
           | [ H : ?x # ?y   |- _ ] => destruct H
           | [ H : ?x [+] ?y |- _ ] => destruct H
         end.

Definition tiff_fst :=
  fun {A B : [univ]} (p : A <=> B) => let (x, _) := p in x.

Definition tiff_snd :=
  fun {A B : [univ]} (p : A <=> B) => let (_, y) := p in y.

Lemma tiff_is_prod_implies1 :
  forall A B,
    (A <=> B) <=> ((A -> B) # (B -> A)).
Proof.
  intros; split; intros k; split; intros; destruct k; auto.
Qed.

Lemma tiff_is_prod_implies2 :
  forall A B : [univ],
    ((A -> B) # (B -> A)) <=> (A <=> B).
Proof.
  intros; split; intros k; split; intros; destruct k; auto.
Qed.

Lemma combine_t_iff_proofs_imp :
  forall {A B A' B' : [univ]},
    (A <=> A') -> (B <=> B') -> ((A -> B) <=> (A' -> B')).
Proof.
  intros; dall; constructor; auto.
Qed.

Lemma combine_t_iff_proofs_t_iff :
  forall {A B A' B'},
    (A <=> A')
    -> (B <=> B')
    -> ((A <=> B) <=> (A' <=> B')).
Proof.
  intros.
  dall; constructor; intro; dall; constructor; auto.
Qed.

Lemma combine_t_iff_proofs_prod :
  forall {A B A' B'},
    (A <=> A')
    -> (B <=> B')
    -> ((A # B) <=> (A' # B')).
Proof.
  intros.
  dall; constructor; intro; dall; auto.
Qed.

Lemma combine_t_iff_proofs_sum :
  forall {A B A' B'},
    (A <=> A')
    -> (B <=> B')
    -> ((A [+] B) <=> (A' [+] B')).
Proof.
  intros.
  dall; constructor; intro; dall; auto.
Qed.

Lemma combine_t_iff_proofs_not :
  forall {A A'},
    (A <=> A')
    -> (!A <=> !A').
Proof.
  intros.
  dall; constructor; repeat intro; auto.
Qed.

Lemma t_iff_refl :
  forall A, A <=> A.
Proof.
  intros; constructor; auto.
Qed.

Lemma t_iff_sym :
  forall {A B}, (A <=> B) -> (B <=> A).
Proof.
  intros.
  dall; constructor; auto.
Qed.

(* this build a proof object of T <=> T[b/a] where p is the proof of a<=>b.
*)
Ltac build_tiff_term T a b p :=
  match T with
    | a => p
    | ?x -> ?y =>
      let l := build_tiff_term x a b p in
      let r := build_tiff_term y a b p in
      constr:(combine_t_iff_proofs_imp l r)
    | ?x <=> ?y =>
      let l := build_tiff_term x a b p in
      let r := build_tiff_term y a b p in
      constr:(combine_t_iff_proofs_t_iff l r)
    | ?x # ?y =>
      let l := build_tiff_term x a b p in
      let r := build_tiff_term y a b p in
      constr:(combine_t_iff_proofs_prod l r)
    | ?x [+] ?y =>
      let l := build_tiff_term x a b p in
      let r := build_tiff_term y a b p in
      constr:(combine_t_iff_proofs_sum l r)
    | !?x =>
      let l := build_tiff_term x a b p in
      constr:(combine_t_iff_proofs_not l)
    | _ => constr:(t_iff_refl T)
  end.

Tactic Notation "thin_last" :=
  match goal with H: ?T |- _ => clear H end.

Ltac apply' H1 H2 :=
  let H3 := fresh in
  (pose proof (H1 H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
  (pose proof (H1 _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
  (pose proof (H1 _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
  (pose proof (H1 _ _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
  (pose proof (H1 _ _ _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
  (pose proof (H1 _ _ _ _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
  (pose proof (H1 _ _ _ _ _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
  (pose proof (H1 _ _ _ _ _ _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
  (pose proof (H1 _ _ _ _ _ _ _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
  (pose proof (H1 _ _ _ _ _ _ _ _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
  (pose proof (H1 _ _ _ _ _ _ _ _ _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3).

Ltac build_and_rewrite H :=
  let T := type of H in
  match goal with
    | [ |- ?C ] =>
      match T with
        | ?A <=> ?B =>
          let d := build_tiff_term C A B H in
          let name := fresh H in
          remember d as name;
            thin_last;
            apply  name;
            clear name
      end
  end.

Ltac build_and_rewrite_hyp H H2 :=
  let T := type of H in
  let C := type of H2 in
  match T with
    | ?A <=> ?B =>
      let d := build_tiff_term C A B H in
      let name := fresh H in
      remember d as name;
        thin_last;
        apply' (tiff_fst name) H2;
        clear name
  end.

Ltac build_and_rewrite_rev H :=
  let T := type of H in
  match goal with
    | [ |- ?C ] =>
      match T with
        | ?A <=> ?B =>
          let d := build_tiff_term C B A (t_iff_sym H) in
          let name := fresh H in
          remember d as name;
            thin_last;
            apply name;
            clear name
      end
  end.

Ltac build_and_rewrite_hyp_rev H H2 :=
  let T := type of H in
  let C := type of H2 in
  match T with
    | ?A <=> ?B =>
      let d := build_tiff_term C B A (t_iff_sym H) in
      let name := fresh H in
      remember d as name;
        thin_last;
        apply' (tiff_fst name)  H2;
        clear name
  end.

Tactic Notation "trewrite" ident(H) :=
       build_and_rewrite H.

Tactic Notation "trewrite" ident(H) "in" ident (H') :=
       build_and_rewrite_hyp H H'.

Tactic Notation "trewrite" "<-" ident(H) :=
       build_and_rewrite_rev H.

Tactic Notation "trewrite" "<-" ident(H) "in" ident(H') :=
       build_and_rewrite_hyp_rev H H'.

Ltac get_instance_of  T  H Hn :=
  match H with
    | _ =>
     let name:= fresh "Htemp" in
      (* idtac "trying gio" H;*)
     progress (
        (pose proof (fun h:H => (tiff_fst T) h) as name)||
        (pose proof (fun h:H => (tiff_fst (T _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _ _ _ _ _)) h) as name)
      ); (* idtac "succeded" H; *)
     let H2 := type of name in
         match H2 with
           | ?H -> ?H => fail 1 (* both sides are the same, we won't rewrite anything *)
           | ?H -> ?H2 =>
             clear name;
               assert (H <=> H2) as Hn by (apply T)
         (*; idtac "really succeded" H *)
         end

    | ?Hl <=> ?Hr => get_instance_of T Hl Hn || get_instance_of T Hr Hn
    | ?Hl # ?Hr => get_instance_of T Hl Hn || get_instance_of T Hr Hn
    | ?Hl [+] ?Hr => get_instance_of T Hl Hn || get_instance_of T Hr Hn
    | !?Hl => get_instance_of T Hl Hn
    | ?Hl -> ?Hr => get_instance_of T Hl Hn || get_instance_of T Hr Hn
  end.

Ltac get_instance_of_rev  T  H Hn :=
  match H with
    | _ =>
     let name:= fresh "Htemp" in
      (* idtac "trying gio" H;*)
     progress (
        (pose proof (fun h:H => (tiff_snd T) h) as name)||
        (pose proof (fun h:H => (tiff_snd (T _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _ _ _ _ _)) h) as name)
      ); (* idtac "succeded" H;*)
     let H2 := type of name in
         match H2 with
           | ?H -> ?H => fail 1 (* both sides are the same, we won't rewrite anything *)
           | ?H -> ?H2 =>
             clear name;
               assert (H2 <=> H) as Hn by (apply T)
         (** H2 in LHS; apply does not automatically take care
                    of symmetry *)
         (*; idtac "really succeded" H*)
         end

    | ?Hl <=> ?Hr => get_instance_of_rev T Hl Hn || get_instance_of_rev T Hr Hn
    | ?Hl # ?Hr => get_instance_of_rev T Hl Hn || get_instance_of_rev T Hr Hn
    | ?Hl [+] ?Hr => get_instance_of_rev T Hl Hn || get_instance_of_rev T Hr Hn
    | !?Hl => get_instance_of_rev T Hl Hn
    | ?Hl -> ?Hr => get_instance_of_rev T Hl Hn || get_instance_of_rev T Hr Hn
  end.

(** rewrite using a universally quantified t_iff relation T  in the conclusion *)
Ltac trw T :=
  match goal with
      [  |- ?C ] =>
      let name:= fresh "Hget_instance_of_in_concl" in
      get_instance_of T C name;
        build_and_rewrite name; clear name
  end.

Ltac trw_rev  T :=
  match goal with
      [  |- ?C ] =>
      let name:= fresh "Hget_instance_of_in_concl" in
      get_instance_of_rev T C name;
        build_and_rewrite_rev name ; clear name
  end.

Ltac trw_h T h :=
  let C := type of h in
  let name:= fresh "Hget_instance_of_in_concl" in
  get_instance_of T C name;
    build_and_rewrite_hyp name h; clear name.

Ltac trw_rev_h T h :=
  let C := type of h in
  let name:= fresh "Hget_instance_of_in_concl" in
  get_instance_of_rev T C name;
    build_and_rewrite_hyp_rev name h; clear name.

(* Some general notation to use the above tactics *)

Tactic Notation "rw" constr(T) :=
  trw T || rewrite T.
Tactic Notation "rw" "<-" constr(T) :=
  trw_rev T || rewrite <- T.
Tactic Notation "rw" constr(T) "in" ident(H) :=
  trw_h T H || rewrite T in H.
Tactic Notation "rw" "<-" constr(T) "in" ident(H) :=
  trw_rev_h T H || rewrite <- T in H.

Tactic Notation "onerw" :=
       match goal with
         | [ H : _ |- _ ] => progress (trw H || rewrite H)
       end.

Tactic Notation "allrw" := repeat onerw.

Tactic Notation "allrw" "<-" :=
  repeat match goal with
           | [ H : _ |- _ ] => progress (trw_rev H || rewrite <- H)
          end.

(*
Tactic Notation "onerw" constr(T) :=
       match goal with
         | [ H : _ |- _ ] =>
             progress (trw_h T H || trw T || rewrite T in H || rewrite T)
       end.

Tactic Notation "allrw" constr(T) := repeat (onerw T).
*)

Tactic Notation "onerw" constr(T) :=
       let t := type of T in
       match goal with
         | [ H : _, H' : t |- _ ] =>
             progress (trw_h T H || trw T || rewrite T in H || rewrite T)
         | [ H : t |- _ ] => fail 1
         | [ H : _ |- _ ] =>
             progress (trw_h T H || trw T || rewrite T in H || rewrite T)
       end.

Tactic Notation "allrw" constr(T) := repeat (onerw T).

Tactic Notation "rww" ident(T) :=
  let t := type of T in
  repeat match goal with
           | [ H1 : t, H : _ |- _ ] =>
             progress (trw_h T H || trw T || rewrite T in H || rewrite T)
         end.

Tactic Notation "allrw" "<-" constr(T) :=
  repeat match goal with
           | [ H : _ |- _ ] =>
             progress (trw_rev_h T H || trw_rev T || rewrite <- T in H || rewrite <- T)
         end.

Tactic Notation "rww" "<-" ident(T) :=
  let t := type of T in
  repeat match goal with
           | [ H1 : t, H : _ |- _ ] =>
             progress (trw_rev_h T H || trw_rev T || rewrite <- T in H || rewrite <- T)
         end.

(* ------------------------ *)

(*
Theorem trw_demo: forall (P Q: nat -> Type),
 (forall n, P n <=> Q n )
  -> ((P 1 * void -> void ) <=> (Q 1 * void -> void )).
Proof.
  intros ? ?  Hiff.
  assert (P 1) by aXdmit.
  trw_h Hiff  X.
  trw Hiff .  apply t_iff_refl.
Qed.

(*
Theorem trw_demo2:
  forall (P Q: nat -> Type),
    (forall n, P n <=> forall m, Q m )
    -> ((P 1 * void -> void ) <=> ((forall m, Q m) * void -> void )).
Proof.
  intros ? ?  Hiff.
  constructor; intros.
  destruct X; auto.
  destruct X; auto.
Qed.
*)

Theorem trw_demo2:
  forall (P Q: nat -> Type),
    (forall n, P n <=> forall m, Q m )
    -> ((P 1 * void -> void ) <=> ((forall m, Q m) * void -> void )).
Proof.
  intros ? ?  Hiff.
  trw Hiff.
  apply t_iff_refl.
Qed.
*)

(**  --- setoid stuff -- delete? *)

Require Import Coq.Setoids.Setoid.

Inductive Cast (t : [univ]) : Prop :=
| cast : t -> Cast t.
Hint Constructors Cast.

Inductive Cast2 (p : Prop) : [univ] :=
| cast2 : p -> Cast2 p.
Hint Constructors Cast2.

Definition c_t_iff : relation [univ] :=
  fun A B : [univ] => Cast (A <=> B).

Notation "x <==> y" := (c_t_iff x y) (at level 95, no associativity).

Definition t_c_iff : relation [univ] :=
  fun A B : [univ] => Cast (A -> B) /\ Cast (B -> A).

Notation "x <~> y" := (t_c_iff x y) (at level 95, no associativity).

Lemma CType_S : Setoid_Theory [univ] c_t_iff.
Proof.
  split.

  repeat constructor; auto.

  unfold Symmetric; intros.
  inversion H; subst.
  dall.
  repeat constructor; auto.

  unfold Transitive; intros.
  inversion H; inversion H0; subst.
  dall.
  repeat constructor; auto.
Qed.

Lemma TypeC_S : Setoid_Theory [univ] t_c_iff.
Proof.
  split.

  repeat constructor; auto.

  unfold Symmetric; intros.
  destruct H.
  inversion H; subst.
  inversion H0; subst.
  repeat constructor; auto.

  unfold Transitive; intros.
  destruct H; destruct H0.
  inversion H; inversion H0; inversion H1; inversion H2; subst.
  repeat constructor; auto.
Qed.

Add Setoid [univ] c_t_iff CType_S as Type_iff_reg.
Add Setoid [univ] t_c_iff TypeC_S as Type_iff_reg2.

Hint Resolve (Seq_refl  [univ] c_t_iff CType_S): setoid.
Hint Resolve (Seq_sym   [univ] c_t_iff CType_S): setoid.
Hint Resolve (Seq_trans [univ] c_t_iff CType_S): setoid.

Hint Resolve (Seq_refl  [univ] t_c_iff TypeC_S): setoid.
Hint Resolve (Seq_sym   [univ] t_c_iff TypeC_S): setoid.
Hint Resolve (Seq_trans [univ] t_c_iff TypeC_S): setoid.

(* ============================================== *)

(*
Lemma test :
  forall a b (*c f*), (a <=> b) -> Cast a. (*.  # { x : c | f x }.*)
Proof.
  intros.
  rewrite X.
Qed.
*)

(** should not be required anymore? *)

Tactic Notation "trewrite" "<-" ident(H) ident(p1) :=
  let name := fresh H in
  generalize (H p1);
    intro name;
    build_and_rewrite_rev name;
    clear name.

Tactic Notation "trewrite" "<-" ident(H) ident(p1) ident(p2) :=
  let name := fresh H in
  generalize (H p1 p2);
    intro name;
    build_and_rewrite_rev name;
    clear name.
Tactic Notation "trewrite" ident(H) ident(p1) :=
  let name := fresh H in
  generalize (H p1);
    intro name;
    build_and_rewrite name;
    clear name.

Tactic Notation "trewrite" ident(H) ident(p1) ident(p2) :=
  let name := fresh H in
  generalize (H p1 p2);
    intro name;
    build_and_rewrite name;
    clear name.

Tactic Notation "trewrite" ident(H) ident(p1) "in" ident (H') :=
  let name := fresh H in
  generalize (H p1);
    intro name;
    build_and_rewrite_hyp name H';
    clear name.

Tactic Notation "trewrite" ident(H) ident(p1) ident(p2) "in" ident (H') :=
  let name := fresh H in
  generalize (H p1 p2);
    intro name;
    build_and_rewrite_hyp name H';
    clear name.
Tactic Notation "trewrite" "<-" ident(H) ident(p1) "in" ident(H') :=
  let name := fresh H in
  generalize (H p1);
    intro name;
    build_and_rewrite_hyp_rev name H';
    clear name.

Tactic Notation "trewrite" "<-" ident(H) ident(p1) ident(p2) "in" ident(H') :=
  let name := fresh H in
  generalize (H p1 p2);
    intro name;
    build_and_rewrite_hyp_rev name H';
    clear name.

Theorem dont_touch_forall :
  forall (P Q : (nat : Set) -> [univ]),
    (forall (n : (nat : Set)), P n <=> (forall (m : (nat : Set)), Q (m+n)))
    -> P (1 : (nat : Set))
    -> forall (m : (nat : Set)), Q (m+1).
Proof.
  intros ? ? Hif Hp1.

  rw Hif in Hp1; trivial.
Qed.

Theorem dont_touch_forall2 :
  forall (P Q : nat -> [univ]),
    (forall n, P n <=> (forall m, Q (m+n)))
    -> P 1
    -> forall m, Q (m+1).
Proof.
  intros ? ?  Hif Hp1.
  trw_rev Hif. trivial.
Qed.

Theorem dont_touch_forall3 :
  forall (P Q: nat -> [univ]),
    (forall n, P n <=> (forall m, Q (m+n)))
    -> (forall m, Q (m+1))
    -> P 1.
Proof.
  intros ? ? Hif Hq .
  trw_rev_h Hif Hq. trivial.
Qed.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                    Prelude  Synthese Algorithmes Rauzy                   *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                               Prelude_BDT.v                              *)
(****************************************************************************)

(* Uses Axiom  Classic : (A:Prop)~(~A)->A. *)

Global Set Asymmetric Patterns.

Require Export Bool.
Require Export Compare.
Require Export Compare_dec.
Require Export Le.
Require Export Lt.
Require Export Gt.
Require Export Wf_nat.

(*********************           Logic               *************************)

Lemma Contra : forall P Q : Prop, (P -> Q) -> ~ Q -> ~ P.
Proof.
unfold not in |- *; auto.
Qed.

Lemma deMorgan_not_or : forall P Q : Prop, ~ P -> ~ Q -> ~ (P \/ Q).
Proof.
unfold not in |- *.
intros P Q notP notQ.
simple induction 1; auto.
Qed.

Lemma deMorgan_and_not : forall P Q : Prop, ~ (P \/ Q) -> ~ P /\ ~ Q.
Proof.
unfold not in |- *.
intros.
split; auto.
Qed.

Lemma deMorgan_not_and : forall P Q : Prop, ~ P \/ ~ Q -> ~ (P /\ Q).
Proof.
simple induction 1; intro H1; unfold not in |- *; simple induction 1; intros.
absurd P; trivial.
absurd Q; trivial.
Qed.

Lemma P_notnotP : forall P : Prop, P -> ~ ~ P.
Proof.
unfold not in |- *; auto.
Qed.

(*--------------           Classical   identities         -------------------*)

Axiom Classic : forall A : Prop, ~ ~ A -> A.

Lemma excluded_middle : forall A : Prop, A \/ ~ A.
Proof.
intro A.
apply Classic.
unfold not at 1 in |- *; intro H.
elim (deMorgan_and_not A (~ A) H).
intros; absurd (~ A); trivial.
Qed.

Lemma not_all_exist_not :
 forall (A : Set) (P : A -> Prop),
 ~ (forall a : A, P a) -> exists x : A, ~ P x.
Proof.
intros A P H.
apply Classic.
unfold not at 1 in |- *; intro Habsurde.
absurd (forall a : A, P a); try trivial.
intro a.
elim (excluded_middle (P a)); try trivial.
intro Habsurde2.
absurd (exists x : A, ~ P x); [ assumption | exists a; exact Habsurde2 ].
Qed.

Lemma deMorgan_or_not : forall P Q : Prop, ~ (P /\ Q) -> ~ P \/ ~ Q.
Proof.
intros P Q H.
elim (excluded_middle P); elim (excluded_middle Q); auto.
Qed.

(***********                   Booleans                  ********************)

Lemma Commutative_andb : forall b1 b2 : bool, b1 && b2 = b2 && b1.
Proof.
simple induction b1; simple induction b2; auto.
Qed.

Lemma Commutative_orb : forall b1 b2 : bool, b1 || b2 = b2 || b1.
Proof.
simple induction b1; simple induction b2; auto.
Qed.

(***********              Basic  specifications          ********************)

Inductive Case3 (A B C : Prop) : Set :=
  | case_left : A -> Case3 A B C
  | case_middle : B -> Case3 A B C
  | case_right : C -> Case3 A B C.

(*********************           Lists               *************************)

Require Export List.

(*  Restoring hints from List.v and Inlist.v *)
Hint Resolve in_eq in_cons in_or_app incl_refl incl_cons incl_app app_nil_end
  app_ass ass_app lel_refl lel_cons_cons lel_cons lel_nil nil_cons.

Hint Immediate in_app_or incl_tl incl_appl incl_appr: bdd.

Hint Unfold incl.

Lemma nil_included_all : forall (A : Set) (l : list A), incl nil l.
Proof.
intros A l.
unfold incl in |- *.
unfold In in |- *; contradiction.
Qed.

Lemma Nil_or_cons :
 forall (A : Set) (l : list A),
 l = nil \/ (exists a : A, (exists m : list A, l = a :: m)).
Proof.
intro A.
simple induction l;
 [ auto | intros a m Hm; right; exists a; exists m; trivial ].
Qed.

Lemma incl_nil_eq : forall (A : Set) (l : list A), incl l nil -> l = nil.
Proof.
intros A l Hincl.
elim (Nil_or_cons A l); [ trivial | idtac ].
simple induction 1; intro a.
simple induction 1; intros m Def_l.
clear H0 H.
absurd (In a nil).
(* not In *)
exact (in_nil (a:=a)).
(*  In  *)
unfold incl in Hincl.
apply Hincl with (a := a).
rewrite Def_l; auto.
Qed.

Definition eq_decidable (A : Set) := forall a b : A, {a = b} + {a <> b}.

Lemma In_list_dec :
 forall A : Set,
 eq_decidable A -> forall (l : list A) (a : A), In a l \/ ~ In a l.
Proof.
intros A Heq.
simple induction l.
  (* l = nil *)
intro a; right; eapply in_nil.
clear l; intros b l Hl.
intro a.
unfold eq_decidable in Heq.
elim (Heq a b); intro Hab.
  (* l = (cons b l) *)
(* Case a=b *)
elim Hab; left; auto.
(* Case a=/=b *)
elim (Hl a); intro Ha.
left; auto.
right; simpl in |- *; apply deMorgan_not_or; try assumption.
apply Contra with (a = b); auto.
Qed.

(***********                   Arithmetic                *******************)

Lemma eq_O_or_gt_O : forall n : nat, {0 = n} + {n > 0}.
Proof.
simple induction n; auto with arith.
Qed.

Lemma lt_gt : forall m n : nat, m < n -> n > m.
Proof.
auto with arith.
Qed.

Lemma gt_lt : forall m n : nat, m > n -> n < m.
Proof.
auto with arith.
Qed.

Lemma gt_neq : forall m n : nat, m > n -> m <> n.
Proof.
unfold not in |- *; intros m n H Habs.
absurd (m < m);
 [ exact (lt_irrefl m)
 | apply gt_lt; pattern m at 2 in |- *; rewrite Habs; trivial ].
Qed.

Lemma le_dec : forall m n : nat, {m <= n} + {~ m <= n}.
Proof.
intros m n.
elim (le_le_S_dec m n); intro Cas.
auto with arith.
right; unfold not in |- *; intro Habs.
elim (le_Sn_n n); apply le_trans with m; auto with arith.
Qed.

Lemma gt_le_weak : forall m n : nat, m > n -> n <= m.
Proof.
intros m n H.
apply lt_le_weak.
apply gt_lt; trivial.
Qed.

Lemma Compar : forall m n : nat, Case3 (m > n) (m = n) (n > m).
Proof.
intros m n.
elim (le_gt_dec m n); intros Cas.
elim (le_lt_eq_dec m n Cas);
 [ intro H; exact (case_right (m > n) (m = n) (n > m) (lt_gt m n H))
 | intro H; exact (case_middle (m > n) (m = n) (n > m) H) ].
exact (case_left (m > n) (m = n) (n > m) Cas).
Qed.

Definition Max (n m : nat) :=
  match le_gt_dec n m return nat with
  | left p => m
  | right q => n
  end.

Lemma Max_le : forall m n : nat, m <= Max m n /\ n <= Max m n.
Proof.
intros m n.
unfold Max in |- *; elim (le_gt_dec m n); auto with arith.
Qed.

Lemma gt_Max : forall m n : nat, m > n -> m = Max m n.
Proof.
intros m n H.
unfold Max in |- *; elim (le_gt_dec m n); auto with arith.
intro Habs.
absurd (m <= n); [ exact (gt_not_le m n H) | assumption ].
Qed.

Lemma gt_mn_gt_Max_mn : forall i m n : nat, i > m -> i > n -> i > Max m n.
Proof.
intros i m n H1i H2i.
unfold Max in |- *; elim (le_gt_dec m n); auto with arith.
Qed.

Lemma le_Max : forall m n : nat, m <= n -> n = Max m n.
Proof.
intros m n H.
unfold Max in |- *; elim (le_gt_dec m n); auto with arith.
intro Habs.
absurd (m > n); [ exact (le_not_gt m n H) | assumption ].
Qed.

Lemma Max_sym : forall n1 n2 : nat, Max n1 n2 = Max n2 n1.
Proof.
intros n1 n2.
unfold Max in |- *; elim (le_gt_dec n1 n2); elim (le_gt_dec n2 n1);
 auto with arith.
intros H1 H2.
absurd (n2 > n1); [ exact (gt_asym n1 n2 H2) | assumption ].
Qed.

Lemma eq_Max : forall n1 n2 : nat, n1 = n2 -> n1 = Max n1 n2.
Proof.
intros n1 n2 H.
elim H; unfold Max in |- *; elim (le_gt_dec n1 n1); auto with arith.
Qed.

Lemma Max_mon_left :
 forall n1 n'1 : nat,
 n1 > n'1 -> forall n2 : nat, n1 > n2 -> Max n1 n2 > Max n'1 n2.
Proof.
intros n1 n'1 H1 n2 H2.
unfold Max at 2 in |- *; elim (le_gt_dec n'1 n2); elim (gt_Max n1 n2);
 auto with arith.
Qed.

Lemma Max_mon_right :
 forall n2 n'2 : nat,
 n2 > n'2 -> forall n1 : nat, n2 > n1 -> Max n1 n2 > Max n1 n'2.
Proof.
intros n2 n'2 H2 n1 H1.
unfold Max at 2 in |- *; elim (le_gt_dec n1 n'2); elim (Max_sym n2 n1);
 elim (gt_Max n2 n1); auto with arith.
Qed.

Lemma Max_mon_middle :
 forall n1 n'1 : nat,
 n1 > n'1 -> forall n2 n'2 : nat, n2 > n'2 -> Max n1 n2 > Max n'1 n'2.
Proof.
intros n1 n'1 H1 n2 n'2 H2.
unfold Max in |- *; elim (le_gt_dec n'1 n'2); elim (le_gt_dec n1 n2);
 auto with arith.
intros; apply gt_trans with n2; auto with arith.
intros; apply le_gt_trans with n1; auto with arith.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************)
(*             Typed LambdaFactor Calculus                            *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                   LamSF_Tactics.v                                  *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import Test.
Require Import General.
Require Import LamSF_Terms.

Definition termred := lamSF -> lamSF -> Prop.

Definition preserve (R : termred) (P : lamSF -> Prop) :=
  forall x : lamSF, P x -> forall y : lamSF, R x y -> P y.

Inductive multi_step : termred -> termred :=
  | zero_red : forall red M, multi_step red M M
  | succ_red : forall (red: lamSF-> lamSF -> Prop) M N P,
                   red M N -> multi_step red N P -> multi_step red M P
.

Inductive sequential : termred -> termred -> termred :=
  | seq_red : forall (red1 red2 : termred) M N P,
                red1 M N -> red2 N P -> sequential red1 red2 M P.

Hint Resolve zero_red succ_red seq_red
.

Definition reflective red := forall (M: lamSF), red M M.

Lemma refl_multi_step : forall (red: termred), reflective (multi_step red).
Proof. red; split_all. Qed.

Lemma refl_seq : forall (red1 red2: termred),
                   reflective red1 -> reflective red2 -> reflective(sequential red1 red2).
Proof. red; split_all; eapply2 seq_red. Qed.

Ltac reflect := match goal with
| |- reflective (multi_step _) => eapply2 refl_multi_step
| |- multi_step _ _ _ => try (eapply2 refl_multi_step)
| |- reflective (sequential _) => eapply2 refl_seq; reflect
| |- sequential _ _ _ _ => try (eapply2 refl_seq)
| _ => split_all
end.

Ltac one_step :=
match goal with
| |- multi_step _ _ ?N => apply succ_red with N; auto; try red; try reflect
end.

Ltac seq_l :=
match goal with
| |- sequential _ _ ?M ?N => apply seq_red with N; auto; red; reflect
end.

Ltac seq_r :=
match goal with
| |- sequential _ _ ?M ?N => apply seq_red with M; auto; red; reflect
end.

Definition transitive red := forall (M N P: lamSF), red M N -> red N P -> red M P.

Lemma transitive_red : forall red, transitive (multi_step red).
Proof. red; induction 1; split_all.
apply succ_red with N; auto.
Qed.

Definition preserves_abs (red : termred) :=
forall M N, red M N -> red (Abs M) (Abs N).

Definition preserves_app (red : termred) :=
forall M M' N N', red M M' -> red N N' -> red (App M N) (App M' N').

Lemma preserves_abs_multi_step : forall red, preserves_abs red -> preserves_abs (multi_step red).
Proof.
red; induction 2; split_all.
apply succ_red with (Abs N); auto.
Qed.

Lemma preserves_app_multi_step : forall (red: termred), reflective red -> preserves_app red -> preserves_app (multi_step red).
Proof.
red. induction 3; split_all. generalize H0; induction 1.
reflect.
apply succ_red with (App M N); auto.
assert( transitive (multi_step red)) by eapply2 transitive_red.
apply X0 with (App N0 N); auto.
one_step.
Qed.

Lemma preserves_abs_seq : forall (red1 red2: termred), preserves_abs red1 -> preserves_abs red2 -> preserves_abs (sequential red1 red2).
Proof.
red; split_all.
inversion H1.
apply seq_red with (Abs N0); auto.
Qed.

Lemma preserves_app_seq : forall (red1 red2: termred), preserves_app red1 -> preserves_app red2 -> preserves_app (sequential red1 red2).
Proof.
red; split_all.
inversion H1; inversion H2.
apply seq_red with (App N0 N1); auto.
Qed.

Hint Resolve preserves_abs_multi_step  preserves_app_multi_step preserves_abs_seq preserves_app_seq .

Definition preserves_app_r (red: termred) :=
forall ty1 ty2 ty3, red ty2 ty3 -> red (App ty1 ty2) (App ty1 ty3).

Lemma preserves_app_r_multi_step:
forall red, preserves_app_r red -> preserves_app_r (multi_step red).
Proof.
red. intros red p ty1 ty2 ty3 m; induction m; split_all. eapply2 succ_red.
Qed.

Definition preserves_abs1 (red: termred) := forall M N, red M N -> forall M0, M = Abs M0 ->
  exists N0, red M0 N0 /\ Abs N0 = N.

Lemma preserves_abs1_multi_step : forall red, preserves_abs1 red -> preserves_abs1 (multi_step red).
Proof.
unfold preserves_abs1.  induction 2; split_all.
exist M0.
assert(exists N0 : lamSF, red M0 N0 /\ Abs N0 = N) by eapply2 H; split_all.
assert(exists N0 : lamSF, multi_step red x N0 /\ Abs N0 = P) by eapply2 IHmulti_step; split_all.
exist x0.
apply succ_red with x; auto.
Qed.

Lemma preserves_abs1_seq : forall red1, preserves_abs1 red1 -> forall red2, preserves_abs1 red2 -> preserves_abs1 (sequential red1 red2).
Proof.
unfold preserves_abs1; split_all.
inversion H1.
elim(H M N0 H3 M0); split_all.
elim(H0 N0 N H4 x); split_all.
exist x0.
apply seq_red with x; auto.
Qed.

Hint Resolve preserves_abs1_multi_step preserves_abs1_seq.

Definition lift_rec_preserves (red: termred) :=
forall (M N : lamSF), red M N -> forall (n k : nat), red  (lift_rec M n k) (lift_rec N n k).

Lemma lift_rec_preserves_multi_step :
forall red, lift_rec_preserves red -> lift_rec_preserves (multi_step red).
Proof. unfold lift_rec_preserves; induction 2; split_all.
apply succ_red with (lift_rec N n k); auto.
Qed.

Lemma lift_rec_preserves_seq :
forall red1 red2, lift_rec_preserves red1 -> lift_rec_preserves red2 ->
                  lift_rec_preserves (sequential red1 red2).
Proof. red; unfold lift_rec_preserves; split_all.
inversion H1. apply seq_red with (lift_rec N0 n k); auto.
Qed.

Hint Resolve  lift_rec_preserves_multi_step lift_rec_preserves_seq.

Definition preserves_lift_rec (red: lamSF ->  lamSF -> Prop) :=
forall M N, red M N -> forall M0 n k, lift_rec M0 n k = M -> exists N0, red M0 N0 /\ lift_rec N0 n k = N.

Lemma preserves_lift_rec_multi_step :
forall red, preserves_lift_rec red -> preserves_lift_rec (multi_step red).
Proof. unfold preserves_lift_rec. induction 2; split_all.
exist M0.
elim(H M N H0 M0 n k); split_all.
elim(IHmulti_step H x n k); split_all.
exist x0.
apply succ_red with x; auto.
Qed.

Lemma preserves_lift_rec_seq :
forall red1, preserves_lift_rec red1 -> forall red2, preserves_lift_rec red2 ->
                                                     preserves_lift_rec (sequential red1 red2).
Proof. unfold preserves_lift_rec. induction 3; split_all.
elim(H M N H1 M0 n k); split_all.
elim(H0 N P H2 x n k); split_all.
exist x0.
apply seq_red with x; auto.
Qed.

Ltac eelim_for_equal :=
match goal with
| H: forall _, _ = _ -> _  |- _ => eelim H; clear H; subst; eelim_for_equal
| _ => split_all
end.

Ltac inv_lift_rec :=
match goal with
| H: Ref _ = lift_rec ?l _ _  |- _ => gen_case_inv H l; inv_lift_rec
| H: Op _ = lift_rec ?l _ _  |- _ => gen_case_inv H l; inv_lift_rec
| H: App _ _ = lift_rec ?l _ _ |- _ => gen_case_inv H l; inv_lift_rec
| H: Abs _ = lift_rec ?l _ _ |- _ => gen_case_inv H l; inv_lift_rec
| H: lift_rec ?l _ _ = Ref _ |- _ => gen_case_inv H l; inv_lift_rec
| H: lift_rec ?l _ _ = Op _ |- _ => gen_case_inv H l; inv_lift_rec
| H: lift_rec ?l _ _ = App _ _ |- _ => gen_case_inv H l; inv_lift_rec
| H: lift_rec ?l _ _ = Abs _ |- _ => gen_case_inv H l; inv_lift_rec
| _ => subst; eelim_for_equal
 end.

Ltac inv1 prop :=
match goal with
| H: prop (Ref _) |- _ => inversion H; clear H; inv1 prop
| H: prop (App  _ _) |- _ => inversion H; clear H; inv1 prop
| H: prop (Op _) |- _ => inversion H; clear H; inv1 prop
| H: prop (Abs _) |- _ => inversion H; clear H; inv1 prop
| _ => split_all
 end.

Definition implies_red (red1 red2: termred) := forall M N, red1 M N -> red2 M N.

Lemma implies_red_multi_step: forall red1 red2, implies_red red1  (multi_step red2) ->
                                                implies_red (multi_step red1) (multi_step red2).
Proof. red.
intros red1 red2 IR M N R; induction R; split_all.
apply transitive_red with N; auto.
Qed.
Lemma implies_red_seq:
 forall red1 red2 red3,
  implies_red red1  (multi_step red3)  ->
  implies_red red2 (multi_step red3) ->
  implies_red (sequential red1 red2) (multi_step red3) .
Proof.
red; split_all. inversion H1. apply transitive_red with N0; auto.
Qed.

Definition subst_rec_preserves_l (red: termred) :=
forall (M M' N : lamSF), red M M' -> forall ( k : nat), red  (subst_rec M N k) (subst_rec M' N k).

Definition subst_rec_preserves_r (red: termred) :=
forall (M N N' : lamSF), red N N' -> forall ( k : nat), red  (subst_rec M N k) (subst_rec M N' k).

Definition subst_rec_preserves (red: termred) :=
forall (M M' : lamSF), red M M' -> forall N N', red N N' -> forall ( k : nat), red  (subst_rec M N k) (subst_rec M' N' k).

Lemma subst_rec_preserves_l_multi_step :
forall (red: termred), subst_rec_preserves_l red -> subst_rec_preserves_l (multi_step red).
Proof. unfold subst_rec_preserves_l.
 induction 2; split_all.
apply succ_red with (subst_rec N0 N k); auto.
Qed.

Lemma subst_rec_preserves_r_multi_step :
forall (red: termred), subst_rec_preserves_r red -> subst_rec_preserves_r (multi_step red).
Proof. unfold subst_rec_preserves_r.
 induction 2; split_all.
apply succ_red with (subst_rec M N k); auto.
Qed.

Lemma subst_rec_preserves_multi_step :
forall (red: termred), subst_rec_preserves_l red -> subst_rec_preserves_r red -> subst_rec_preserves (multi_step red).
Proof.
unfold subst_rec_preserves. split_all.
assert(transitive (multi_step red)) by eapply2 transitive_red.
unfold transitive in *.
apply X with  (subst_rec M' N k); auto.
eapply2 subst_rec_preserves_l_multi_step.
eapply2 subst_rec_preserves_r_multi_step.
Qed.

Lemma subst_rec_preserves_l_seq :
forall red1 , subst_rec_preserves_l red1  -> forall red2 , subst_rec_preserves_l red2  ->
                                                subst_rec_preserves_l (sequential red1 red2).
Proof. unfold subst_rec_preserves_l; split_all.
inversion H1.
apply seq_red with (subst_rec N0 N k); auto.
Qed.

Lemma subst_rec_preserves_r_seq :
forall red1 , subst_rec_preserves_r red1  -> forall red2 , subst_rec_preserves_r red2  ->
                                                         subst_rec_preserves_r (sequential red1 red2).
Proof. unfold subst_rec_preserves_r; split_all.
inversion H1.
apply seq_red with (subst_rec M N0 k); auto.
Qed.

Lemma subst_rec_preserves_seq :
forall red1 , subst_rec_preserves red1  -> forall red2 , subst_rec_preserves red2  ->
                                                         subst_rec_preserves (sequential red1 red2).
Proof. unfold subst_rec_preserves; split_all.
inversion H1.
inversion H2.
apply seq_red with (subst_rec N0 N1 k); auto.
Qed.

Hint Resolve  subst_rec_preserves_multi_step subst_rec_preserves_seq.

Hint Resolve  subst_rec_preserves_multi_step subst_rec_preserves_seq.

Ltac inv red :=
match goal with
| H: multi_step red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red (Ref _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red (Op _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red (Abs _) _ |- _ => inversion H; clear H; inv red
| H: red (Ref _) _ |- _ => inversion H; clear H; inv red
| H: red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: red (Op _) _ |- _ => inversion H; clear H; inv red
| H: red (Abs _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red _ (Ref _) |- _ => inversion H; clear H; inv red
| H: multi_step red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: multi_step red _ (Op _) |- _ => inversion H; clear H; inv red
| H: multi_step red _ (Abs _) |- _ => inversion H; clear H; inv red
| H: red _ (Ref _) |- _ => inversion H; clear H; inv red
| H: red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: red _ (Op _) |- _ => inversion H; clear H; inv red
| H: red _ (Abs _) |- _ => inversion H; clear H; inv red
| |- red (lift _ _) (lift _ _) => unfold lift; eapply2 (lift_rec_preserves red); inv red
| _ => subst; split_all
 end.

Definition diamond (red1 red2 : termred) :=
forall M N, red1 M N -> forall P, red2 M P -> exists Q, red2 N Q /\ red1 P Q.

Lemma diamond_flip: forall red1 red2, diamond red1 red2 -> diamond red2 red1.
Proof. unfold diamond; split_all. elim (H M P H1 N H0); split_all. exist x. Qed.

Lemma diamond_strip :
forall red1 red2, diamond red1 red2 -> diamond red1 (multi_step red2).
Proof. intros.
eapply2 diamond_flip.
red; induction 1; split_all.
exist P.
elim (H M P0 H2 N); split_all.
elim(IHmulti_step H x); split_all.
exist x0.
apply succ_red with x; auto.
Qed.

Definition diamond_star (red1 red2: termred) := forall  M N, red1 M N -> forall P, red2 M P ->
  exists Q, red1 P Q /\ multi_step red2 N Q.

Lemma diamond_star_strip: forall red1 red2, diamond_star red1 red2 -> diamond (multi_step red2) red1 .
Proof.
red. induction 2; split_all.
exist P.
elim(H M P0 H2 N H0); split_all.
elim(IHmulti_step H x); split_all.
exist x0.
apply transitive_red with x; auto.
Qed.

Lemma diamond_tiling :
forall red1 red2, diamond red1 red2 -> diamond (multi_step red1) (multi_step red2).
Proof.
red.  induction 2; split_all.
exist P.
elim(diamond_strip red red2 H M N H0 P0); split_all.
elim(IHmulti_step H x H4); split_all.
exist x0.
apply succ_red with x; auto.
Qed.

Hint Resolve diamond_tiling.

Lemma diamond_seq: forall red red1 red2, diamond red red1 -> diamond red red2 -> diamond red (sequential red1 red2).
Proof. unfold diamond; split_all.
inversion H2.
elim(H M N H1 N0); split_all.
elim(H0 N0 x H11 P); split_all.
exist x0.
apply seq_red with x; auto.
Qed.

Lemma relocate_null :
forall (n n0 : nat), relocate n n0 0 = n.
Proof. split_all. unfold relocate. case (test n0 n); intro; auto with arith. Qed.

Lemma relocate_lessthan : forall m n k, m<=k -> relocate k m n = (n+k).
Proof. split_all. unfold relocate. elim(test m k); split_all; try noway. Qed.
Lemma relocate_greaterthan : forall m n k, m>k -> relocate k m n = k.
Proof. split_all. unfold relocate. elim(test m k); split_all; try noway. Qed.

Ltac relocate_lt :=
try (rewrite relocate_lessthan; [| omega]; relocate_lt);
try (rewrite relocate_greaterthan; [| omega]; relocate_lt);
try(rewrite relocate_null).

Lemma relocate_zero_succ :
forall n k, relocate 0 (S n) k = 0.
Proof.  split_all. Qed.

Lemma relocate_succ :
forall n n0 k, relocate (S n) (S n0) k = S(relocate n n0 k).
Proof.
intros; unfold relocate. elim(test(S n0) (S n)); elim(test n0 n); split_all.
noway.
noway.
Qed.

Lemma relocate_max : forall m1 m2  n k,
max(relocate m1 n k) (relocate m2 n k) = relocate (max m1 m2) n k.
Proof.
induction m1; split_all.
unfold relocate. elim(test n 0); split_all.
assert(n=0) by omega. subst. elim(test 0 m2); split_all.
replace (k+0) with k by omega.
assert(max k (k+m2) >= k+m2) by eapply2 max_is_max.
assert(k+m2 >= max k (k+m2)).
eapply2 max_max2.  omega. omega.  noway.
(* 1 *)
generalize IHm1. clear.
induction m2; split_all.
relocate_lt.
unfold relocate.
elim(test n 0); split_all; try noway.
assert(n=0) by omega; subst.
elim(test 0 (S m1)); split_all.
assert(max (k + S m1) (k + 0) >= k + S m1) by eapply2 max_is_max.
assert(k+ S m1 >= max (k+S m1) (k+0)).
eapply2 max_max2. omega. omega. noway.
rewrite max_zero. auto.
(* 1 *)
unfold relocate.
elim(test n (S (max m1 m2)));  split_all.
elim(test n (S m1)); split_all; try noway.
elim(test n (S m2)); split_all; try noway.
rewrite max_succ.
replace (k+ max (S m1) (S m2)) with (max (S m1) (S m2) + k) by omega.
rewrite max_plus.
auto with arith.
(* 3 *)
rewrite max_succ.
assert(max (S m1) (S m2) >= S m1) by eapply2 max_is_max.
assert(S m1 >= max (S m1) (S m2)).
eapply2 max_max2. omega.
assert(max (S m1) (S m2) = S m1) by omega.
rewrite H1.
assert(max (k+ S m1) (S m2) >= k+ S m1) by eapply2 max_is_max.
assert(k+ S m1 >= max (k+ S m1) (S m2)).
eapply2 max_max2. omega.
omega.
(* 2 *)
elim(test n (S m2)); split_all; try noway.
replace (k + S m2) with (S(k+ m2)) by omega.
assert(m2 >= m1) by omega.
assert(max m1 m2 >= m2) by eapply2 max_is_max.
assert(m2 >= max m1 m2). eapply2 max_max2.
assert(max m1 m2 = m2) by omega.
rewrite H2.
assert(max m1 (k+m2) >= k+m2) by eapply2 max_is_max.
assert(k+m2 >= max m1 (k+m2)). eapply2 max_max2. omega.
assert(max m1 (k+m2) = k+m2) by omega.
rewrite H5.
omega.
assert(n>= max (S(S m1)) (S(S m2))). eapply2 max_max2.
rewrite <- max_succ in H.
rewrite <- max_succ in H. noway.
(* 1 *)
assert(max m1 m2 >= m1) by eapply2 max_is_max.
assert(max m1 m2 >= m2) by eapply2 max_is_max.
assert(n> S m1) by omega.
assert(n> S m2) by omega.
elim(test n (S m1)); split_all; try noway.
elim(test n (S m2)); split_all; try noway.
Qed.

Lemma relocate_mono : forall M N n k, relocate M n k = relocate N n k -> M=N.
Proof.
intros M N n k.
unfold relocate.
elim(test n M); elim(test n N); split_all; omega.
Qed.

Lemma lift_rec_mono : forall M N n k, lift_rec M n k = lift_rec N n k -> M=N.
Proof.
induction M; split_all.
gen_case_inv H N.
assert(n=n1) by eapply2 relocate_mono.
subst; auto.
gen_case_inv H N.
gen_case_inv H N.
assert(M = l) by eapply2 IHM.
congruence.
gen_case_inv H N.
assert(M1 = l) by eapply2 IHM1.
assert(M2 = l0) by eapply2 IHM2. congruence.
Qed.

Lemma insert_Ref_lt : forall M n k, n< k -> insert_Ref M n k = Ref n.
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
Qed.

Lemma insert_Ref_eq : forall M n k, n= k -> insert_Ref M n k = lift k M.
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
unfold lift; unfold lift_rec. unfold relocate. elim(test 0 n); split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
unfold lift; unfold lift_rec. unfold relocate. elim(test 0 n); split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
Qed.

Lemma insert_Ref_gt : forall M n k, n> k -> insert_Ref M n k = Ref (pred n).
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
Qed.

Ltac insert_Ref_out :=
try (rewrite insert_Ref_lt; [|unfold relocate; split_all; omega]; insert_Ref_out);
try (rewrite insert_Ref_eq; [|unfold relocate; split_all; omega]; insert_Ref_out);
try (rewrite insert_Ref_gt; [|unfold relocate; split_all; omega]; insert_Ref_out);
unfold lift; unfold lift_rec; fold lift_rec.

Lemma subst_rec_lift_rec4 :
forall ty n k, subst_rec (lift_rec ty (S n) (S k)) (Ref 0) n = lift_rec ty (S n) k.
Proof.
induction ty; split_all.
unfold relocate. elim(test (S n0) n); intro; insert_Ref_out; split_all.
unfold insert_Ref. elim(compare n0 n); intro; try noway.
elim a; intro; try noway. subst. unfold lift; split_all. relocate_lt.
replace (n+0) with n by omega; auto.
auto.
Qed.

Lemma subst_rec_lift_rec5 :
forall ty j n, subst_rec (lift_rec ty (S j) (S n)) (Ref n) j = lift_rec ty j n.
Proof.
induction ty; intros; simpl.
(* 4 *)
unfold relocate.
elim(test (S j) n); intro.
elim(test j n); intro; try noway.
insert_Ref_out.
replace (pred (S n0 + n)) with (n0+n) by omega. auto.
elim(test j n); intro; try noway.
insert_Ref_out.
relocate_lt.
assert(j+n0=n0+n) by omega.
rewrite H; auto.
insert_Ref_out. auto.
(* 3 *)
auto.
(* 2 *)
rewrite IHty. auto.
(* 1 *)
rewrite IHty2. rewrite IHty1. auto.
Qed.

Definition preserves_apl (red : termred) :=
forall M M' N, red M M' -> red (App M N) (App M' N).

Definition preserves_apr (red : termred) :=
forall M N N', red N N' -> red (App M N) (App M N').

Lemma preserves_apl_multi_step : forall (red: termred), preserves_apl red -> preserves_apl (multi_step red).
Proof. red. induction 2; split_all. apply succ_red with (App N0 N); auto. Qed.

Lemma preserves_apr_multi_step : forall (red: termred), preserves_apr red -> preserves_apr (multi_step red).
Proof. red. induction 2; split_all. apply succ_red with (App M N); auto. Qed.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype tuple.

Set Implicit Arguments.
Unset Strict Implicit.

Section Type_ext.

Variable A : Type.

Lemma thead_tuple1 : forall (i : 1.-tuple A), [tuple thead i] = i.
Proof. move=> [ [|h []] H] //. by apply val_inj. Qed.

Lemma behead_tuple1: forall (i : 1.-tuple A), behead i = nil.
Proof. move => [] [] //= _ [] //=. Qed.

End Type_ext.

Section eqType_ext.

Variable A : eqType.

(* compute the last element of a non-empty tuple *)
Definition tlast {n: nat} (t: {:n.+1.-tuple A}) : A :=
  last (thead t) (behead t).

(* compute the rcons on tuples *)
Definition trcons {n: nat} (t: {:n.-tuple A}) (e: A) : {:n.+1.-tuple A}.
Proof.
refine (@Tuple _ _ (rcons t e) _).
by rewrite size_rcons size_tuple.
Defined.

(* t minus its last item *)
Definition tbelast {n : nat} (t : {:n.+1.-tuple A}) : {:n.-tuple A}.
Proof.
exists (belast (thead t) (behead t)).
by rewrite size_belast size_behead size_tuple.
Defined.

Lemma thead_belast n : forall (t : {:n.+2.-tuple A}),
  thead [tuple of belast (thead t) (behead t)] = thead t.
Proof.
case/tupleP => h1. case/tupleP => h2 t /=; by rewrite !theadE.
Qed.

Lemma thead_tbelast n : forall (t : {:n.+2.-tuple A}),
  thead (tbelast t) = thead t.
Proof.
case/tupleP => h1. case/tupleP => h2 t /=; by rewrite !theadE.
Qed.

Lemma tlast_tbelast n : forall (t : {:n.+2.-tuple A}),
  thead (tbelast t) = thead t.
Proof.
case/tupleP => h1. case/tupleP => h2 t /=; by rewrite !theadE.
Qed.

Lemma thead_trcons n e : forall (t : {:n.+1.-tuple A}), thead (trcons t e) = thead t.
Proof. case/tupleP => h1 => //=. Qed.

Lemma trcons_tbelast_tlast {n} (p: {:n.+1.-tuple A}) :
  trcons (tbelast p) (tlast p) = p.
Proof.
apply val_inj => /=.
rewrite /tlast -lastI.
by case: (tupleP p).
Qed.

Lemma behead_trcons : forall {n} e (p : {:n.+1.-tuple A}),
  behead (trcons p e) = rcons (behead p) e.
Proof. move => n e. by case/tupleP. Qed.

Lemma tlast_trcons {n} : forall e (p : {:n.-tuple A}), tlast (trcons p e) = e.
Proof.
case: n => [|n] e p.
- by rewrite (tuple0 p).
- by rewrite /tlast behead_trcons last_rcons.
Qed.

Lemma decomp_tuple {n} : forall (t: {:n.+2.-tuple A}),
  cons (thead t) (rcons (behead (tbelast t)) (tlast t)) = t.
Proof.
case/tupleP => h1.
case/tupleP => h2 t /=.
by rewrite !theadE /= -lastI.
Qed.

Definition tbehead {n : nat} (t : {:n.+1.-tuple A}) : {:n.-tuple A}.
Proof.
refine (@Tuple _ _ (behead t) _).
by rewrite size_behead size_tuple.
Defined.

Lemma tbeheadE x n : forall (t : n.+1.-tuple A), tbehead [tuple of x :: t] = [tuple of t].
Proof.
case/tupleP => h1 t /=.
by apply/eqP; rewrite /eq_op; simpl.
Qed.

Lemma tlastE x n : forall (t : n.+1.-tuple A), tlast [tuple of x :: t] = tlast t.
Proof. by case/tupleP. Qed.

End eqType_ext.