Require Export Iron.Language.SystemF2Effect.Store.Bind.
Require Export Iron.Language.SystemF2Effect.Store.TypeB.

(********************************************************************)
(* Well typed store.
   All bindings are well typed. *)
Definition StoreT' (sec : stenv) (se: stenv) (sp: stprops) (ss: store)
 := Forall2 (TypeB nil nil sec sp) ss se.
Hint Unfold StoreT'.

Definition StoreT  (se  : stenv) (sp : stprops) (ss : store)
 := StoreT' se se sp ss.
Hint Unfold StoreT.

(********************************************************************)
Lemma storeT_mergeB
 :  forall  sec se sp ss p1 p2
 ,  In (SRegion p1) sp
 -> StoreT' sec se sp ss
 -> StoreT' (mergeTE p1 p2 sec) (mergeTE p1 p2 se) sp (mergeBs p1 p2 ss).
Proof.
 intros.
 unfold StoreT' in *.
 induction H0.
 - snorm.
 - simpl. eapply Forall2_cons.
   + rgwrite (nil = mergeTE p1 p2 nil).
     eapply typeB_mergeT. auto. auto.
   + auto.
Qed.

(* Weaken store properties in store typing judgement. *)
Lemma storeT_weak_stprops
 :  forall se sp ss p
 ,  StoreT se sp ss
 -> StoreT se (SRegion p <: sp) ss.
Proof.
 intros.
 unfold StoreT in *.
 eapply Forall2_impl.
 - intros. eapply typeB_stprops_snoc. eauto.
 - auto.
Qed.
Hint Resolve storeT_weak_stprops.

(* All region handles in store bindings are present
   in the store properties. *)
Lemma storeT_handles_in_stprops
 :  forall se sp ss
 ,  StoreT se sp ss
 -> Forall (fun s => forall p
                  ,  regionOfStBind s = p
                  -> In (SRegion p) sp)
           ss.
Proof.
 intros.
 snorm.
 unfold StoreT in *.
 have (exists ix, get ix ss = Some x).
  dest ix.
 have (exists t, TypeB nil nil se sp x t).
  dest t.
 inverts H3.
 - snorm. subst. inverts_kind. auto.
 - snorm. subst. inverts_kind. auto.
Qed.

(* Extended store is well typed under extended store environment *)
Lemma storeT_snoc
 :  forall se sp ss p1 v1 t2
 ,  In (SRegion p1) sp
 -> TypeV  nil nil se sp v1 t2
 -> StoreT                       se  sp                   ss
 -> StoreT (TRef (TRgn p1) t2 <: se) sp (StValue p1 v1 <: ss).
Proof.
 intros.
 set (tRef' := TRef (TRgn p1) t2).

 assert (TypeB nil nil (tRef' <: se) sp (StValue p1 v1) tRef').
 { apply TbValue; auto.
   - apply typev_stenv_snoc.
     subst tRef'.
     assert (ClosedT t2).
      rrwrite (0 = @length ki nil).
      apply (kind_wfT nil sp t2 KData).

      (* NOTE: This one has to be done manually to instantiate existentials *)
      apply (typex_kind_type nil nil se sp (XVal v1) t2 (TBot KEffect)).
       auto. auto. auto.
 }

 assert (Forall2 (TypeB nil nil (tRef' <: se) sp) ss se).
 { lets D: (@Forall2_impl stbind ty)
                (TypeB nil nil se sp)
                (TypeB nil nil (tRef' <: se) sp)
                ss se H1.
   intros.
   apply typeB_stenv_snoc. auto. subst tRef'. eauto.
   auto.
 }

 unfold StoreT.
 auto.
Qed.
Hint Resolve storeT_snoc.


(*

  Copyright 2014 Cornell University
  Copyright 2015 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 sequents2.
Require Export per_props_equality.
Require Export per_props_equality_more.
Require Export per_can.
Require Export seq_util.

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

(* [28] ============ CONVERGENCE ============ *)

(*
   H |- a <= b

     By convergence lvl(i) x

     H, x : halts(a) |- a <= b
     H, x : is_exc(a) |- a <= b
     H |- halts(a) in Prop(i)
     H |- is_exc(a) in Prop(i)
 *)

Definition rule_convergence_concl {o} (H : @bhyps o) a b :=
  mk_baresequent H (mk_conclax (mk_approx a b)).

Definition rule_convergence_hyp1 {o} (H : @bhyps o) x a b :=
  mk_baresequent (snoc H (mk_hyp x (mk_halts a))) (mk_conclax (mk_approx a b)).

Definition rule_convergence_hyp2 {o} (H : @bhyps o) x a b :=
  mk_baresequent (snoc H (mk_hyp x (mk_isexc a))) (mk_conclax (mk_approx a b)).

Definition rule_convergence_hyp3 {o} (H : @bhyps o) a i :=
  mk_baresequent H (mk_conclax (mk_member (mk_halts a) (mk_uni i))).

Definition rule_convergence_hyp4 {o} (H : @bhyps o) a i :=
  mk_baresequent H (mk_conclax (mk_member (mk_isexc a) (mk_uni i))).

Definition rule_convergence {o}
           (H   : barehypotheses)
           (i   : nat)
           (a b : @NTerm o)
           (x   : NVar) :=
  mk_rule
    (rule_convergence_concl H a b)
    [ rule_convergence_hyp1 H x a b,
      rule_convergence_hyp2 H x a b,
      rule_convergence_hyp3 H a i,
      rule_convergence_hyp4 H a i
    ]
    [].

Lemma rule_convergence_true3 {o} :
  forall lib
         (H : barehypotheses)
         (i : nat)
         (a b : @NTerm o)
         (x : NVar),
    rule_true3 lib (rule_convergence H i a b x).
Proof.
  unfold rule_convergence, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destruct Hyp  as [ws1 hyp1].
  destruct Hyp0 as [ws2 hyp2].
  destruct Hyp1 as [ws3 hyp3].
  destruct Hyp2 as [ws4 hyp4].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent ((H) ||- (mk_conclax (mk_approx a b)))) as wfs by prove_seq.
  exists wfs.
  unfold wf_csequent, wf_sequent, wf_bseq in wfs; allsimpl; repnd; proof_irr; GC.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars a)
          # !LIn x (free_vars b)) as vhyps.

  { clear hyp1 hyp2 hyp3 hyp4.
    dwfseq.
    sp. }

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

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

  lsubst_tac.
  rw @member_eq.
  rw <- @member_approx_iff.
  rw @tequality_mkc_approx.

  (* Now we start proving our second subgoal: an approximation *)
  assert (capproxc lib (lsubstc a w1 s1 c1) (lsubstc b w2 s1 c2)) as apx1.
  (* for that we can assume that the term on the left computes to a value *)
  { spcast.
    (* we're going to use hyp1, but to prove similarity, we need `hv' *)
    apply approxc_assume_hasvalue; intro hv.
    apply hasvalue_likec_eq in hv; repndors;[|].

    { (* to prove that we will have to use our first subgoal *)
      vr_seq_true in hyp1.
      generalize (hyp1 (snoc s1 (x, mkc_axiom))
                       (snoc s2 (x, mkc_axiom)));
        clear hyp1; intro hyp1.
      dest_imp hyp1 hyp.
      { apply hyps_functionality_snoc2; simpl; try (complete sp).
        introv e s.
        lsubst_tac.
        rw @tequality_mkc_halts.
        apply equality_refl in e.
        rw <- @member_halts_iff in e.
        split; intro chv; try (complete sp).

        vr_seq_true in hyp3.
        generalize (hyp3 s1 s' eqh s); clear hyp3; intro hyp3; exrepnd.
        lsubst_tac.
        allrw @member_eq.
        allrw <- @member_member_iff.
        apply @tequality_in_uni_implies_tequality in hyp0.
        repnd.
        apply hyp0 in hyp1.
        rw @tequality_mkc_halts in hyp1.
        apply hyp1; auto.
      }

      assert (cover_vars (mk_halts a) s1) as cvh1 by (rw @cover_vars_halts; sp).

      dest_imp hyp1 hyp.

      { allrw @similarity_snoc; simpl.
        exists s1 s2 (@mkc_axiom o) (@mkc_axiom o) (wf_halts a w1) cvh1.
        rw @member_eq; lsubst_tac; rw <- @member_halts_iff.
        sp; spcast; sp.
      }

      exrepnd; lsubst_tac.
      allrw @member_eq.
      allrw @tequality_mkc_approx.
      allrw <- @member_approx_iff.
      apply approx_stable in hyp1; auto.
    }

    { vr_seq_true in hyp2.
      generalize (hyp2 (snoc s1 (x, mkc_axiom))
                       (snoc s2 (x, mkc_axiom)));
        clear hyp2; intro hyp2.
      dest_imp hyp2 hyp.
      { apply hyps_functionality_snoc2; simpl; try (complete sp).
        introv e s.
        lsubst_tac.
        apply tequality_mkc_isexc.
        apply equality_refl in e.
        rw <- @member_isexc_iff in e; GC.
        split; intro chv; tcsp;[].

        vr_seq_true in hyp4.
        generalize (hyp4 s1 s' eqh s); clear hyp3; intro hyp3; exrepnd.
        lsubst_tac.
            allrw @member_eq.
            allrw <- @member_member_iff.
            apply @tequality_in_uni_implies_tequality in hyp0.
            repnd.
            apply hyp0 in hyp2.
            rw @tequality_mkc_isexc in hyp2.
            apply hyp2. sp.
      }
      assert (cover_vars (mk_isexc a) s1) as cvh1 by (rw @cover_vars_isexc; sp).

      dest_imp hyp2 hyp.

      { allrw @similarity_snoc; simpl.
        exists s1 s2 (@mkc_axiom o) (@mkc_axiom o) (wf_isexc a w1) cvh1.
        rw @member_eq; lsubst_tac; rw <- @member_isexc_iff.
        sp; spcast; sp.
      }

      exrepnd; lsubst_tac.
      allrw @member_eq.
      allrw @tequality_mkc_approx.
      allrw <- @member_approx_iff.
      apply approx_stable in hyp2; auto.
    }
  }

  { (* Then prove the same thing but for s2 instead of s1 *)
    assert (capproxc lib (lsubstc a w1 s2 c0) (lsubstc b w2 s2 c3)) as apx2.
    (* for that we can assume that the term on the left computes to a value *)
    { spcast.
      (* we're going to use hyp1, but to prove similarity, we need `hv' *)
      apply approxc_assume_hasvalue; intro hv.
      apply hasvalue_likec_eq in hv; repndors;[|].

      { (* to prove that will have to use our first subgoal *)
        vr_seq_true in hyp1.
        generalize (hyp1 (snoc s1 (x, mkc_axiom))
                         (snoc s2 (x, mkc_axiom)));
          clear hyp1; intro hyp1.
        dest_imp hyp1 hyp.
        { apply hyps_functionality_snoc2; simpl; try (complete sp).
          introv e s.
          lsubst_tac.
          rw @tequality_mkc_halts.
          apply equality_refl in e.
          rw <- @member_halts_iff in e.
          split; intro chv; try (complete sp).

          vr_seq_true in hyp3.
          generalize (hyp3 s1 s' eqh s); clear hyp3; intro hyp3; exrepnd.
          lsubst_tac.
          allrw @member_eq.
          allrw <- @member_member_iff.
          apply @tequality_in_uni_implies_tequality in hyp0.
        repnd.
        apply hyp0 in hyp1.
        rw @tequality_mkc_halts in hyp1.
        apply hyp1; auto.

        }

        assert (cover_vars (mk_halts a) s1) as cvh1 by (rw @cover_vars_halts; sp).
        assert (cover_vars (mk_halts a) s2) as cvh2 by (rw @cover_vars_halts; sp).

        dest_imp hyp1 hyp.
        { apply similarity_sym.

          assert (eq_hyps lib s2 s1 H) as eqhs by (apply eq_hyps_sym; apply eqh in sim; sp).
          { rw @eq_hyps_snoc; simpl.
            exists s2 s1 (@mkc_axiom o) (@mkc_axiom o) (wf_halts a w1) cvh2 cvh1.
            lsubst_tac; rw @tequality_mkc_halts; sp.

            vr_seq_true in hyp3.
            generalize (hyp3 s1 s2 eqh sim); clear hyp3; intro hyp3; exrepnd.
            lsubst_tac.
            allrw @member_eq.
            allrw <- @member_member_iff.
            apply @tequality_in_uni_implies_tequality in hyp0.
            repnd.
            apply hyp0 in hyp1.
            rw @tequality_mkc_halts in hyp1.
            rw hyp1. sp.

          }

          allrw @similarity_snoc; simpl.
          exists s2 s1 (@mkc_axiom o) (@mkc_axiom o) (wf_halts a w1) cvh2.
          rw @member_eq; lsubst_tac; rw <- @member_halts_iff.
          sp; spcast; auto.
          apply similarity_sym; sp.
        }

        exrepnd; lsubst_tac.
        allrw @member_eq.
        allrw @tequality_mkc_approx.
        allrw <- @member_approx_iff.
        apply approx_stable; apply hyp0; auto.
      }

      { vr_seq_true in hyp2.
        generalize (hyp2 (snoc s1 (x, mkc_axiom))
                         (snoc s2 (x, mkc_axiom)));
          clear hyp2; intro hyp2.
        dest_imp hyp2 hyp.
        { apply hyps_functionality_snoc2; simpl; try (complete sp).
          introv e s.
          lsubst_tac.
          rw @tequality_mkc_isexc.
          apply equality_refl in e.
          rw <- @member_isexc_iff in e.
          split; intro chv; try (complete sp).

          vr_seq_true in hyp4.
          generalize (hyp4 s1 s' eqh s); clear hyp3; intro hyp3; exrepnd.
          lsubst_tac.
          allrw @member_eq.
          allrw <- @member_member_iff.
          apply @tequality_in_uni_implies_tequality in hyp0.
          repnd.
          apply hyp0 in hyp2.
          rw @tequality_mkc_isexc in hyp2.
          apply hyp2; auto.
        }

        assert (cover_vars (mk_isexc a) s1) as cvh1 by (rw @cover_vars_isexc; sp).
        assert (cover_vars (mk_isexc a) s2) as cvh2 by (rw @cover_vars_isexc; sp).

        dest_imp hyp2 hyp.
        { apply similarity_sym.

          assert (eq_hyps lib s2 s1 H) as eqhs by (apply eq_hyps_sym; apply eqh in sim; sp).
          { rw @eq_hyps_snoc; simpl.
            exists s2 s1 (@mkc_axiom o) (@mkc_axiom o) (wf_isexc a w1) cvh2 cvh1.
            lsubst_tac; rw @tequality_mkc_isexc; sp.

            vr_seq_true in hyp4.
            generalize (hyp4 s1 s2 eqh sim); clear hyp4; intro hyp4; exrepnd.
            lsubst_tac.
            allrw @member_eq.
            allrw <- @member_member_iff.
            apply @tequality_in_uni_implies_tequality in hyp0.
            repnd.
            apply hyp0 in hyp2.
            rw @tequality_mkc_isexc in hyp2.
            rw hyp2. sp.

          }

          allrw @similarity_snoc; simpl.
          exists s2 s1 (@mkc_axiom o) (@mkc_axiom o) (wf_isexc a w1) cvh2.
          rw @member_eq; lsubst_tac; rw <- @member_isexc_iff.
          sp; spcast; auto.
          apply similarity_sym; sp.
        }

        exrepnd; lsubst_tac.
        allrw @member_eq.
        allrw @tequality_mkc_approx.
        allrw <- @member_approx_iff.
        apply approx_stable; apply hyp0; auto.
      }
    }

    (* We finish the proof *)
    sp.
  }
Qed.

Lemma rule_convergence_true {o} :
  forall lib
         (H : barehypotheses)
         (i : nat)
         (a b : @NTerm o)
         (x : NVar),
    rule_true lib (rule_convergence H i a b x).
Proof.
  introv.
  apply rule_true3_implies_rule_true.
  apply rule_convergence_true3.
Qed.

(* !!MOVE *)
Lemma covered_halts {o} :
  forall (a : @NTerm o) vs,
    covered (mk_halts a) vs <=> covered a vs.
Proof.
  introv; unfold covered; simpl; autorewrite with slow; sp.
Qed.

(* !!MOVE *)
Lemma covered_isexc {o} :
  forall (a : @NTerm o) vs,
    covered (mk_isexc a) vs <=> covered a vs.
Proof.
  introv; unfold covered; simpl; autorewrite with slow; sp.
Qed.

Lemma rule_convergence_wf2 {o} :
  forall (H : barehypotheses)
         (i : nat)
         (a b : @NTerm o)
         (x : NVar),
    !LIn x (vars_hyps H)
    -> wf_rule2 (rule_convergence H i a b x).
Proof.
  introv nix wf j; allsimpl.

  repndors; subst; allsimpl; tcsp; allunfold @wf_bseq; allsimpl;
  repnd; dands; destseq; allsimpl; tcsp;
  allrw @covered_approx; repnd;
    allrw <- @wf_approx_iff; repnd;
      allrw @wf_member_iff2;
      allsimpl; dands; tcsp;
        try (apply vswf_hypotheses_nil_eq);
        try (complete (rw @vars_hyps_snoc; simpl; apply covered_snoc_weak; auto));
        try (apply wf_cbv; eauto 2 with slow);
        try (apply wf_halts; auto);
        auto.

  - apply wf_hypotheses_snoc; dands; simpl; auto.
    apply isprog_vars_halts.
    rw @isprog_vars_eq.
    allunfold @covered; dands; eauto 3 with slow.

  - apply wf_hypotheses_snoc; dands; simpl; auto.
    apply isprog_vars_isexc.
    rw @isprog_vars_eq.
    allunfold @covered; dands; eauto 3 with slow.

  - unfold closed_type_baresequent, closed_type, covered; simpl; autorewrite with slow.
    apply subvars_app_l; dands; auto.

  - apply wf_isexc; auto.

  - unfold closed_type_baresequent, closed_type, covered; simpl; autorewrite with slow.
    apply subvars_app_l; dands; auto.
Qed.

(*
   H |- a <= b

     By convergence2 lvl(i) x

     H, x : halts_like(a) |- a <= b
     H |- halts_like(a) in Prop(i)
 *)
Definition rule_convergence2 {o}
           (H   : barehypotheses)
           (i   : nat)
           (a b : @NTerm o)
           (x   : NVar) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_approx a b)))
    [ mk_baresequent (snoc H (mk_hyp x (mk_halts_like a))) (mk_conclax (mk_approx a b)),
      mk_baresequent H (mk_conclax (mk_member (mk_halts_like a) (mk_uni i)))
    ]
    [].

Lemma rule_convergence2_true {o} :
  forall lib
         (H : barehypotheses)
         (i : nat)
         (a b : @NTerm o)
         (x : NVar),
    rule_true lib (rule_convergence2 H i a b x).
Proof.
  unfold rule_convergence2, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

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

  assert (closed_extract H (mk_conclax (mk_approx a b))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars a)
          # !LIn x (free_vars b)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp.

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

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

  lsubst_tac.
  rw @member_eq.
  rw <- @member_approx_iff.
  rw @tequality_mkc_approx.

  (* Now we start proving our second subgoal: an approximation *)
  assert (capproxc lib (lsubstc a w1 s1 c1) (lsubstc b w2 s1 c2)) as apx1.
  (* for that we can assume that the term on the left computes to a value *)
  { spcast.
    (* we're going to use hyp1, but to prove similarity, we need `hv' *)
    apply approxc_assume_hasvalue; intro hv.

    (* to prove that we will have to use our first subgoal *)
    vr_seq_true in hyp1.
    generalize (hyp1 (snoc s1 (x, mkc_axiom))
                     (snoc s2 (x, mkc_axiom)));
      clear hyp1; intro hyp1.
    dest_imp hyp1 hyp.
    { apply hyps_functionality_snoc2; simpl; try (complete sp).
      introv e s.
      lsubst_tac.
      rw @tequality_mkc_halts_like.
      apply equality_refl in e.
      rw @member_halts_like_iff in e.
      split; intro chv; try (complete sp).

      vr_seq_true in hyp2.
      generalize (hyp2 s1 s' eqh s); clear hyp2; intro hyp2; exrepnd.
      lsubst_tac.
      allrw @member_eq.
      allrw <- @member_member_iff.
      apply @tequality_in_uni_implies_tequality in hyp0.
      repnd.
      apply hyp0 in hyp1.
      rw @tequality_mkc_halts_like in hyp1.
      apply hyp1; auto.
    }

    assert (cover_vars (mk_halts_like a) s1) as cvh1 by (rw @cover_vars_halts_like; sp).

    dest_imp hyp1 hyp.

    { allrw @similarity_snoc; simpl.
      exists s1 s2 (@mkc_axiom o) (@mkc_axiom o) (wf_halts a w1) cvh1.
      rw @member_eq; lsubst_tac; rw @member_halts_like_iff.
      sp; spcast; sp.
    }

    exrepnd; lsubst_tac.
    allrw @member_eq.
    allrw @tequality_mkc_approx.
    allrw <- @member_approx_iff.
    apply approx_stable in hyp1; auto.
  }

  { (* The prove the same thing but for s2 instead of s1 *)
    assert (capproxc lib (lsubstc a w1 s2 c0) (lsubstc b w2 s2 c3)) as apx2.
    (* for that we can assume that the term on the left computes to a value *)
    { spcast.
      (* we're going to use hyp1, but to prove similarity, we need `hv' *)
      apply approxc_assume_hasvalue; intro hv.

      (* to prove that will have to use our first subgoal *)
      vr_seq_true in hyp1.
      generalize (hyp1 (snoc s1 (x, mkc_axiom))
                       (snoc s2 (x, mkc_axiom)));
        clear hyp1; intro hyp1.
      dest_imp hyp1 hyp.
      { apply hyps_functionality_snoc2; simpl; try (complete sp).
        introv e s.
        lsubst_tac.
        rw @tequality_mkc_halts_like.
        apply equality_refl in e.
        rw @member_halts_like_iff in e.
        split; intro chv; try (complete sp).

        vr_seq_true in hyp2.
        generalize (hyp2 s1 s' eqh s); clear hyp2; intro hyp2; exrepnd.
        lsubst_tac.
        allrw @member_eq.
        allrw <- @member_member_iff.
        apply @tequality_in_uni_implies_tequality in hyp0.
        repnd.
        apply hyp0 in hyp1.
      rw @tequality_mkc_halts_like in hyp1.
      apply hyp1; auto.

      }

      assert (cover_vars (mk_halts_like a) s1) as cvh1 by (rw @cover_vars_halts_like; sp).
      assert (cover_vars (mk_halts_like a) s2) as cvh2 by (rw @cover_vars_halts_like; sp).

      dest_imp hyp1 hyp.
      { apply similarity_sym.

        assert (eq_hyps lib s2 s1 H) as eqhs by (apply eq_hyps_sym; apply eqh in sim; sp).
        { rw @eq_hyps_snoc; simpl.
          exists s2 s1 (@mkc_axiom o) (@mkc_axiom o) (wf_halts a w1) cvh2 cvh1.
          lsubst_tac; rw @tequality_mkc_halts_like; sp.

          vr_seq_true in hyp2.
          generalize (hyp2 s1 s2 eqh sim); clear hyp2; intro hyp2; exrepnd.
          lsubst_tac.
          allrw @member_eq.
          allrw <- @member_member_iff.
          apply @tequality_in_uni_implies_tequality in hyp0.
          repnd.
          apply hyp0 in hyp1.
          rw @tequality_mkc_halts_like in hyp1.
          rw hyp1; auto.

        }

        allrw @similarity_snoc; simpl.
        exists s2 s1 (@mkc_axiom o) (@mkc_axiom o) (wf_halts a w1) cvh2.
        rw @member_eq; lsubst_tac; rw @member_halts_like_iff.
        sp; spcast; auto.
        apply similarity_sym; sp.
      }

      exrepnd; lsubst_tac.
      allrw @member_eq.
      allrw @tequality_mkc_approx.
      allrw <- @member_approx_iff.
      apply approx_stable; apply hyp0; auto.
    }

    (* We finish the proof *)
    sp.
  }
Qed.

(* end hide *)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C IB XB IA XA X : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ IB B /\ (wd_ IA A /\ (wd_ XA B /\ (wd_ XB A /\ (wd_ X A /\ (wd_ X B /\ (wd_ C X /\ (wd_ XB B /\ (wd_ XA A /\ (col_ B C X /\ (col_ XA X A /\ (col_ XB X B /\ (col_ B XA C /\ (col_ A XB C /\ (col_ A XA IA /\ col_ B XB IB)))))))))))))))))) -> col_ C B IB)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B X Y M Aprime Bprime : Universe, ((wd_ X Y /\ (wd_ A M /\ (wd_ Aprime M /\ (wd_ B M /\ (wd_ Bprime M /\ (wd_ B X /\ (wd_ B Y /\ (wd_ A X /\ (wd_ A Y /\ (wd_ B Bprime /\ (wd_ A B /\ (col_ X Y M /\ (col_ A M Aprime /\ (col_ Aprime X Y /\ col_ M B Bprime)))))))))))))) -> col_ M Aprime X)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Bool.Sumbool.
Require Import List.
Import ListNotations.
Require Import ZArith.

Require Import CakeSem.Utils.
Require Import CakeSem.CakeAST.
Require Import CakeSem.Namespace.
Require Import CakeSem.ffi.FFI.

Open Scope string_scope.
Open Scope list_scope.

Set Implicit Arguments.
(* ********************************************************************** *)
(** * Auxiliary semantics constructs *)

(* ---------------------------------------------------------------------- *)
(** ** Stamps and predefined constructors *)

(* constructor name and unique type number *)
Inductive stamp : Type :=
  | TypeStamp : conN -> nat -> stamp
  | ExnStamp : nat -> stamp.
Scheme Equality for stamp.
#[export] Hint Resolve stamp_eq_dec : DecidableEquality.

(* ---------------------------------------------------------------------- *)
(** ** Environments *)
(* QUESTION: what is the interest of being generic in the type of values? *)
(* ANSWER: I DON'T EVEN KNOW, but also we havent defined our values yet *)

Record sem_env (V : Type) := {
  sev : namespace modN varN V;
  (* nat is the arity of the constructor name conN *)
  sec : namespace modN conN (nat * stamp) }.

Arguments sev {V} _.
Arguments sec {V} _.

(* TODO: Move to theorems file? *)
Theorem sem_env_id : forall (V : Type) (env : sem_env V), env = {| sev := sev env; sec := sec env|}.
Proof. destruct env; reflexivity.  Qed.

(** Auxiliary definition to mimic [{ env with sev = .. }] *)
Definition update_sev V (e:sem_env V) (x:namespace modN varN V) :=
  {| sev := x; sec := sec e |}.

(** Auxiliary definition to mimic [{ env with sec = .. }] *)
Definition update_sec V (e:sem_env V) x :=
  {| sev := sev e; sec := x |}.

(* BACKPORT: use this definition in semantics *)
Definition empty_sem_env {V : Type} : sem_env V :=
  {| sev := nsEmpty; sec := nsEmpty |}.

(* BACKPORT: extend_dec_env should be used in definition of combine_dec_result *)
Definition extend_dec_env (V : Type) (new_env env : sem_env V) : sem_env V :=
  {| sev := nsAppend (sev new_env) (sev env);
     sec := nsAppend (sec new_env) (sec env)|}.

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

Unset Elimination Schemes.

(* TODO: HOL4 version now supports floating point and a repl *)
Inductive val : Type :=
  | Litv : lit -> val
  | Conv : option stamp -> list val -> val
  | Closure : sem_env val -> varN -> exp -> val
  | Recclosure : sem_env val -> list (varN * varN * exp) -> varN -> val
  | Loc : nat -> val
  | Vectorv : list val -> val.

Set Elimination Schemes.
Definition env_val := namespace modN varN val.
Definition env_ctor := namespace modN conN (nat * stamp).

(** [is_closure v] captures whether [v] is a closure or a recursive closure. *)
Definition is_closureb (v : val) : bool :=
  match v with
  | Closure _ _ _ => true
  | Recclosure _ _ _ => true
  | _ => false
  end.

Definition is_closure (v : val) : Prop :=
  match v with
  | Closure _ _ _ => True
  | Recclosure _ _ _ => True
  | _ => False
  end.

(* ---------------------------------------------------------------------- *)
(** ** Predefined exceptions and constructors  *)
(* BACKPORT: bind_stamp is used to mean "match failure", but that's not an intuitive name for it *)
Definition bind_stamp := ExnStamp 0.
Definition chr_stamp := ExnStamp 1.
Definition div_stamp := ExnStamp 2.
Definition subscript_stamp := ExnStamp 3.

Definition bind_exn_v := Conv (Some bind_stamp) [].
Definition chr_exn_v  := Conv (Some chr_stamp) [].
Definition div_exn_v  := Conv (Some div_stamp) [].
Definition sub_exn_v  := Conv (Some subscript_stamp) [].

Definition bool_type_num := 0.
Definition list_type_num := 1.
Definition option_type_num := 2.

(* BACKPORT: define these 3 shorthands *)

Definition ConvTrue := Conv (Some (TypeStamp "True"  bool_type_num)) [].
Definition ConvFalse := Conv (Some (TypeStamp "False"  bool_type_num)) [].
Definition ConvUnit := Conv None [].

Definition Boolv (b : bool) : val :=
  if b then ConvTrue  else ConvFalse.

(* ---------------------------------------------------------------------- *)
(** ** Result of an evaluation *)

(* Result of evaluation *)

Inductive abort : Type :=
  | Rtype_error : abort
  | Rtimeout_error : abort
  | Rffi_error : final_event -> abort.

Inductive error_result (A : Type) : Type :=
  | Rraise : A -> error_result A
  | Rabort : abort -> error_result A.

Arguments Rraise {A}.
Arguments Rabort {A}.

Inductive result (A : Type) (B : Type) : Type :=
  | Rval : A -> result A B
  | Rerr : error_result B -> result A B.

Arguments Rval {A} {B}.
Arguments Rerr {A} {B}.

Definition combine_dec_result {A : Type} (env : sem_env val) (r : result (sem_env val) A) :
  result (sem_env val) A :=
  match r with
  | Rerr err => r
  | Rval env' =>  Rval (extend_dec_env env' env)
  end.

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

Inductive store_v (A : Type) : Type :=
  (* Reference *)
  | Refv : A -> store_v A
  (* Byte array *)
  | W8array : list word8 -> store_v A
  (* Value array *)
  | Varray : list A -> store_v A.

Arguments Refv {A}.
Arguments W8array {A}.
Arguments Varray {A}.

(* The nth item in the list is the value at location n *)

Definition store (A : Type) :=
  list (store_v A).

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

Record state (A : Type) :=
  {
    clock : nat;
    refs : store val;
    ffi : ffi_state A;
    next_type_stamp : nat;
    next_exn_stamp : nat
  }.

Arguments clock {A} _.
Arguments refs {A} _.
Arguments ffi {A} _.
Arguments next_type_stamp {A} _.
Arguments next_exn_stamp {A} _.
Arguments refs {A} _.

Definition state_update_refs_and_ffi A (st:state A) refs' (ffi':ffi_state A) :=
   {| clock := clock st;
      refs := refs';
      ffi := ffi';
      next_type_stamp := next_type_stamp st ;
      next_exn_stamp := next_exn_stamp st |}.

(** Auxiliary definition to mimic [{ st with next_type_stamp = .. }] *)
Definition state_update_next_type_stamp A (st:state A) x :=
   {| clock := clock st;
      refs := refs st;
      ffi := ffi st;
      next_type_stamp := x ;
      next_exn_stamp := next_exn_stamp st |}.

(** Auxiliary definition to mimic [{ st with next_exn_stamp = .. }] *)
Definition state_update_next_exn_stamp A (st:state A) x :=
   {| clock := clock st;
      refs := refs st;
      ffi := ffi st;
      next_type_stamp := next_type_stamp st ;
      next_exn_stamp := x |}.

(* ---------------------------------------------------------------------- *)
(** ** Pattern-maching result *)

Inductive match_result (A : Type) : Type :=
  | No_match : match_result A
  | Match_type_error : match_result A
  | Match : A -> match_result A.

Arguments No_match {A}.
Arguments Match_type_error {A}.
Arguments Match {A}.

(* ********************************************************************** *)
(** * Auxiliary operations *)

(* BACKPORT: it would scale up better to use modules to organize the names,
   e.g. Store.empty, Store.lookup, etc.. (The C-style naming convention
   with everything flat eventually shows its limits... *)

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

Definition store_v_same_type (A : Type) (v1 v2 : store_v A) : bool :=
  match v1, v2 with
  | Refv _, Refv _ => true
  | W8array _, W8array _ => true
  | Varray _, Varray _ => true
  | _, _ => false
  end.

Definition lit_same_type (l1 l2 : lit) : bool :=
  match l1, l2 with
    | IntLit _, IntLit _ => true
    | CharLit _, CharLit _ => true
    | StrLit _, StrLit _ => true
    | Word8Lit _, Word8Lit _ => true
    | Word64Lit _, Word64Lit _ => true
    | _, _ => false
  end.

Definition stamp_same_type (s1 s2 : stamp) : bool :=
  match s1, s2 with
  | TypeStamp _ n1, TypeStamp _ n2 => Nat.eqb n1 n2
  | ExnStamp _, ExnStamp _ => true
  | _, _ => false
  end.

Definition ctor_same_type (os1 os2 : option stamp) : bool :=
  match os1, os2 with
  | None, None => true
  | Some s1, Some s2 => stamp_same_type s1 s2
  | _, _ => false
end.

(** [con_check cenv o l] asserts that the constructor (or None for a tuple) admits arity [l].
    (Note that tuples admit any arity.)
    This is an inductive version of [do_con_check] *)
Definition do_con_check (cenv : env_ctor) (cid : constr_id) (l : nat) : bool :=
  match cid with
  | None => true
  | Some id => match nsLookup (ident_beq _ _ String.eqb String.eqb) id cenv with
              | None => false
              | Some (l',s) => Nat.eqb l' l
              end
  end.

(* ---------------------------------------------------------------------- *)
(** ** Operations on the store *)

Definition empty_store (A : Type) : store A := [].
Arguments empty_store {A}.

Definition store_lookup {A : Type} (n : nat) (st : store A) :=
  List.nth_error st n.

Definition store_alloc {A : Type} (v : store_v A) (st : store A) : (store A * nat) :=
  (st ++ [v], List.length st).

Definition store_assign_nocheck {A : Type} (n : nat) (v : store_v A) (st : store A) : store A :=
  Utils.update n v st.

(* ---------------------------------------------------------------------- *)
(** ** Operations on constructors *)

Definition build_conv (cenv : env_ctor) (cid : constr_id) (vs: list val) : option val :=
  match cid with
  | None => Some (Conv None vs)
  | Some id => match nsLookup (ident_beq _ _ String.eqb String.eqb) id cenv with
              | None => None
              | Some (len,stmp) => Some (Conv (Some stmp) vs)
              end
  end.

(* ---------------------------------------------------------------------- *)
(** ** Operations for functions *)
Definition build_rec_env (funs : list (varN * varN * exp)) (cl_env : sem_env val)
           (add_to_env : env_val) : env_val :=
  fold_right (fun '(f,x,e) env' => nsBind f (Recclosure cl_env funs f) env') add_to_env funs.

Fixpoint find_recfun {A B : Type} (n : varN) (funs : list (varN * A * B)) : option (A * B) :=
  match funs with
  | [] => None
  | (f,x,e)::funs' => if string_dec f n then Some (x,e) else find_recfun n funs'
  end.

(* ---------------------------------------------------------------------- *)
(** ** Lookup for binary operations *)

Definition opn_lookup (op : opn) : Z -> Z -> Z :=
  match op with
  | Plus => Z.add
  | Minus => Z.sub
  | Times => Z.mul
  | Divide => Z.div
  | Modulo => Z.modulo
  end.

Definition opb_lookup (op : opb) : Z -> Z -> bool :=
  match op with
  | Lt => Z.ltb
  | Gt => Z.gtb
  | Leq => Z.leb
  | Geq => Z.geb
  end.

Definition opb_lookup_Prop (op : opb) : Z -> Z -> Prop :=
  match op with
  | Lt => Z.lt
  | Gt => Z.gt
  | Leq => Z.le
  | Geq => Z.ge
  end.

Parameter opw8_lookup : forall (op : opw), word8 -> word8 -> word8.
(* TODO: implement
  match op with
  | Andw => word_and
  | Orw  => word_or
  | Xorw => word_xor
  | Addw => word_add
  end 8.*)

Parameter opw64_lookup : forall (op : opw), word64 -> word64 -> word64.
(* TODO: implement
  match op with
  | Andw => word_and
  | Orw  => word_or
  | Xorw  => word_xor
  | Addw  => word_add
  end 64. *)

Parameter shift8_lookup : forall (op : CakeAST.shift), word8 -> nat -> word8.
(* TODO: implement
 fun w n => match op with
         | Lsl => id w
         | Lsr => id w
         | Asr => id w
         | Ror => id w
         end. *)

Parameter shift64_lookup : forall (op : CakeAST.shift), word64 -> nat -> word64.
(* TODO: implement
  fun w n => match op with
          | Lsl => id w
          | Lsr => id w
          | Asr => id w
          | Ror => id w
          end. *)

(* ---------------------------------------------------------------------- *)
(** ** Type definitions *)

Open Scope bool_scope.
Open Scope nat_scope.
Definition UniqueCtorsInDef (td : list tvarN * typeN * list (conN * list ast_t)) : Prop :=
  let '(tvs,tn,condefs) := td in
  NoDup (List.map (fun '(n,_) => n) condefs).

Definition UniqueCtorsInDefs (tds : typeDef) : Prop :=
  List.Forall UniqueCtorsInDef tds.

Definition build_constrs (s : nat) (condefs : list (conN * (list ast_t)) ) :=
  List.map (fun '(conN,ts) => (conN,(List.length ts, TypeStamp conN s))) condefs.

Fixpoint build_tdefs (next_stamp : nat) (tds : list (list tvarN * typeN * list (conN * list ast_t))) : env_ctor :=
  match tds with
  | [] => alist_to_ns []
  | (tvars,tn,condefs)::tds' => nsAppend
                                (build_tdefs (next_stamp + 1) tds')
                                (alist_to_ns (List.rev (build_constrs next_stamp condefs)))
  end.

(* ********************************************************************** *)
(** * Other auxiliary operations,
      currently not needed by RelationBigStep, but might be in the future *)

Fixpoint val_to_list (v : val) : option (list val) :=
  match v with
  | Conv (Some stamp) [] => if stamp_eq_dec stamp (TypeStamp "[]" list_type_num)
                           then Some []
                           else None
  | Conv (Some stamp) [v1;v2] => if stamp_eq_dec stamp (TypeStamp "::" list_type_num)
                                then match val_to_list v2 with
                                     | Some vs => Some (v1::vs)
                                     | None => None
                                     end
                                else None
  | _ => None
  end.

Fixpoint list_to_val (vs : list val) : val :=
  match vs with
  | [] => Conv (Some (TypeStamp "[]" list_type_num)) []
  | v'::vs' => Conv (Some (TypeStamp "::" list_type_num)) [v'; list_to_val vs']
  end.

Fixpoint val_to_char_list (v : val) : option (list char) :=
  match v with
  | Conv (Some stamp) [] => if stamp_eq_dec stamp (TypeStamp "[]" list_type_num)
                           then Some []
                           else None
  | Conv (Some stamp) [Litv (CharLit c); v'] =>
    if stamp_eq_dec stamp (TypeStamp "::" list_type_num)
    then match val_to_char_list v' with
         | Some cs => Some (c::cs)
         | None => None
         end
    else None
  | _ => None
  end.

Fixpoint vals_to_string (vs : list val) : option String.string :=
  match vs with
  | [] => Some ""
  | (Litv (StrLit s1))::vs' => match vals_to_string vs' with
                             | Some s2 => Some (String.append s1 s2)
                             | None => None
                             end
  | _ => None
  end.

Open Scope bool_scope.
Open Scope Z_scope.

Definition copy_array {A : Type} (p : list A * Z) (len : Z)
                      (op : option (list A * Z)) : option (list A) :=
  let (src,srcoff) := p in
  if (srcoff =? 0) || (len <? 0) || (Zlength src <? srcoff + len)
  then None
  else let copied := List.firstn (Z.to_nat len)
                       (List.skipn (Z.to_nat srcoff) src) in
       match op with
       | Some (dst,dstoff) => if (dstoff <? 0) || (Zlength dst <? dstoff + len)
                             then None
                             else Some (List.firstn
                                          (Z.to_nat dstoff)
                                          dst ++ copied ++
                                          List.skipn (Z.to_nat (dstoff + len)) dst)
       | None => Some copied
       end.

Close Scope bool_scope.
Close Scope Z_scope.

(* ********************************************************************** *)
(** * Induction principles *)

(* ---------------------------------------------------------------------- *)
(** ** Induction for values *)

Fixpoint val_rect (P : val -> Type)
         (H1 : forall (l : lit), P (Litv l))
         (H2 : forall (o : option stamp) (l : list val), Forall''  P l -> P (Conv o l))
         (H3 : forall (s : sem_env val) (n : varN) (e : exp), Forall'' (fun p => P (snd p)) (sev s) -> P (Closure s n e))
         (H4 : forall (s : sem_env val) (l : list (varN * varN * exp)) (n : varN), Forall'' (fun p => P (snd p)) (sev s) ->
                                                                            P (Recclosure s l n))
         (H5 : forall (n : nat), P (Loc n))
         (H6 : forall (l : list val), Forall'' P l -> P (Vectorv l))
         (v : val) : P v :=
  let val_rect' := @val_rect P H1 H2 H3 H4 H5 H6 in
  match v with
  | Litv l => H1 l
  | Conv o l => let fix loop (l : list val) :=
                   match l with
                   | [] => Forall_nil'' val P
                   | h::t => Forall_cons'' val P h t (val_rect' h) (loop t)
                   end
               in
               H2 o l (loop l)
  | Closure s n e => let fix loop__ns (ls : namespace modN varN val) :=
                        match ls with
                          | [] => Forall_nil'' (ident modN varN * val) (fun p => P (snd p))
                          | ((i,v'))::ls' => Forall_cons'' (ident modN varN * val) (fun p => P (snd p))
                                                       (i,v') ls' (val_rect' v') (loop__ns ls')
                        end
                    in
                    H3 s n e (loop__ns (sev s))
  | Recclosure s l n => let fix loop__ns (ls : namespace modN varN val) :=
                           match ls with
                           | [] => Forall_nil'' (ident modN varN * val) (fun p => P (snd p))
                           | ((i,v'))::ls' => Forall_cons'' (ident modN varN * val) (fun p => P (snd p))
                                                         (i,v') ls' (val_rect' v') (loop__ns ls')
                           end
                       in
                       H4 s l n (loop__ns (sev s))
  | Loc n => H5 n
  | Vectorv l => let fix loop (l : list val) :=
                    match l with
                    | [] => Forall_nil'' val P
                    | h::t => Forall_cons'' val P h t (val_rect' h) (loop t)
                    end
                in
                H6 l (loop l)
  end.

Definition val_ind (P : val -> Prop) := @val_rect P.
Definition val_rec (P : val -> Set) := @val_rect P.

Fixpoint val_beq (v1 v2 : val) : bool :=
  match v1, v2 with
  | Litv l1, Litv l2 => lit_beq l1 l2
  | Conv o1 l1, Conv o2 l2 => andb (option_beq _ stamp_beq o1 o2) (list_beq val_beq l1 l2)
  (* not real equality, but considered equivalent by CakeML*)
  | Closure env1 v1 e1, Closure env2 v2 e2 => true
  | Recclosure env1 l1 v1, Recclosure env2 l2 v2 => true
  | Loc n1, Loc n2 => n1 =? n2
  | Vectorv l1, Vectorv l2 => list_beq val_beq l1 l2
  | _, _ => false
  end.

(** Decidability theorems *)

(* Theorem val_eq_dec : forall (v0 v1 : val), {v0 = v1} + {v0 <> v1}. *)
(* Proof. *)
(*   decide equality; auto with DecidableEquality. *)
(*   - generalize dependent l0. induction l; destruct l0; try (left; reflexivity); try (right; discriminate). *)
(*     inversion X; subst; clear X. destruct (X0 v); destruct (IHl X1 l0); subst; try (right; discriminate); try (left; reflexivity). *)
(*     right; injection; assumption. *)
(*     right; injection; assumption. *)
(*     right; injection. intro. assumption. *)
(*   - generalize dependent s0. induction s; destruct s0. *)

(*     assert (pair_nat_stamp_dec : forall (p p0: (nat * stamp)), {p = p0} + {p <> p0}) *)
(*       by (decide equality; auto with DecidableEquality). *)
(*     destruct (namespace_eq_dec modN conN (nat * stamp) String.string_dec String.string_dec *)
(*                                pair_nat_stamp_dec sec0 sec1); subst. *)

(*     generalize dependent sev1. *)
(*     simpl in X. *)
(*     induction X; destruct sev1; try (left; reflexivity); try (right; discriminate). *)
(*     destruct x; destruct p0. *)
(*     destruct (ident_eq_dec modN varN string_dec string_dec i i0); subst. *)
(*     destruct (p v3); subst. *)
(*     simpl in *. *)
(*     destruct (IHX sev1). *)
(*     inversion e1. *)
(*     left; reflexivity. *)
(*     right; intro con; inversion con. apply n0. rewrite H0. reflexivity. *)
(*     right; intro con; inversion con; auto. *)
(*     right; intro con; inversion con; auto. *)
(*     right; intro con; inversion con; auto. *)
(*   - generalize dependent s0. induction s; destruct s0. *)

(*     assert (pair_nat_stamp_dec : forall (p p0: (nat * stamp)), {p = p0} + {p <> p0}) *)
(*       by (decide equality; auto with DecidableEquality). *)
(*     destruct (namespace_eq_dec modN conN (nat * stamp) String.string_dec String.string_dec *)
(*                                pair_nat_stamp_dec sec0 sec1); subst. *)

(*     simpl in X. *)
(*     generalize dependent sev1. *)
(*     induction X; destruct sev1; try (left; reflexivity); try (right; discriminate). *)
(*     destruct x; destruct p0. *)
(*     destruct (ident_eq_dec modN varN string_dec string_dec i i0); subst. *)
(*     destruct (p v3); subst. *)
(*     simpl in *. *)
(*     destruct (IHX sev1). *)
(*     inversion e. *)
(*     left; reflexivity. *)
(*     right; intro con; inversion con. apply n0. rewrite H0. reflexivity. *)
(*     right; intro con; inversion con; auto. *)
(*     right; intro con; inversion con; auto. *)
(*     right; intro con; inversion con; auto. *)
(*   - generalize dependent l0. induction l; destruct l0; try (left; reflexivity); try (right; discriminate). *)
(*     inversion X; subst; clear X. destruct (X0 v); destruct (IHl X1 l0); subst; try (right; discriminate); try (left; reflexivity). *)
(*     right; injection; assumption. *)
(*     right; injection; assumption. *)
(*     right; injection. intro. assumption. *)
(* Defined. *)

Lemma UniqueCtorsInDef_dec : forall (td : (list tvarN * typeN * list (conN * list ast_t))),
    {UniqueCtorsInDef td} + {~ UniqueCtorsInDef td}.
Proof.
  unfold UniqueCtorsInDef. intro td.
  destruct td. destruct p.
  apply NoDuplicates_dec.
  auto with DecidableEquality.
Defined.

Theorem UniqueCtorsInDefs_dec : forall (tds : typeDef), {UniqueCtorsInDefs tds} + {~ UniqueCtorsInDefs tds}.
Proof.
  apply Forall_dec.
  apply UniqueCtorsInDef_dec.
Defined.


Require Export liblayers.simrel.SimulationRelation.
Require Export liblayers.simrel.SimrelLessdef.
Require Export liblayers.simrel.SimrelInject.
Require Import liblayers.simrel.MemoryRel.
Local Opaque mwd_ops.

(** extends cancels out when composed with inject *)

Section WITHMEM.
  Context `{Hmem: BaseMemoryModel}.
  Context {D: layerdata}.

  Global Instance extends_inject_compose:
    SimulationRelationEquivalence _ _ (equiv_extends_compose_left (inj (D:=D))).
  Proof.
    apply extends_compose_left; simpl; auto.
    - reflexivity.
    - intros p m1 m2 m3 H H0.
      eapply inject_same_nextblock; eauto.
      + eapply (Mem.extends_inject_compose (mem := mwd D)); eauto.
        destruct H0; eauto.
      + apply memrel_mext_next; eauto.
  Qed.

  Global Instance inject_extends_compose:
    SimulationRelationEquivalence _ _ (equiv_extends_compose_right (inj (D:=D))).
  Proof.
    apply extends_compose_right; simpl; auto.
    - reflexivity.
    - intros p m1 m2 m3 H H0.
      eapply inject_same_nextblock; eauto.
      + eapply Mem.inject_extends_compose; eauto.
        destruct H; eauto.
      + symmetry.
        apply memrel_mext_next; eauto.
  Qed.
End WITHMEM.


Require Import Lia.
From hahn Require Import Hahn.
From imm Require Import
     AuxDef
     Events Execution
     Prog ProgToExecution ProgToExecutionProperties.
Require Import AuxDef.
Require Import AuxRel.
Require Import ImmProperties.

Lemma unique_eps_step thread state state' state''
      (EPS_STEP1 : istep thread [] state state')
      (EPS_STEP2 : istep thread [] state state'') :
  state' = state''.
Proof.
  cdes EPS_STEP1.
  cdes EPS_STEP2.
  rewrite <- ISTEP in ISTEP1. inv ISTEP1.
  inv ISTEP0.
  all: inv ISTEP2.
  all: destruct state'.
  all: destruct state''.
  all: simpls.
  all: desf.
Qed.

Lemma unique_ineps_step thread lbl state state' state''
      (STEP1 : istep thread lbl state state')
      (STEP2 : istep thread lbl state state'') :
  state' = state''.
Proof.
  cdes STEP1.
  cdes STEP2.
  rewrite <- ISTEP in ISTEP1. inv ISTEP1.
  inv ISTEP0.
  all: inv ISTEP2.
  all: destruct state'.
  all: destruct state''.
  all: simpls.
  all: desf.
Qed.

Definition stable_state :=
  set_compl
    (dom_rel (fun x y => exists thread, istep thread [] x y)).

Definition stable_lprog lprog :=
  forall thread state (INSTR : state.(instrs) = lprog)
         (REACH : (step thread)＊ (init lprog) state),
    { state' |
      ⟪ STEPS : (istep thread [])＊ state state' ⟫ /\
      ⟪ STABLE : stable_state state' ⟫ }.

Lemma get_stable thread state
      (LPST : stable_lprog state.(instrs))
      (REACH : (step thread)＊ (init state.(instrs)) state) :
  { state' |
    unique (fun state' =>
              ⟪ STEPS : (istep thread [])＊ state state' ⟫ /\
              ⟪ STABLE : stable_state state' ⟫)
    state' }.
Proof.
  edestruct LPST as [state']; eauto.
  desf.
  exists state'.
  red. splits; auto.
  clear -STEPS STABLE.
  apply clos_rt_rt1n in STEPS.
  intros y [AA BB].
  apply clos_rt_rt1n in AA.
  generalize dependent y.
  induction STEPS.
  { ins. destruct AA; auto.
    exfalso. apply STABLE.
    eexists. eauto. }
  ins.
  apply IHSTEPS; auto.
  destruct AA.
  { exfalso. apply BB.
    eexists. eauto. }
  assert (y = y0); desf.
  eapply unique_eps_step; eauto.
Qed.

Lemma terminal_stable : is_terminal ⊆₁ stable_state.
Proof.
  intros state TERM [state' HH].
  desf. cdes HH.
  assert (nth_error (instrs state) (pc state) <> None) as YY.
  { by rewrite <- ISTEP. }
  apply nth_error_Some in YY.
  red in TERM.
  rewrite INSTRS in *.
  inv ISTEP0; desf.
  all: lia.
Qed.

Definition ineps_step thread lbls (state state' : state) :=
  ⟪ NNIL : lbls <> [] ⟫ /\
  ⟪ STEP : istep thread lbls state state' ⟫.

Definition neps_step thread (state state' : state) :=
  exists lbls, ineps_step thread lbls state state'.

Definition ilbl_step thread lbls :=
  ineps_step thread lbls ⨾ (istep thread [])＊ ⨾ ⦗ stable_state ⦘.

Definition lbl_step thread (state state' : state) :=
  exists lbls, ilbl_step thread lbls state state'.

Lemma ilbl_step_in_steps thread lbls : ilbl_step thread lbls ⊆ (step thread)⁺.
Proof.
  unfold ilbl_step.
  arewrite ((istep thread [])＊ ⊆ (step thread)＊).
  { apply clos_refl_trans_mori. unfold step. basic_solver. }
  arewrite (ineps_step thread lbls ⊆ step thread).
  { unfold step, ineps_step. basic_solver. }
  rewrite <- seqA.
  rewrite <- ct_begin.
  basic_solver.
Qed.

Lemma lbl_step_in_steps thread : lbl_step thread ⊆ (step thread)⁺.
Proof.
  intros x y [lbl HH]. cdes HH.
  eapply ilbl_step_in_steps. eauto.
Qed.

Lemma lbl_steps_in_steps thread : (lbl_step thread)＊ ⊆ (step thread)＊.
Proof. rewrite lbl_step_in_steps. apply rt_of_ct. Qed.

Lemma ineps_eps_step_dom_empty thread lbls :
  dom_rel (ineps_step thread lbls) ∩₁
  dom_rel (fun x y => exists thread, istep thread [] x y) ≡₁ ∅.
Proof.
  split; [|basic_solver].
  intros x [[y AA] [z BB]].
  cdes AA.
  cdes STEP.
  cdes BB.
  rewrite <- ISTEP in ISTEP1. inv ISTEP1.
  inv ISTEP2.
  all: inv ISTEP0.
Qed.

Lemma steps_to_eps_steps_steps thread state state' state''
      (STBL : stable_state state'')
      (EPS_STEPS : (istep thread [])＊ state state')
      (    STEPS : (step thread)＊     state state'') :
  (step thread)＊ state' state''.
Proof.
  apply clos_rt_rt1n in EPS_STEPS.
  induction EPS_STEPS; auto.
  apply IHEPS_STEPS.
  clear dependent z.
  apply clos_rt_rt1n in STEPS.
  inv STEPS.
  { exfalso. apply STBL. eexists. eauto. }
  assert (y0 = y); subst.
  2: by apply clos_rt1n_rt.
  match goal with
  | H : step thread x y0 |- _ => inv H
  end.
  destruct (classic (x0 = [])); subst.
  { eapply unique_eps_step; eauto. }
  exfalso.
  eapply ineps_eps_step_dom_empty.
  split; eexists; [red; splits|]; eauto.
Qed.

Lemma ineps_step_stable_l thread lbls :
  ineps_step thread lbls ≡ ⦗ stable_state ⦘ ⨾ ineps_step thread lbls.
Proof.
  split; [|basic_solver].
  intros x y HH.
  apply seq_eqv_l. split; auto.
  intros [z AA]. desf.
  eapply ineps_eps_step_dom_empty.
  split; eexists; eauto.
Qed.

Lemma neps_step_stable_l thread :
  neps_step thread ≡ ⦗ stable_state ⦘ ⨾ neps_step thread.
Proof.
  split; [|basic_solver].
  intros x y HH.
  apply seq_eqv_l. split; auto.
  red in HH. desf.
  apply ineps_step_stable_l in HH.
  apply seq_eqv_l in HH. desf.
Qed.

Lemma lbl_step_alt thread :
  lbl_step thread ≡ neps_step thread ⨾ (istep thread [])＊ ⨾ ⦗stable_state⦘.
Proof.
  split.
  { intros x y [l [e HH]].
    eexists. split; [eexists|]; apply HH. }
  intros x y [e [[l AA] HH]].
  eexists. eexists. split; eauto.
Qed.

Lemma steps_stable_lbl_steps thread :
  ⦗stable_state⦘ ⨾ (step thread)＊ ⨾ ⦗stable_state⦘ ⊆ (lbl_step thread)＊.
Proof.
  arewrite (step thread ⊆ neps_step thread ∪ istep thread []).
  { intros x y HH. red in HH. desf.
    destruct lbls; [by right|].
    left. eexists. red.
      by splits; eauto. }
  rewrite rt_unionE.
  rewrite seqA.
  arewrite (⦗stable_state⦘ ⨾ (istep thread [])＊ ⊆ ⦗stable_state⦘).
  { rewrite rtE. rewrite seq_union_r.
    apply inclusion_union_l; [basic_solver|].
    rewrite ct_begin.
    arewrite (⦗stable_state⦘ ⨾ istep thread [] ⊆ ∅₂).
    2: basic_solver.
    intros x y HH.
    apply seq_eqv_l in HH. apply HH.
    eexists. eexists. apply HH. }
  rewrite rt_dom_ri.
  2: { rewrite neps_step_stable_l at 1. by rewrite !seqA. }
  rewrite !seqA.
  rewrite <- lbl_step_alt.
  basic_solver.
Qed.

Lemma ilbl_step_alt thread lbls (state state'' : state)
      (ILBL_STEP : ilbl_step thread lbls state state'') :
  exists state',
    ⟪ NNIL     : lbls <> [] ⟫ /\
    ⟪ ISTEP    : istep thread lbls state state' ⟫ /\
    ⟪ EPS_STEP : (istep thread [])＊ state' state'' ⟫ /\
    ⟪ STABLE   : stable_state state'' ⟫.
Proof.
  edestruct ILBL_STEP.
  unfold seq in *.
  unfold ineps_step in *.
  unfold eqv_rel in *.
  desf. eexists. splits; eauto.
Qed.

Lemma same_pos_stable state state'
      (INSTR : state.(instrs) = state'.(instrs))
      (PC : state.(pc) = state'.(pc))
      (STABLE : stable_state state) :
    stable_state state'.
Proof.
  red. red. intros [state'' STEP].
  desf. cdes STEP. inv ISTEP0; eapply STABLE.
  eexists (Build_state _ _ _ _ _ _ _).
  2: eexists (Build_state _
                          (if Event.Const.eq_dec (RegFile.eval_expr (regf state) expr) 0
                           then pc state + 1
                           else shift) _ _ _ _ _).
  all: eexists; red; splits; [by eauto|].
  all: eexists; splits; [by rewrite PC, INSTR; eauto|].
  { eapply assign; eauto; simpls. }
  eapply if_; eauto; simpls.
  desf.
Unshelve. all: eauto.
Qed.

(*****************************************
** General properties of istep and step **
*****************************************)

Lemma step_same_instrs thread state state'
      (STEP : step thread state state') :
  state'.(instrs) = state.(instrs).
Proof. cdes STEP. inv STEP0. Qed.

Lemma steps_same_instrs thread state state'
      (STEP : (step thread)＊ state state') :
  state'.(instrs) = state.(instrs).
Proof.
  induction STEP; auto.
  { eapply step_same_instrs; eauto. }
  etransitivity; eauto.
Qed.

Lemma eps_step_same_G thread state state'
      (STEP : istep thread [] state state') :
  state'.(G) = state.(G).
Proof. cdes STEP. inv ISTEP0. Qed.

Lemma eps_steps_same_G thread state state'
      (STEP : (istep thread [])＊ state state') :
  state'.(G) = state.(G).
Proof.
  induction STEP; auto.
  { eapply eps_step_same_G; eauto. }
  etransitivity; eauto.
Qed.

Lemma eps_step_in_step thread : istep thread [] ⊆ step thread.
Proof. unfold step. basic_solver. Qed.

Lemma eps_steps_in_steps thread : (istep thread [])＊ ⊆ (step thread)＊.
Proof. by rewrite eps_step_in_step. Qed.

Lemma no_step_from_terminal thread : ⦗ is_terminal ⦘ ⨾ (step thread) ≡ ∅₂.
Proof.
  split; [|basic_solver].
  unfolder. intros x y [TERM STEP]. red in TERM.
  assert (nth_error (instrs x) (pc x) <> None) as NN.
  { cdes STEP. cdes STEP0. by inv ISTEP0; rewrite <- ISTEP. }
  apply nth_error_Some in NN. lia.
Qed.

Lemma no_lbl_step_from_terminal thread : ⦗ is_terminal ⦘ ⨾ (lbl_step thread) ≡ ∅₂.
Proof.
  split; [|basic_solver].
  rewrite lbl_step_in_steps. rewrite ct_begin, <- seqA.
  rewrite no_step_from_terminal. basic_solver.
Qed.

Lemma stable_state_no_eps_step thread : ⦗stable_state⦘ ⨾ (istep thread []) ≡ ∅₂.
Proof.
  split; [|basic_solver].
  unfolder. intros x y [ST STEP].
  apply ST. do 2 eexists. eauto.
Qed.

Lemma stable_state_eps_steps_refl thread :
  ⦗stable_state⦘ ⨾ (istep thread [])＊ ≡ ⦗stable_state⦘.
Proof.
  rewrite rtE, ct_begin, seq_union_r, seq_id_r.
  rewrite <- seqA. rewrite stable_state_no_eps_step.
  basic_solver.
Qed.

Lemma unique_eps_steps_to_stable thread st st' st''
      (STEP1 : ((istep thread [])＊ ⨾ ⦗stable_state⦘) st st')
      (STEP2 : ((istep thread [])＊ ⨾ ⦗stable_state⦘) st st'') :
  st'' = st'.
Proof.
  destruct_seq_r STEP1 as ST1.
  destruct_seq_r STEP2 as ST2.
  apply clos_rt_rt1n in STEP1.
  induction STEP1.
  { symmetry. eapply stable_state_eps_steps_refl.
    apply seq_eqv_l. split; eauto. }
  apply IHSTEP1.
  specialize (IHSTEP1 ST1); auto.
  apply clos_rt_rt1n in STEP2.
  destruct STEP2 as [|w].
  { exfalso.
    apply ST2. do 2 eexists. eauto. }
  assert (w = y); subst.
  2: by apply clos_rt1n_rt.
  eapply unique_eps_step; eauto.
Qed.

Lemma unique_ilbl_step thread lbl state state' state''
      (STEP1 : ilbl_step thread lbl state state')
      (STEP2 : ilbl_step thread lbl state state'') :
  state' = state''.
Proof.
  cdes STEP1.
  cdes STEP2.
  destruct STEP0 as [st0 [ST01 ST02]].
  destruct STEP3 as [st1 [ST11 ST12]].
  assert (st0 = st1); subst.
  { cdes ST01. cdes ST11. eapply unique_ineps_step; eauto. }
  eapply unique_eps_steps_to_stable; eauto.
Qed.

Lemma app_eq {A B} (f f' : A -> B) (EQ : f = f') (a : A) :
  f a = f' a.
Proof. by rewrite EQ. Qed.

Lemma unique_lbl_istep_same_G thread lbl lbl' state state' state''
      (STEP1 : istep thread lbl  state state')
      (STEP2 : istep thread lbl' state state'')
      (GEQ   : ProgToExecution.G state' = ProgToExecution.G state'') :
  lbl = lbl'.
Proof.
  cdes STEP1. cdes STEP2.
  inv ISTEP0.
  all: inv ISTEP2; rewrite <- ISTEP in ISTEP1; inv ISTEP1.
  3,4: by exfalso;
    unfold add, add_rmw in *;
    rewrite <- GEQ in UG0; rewrite UG in UG0; inv UG0;
      clear -H1; induction (acts (G state)); inv H1.
  all: assert (val = val0); desf;
    rewrite <- GEQ in UG0; rewrite UG in UG0; inv UG0;
    pose proof (app_eq _ _ H0 (ThreadEvent thread (eindex state))) as AA.
  1,2: by rewrite !upds in *; inv AA.
  rewrite updo in *; [rewrite upds in *|].
  2: { intros BB. inv BB. lia. }
  rewrite updo in *; [rewrite upds in *|].
  2: { intros BB. inv BB. lia. }
  inv AA.
Qed.

Lemma unique_lbl_istep thread lbl lbl' state state'
      (STEP1 : istep thread lbl  state state')
      (STEP2 : istep thread lbl' state state') :
  lbl = lbl'.
Proof. eapply unique_lbl_istep_same_G; eauto. Qed.

Lemma unique_lbl_ilbl_step thread lbl lbl' state state'
      (STEP1 : ilbl_step thread lbl  state state')
      (STEP2 : ilbl_step thread lbl' state state') :
  lbl = lbl'.
Proof.
  cdes STEP1.
  cdes STEP2.
  destruct STEP0 as [st0 [ST01 ST02]]. cdes ST01.
  destruct STEP3 as [st1 [ST11 ST12]]. cdes ST11.
  destruct_seq_r ST02 as STBL.
  destruct_seq_r ST12 as STBL'.
  eapply unique_lbl_istep_same_G; eauto.
  erewrite <- eps_steps_same_G with (state':=state'); eauto.
  eapply eps_steps_same_G; eauto.
Qed.

Lemma wf_thread_state_ilbl_step thread lbls state state'
      (WTS  : wf_thread_state thread state)
      (STEP : ilbl_step thread lbls state state') :
  wf_thread_state thread state'.
Proof.
  eapply wf_thread_state_steps; eauto.
  apply rtE. right. eapply ilbl_step_in_steps; eauto.
Qed.

Lemma wf_thread_state_lbl_step thread state state'
      (WTS  : wf_thread_state thread state)
      (STEP : lbl_step thread state state') :
  wf_thread_state thread state'.
Proof. cdes STEP. eapply wf_thread_state_ilbl_step; eauto. Qed.

Lemma wf_thread_state_lbl_steps thread state state'
      (WTS  : wf_thread_state thread state)
      (STEPS : (lbl_step thread)＊ state state') :
  wf_thread_state thread state'.
Proof.
  apply clos_rt_rt1n in STEPS.
  induction STEPS; auto.
  apply IHSTEPS. eapply wf_thread_state_lbl_step; eauto.
Qed.

(****************************
** Destruction of lbl_step **
*****************************)

Lemma ilbl_step_cases thread lbls state state'
      (WFT : wf_thread_state thread state)
      (ILBL_STEP : ilbl_step thread lbls state state') :
  exists lbl lbl',
    ⟪ LBLS : lbls = opt_to_list lbl' ++ [lbl] ⟫ /\
    ( ( ⟪ EINDEX : state'.(eindex) = 1 + state.(eindex) ⟫ /\
        ⟪ ACTS : acts_set state'.(G) ≡₁
                 acts_set state.(G) ∪₁ eq (ThreadEvent thread state.(eindex)) ⟫ /\
        ⟪ GLAB : lab state'.(G) = upd (lab state.(G)) (ThreadEvent thread state.(eindex)) lbl ⟫ /\
        ⟪ LBL'none : lbl' = None ⟫ /\
        ( (exists ord loc val, ⟪ LBL_LD : lbl = Aload false ord loc val ⟫) \/
          (exists ord loc val, ⟪ LBL_LD_EX : lbl = Aload true ord loc val ⟫) \/
          (exists ord loc val, ⟪ LBL_ST : lbl = Astore Xpln ord loc val ⟫) \/
          (exists ord, ⟪ LBL_F : lbl = Afence ord ⟫) ) /\
        ⟪ GRMW : rmw state'.(G) = rmw state.(G) ⟫ ) \/
      ( ⟪ EINDEX : state'.(eindex) = 2 + state.(eindex) ⟫ /\
        ⟪ ACTS : acts_set state'.(G) ≡₁
                 acts_set state.(G) ∪₁
                 eq (ThreadEvent thread state.(eindex)) ∪₁ eq (ThreadEvent thread (1 + state.(eindex))) ⟫ /\
        ⟪ GLAB : lab state'.(G) =
                 upd_opt (upd (lab state.(G)) (ThreadEvent thread state.(eindex)) lbl)
                              (Some (ThreadEvent thread (1 + state.(eindex)))) lbl' ⟫ /\
        (exists xmod ordr ordw loc valr valw,
          ⟪ LBL_LD_EX : lbl = Aload true ordr loc valr ⟫ /\
          ⟪ LBL_ST_EX : lbl' = Some (Astore xmod ordw loc valw) ⟫ ) /\
        ⟪ GRMW : rmw state'.(G) ≡ rmw state.(G) ∪
                 eq (ThreadEvent thread state.(eindex)) × eq (ThreadEvent thread (1 + state.(eindex))) ⟫ )).
Proof.
  eapply ilbl_step_alt in ILBL_STEP; desf.
  cdes ISTEP.
  edestruct ISTEP0; desf; do 2 eexists.

  Ltac nupd_helper UINDEX UG :=
    split;
      [ erewrite opt_to_list_none; by apply app_nil_l
      | left; splits; eauto 20;
        [ symmetry; etransitivity;
          [ erewrite Nat.add_comm; by erewrite <- UINDEX
          | symmetry; eapply steps_same_eindex; eauto;
            eapply wf_thread_state_step; eauto;
            econstructor; eauto ]
        | erewrite eps_steps_same_G; eauto;
          unfold add in UG; rewrite UG;
          unfold acts_set; simpl; basic_solver
        | erewrite eps_steps_same_G; eauto;
          unfold add in UG; rewrite UG;
          unfold acts_set; simpl; basic_solver
        | erewrite eps_steps_same_G; [|eauto];
          unfold add in UG; by rewrite UG
        ]
      ].

  1-4: nupd_helper UINDEX UG.

  Ltac upd_helper UINDEX UG :=
    split;
      [ erewrite opt_to_list_some; unfold "++"; eauto
      | right; splits; eauto 20;
        [ symmetry; etransitivity;
          [ erewrite Nat.add_comm; by erewrite <- UINDEX
          | symmetry; eapply steps_same_eindex; eauto;
            eapply wf_thread_state_step; eauto;
            econstructor; eauto ]
        | erewrite eps_steps_same_G; eauto;
          unfold add in UG; unfold add_rmw in UG; rewrite UG;
          unfold acts_set, upd_opt; simpl;
          rewrite Nat.add_1_r; basic_solver
        | erewrite eps_steps_same_G; eauto;
          unfold add in UG; unfold add_rmw in UG; rewrite UG;
          unfold acts_set, upd_opt; simpl;
          rewrite Nat.add_1_r; basic_solver
        | erewrite eps_steps_same_G; [|eauto];
          unfold add_rmw in UG; rewrite UG; simpl;
          rewrite Nat.add_comm; basic_solver
        ]
      ].

  all: upd_helper UINDEX UG.

Qed.

Lemma ilbl_step_lbls thread lbls state state'
      (WFT : wf_thread_state thread state)
      (ILBL_STEP : ilbl_step thread lbls state state') :
  exists lbl lbl', lbls = opt_to_list lbl' ++ [lbl].
Proof. edestruct ilbl_step_cases; desf; eauto. Qed.

Lemma ilbl_step_acts_set thread lbl lbl' state state'
      (WFT : wf_thread_state thread state)
      (ILBL_STEP : ilbl_step thread (opt_to_list lbl' ++ [lbl]) state state') :
  exists e e',
    ⟪ REPe  : e = ThreadEvent thread state.(eindex) ⟫ /\
    ⟪ REPe' : match lbl' with
              | None   => e' = None
              | Some _ => e' = Some (ThreadEvent thread (1 + state.(eindex)))
              end ⟫ /\
    ⟪ ACTS : acts_set state'.(G) ≡₁ acts_set state.(G) ∪₁ eq e ∪₁ eq_opt e'⟫.
Proof.
  unfold eq_opt.
  edestruct ilbl_step_cases as [l [l' [LBLS HH]]]; eauto.
  apply opt_to_list_app_singl in LBLS. desc. subst l l'.
  destruct HH as [HA | HB].
  { destruct HA as [_ [ACTS [_ [LBL' _]]]].
    red in ACTS, LBL'. subst lbl'.
    do 2 eexists; splits; eauto.
    generalize ACTS. basic_solver. }
  destruct HB as [_ [ACTS [_ [LBL' _]]]].
  desc. subst lbl'.
  do 2 eexists; splits; eauto.
Qed.

Lemma ilbl_step_acts_set_mon thread lbl lbl' state state'
      (WFT : wf_thread_state thread state)
      (ILBL_STEP : ilbl_step thread (opt_to_list lbl' ++ [lbl]) state state') :
  acts_set state.(G) ⊆₁ acts_set state'.(G).
Proof.
  edestruct ilbl_step_acts_set; eauto.
  desc. rewrite ACTS. basic_solver.
Qed.

Lemma ineps_step_eindex_shift thread lbl st st'
      (STEP : ineps_step thread lbl st st') :
  eindex st' = eindex st + length lbl.
Proof.
  cdes STEP. erewrite istep_eindex_shift with (st':=st'); eauto.
Qed.

Lemma eps_step_eindex_same thread st st'
      (STEP : istep thread [] st st') :
  eindex st' = eindex st.
Proof. erewrite istep_eindex_shift; eauto. simpls. lia. Qed.

Lemma eps_steps_eindex_same thread st st'
      (STEP : (istep thread [])＊ st st') :
  eindex st' = eindex st.
Proof.
  induction STEP; auto.
  2: by intuition.
  erewrite eps_step_eindex_same; eauto.
Qed.

Lemma ilbl_step_eindex_shift thread lbl st st'
      (STEP : ilbl_step thread lbl st st') :
  eindex st' = eindex st + length lbl.
Proof.
  cdes STEP.
  destruct STEP0 as [st'' [ST ST']].
  destruct_seq_r ST' as BB.
  arewrite (eindex st' = eindex st'').
  { eapply eps_steps_eindex_same. eauto. }
  eapply ineps_step_eindex_shift; eauto.
Qed.

Lemma ineps_step_eindex_lt thread st st' lbl
      (STEP : ineps_step thread lbl st st') :
  eindex st < eindex st'.
Proof.
  erewrite ineps_step_eindex_shift with (st':=st'); eauto.
  cdes STEP. destruct lbl; simpls. lia.
Qed.

Lemma ilbl_step_eindex_lt thread st st' lbl
      (STEP : ilbl_step thread lbl st st') :
  eindex st < eindex st'.
Proof.
  erewrite ilbl_step_eindex_shift with (st':=st'); eauto.
  apply ilbl_step_alt in STEP. desf.
  destruct lbl; simpls. lia.
Qed.

Lemma lbl_step_eindex_lt thread st st'
      (STEP : lbl_step thread st st') :
  eindex st < eindex st'.
Proof.
  cdes STEP.
  eapply ilbl_step_eindex_lt; eauto.
Qed.

Lemma istep_eindex_lbl thread lbl lbl' st st'
      (WTS : wf_thread_state thread st)
      (STEP: istep thread (opt_to_list lbl' ++ [lbl]) st st') :
  lbl = lab (ProgToExecution.G st') (ThreadEvent thread (eindex st)).
Proof.
  cdes STEP. inv ISTEP0.
  1-2: by destruct lbl'; simpls.

  1-4: apply app_eq_unit in LABELS; desf.
  1-4: by rewrite UG; unfold add in *; simpls; rewrite upds.

  all: apply app_eq_unit2 in LABELS; desf.
  all: rewrite UG; unfold add_rmw in *; simpls.
  all: rewrite updo; [|intros BB; inv BB; lia].
  all: by rewrite upds.
Qed.

Lemma istep_eindex_lbl' thread lbl lbl' st st'
      (WTS : wf_thread_state thread st)
      (STEP: istep thread (opt_to_list (Some lbl') ++ [lbl]) st st') :
  lbl' = lab (ProgToExecution.G st') (ThreadEvent thread (1 + eindex st)).
Proof.
  assert (eindex st + 1 = 1 + eindex st)
    as HH by lia.
  cdes STEP; inv ISTEP0;
    apply opt_to_list_app_singl_pair in LABELS; desf;
    rewrite UG; unfold add_rmw in *; simpls;
    by rewrite HH, upds.
Qed.

Lemma ilbl_step_eindex_lbl thread lbl lbl' st st'
      (WTS : wf_thread_state thread st)
      (STEP: ilbl_step thread (opt_to_list lbl' ++ [lbl]) st st') :
  lbl = lab (ProgToExecution.G st') (ThreadEvent thread (eindex st)).
Proof.
  edestruct ilbl_step_cases with (state0:=st) (state':=st')
    as [l [l']]; eauto. desf.
  all: rewrite GLAB.
  1-4: by rewrite upds; apply app_inj_tail in LBLS; desf.
  unfold upd_opt. rewrite updo.
  2: intros BB; inv BB; lia.
  apply app_inj_tail in LBLS; desf. by rewrite upds.
Qed.

Lemma ilbl_step_eindex_lbl' thread lbl lbl' st st'
      (WTS : wf_thread_state thread st)
      (STEP: ilbl_step thread (opt_to_list (Some lbl') ++ [lbl]) st st') :
  lbl' = lab (ProgToExecution.G st') (ThreadEvent thread (1 + eindex st)).
Proof.
  edestruct ilbl_step_cases with (state0:=st) (state':=st')
    as [l [l']]; eauto. desf.
  all: rewrite GLAB.
  by rewrite upd_opt_some, upds.
Qed.

Lemma ilbl_step_nrmw_None thread lbl lbl' st st'
      (WTS : wf_thread_state thread st)
      (STEP : ilbl_step
                thread
                (opt_to_list lbl' ++ [lbl]) st st')
      (NRMW : ~ rmw (ProgToExecution.G st') (ThreadEvent thread (eindex st))
                (ThreadEvent thread (1 + eindex st))) :
  lbl' = None.
Proof.
  edestruct ilbl_step_cases with (state0:=st) (state':=st')
    as [l [l']]; eauto. desf.
  1-4: by apply app_eq_unit in LBLS; desf; destruct lbl'; simpls; inv LBLS.
  exfalso. apply NRMW. apply GRMW. basic_solver.
Qed.

Lemma same_label_u2v_istep thread la la' lb lb' state state' state''
      (STEP1 : istep thread (opt_to_list la' ++ [la]) state state')
      (STEP2 : istep thread (opt_to_list lb' ++ [lb]) state state'') :
  same_label_u2v la lb.
Proof.
  destruct STEP1 as [EQis1 [instr1 [EQi1 STEP1_]]].
  destruct STEP2 as [EQis2 [instr2 [EQi2 STEP2_]]].
  red in EQis1, EQis2.
  assert (instr1 = instr2) as EQii.
  { congruence. }
  inversion STEP1_;
    try (by exfalso; eapply app_cons_not_nil; eauto).
  all: inversion STEP2_;
    try (by exfalso; eapply app_cons_not_nil; eauto).
  all : rewrite EQii, II0 in II; inversion II; subst.
  all:
    try apply opt_to_list_app_singl_singl
      in LABELS;
    try apply opt_to_list_app_singl_pair
      in LABELS;
    try apply opt_to_list_app_singl_singl
      in LABELS0;
    try apply opt_to_list_app_singl_pair
      in LABELS0;
    desc; rewrite LABELS, LABELS0; by red.
Qed.

Lemma same_label_u2v_ilbl_step thread la la' lb lb' state state' state''
      (STEP1 : ilbl_step thread (opt_to_list la' ++ [la]) state state')
      (STEP2 : ilbl_step thread (opt_to_list lb' ++ [lb]) state state'') :
  same_label_u2v la lb.
Proof.
  unfold ilbl_step, ineps_step in *.
  destruct STEP1 as [s1 [[_ ISTEP1] _]].
  destruct STEP2 as [s2 [[_ ISTEP2] _]].
  eapply same_label_u2v_istep; eauto.
Qed.

Lemma same_label_fst_istep thread l la' lb' state state' state''
      (STEP1 : istep thread (opt_to_list la' ++ [l]) state state')
      (STEP2 : istep thread (opt_to_list lb' ++ [l]) state state'') :
  la' = lb'.
Proof.
  destruct STEP1 as [EQis1 [instr1 [EQi1 STEP1_]]].
  destruct STEP2 as [EQis2 [instr2 [EQi2 STEP2_]]].
  red in EQis1, EQis2.
  assert (instr1 = instr2) as EQii.
  { congruence. }
  inversion STEP1_;
    try (by exfalso; eapply app_cons_not_nil; eauto).
  all: inversion STEP2_;
    try (by exfalso; eapply app_cons_not_nil; eauto).
  all : rewrite EQii, II0 in II; inversion II; subst.
  all:
    try apply opt_to_list_app_singl_singl
      in LABELS;
    try apply opt_to_list_app_singl_pair
      in LABELS;
    try apply opt_to_list_app_singl_singl
      in LABELS0;
    try apply opt_to_list_app_singl_pair
      in LABELS0;
    desc; congruence.
Qed.

Lemma same_label_fst_ilbl_step thread l la' lb' state state' state''
      (STEP1 : ilbl_step thread (opt_to_list la' ++ [l]) state state')
      (STEP2 : ilbl_step thread (opt_to_list lb' ++ [l]) state state'') :
  la' = lb'.
Proof.
  unfold ilbl_step, ineps_step in *.
  destruct STEP1 as [s1 [[_ ISTEP1] _]].
  destruct STEP2 as [s2 [[_ ISTEP2] _]].
  eapply same_label_fst_istep; eauto.
Qed.

Lemma nR_istep thread la la' lb lb' state state' state''
      (STEP1 : istep thread (opt_to_list la' ++ [la]) state state')
      (STEP2 : istep thread (opt_to_list lb' ++ [lb]) state state'')
      (nR : ~ is_r id la) :
  ⟪ EQLab    : la = lb ⟫ /\
  ⟪ LabNone  : la' = None ⟫ /\
  ⟪ LabNone' : lb' = None ⟫.
Proof.
  destruct STEP1 as [EQis1 [instr1 [EQi1 STEP1_]]].
  destruct STEP2 as [EQis2 [instr2 [EQi2 STEP2_]]].
  red in EQis1, EQis2.
  assert (instr1 = instr2) as EQii.
  { congruence. }
  unfold is_r, id in nR.
  inversion STEP1_;
    try (by exfalso; eapply app_cons_not_nil; eauto).
  all:
    try apply opt_to_list_app_singl_singl
      in LABELS;
    try apply opt_to_list_app_singl_pair
      in LABELS;
    desc.
  all: try by (
    exfalso; apply nR; by rewrite LABELS
  ).
  all: inversion STEP2_;
    try (by exfalso; eapply app_cons_not_nil; eauto).
  all: rewrite EQii, II0 in II; inversion II; subst.
  all: apply opt_to_list_app_singl_singl in LABELS1.
  all: desc; splits; congruence.
Qed.

Lemma nR_ilbl_step thread la la' lb lb' state state' state''
      (STEP1 : ilbl_step thread (opt_to_list la' ++ [la]) state state')
      (STEP2 : ilbl_step thread (opt_to_list lb' ++ [lb]) state state'')
      (nR : ~ is_r id la) :
  ⟪ EQLab    : la = lb ⟫ /\
  ⟪ LabNone  : la' = None ⟫ /\
  ⟪ LabNone' : lb' = None ⟫.
Proof.
  unfold ilbl_step, ineps_step in *.
  destruct STEP1 as [s1 [[_ ISTEP1] _]].
  destruct STEP2 as [s2 [[_ ISTEP2] _]].
  eapply nR_istep; eauto.
Qed.

Lemma same_label_nR_istep thread la la' lb lb' state state' state''
      (STEP1 : istep thread (opt_to_list la' ++ [la]) state state')
      (STEP2 : istep thread (opt_to_list lb' ++ [lb]) state state'')
      (nR : ~ is_r id la) :
  la = lb.
Proof. eapply nR_istep; eauto. Qed.

Lemma same_label_nR_ilbl_step thread la la' lb lb' state state' state''
      (STEP1 : ilbl_step thread (opt_to_list la' ++ [la]) state state')
      (STEP2 : ilbl_step thread (opt_to_list lb' ++ [lb]) state state'')
      (nR : ~ is_r id la) :
  la = lb.
Proof. eapply nR_ilbl_step; eauto. Qed.

Lemma unique_same_label_fst_ilbl_step thread la la' lb lb' state state' state''
      (EQ : la = lb)
      (STEP1 : ilbl_step thread (opt_to_list la' ++ [la]) state state' )
      (STEP2 : ilbl_step thread (opt_to_list lb' ++ [lb]) state state'') :
  state' = state''.
Proof.
  rewrite EQ in *.
  eapply unique_ilbl_step; eauto.
  erewrite same_label_fst_ilbl_step
    with (la' := la'); eauto.
Qed.

Lemma unique_nR_ilbl_step thread la la' lb lb' state state' state''
      (STEP1 : ilbl_step thread (opt_to_list la' ++ [la]) state state')
      (STEP2 : ilbl_step thread (opt_to_list lb' ++ [lb]) state state'')
      (nR : ~ is_r id la) :
  state' = state''.
Proof.
  eapply unique_ilbl_step; eauto.
  edestruct nR_ilbl_step
    with (la := la) as [HA [HB HC]]; eauto.
  red in HA, HB, HC. by subst.
Qed.


(* Scheme Equality not robust wrt names *)

Module A1.
  Inductive A (T : Type) := C (a : T).
  Scheme Equality for A. (* success *)
End A1.

Module A2.
  Inductive A (x : Type) := C (a : x).
  Scheme Equality for A.
End A2.


(** * Classification of path spaces of precategories *)
Require Import Category.Core.
Require Import HoTT.Basics.Equivalences HoTT.Basics.PathGroupoids HoTT.Basics.Trunc.
Require Import HoTT.Types.Sigma HoTT.Types.Arrow HoTT.Types.Forall HoTT.Types.Paths.
Require Import HoTT.HProp HoTT.Tactics.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope morphism_scope.
Local Open Scope category_scope.

Section path_category.
  Local Open Scope path_scope.

  (** We add a prime ([']) as an arbitrary convention to denote that
      we are talking about equality of functions (less convenient for
      use) rather than pointwise equality of functions (more
      convenient for use, but more annoying for proofs).  We add two
      primes to denote the even less convenient version, which
      requires an identity equality proof. *)
  Local Notation path_precategory''_T C D
    := { Hobj : object C = object D
       | { Hmor : transport (fun obj => obj -> obj -> Type)
                            Hobj
                            (morphism C)
                  = morphism D
         | transport _
                     Hmor
                     (transportD (fun obj => obj -> obj -> Type)
                                 (fun obj mor => forall s d d', mor d d' -> mor s d -> mor s d')
                                 Hobj
                                 (morphism C)
                                 (@compose C))
           = @compose D
           /\ transport _
                        Hmor
                        (transportD (fun obj => obj -> obj -> Type)
                                    (fun obj mor => forall x, mor x x)
                                    Hobj
                                    (morphism C)
                                    (@identity C))
              = @identity D }}.

  Local Notation path_precategory'_T C D
    := { Hobj : object C = object D
       | { Hmor : transport (fun obj => obj -> obj -> Type)
                            Hobj
                            (morphism C)
                  = morphism D
         | transport _
                     Hmor
                     (transportD (fun obj => obj -> obj -> Type)
                                 (fun obj mor => forall s d d', mor d d' -> mor s d -> mor s d')
                                 Hobj
                                 (morphism C)
                                 (@compose C))
           = @compose D }}.

  (** ** Classify sufficient conditions to prove precategories equal *)
  Lemma path_precategory_uncurried__identity_helper `{Funext} (C D : PreCategory)
        (Heq : path_precategory'_T C D)
  : transport _
              Heq.2.1
              (transportD (fun obj => obj -> obj -> Type)
                          (fun obj mor => forall x, mor x x)
                          Heq.1
                          (morphism C)
                          (@identity C))
    = @identity D.
  Proof.
    destruct Heq as [? [? ?]]; cbn in *.
    repeat (intro || apply path_forall).
    apply identity_unique; cbn in *; auto with morphism.
    destruct C, D; cbn in *.
    path_induction; cbn in *.
    auto.
  Qed.

  Definition path_precategory''_T__of__path_precategory'_T `{Funext} C D
  : path_precategory'_T C D -> path_precategory''_T C D
    := fun H => (H.1; (H.2.1; (H.2.2, path_precategory_uncurried__identity_helper C D H))).

  Lemma eta2_sigma_helper A B P Q `{forall a b, IsHProp (Q a b)}
        (x : { a : A & { b : B a & P a b /\ Q a b }})
        q'
  : (x.1; (x.2.1; (fst x.2.2, q'))) = x.
  Proof.
    destruct x as [? [? [? ?]]]; cbn in *.
    repeat f_ap; apply path_ishprop.
  Defined.

  Global Instance isequiv__path_precategory''_T__of__path_precategory'_T `{fs : Funext} C D
  : IsEquiv (@path_precategory''_T__of__path_precategory'_T fs C D)
    := isequiv_adjointify
         (@path_precategory''_T__of__path_precategory'_T fs C D)
         (fun H => (H.1; (H.2.1; fst H.2.2)))
         (fun x => eta2_sigma_helper _ _ _ x _)
         eta2_sigma.

  Definition path_precategory_uncurried' `{fs : Funext} (C D : PreCategory)
  : path_precategory''_T C D -> C = D.
  Proof.
    intros [? [? [? ?]]].
    destruct C, D; cbn in *.
    path_induction; cbn in *.
    f_ap;
      eapply @center; abstract exact _.
  Defined.

  (** *** Said proof respects [object] *)
  Lemma path_precategory_uncurried'_fst `{Funext} C D HO HM HC HI
  : ap object (@path_precategory_uncurried' _ C D (HO; (HM; (HC, HI)))) = HO.
  Proof.
    destruct C, D; cbn in *.
    path_induction_hammer.
  Qed.

  (** *** Said proof respects [idpath] *)
  Lemma path_precategory_uncurried'_idpath `{Funext} C
  : @path_precategory_uncurried' _ C C (idpath; (idpath; (idpath, idpath))) = idpath.
  Proof.
    destruct C; cbn in *.
    rewrite !(contr idpath).
    reflexivity.
  Qed.

  (** ** Equality of precategorys gives rise to an inhabitant of the path-classifying-type *)
  Definition path_precategory_uncurried'_inv (C D : PreCategory)
  : C = D -> path_precategory''_T C D.
  Proof.
    intro H'.
    exists (ap object H').
    exists ((transport_compose _ object _ _) ^ @ apD (@morphism) H').
    split.
    - refine (_ @ apD (@compose) H'); cbn.
      refine (transport_pp _ _ _ _ @ _).
      refine ((ap _ (transportD_compose
                       (fun obj => obj -> obj -> Type)
                       (fun obj mor =>
                          forall s d d' : obj, mor d d' -> mor s d -> mor s d') object H'
                       (morphism C) (@compose C))^)
                @ (transport_apD_transportD
                     _
                     morphism
                     (fun x mor => forall s d d' : x, mor d d' -> mor s d -> mor s d') H'
                     (@compose C))).
    - refine (_ @ apD (@identity) H'); cbn.
      refine (transport_pp _ _ _ _ @ _).
      refine ((ap _ (transportD_compose
                       (fun obj => obj -> obj -> Type)
                       (fun obj mor =>
                          forall x : obj, mor x x) object H'
                       (morphism C) (@identity C))^)
                @ (transport_apD_transportD
                     _
                     morphism
                     (fun x mor => forall s : x, mor s s) H'
                     (@identity C))).
  Defined.

  (** ** Classify equality of precategorys up to equivalence *)
  Lemma equiv_path_precategory_uncurried'__eissect `{Funext} (C D : PreCategory)
  : forall x : path_precategory''_T C D,
      path_precategory_uncurried'_inv (path_precategory_uncurried' C D x) = x.
  Proof.
    destruct C, D; cbn in *.
    intros [H0' [H1' [H2' H3']]].
    path_induction.
    cbn.
    repeat (edestruct (center (_ = _)); try reflexivity).
  Qed.

  Lemma equiv_path_precategory_uncurried' `{Funext} (C D : PreCategory)
  : path_precategory''_T C D <~> C = D.
  Proof.
    apply (equiv_adjointify (@path_precategory_uncurried' _ C D)
                            (@path_precategory_uncurried'_inv C D)).
    - hnf.
      intros [].
      apply path_precategory_uncurried'_idpath.
    - hnf.
      apply equiv_path_precategory_uncurried'__eissect.
  Defined.

  Definition equiv_path_precategory_uncurried `{Funext} (C D : PreCategory)
  : path_precategory'_T C D <~> C = D
    := ((equiv_path_precategory_uncurried' C D)
          oE (Build_Equiv
                _ _ _
                (isequiv__path_precategory''_T__of__path_precategory'_T C D))).

  Definition path_precategory_uncurried `{Funext} C D : _ -> _
    := equiv_path_precategory_uncurried C D.

  (** ** Curried version of path classifying lemma *)
  Lemma path_precategory' `{fs : Funext} (C D : PreCategory)
  : forall (Hobj : object C = object D)
           (Hmor : transport (fun obj => obj -> obj -> Type)
                             Hobj
                             (morphism C)
                   = morphism D),
      transport _
                Hmor
                (transportD (fun obj => obj -> obj -> Type)
                            (fun obj mor => forall s d d', mor d d' -> mor s d -> mor s d')
                            Hobj
                            (morphism C)
                            (@compose C))
      = @compose D
      -> C = D.
  Proof.
    intros.
    apply path_precategory_uncurried.
    repeat esplit; eassumption.
  Defined.

  (** ** Curried version of path classifying lemma, using [forall] in place of equality of functions *)
  Lemma path_precategory `{fs : Funext} (C D : PreCategory)
  : forall (Hobj : object C = object D)
           (Hmor : forall s d,
                     morphism C (transport idmap Hobj^ s) (transport idmap Hobj^ d)
                     = morphism D s d),
      (forall s d d' m m',
         transport idmap (Hmor _ _)
                   (@compose C _ _ _
                             (transport idmap (Hmor _ _)^ m)
                             (transport idmap (Hmor _ _)^ m'))
         = @compose D s d d' m m')
      -> C = D.
  Proof.
    intros Hobj Hmor Hcomp.
    pose (path_forall
            _ _
            (fun s =>
               path_forall
                 _ _
                 (fun d =>
                    (ap10 (@transport_arrow Type idmap (fun x => x -> Type) _ _ Hobj (@morphism C) _) _)
                      @ (@transport_arrow Type idmap _ _ _ Hobj (@morphism C _) _)
                      @ (transport_const _ _)
                      @ Hmor s d)))
      as Hmor'.
    eapply (path_precategory' C D Hobj Hmor').
    repeat (apply path_forall; intro).
    refine (_ @ Hcomp _ _ _ _ _); clear Hcomp.
    subst Hmor'.
    cbn.
    abstract (
        destruct C, D;
        cbn in *;
          destruct Hobj;
        cbn in *;
          repeat match goal with
                   | _ => reflexivity
                   | _ => rewrite !concat_1p
                   | _ => rewrite !transport_forall_constant, !transport_arrow
                   | _ => progress transport_path_forall_hammer
                   | [ |- transport ?P ?p^ ?u = ?v ]
                     => (apply (@moveR_transport_V _ P _ _ p u v); progress transport_path_forall_hammer)
                   | [ |- ?u = transport ?P ?p^ ?v ]
                     => (apply (@moveL_transport_V _ P _ _ p u v); progress transport_path_forall_hammer)
                   | [ |- context[?H ?x ?y] ]
                     => (destruct (H x y); clear H)
                   | _ => progress f_ap
                 end
      ).
  Defined.
End path_category.

(** ** Tactic for proving equality of precategories *)
(** We move the funext inference outside the loop. *)
Ltac path_category :=
  idtac;
  let lem := constr:(@path_precategory _) in
  repeat match goal with
           | _ => intro
           | _ => reflexivity
           | _ => simple refine (lem _ _ _ _ _); cbn
         end.


Require Export LUB_spec.

Module mBridges2(N:Num_w).

Import N.
Module Export HH := lub_spec(N).

Axiom A0_dec : forall x, {x < 0}+{x==0}+{0 < x}.
(** holds for axiomatic non-standard integers but not prouvable in Laugwitz-Schmieden : counter-example : (-1)^n *)

Axiom not_le_lt : forall x y, ~x <= y -> y < x.
(** holds for axiomatic non-standard integers not prouvable in Laugwitz_schmiden : counter-example : b_n = a_n + (-1)^n *)

Lemma R2_2 : forall x y,  x [>] y -> forall z, x [>] z \/ z [>] y.
Proof.
intros x; case x; clear x.
intros xx Hxx.
intros y; case y; clear y.
intros yy Hyy.
intros H; unfold HRwgt in H.
intros z; case z; clear z.
intros zz Hzz.
simpl.
elim H.
intros n (Hlim,(Hlt,Hn)).
setoid_replace (xx+ -yy) with (xx + -yy +zz + - zz) in Hn by ring.
setoid_replace (n * (xx + - yy + zz + - zz)) with (n*(xx+ -zz) + n*(zz+ -yy)) in Hn by ring.

simpl.
elim (A0_dec ((xx + (- zz)) + - (zz + (- yy)))). (* occurs in R2_2 *)
intros a; elim a; clear a.
(* negative *)
intros.
right.
exists (n+n).
split.
apply ANS2a; assumption.
split.
setoid_replace 0 with (0+0) by ring; apply lt_plus; assumption.
apply le_trans with (y:= (n * (xx + - zz) + n * (zz + - yy))).
assumption.
setoid_replace ((n + n) * (zz + - yy)) with (n*(zz+ -yy) + n*(zz + - yy)) by ring.
apply le_plus.
rewrite (mult_comm  n (xx + -zz)).
rewrite (mult_comm  n (zz + -yy)).
apply le_mult_simpl.
apply lt_le; assumption.
apply le_plus_inv with (z:= - (zz + - yy)).
setoid_replace (zz + - yy + - (zz + - yy)) with 0 by ring.
apply lt_le.
assumption.
apply le_refl.

(* zero *)
intros.
left.
exists (n+n).
split.
apply ANS2a; assumption.
split.
setoid_replace 0 with (0+0) by ring; apply lt_plus; assumption.
apply le_trans with (y:= (n * (xx + - zz) + n * (zz + - yy))).
assumption.
setoid_replace ((n + n) * (xx + - zz)) with (n*(xx+ -zz) + n *(xx + - zz)) by ring.
apply le_plus.
rewrite (mult_comm  n (xx + -zz)).
apply le_refl.
rewrite (mult_comm  n (xx + -zz)).
rewrite (mult_comm  n  (zz + - yy)).
apply le_mult_simpl.
apply lt_le.
assumption.
apply le_plus_inv with (z:= - (zz + - yy)).
rewrite b.
setoid_replace (zz + - yy + - (zz + - yy))  with 0 by ring.
apply le_refl.

(* positive *)
intros.
left.
exists (n+n).
split.
apply ANS2a; assumption.
split.
setoid_replace 0 with (0+0) by ring; apply lt_plus; assumption.
apply le_trans with (y:= (n * (xx + - zz) + n * (zz + - yy))).
assumption.
setoid_replace ((n + n) * (xx + - zz)) with (n*(xx+ -zz) + n *(xx + - zz)) by ring.
apply le_plus.
rewrite (mult_comm  n (xx + -zz)).
apply le_refl.
rewrite (mult_comm  n (xx + -zz)).
rewrite (mult_comm n  (zz + - yy)).
apply le_mult_simpl.
apply lt_le.
assumption.

apply le_plus_inv with (z:= - (zz + - yy)).
setoid_replace (zz + - yy + - (zz + - yy)) with 0 by ring.
apply lt_le.
assumption.
Qed.

Lemma R2_3 : forall x y, ~HRwdiff x y -> HRwequal x y.
Proof.
intros x; elim x; intros xx Hxx.
intros y; elim y; intros yy Hyy.
clear x y.
intros Hxy.
unfold HRwdiff, HRwgt, HRwequal in *.
firstorder.
elim (A0_dec (xx+ -yy)). (* occurs in R2_3 *)
intros Hdec.
elim Hdec.
intros Hxxyy.
rewrite abs_neg_val.
setoid_replace (n * - (xx + - yy)) with (n * (yy + - xx)) by ring.
apply lt_le.
apply not_le_lt.
intro.
apply (H2 n); repeat split; assumption.
apply lt_le; assumption.
intros Heq.
rewrite Heq.
rewrite abs_pos_val.
setoid_replace (n * 0  ) with 0 by ring.
apply lt_le.
apply Aw.
apply le_refl.
intros.
rewrite abs_pos_val.
apply lt_le.
apply not_le_lt.
intro; apply (H1 n).
repeat split; solve [ apply lt_le; assumption | assumption].
apply lt_le; assumption.
Qed.

Lemma not_HRwgt_HRwge : forall a b : HRw, ~ ( a [>] b)-> b [>=] a.
Proof.
intros a b; destruct a as [a' Ha']; destruct b as [b' Hb'].
unfold HRwgt, HRwge in *.
intros.
firstorder.
generalize (H n); intros.
apply lt_le.
apply not_le_lt.
intro.
apply H8.
split.
assumption.
split.
assumption.
assumption.
Qed.

End mBridges2.


Require Import AutoSep.
Require Import TimeAbstract.

(** A very basic abstract predicate: pairs of words *)

Module Type PAIR.
  Parameter pair : W -> W -> W -> HProp.

  Axiom pair_extensional : forall a b p, HProp_extensional (pair a b p).

  Axiom pair_fwd : forall a b p,
    pair a b p ===> p =*> a * (p ^+ $4) =*> b.

  Axiom pair_bwd : forall a b p,
    p =*> a * (p ^+ $4) =*> b ===> pair a b p.
End PAIR.

Module Pair : PAIR.
  Open Scope Sep_scope.

  Definition pair (a b p : W) : HProp :=
    p =*> a * (p ^+ $4) =*> b.

  Theorem pair_extensional : forall a b p, HProp_extensional (pair a b p).
    reflexivity.
  Qed.

  Theorem pair_fwd : forall a b p,
    pair a b p ===> p =*> a * (p ^+ $4) =*> b.
    unfold pair; sepLemma.
  Qed.

  Theorem pair_bwd : forall a b p,
    p =*> a * (p ^+ $4) =*> b ===> pair a b p.
    unfold pair; sepLemma.
  Qed.
End Pair.

Import Pair.
Hint Immediate pair_extensional.

Definition firstS : spec := SPEC("p") reserving 0
  Al a, Al b,
  PRE[V] pair a b (V "p")
  POST[R] [| R = a |] * pair a b (V "p").

Definition updSecondS : spec := SPEC("p", "x") reserving 0
  Al a, Al b,
  PRE[V] pair a b (V "p")
  POST[_] pair a (V "x") (V "p").

Definition pair := bmodule "pair" {{
  bfunction "first"("p") [firstS]
    "p" <-* "p";;
    Return "p"
  end with bfunction "second"("p", "x") [updSecondS]
    "p" <- "p" + 4;;
    "p" *<- "x";;
    Return 0
  end
}}.

(*TIME Clear Timing Profile. *)

Definition hints : TacPackage.
  (*TIME idtac "pair:prepare". Time *)
  prepare pair_fwd pair_bwd.
Defined.

Theorem pairOk : moduleOk pair.
  (*TIME idtac "pair:verify". Time *)
(*TIME  (time "vcgen:all" *) vcgen
(*TIME ) *); time_abstract ltac:(idtac; sep hints).
Qed.

(*TIME Print Timing Profile. *)