(*

  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 type_sys.
(** printing #  $\times$ #×# *)
(** printing <=>  $\Leftrightarrow$ #⇔# *)
(** printing ~<~  $\preceq$ #⪯# *)
(** printing ~=~  $\sim$ #~# *)
(* printing ===>  $\longmapsto$ *)
(** printing ===>  $\Downarrow$ #⇓# *)
(** printing [[  $[$ *)
(** printing ]]  $]$ *)
(** printing \\  $\backslash$ *)
(** printing mkc_axiom   $\mathtt{Ax}$ *)
(** printing mkc_base    $\mathtt{Base}$ *)
(** printing mkc_int     $\intg$ *)
(** printing mkc_integer $\mathtt{int}$ *)

Lemma eq_term_equals_sym_tsp {p} :
  forall lib (ts : cts(p)) eqa (eqb : per-fam(eqa))
         a1 a2
         (e : eqa a1 a1) (e1 : eqa a1 a2) (e2 : eqa a2 a1)
         v1 B1 v2 B2,
    (forall (a1 a2 : CTerm) (e : eqa a1 a2),
       type_sys_props lib ts
                      (substc a1 v1 B1)
                      (substc a2 v2 B2)
                      (eqb a1 a2 e))
    -> eq_term_equals (eqb a1 a2 e1) (eqb a1 a1 e)
       # eq_term_equals (eqb a2 a1 e2) (eqb a1 a1 e)
       # eq_term_equals (eqb a1 a2 e1) (eqb a2 a1 e2).
Proof.
  introv ftspb.
  (* 1 *)
  assert (eq_term_equals (eqb a1 a2 e1) (eqb a1 a1 e)) as eqt1.

  generalize (ftspb a1 a1 e); intro i.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.

  generalize (ftspb a1 a2 e1); intro i.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
  implies_ts_or (substc a2 v2 B2) tygt.
  apply uv2 in tygt; sp.

  (* 2 *)
  assert (eq_term_equals (eqb a2 a1 e2) (eqb a1 a1 e)) as eqt2.

  generalize (ftspb a1 a1 e); intro i.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.

  generalize (ftspb a2 a1 e2); intro i.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.

  generalize (tygs (substc a1 v1 B1) (substc a1 v2 B2) (eqb a1 a1 e)); intro i.
  repeat (dest_imp i h); repnd.
  rw i in tygt.
  rev_implies_ts_or (substc a2 v1 B1) tygt.
  apply uv2 in tygt; sp.

  (* 3 *)
  assert (eq_term_equals (eqb a1 a2 e1) (eqb a2 a1 e2)) as eqt3.
  apply eq_term_equals_trans with (eq2 := eqb a1 a1 e); sp.
  apply eq_term_equals_sym; sp.

  sp.
Qed.

Lemma eq_term_equals_sym_tsp2 {p} :
  forall lib
         (ts : cts(p))
         (eqa : per)
         (eqb : per-fam(eqa))
         v1 B1 v2 B2,
    term_equality_transitive eqa
    -> (forall (a1 a2 : CTerm) (e : eqa a1 a2),
          type_sys_props lib ts
                         (substc a1 v1 B1)
                         (substc a2 v2 B2)
                         (eqb a1 a2 e))
    -> (forall a1 a2 (e1 : eqa a1 a2) (e : eqa a1 a1),
          eq_term_equals (eqb a1 a2 e1) (eqb a1 a1 e))
     # (forall a1 a2 (e2 : eqa a2 a1) (e : eqa a1 a1),
          eq_term_equals (eqb a2 a1 e2) (eqb a1 a1 e))
     # (forall a1 a2 (e1 : eqa a1 a2) (e2 : eqa a2 a1),
          eq_term_equals (eqb a1 a2 e1) (eqb a2 a1 e2)).
Proof.
  introv teta ftspb.

  (* 1 *)
  assert (forall a1 a2 (e1 : eqa a1 a2) (e : eqa a1 a1),
            eq_term_equals (eqb a1 a2 e1) (eqb a1 a1 e)) as eqt1.
  intros.
  generalize (ftspb a1 a1 e); intro i.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.

  generalize (ftspb a1 a2 e1); intro i.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
  implies_ts_or (substc a2 v2 B2) tygt.
  apply uv2 in tygt; sp.

  (* 2 *)
  assert (forall a1 a2 (e2 : eqa a2 a1) (e : eqa a1 a1),
            eq_term_equals (eqb a2 a1 e2) (eqb a1 a1 e)) as eqt2.
  intros.
  generalize (ftspb a1 a1 e); intro i.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.

  generalize (ftspb a2 a1 e2); intro i.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.

  generalize (tygs (substc a1 v1 B1) (substc a1 v2 B2) (eqb a1 a1 e)); intro i.
  repeat (dest_imp i h); repnd.
  rw i in tygt.
  rev_implies_ts_or (substc a2 v1 B1) tygt.
  apply uv2 in tygt; sp.

  (* 3 *)
  assert (forall a1 a2 (e1 : eqa a1 a2) (e2 : eqa a2 a1),
            eq_term_equals (eqb a1 a2 e1) (eqb a2 a1 e2)) as eqt3.
  intros.
  assert (eqa a1 a1) as e by (apply teta with (t2 := a2); sp).
  apply eq_term_equals_trans with (eq2 := eqb a1 a1 e); sp.
  apply eq_term_equals_sym; sp.

  sp.
Qed.

Lemma type_sys_props_eqb_comm {p} :
  forall lib (ts : cts(p)) eqa (eqb : per-fam(eqa))
         a1 a2
         (e : eqa a1 a2) (e1 : eqa a2 a1) (e2 : eqa a1 a1) (e3 : eqa a2 a2)
         v1 B1 v2 B2,
    (forall (a1 a2 : CTerm) (e : eqa a1 a2),
       type_sys_props lib ts (substc a1 v1 B1) (substc a2 v2 B2) (eqb a1 a2 e))
    -> type_sys_props lib ts (substc a2 v1 B1) (substc a1 v2 B2) (eqb a1 a2 e).
Proof.
  introv e1 e2 e3 ftspb.

  generalize (eq_term_equals_sym_tsp lib ts eqa eqb a2 a1 e3 e1 e
                                     v1 B1 v2 B2); intro i.
  dest_imp i h.
  destruct i as [eqtb2 i].
  destruct i as [eqtb1 eqtb3].

  prove_type_sys_props Case; intros; try (complete sp).

  - Case "uniquely_valued".
    repdors.

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    implies_ts_or_eq (substc a2 v1 B1) T3 (substc a1 v2 B2) h.
    apply uv2 in h.
    apply eq_term_equals_trans with (eq2 := eqb a2 a1 e1); sp.
    apply eq_term_equals_sym; sp.

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    rev_implies_ts_or_eq (substc a1 v2 B2) T3 (substc a2 v1 B1) h.
    apply uv2 in h.
    apply eq_term_equals_trans with (eq2 := eqb a2 a1 e1); sp.
    apply eq_term_equals_sym; sp.

  - Case "type_symmetric".
    repdors; subst.

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tyst2 T3 (eqb a1 a2 e)); intro i.
    dest_imp i h; repnd.
    generalize (tyt2 T3 (eqb a1 a2 e)); intro j.
    dest_imp j h; repnd.
    generalize (tys2 (substc a2 v1 B1) T3 eq'); intro k.
    repeat (dest_imp k h).
    apply eq_term_equals_trans with (eq2 := eqb a1 a2 e); sp.

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tyt2 T3 (eqb a1 a2 e)); intro i.
    dest_imp i h; repnd.
    generalize (tyst2 T3 (eqb a1 a2 e)); intro j.
    dest_imp j h; repnd.
    generalize (tys2 (substc a1 v2 B2) T3 eq'); intro k.
    repeat (dest_imp k h).
    apply eq_term_equals_trans with (eq2 := eqb a1 a2 e); sp.

  - Case "type_transitive".
    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tyt2 T3 eq'); intro k.
    dest_imp k h; repnd; sp.

  - Case "type_stransitive".
    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tyst2 T3 eq'); intro k.
    dest_imp k h; repnd; sp.

  - Case "type_value_respecting".

    repdors; subst.

    (* 1 *)
    generalize (ftspb a2 a2 e3); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tyvr2 (substc a2 v1 B1) T3); intro i.
    dest_imp i h.
    dest_imp i h.

    generalize (ftspb a1 a2 e); intro j.
    onedtsp uv3 tys3 tyt3 tyst3 tyvr3 tes3 tet3 tevr3 tygs3 tygt3 dum3.
    generalize (tygs3 (substc a1 v1 B1) (substc a2 v2 B2) (eqb a1 a2 e)); intro k.
    repeat (dest_imp k h); repnd.
    rw k in tygt3.
    rev_implies_ts_or (substc a2 v1 B1) tygt3.
    apply uv2 in tygt3.
    generalize (tys2 (substc a2 v1 B1) (substc a2 v2 B2) (eqb a1 a2 e)); intro l.
    dest_imp l h.

    (* 2 *)
    generalize (ftspb a1 a1 e2); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tyvr2 (substc a1 v2 B2) T3); intro i.
    dest_imp i h.
    dest_imp i h.

    generalize (ftspb a1 a2 e); intro j.
    onedtsp uv3 tys3 tyt3 tyst3 tyvr3 tes3 tet3 tevr3 tygs3 tygt3 dum3.
    implies_ts_or (substc a1 v2 B2) tygt3.
    apply uv2 in tygt3.
    generalize (tys2 (substc a1 v1 B1) T3 (eqb a1 a2 e)); intro l.
    dest_imp l h.

  - Case "term_symmetric".
    generalize (ftspb a1 a2 e); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2; sp.

  - Case "term_transitive".
    generalize (ftspb a1 a2 e); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2; sp.

  - Case "term_value_respecting".
    generalize (ftspb a1 a2 e); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2; sp.

  - Case "type_gsymmetric".
    repdors; subst.
    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2; sp.
    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2; sp.

  - Case "type_gtransitive".

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tys2 (substc a2 v1 B1) (substc a1 v2 B2) (eqb a2 a1 e1)); sp.

(*
  - Case "type_gtransitive".
    repdors; subst.

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tygt2 (substc a2 v1 B1) T3 T4 eq1 eq2); sp.

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
    generalize (tygt2 (substc a1 v2 B2) T3 T4 eq1 eq2); sp.
*)

  - Case "type_mtransitive".
    repdors; subst.

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 tymt2.
    generalize (tymt2 (substc a2 v1 B1) T3 T4 eq1 eq2); sp.

    generalize (ftspb a2 a1 e1); intro i.
    onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 tymt2.
    generalize (tymt2 (substc a1 v2 B2) T3 T4 eq1 eq2); sp.
Qed.

Lemma eq_term_equals_type_family {p} :
  forall lib (T1 T2 : @CTerm p) eqa1 eqa2 eqb1 eqb2 ts A v B A' v' B'
         (C : CTerm -> forall v : NVar, CVTerm [v] -> CTerm),
    (forall x y z a b c, C x y z = C a b c -> x = a # y = b)
    -> (forall x y z c, C x y z = C x y c -> z = c)
    -> type_family lib C ts T1 T2 eqa1 eqb1
    -> computes_to_valc lib T1 (C A v B)
    -> type_sys_props lib ts A A' eqa2
    -> (forall (a a' : CTerm) (e : eqa2 a a'),
          type_sys_props lib ts
                         (substc a v B)
                         (substc a' v' B')
                         (eqb2 a a' e))
    -> eq_term_equals eqa2 eqa1
       # (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2))
       # (forall a1 a2 (e1 : eqa2 a1 a1) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb2 a1 a1 e1) (eqb2 a1 a2 e2))
       # (forall a1 a2 (e1 : eqa2 a1 a1) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb2 a1 a1 e1) (eqb2 a2 a1 e2))
       # (forall a1 a2 (e1 : eqa2 a1 a2) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb2 a1 a2 e1) (eqb2 a2 a1 e2))
       # type_family lib C ts T1 T2 eqa2 eqb2
       # type_family lib C ts T2 T1 eqa2 eqb2.
Proof.
  introv c1 c2 tf co1 tspa ftspb; introv.
  unfold type_family in tf; exrepd.
  ccomputes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.

  (* First clause *)
  assert (eq_term_equals eqa2 eqa1) as eqta.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
  apply uv with (T3 := A'0); sp.

  (* Second clause *)
  assert (forall (a1 a2 : CTerm) (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
             eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2)) as feqtb.
  intros.
  generalize (t0 a1 a2 e1); intro ts1.
  assert (ts (substc a1 v0 B0) (substc a2 v' B') (eqb2 a1 a2 e2))
         as ts2
         by (generalize (ftspb a1 a2 e2); intro i;
             onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum; sp).
  generalize (ftspb a1 a2 e2); intro tsp.

  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
  implies_ts_or (substc a2 v' B') ts1.
  apply uv in ts1.
  apply eq_term_equals_sym; auto.

  (* Third clause *)
  assert (forall a1 a2 (e1 : eqa2 a1 a1) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb2 a1 a1 e1) (eqb2 a1 a2 e2)) as feqtb1.
  intros.
  generalize (ftspb a1 a1 e1); intro tsp1.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
  assert (ts (substc a1 v0 B0) (substc a2 v' B') (eqb2 a1 a2 e2))
         as ts1
         by (generalize (ftspb a1 a2 e2); intro i;
             onedtsp uv1 tys1 tyt1 tyst1 tyvr1 tes1 tet1 tevr1 tygs1 tygt1 dum1; sp).
  implies_ts_or (substc a1 v' B') ts1.
  apply uv in ts1; sp.

  (* Fourth clause *)
  assert (forall a1 a2 (e1 : eqa2 a1 a1) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb2 a1 a1 e1) (eqb2 a2 a1 e2)) as feqtb2.
  intros.
  generalize (ftspb a1 a1 e1); intro tsp1.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
  generalize (ftspb a2 a1 e2); intro tsp2.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
  assert (ts (substc a2 v0 B0) (substc a1 v' B') (eqb2 a2 a1 e2))
         as ts1
         by (generalize (ftspb a2 a1 e2); intro i;
             onedtsp uv1 tys1 tyt1 tyst1 tyvr1 tes1 tet1 tevr1 tygs1 tygt1 dum1; sp).
  apply tygs2 in ts1; sp.
  rev_implies_ts_or (substc a1 v0 B0) ts1.
  apply uv in ts1; sp.

  (* Fifth clause *)
  assert (forall a1 a2 (e1 : eqa2 a1 a2) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb2 a1 a2 e1) (eqb2 a2 a1 e2)) as feqtb3.
  intros.
  assert (eqa2 a1 a1)
         as e11
         by (onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum;
             apply tet with (t2 := a2); sp).
  generalize (feqtb1 a1 a2 e11 e1); intro tsp1.
  generalize (feqtb2 a1 a2 e11 e2); intro tsp2.
  apply eq_term_equals_trans with (eq2 := eqb2 a1 a1 e11); sp.
  apply eq_term_equals_sym; auto.

  (* this gets the first non type_family clauses *)
  sp.

  (* we prove the first type_family *)
  unfold type_family.
  exists A0 A'0 v0 v'0 B0 B'0; sp; spcast; sp.

  apply (type_sys_props_ts_uv2 lib) with (C := A') (eq1 := eqa1); sp.

  assert (eqa1 a a') as e' by (rw <- eqta; auto).
  generalize (feqtb a a' e' e); intro eqtb.
  generalize (ftspb a a' e); intro tspb.
  apply (type_sys_props_ts_uv2 lib) with (C := substc a' v' B') (eq1 := eqb1 a a' e'); sp.

  (* we prove the second type_family *)
  unfold type_family.
  exists A'0 A0 v'0 v0 B'0 B0; sp; spcast; sp.

  assert (ts A0 A'0 eqa2)
         as i by (apply (type_sys_props_ts_uv2 lib) with (C := A') (eq1 := eqa1); sp).
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
  generalize (tygs A0 A'0 eqa2); intro j; dest_imp j h.
  rw <- j; sp.

  assert (eqa1 a' a)
         as e1
         by (rw <- eqta;
             onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum;
             auto).
  assert (eqa2 a' a) as e2 by (rw eqta; auto).
  generalize (t0 a' a e1); intro tsb1.
  generalize (feqtb a' a e1 e2); intro eqtb.
  generalize (ftspb a' a e2); intro tspb.

  assert (ts (substc a' v0 B0) (substc a v'0 B'0) (eqb2 a a' e))
         as i
         by (apply (type_sys_props_ts_uv3 lib) with (C := substc a v' B') (eq1 := eqb1 a' a e1) (eq2 := eqb2 a' a e2); sp).
  apply (type_sys_props_ts_sym3 lib) with (C := substc a v' B') (eq1 := eqb2 a' a e2); sp.
Qed.

Lemma eq_term_equals_type_family2 {p} :
  forall lib (T1 T2 : @CTerm p) eqa1 eqa2 eqb1 eqb2 ts A v B A' v' B'
         (C : CTerm -> forall v : NVar, CVTerm [v] -> CTerm),
    (forall x y z a b c, C x y z = C a b c -> x = a # y = b)
    -> (forall x y z c, C x y z = C x y c -> z = c)
    -> type_family lib C ts T1 T2 eqa1 eqb1
    -> computes_to_valc lib T2 (C A v B)
    -> type_sys_props lib ts A A' eqa2
    -> (forall (a a' : CTerm) (e : eqa2 a a'),
          type_sys_props lib ts
                         (substc a v B)
                         (substc a' v' B')
                         (eqb2 a a' e))
    -> eq_term_equals eqa2 eqa1
       # (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2))
       # (forall a1 a2 (e1 : eqa2 a1 a1) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb2 a1 a1 e1) (eqb2 a1 a2 e2))
       # (forall a1 a2 (e1 : eqa2 a1 a1) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb2 a1 a1 e1) (eqb2 a2 a1 e2))
       # (forall a1 a2 (e1 : eqa2 a1 a2) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb2 a1 a2 e1) (eqb2 a2 a1 e2))
       # type_family lib C ts T1 T2 eqa2 eqb2
       # type_family lib C ts T2 T1 eqa2 eqb2.
Proof.
  introv c1 c2 tf co1 tspa ftspb; introv.
  unfold type_family in tf; exrepd.
  ccomputes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.
  generalize (type_sys_props_ts_refl lib ts A'0 A' eqa2); intro k; dest_imp k h; repnd.

  (* First clause *)
  assert (eq_term_equals eqa2 eqa1) as eqta.
  apply (type_sys_props_eq_term_equals lib) with (ts := ts) (A := A0) (B := A'0) (C := A'); sp.

  (* Second clause *)
  assert (forall (a1 a2 : CTerm) (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
             eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2)) as feqtb.
  intros.
  assert (eqa1 a1 a1)
         as e3
         by (rw <- eqta;
             onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum;
             apply tet with (t2 := a2); sp).
  assert (eqa2 a1 a1)
         as e4
         by (onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum;
             apply tet with (t2 := a2); sp).
  assert (eqa2 a2 a1)
         as e5 by (onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum; sp).
  generalize (t0 a1 a2 e1); intro ts1.
  generalize (ftspb a2 a1 e5); intro i.
  generalize (eq_term_equals_sym_tsp lib ts eqa2 eqb2 a1 a2 e4 e2 e5 v'0 B'0 v' B' ftspb); intro l; repnd.
  apply eq_term_equals_trans with (eq2 := eqb2 a2 a1 e5).
  apply eq_term_equals_sym.
  apply (type_sys_props_eq_term_equals lib)
        with (ts := ts) (A := substc a1 v0 B0) (B := substc a2 v'0 B'0) (C := substc a1 v' B'); sp.
  apply eq_term_equals_trans with (eq2 := eqb2 a1 a1 e4); sp.
  apply eq_term_equals_sym; sp.

  (* Third clause *)
  assert (forall a1 a2 (e1 : eqa2 a1 a1) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb2 a1 a1 e1) (eqb2 a1 a2 e2)) as feqtb1.
  intros.
  generalize (ftspb a1 a1 e1); intro tsp1.
  generalize (ftspb a1 a2 e2); intro tsp2.
  apply type_sys_props_ts_refl in tsp1; repnd.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  implies_ts_or (substc a2 v' B') tsp0.
  apply uv in tsp0; sp.
  apply eq_term_equals_sym; sp.

  (* Fourth clause *)
  assert (forall a1 a2 (e1 : eqa2 a1 a1) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb2 a1 a1 e1) (eqb2 a2 a1 e2)) as feqtb2.
  intros.
  generalize (ftspb a1 a1 e1); intro tsp1.
  generalize (ftspb a2 a1 e2); intro tsp2.
  apply type_sys_props_ts_refl in tsp1; repnd.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  rev_implies_ts_or (substc a2 v'0 B'0) tsp1.
  apply uv in tsp1; sp.
  apply eq_term_equals_sym; sp.

  (* Fifth clause *)
  assert (forall a1 a2 (e1 : eqa2 a1 a2) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb2 a1 a2 e1) (eqb2 a2 a1 e2)) as feqtb3.
  intros.
  assert (eqa2 a1 a1)
         as e11
         by (onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum;
             apply tet with (t2 := a2); sp).
  generalize (feqtb1 a1 a2 e11 e1); intro tsp1.
  generalize (feqtb2 a1 a2 e11 e2); intro tsp2.
  apply eq_term_equals_trans with (eq2 := eqb2 a1 a1 e11); sp.
  apply eq_term_equals_sym; auto.

  (* this gets the first non type_family clauses *)
  sp.

  (* we prove the first type_family *)
  unfold type_family.
  exists A0 A'0 v0 v'0 B0 B'0; sp; spcast; sp.

  apply (type_sys_props_ts_uv lib) with (C := A') (eq1 := eqa1); sp.

  assert (eqa1 a a') as e1 by (rw <- eqta; auto).
  assert (eqa2 a' a)
         as e2
         by (onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum; sp).
  generalize (ftspb a' a e2); intro i.

  generalize (t0 a a' e1); intro j.
  apply (type_sys_props_ts_uv4 lib) with (C := substc a v' B') (eq1 := eqb1 a a' e1) (eq2 := eqb2 a' a e2); sp.

  (* we prove the second type_family *)
  unfold type_family.
  exists A'0 A0 v'0 v0 B'0 B0; sp; spcast; sp.

  assert (ts A0 A'0 eqa2)
         as i by (apply (type_sys_props_ts_uv lib) with (C := A') (eq1 := eqa1); sp).
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
  generalize (tygs A'0 A0 eqa2); intro j; dest_imp j h.
  rw j; sp.

  assert (eqa1 a' a)
         as e1
         by (rw <- eqta;
             onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum;
             auto).
  assert (eqa2 a' a) as e2 by (rw eqta; auto).
  generalize (t0 a' a e1); intro tsb1.
  generalize (ftspb a a' e); intro tspb.

  assert (ts (substc a' v0 B0) (substc a v'0 B'0) (eqb2 a a' e))
         as i
         by (apply (type_sys_props_ts_uv4 lib) with (C := substc a' v' B') (eq1 := eqb1 a' a e1) (eq2 := eqb2 a a' e); sp).
  apply (type_sys_props_ts_sym2 lib) with (C := substc a' v' B') (eq1 := eqb2 a a' e); sp.
Qed.

Lemma type_family_trans {p} :
  forall lib C (ts : cts(p)) T1 T2 T3 eqa eqb eqa1 eqb1 eqa2 eqb2 A v B A' v' B',
    (forall x y z a b c, C x y z = C a b c -> x = a # y = b)
    -> (forall x y z c, C x y z = C x y c -> z = c)
    -> computes_to_valc lib T1 (C A v B)
    -> computes_to_valc lib T2 (C A' v' B')
    -> type_sys_props lib ts A A' eqa
    -> (forall (a a' : CTerm) (e : eqa a a'),
          type_sys_props lib ts
                         (substc a v B)
                         (substc a' v' B')
                         (eqb a a' e))
    -> type_family lib C ts T1 T2 eqa1 eqb1
    -> type_family lib C ts T2 T3 eqa2 eqb2
    -> eq_term_equals eqa eqa1
       # eq_term_equals eqa1 eqa2
       # (forall a1 a2 (e1 : eqa a1 a2) (e2 : eqa1 a1 a2),
            eq_term_equals (eqb a1 a2 e1) (eqb1 a1 a2 e2))
       # (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2))
       # type_family lib C ts T1 T3 eqa eqb.
Proof.
  introv c1 c2 co1 co2 tspa ftspb tf1 tf2.
  allunfold @type_family; exrepnd.
  ccomputes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.
  ccomputes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.
  ccomputes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.

  (* We prove the first clause *)
  assert (eq_term_equals eqa eqa1)
         as eqta1
         by (generalize (uv A' eqa1); sp).

  (*  *)
  assert (eq_term_equals eqa eqa2)
         as eqta2 by (generalize (uv A'0 eqa2); sp).

  (* We prove the second clause *)
  assert (eq_term_equals eqa1 eqa2)
         as eqta3
         by (apply eq_term_equals_trans with (eq2 := eqa); sp;
             apply eq_term_equals_sym; sp).

  (* We prove the third clause *)
  assert (forall a1 a2 (e1 : eqa a1 a2) (e2 : eqa1 a1 a2),
            eq_term_equals (eqb a1 a2 e1) (eqb1 a1 a2 e2)) as eqtb1.
  intros.
  generalize (tf1 a1 a2 e2); intro ts1.
  generalize (ftspb a1 a2 e1); intro tsp.
  apply (type_sys_props_eq_term_equals2 lib)
        with (ts := ts) (A := substc a1 v B) (B := substc a2 v' B') (C := substc a1 v B); sp.

  (* *)
  assert (forall a1 a2 (e1 : eqa a1 a2) (e2 : eqa2 a2 a1),
            eq_term_equals (eqb a1 a2 e1) (eqb2 a2 a1 e2)) as eqtb2.
  intros.
  generalize (tf2 a2 a1 e2); intro ts1.
  generalize (ftspb a1 a2 e1); intro tsp.
  apply (type_sys_props_eq_term_equals3 lib)
        with (ts := ts) (A := substc a1 v'0 B'0) (B := substc a2 v' B') (C := substc a1 v B); sp.

  (* *)
  generalize (eq_term_equals_sym_tsp2 lib ts eqa eqb v B v' B' tet ftspb); intro i; repnd.

  (* We prove the fourth clause *)
  assert (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2)) as eqtb3.
  intros.
  assert (eqa a1 a2) as e3 by (rw eqta1; auto).
  assert (eqa a2 a1) as e4 by sp.
  generalize (eqtb1 a1 a2 e3 e1); intro k.
  generalize (eqtb2 a2 a1 e4 e2); intro l.
  apply eq_term_equals_trans with (eq2 := eqb a1 a2 e3); sp.
  apply eq_term_equals_sym; sp.
  apply eq_term_equals_trans with (eq2 := eqb a2 a1 e4); sp.

  (* We prove the third clause *)
  sp.

  exists A A'0 v v'0 B B'0; sp; spcast; sp.
  generalize (tyt A'0 eqa2); sp.

  assert (eqa a' a') as e1 by (apply tet with (t2 := a); auto).
  assert (eqa2 a' a') as e3 by (rw <- eqta2; auto).
  assert (eqa1 a a') as e4 by (rw <- eqta1; auto).

  generalize (tf1 a a' e4); intro ts1.
  generalize (tf2 a' a' e3); intro ts2.
  generalize (ftspb a a' e); intro tspb.

  apply (type_sys_props_ts_trans lib) with (B := substc a' v' B') (eq1 := eqb1 a a' e4) (eq2 := eqb2 a' a' e3); sp.
Qed.

Lemma type_sys_props_eq {p} :
  forall lib (ts : cts(p)) A B C eq1 eq2,
    type_sys_props lib ts A C eq1
    -> type_sys_props lib ts B C eq2
    -> ts A B eq1.
Proof.
  introv tsp1 tsp2.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 tymt2.
  generalize (tygs B C eq2); intro i; dest_imp i h.
  rw i in tygt.
  generalize (tyt2 B eq2); sp.
Qed.

Lemma type_sys_props_ts_trans2 {p} :
  forall lib (ts : cts(p)) A B C D eq1 eq2 eq,
    ts A B eq1
    -> ts A C eq2
    -> type_sys_props lib ts A D eq
    -> ts B C eq.
Proof.
  introv ts1 ts2 tsp.
  generalize (type_sys_props_ts_uv2 lib ts B A D eq1 eq); intro i; repeat (dest_imp i h).
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  generalize (tygs A B eq); intro j; dest_imp j h.
  rw j in i.
  generalize (tymt A B C eq eq2); sp.
Qed.

Lemma type_sys_props_ts_trans3 {p} :
  forall lib (ts : cts(p)) A B C D eq1 eq2 eq,
    ts A B eq1
    -> ts B C eq2
    -> type_sys_props lib ts B D eq
    -> ts A C eq1.
Proof.
  introv ts1 ts2 tsp.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  generalize (tymt B A C eq1 eq2); sp.
Qed.

Lemma type_sys_props_ts_trans4 {p} :
  forall lib (ts : cts(p)) A B C D eq1 eq2 eq,
    ts A B eq1
    -> ts B C eq2
    -> type_sys_props lib ts B D eq
    -> ts A C eq2.
Proof.
  introv ts1 ts2 tsp.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  generalize (tymt B A C eq1 eq2); sp.
Qed.

Lemma type_sys_props_ts_trans5 {p} :
  forall lib (ts : cts(p)) A B C D eq1 eq2 eq,
    ts A B eq1
    -> ts A C eq2
    -> type_sys_props lib ts A D eq
    -> ts B C eq1 # ts B C eq2 # ts C C eq2.
Proof.
  introv ts1 ts2 tsp.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  generalize (tygs A B eq1); intro j; dest_imp j h.
  generalize (tygs A C eq2); intro i; dest_imp i h.
  rw j in ts1.
  applydup i in ts2 as ts3.
  generalize (tymt A B C eq1 eq2); sp;
  generalize (tymt A C C eq2 eq2); sp.
Qed.

Lemma type_sys_props_ts_trans6 {p} :
  forall lib (ts : cts(p)) A B C eq1 eq2 eq,
    ts A B eq1
    -> ts B C eq2
    -> type_sys_props lib ts A B eq
    -> ts A C eq1 # ts A C eq2 # ts C C eq2.
Proof.
  introv ts1 ts2 tsp.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
  generalize (tyt C eq2); sp.
  generalize (dum B A C eq1 eq2); sp.
Qed.

Lemma type_family_refl {p} :
  forall lib C (ts : cts(p)) T1 T2 eqa eqb A v B A' v' B',
    (forall x y z a b c, C x y z = C a b c -> x = a # y = b)
    -> (forall x y z c, C x y z = C x y c -> z = c)
    -> type_sys_props lib ts A A' eqa
    -> (forall (a a' : CTerm) (e : eqa a a'),
          type_sys_props lib ts (substc a v B) (substc a' v' B') (eqb a a' e))
    -> computes_to_valc lib T1 (C A v B)
    -> type_family lib C ts T1 T2 eqa eqb
    -> type_family lib C ts T1 T1 eqa eqb
       # type_family lib C ts T2 T2 eqa eqb.
Proof.
  introv c1 c2 tspa tspb co1 tf.
  allunfold @type_family; exrepd.
  ccomputes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.

  dands.

  exists A A v v B B; sp; spcast; sp.

  generalize (type_sys_props_ts_refl lib ts A A' eqa); sp.

  assert (eqa a' a')
         as e'
         by (onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt;
             apply tet with (t2 := a); sp).
  generalize (tspb a a' e); intro i.
  generalize (tspb a' a' e'); intro j.
  apply (type_sys_props_eq lib) with (C := substc a' v' B') (eq2 := eqb a' a' e'); sp.

  exists A'0 A'0 v'0 v'0 B'0 B'0; sp; spcast; sp.

  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  generalize (tyst A'0 eqa); sp.

  assert (eqa a a)
         as e'
         by (onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt;
             apply tet with (t2 := a'); sp).
  generalize (tspb a a' e); intro i.
  generalize (t0 a a' e); intro j.
  generalize (t0 a a e'); intro k.

  generalize (type_sys_props_ts_trans2 lib ts (substc a v B) (substc a v'0 B'0) (substc a' v'0 B'0) (substc a' v' B') (eqb a a e') (eqb a a' e) (eqb a a' e)); sp.
Qed.

(*
Lemma type_family_trans :
  forall C ts T1 T2 T3 eqa1 eqb1 eqa2 eqb2 A v B A' v' B',
    (forall x y z a b c, C x y z = C a b c -> x = a # y = b)
    -> (forall x y z c, C x y z = C x y c -> z = c)
    -> computes_to_valc T1 (C A v B)
    -> type_sys_props ts A A' eqa1
    -> (forall (a a' : CTerm) (e : eqa1 a a'),
          type_sys_props ts
                         (substc a v B)
                         (substc a' v' B')
                         (eqb1 a a' e))
    -> type_family C ts T1 T2 eqa1 eqb1
    -> type_family C ts T2 T3 eqa2 eqb2
    -> eq_term_equals eqa1 eqa2
       # (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2))
       # type_family C ts T1 T3 eqa1 eqb1.
Proof.
  introv c1 c2 co tspa ftspb tf1 tf2.
  allunfold type_family; exrepnd.
  computes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.
  computes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.

  (* We prove the first clause *)
  assert (eq_term_equals eqa1 eqa2)
         as eqta
         by (generalize (tygt A A'1 A'0 eqa1 eqa2); sp;
             apply uv with (T3 := A'0); sp).

  (* We prove the second clause *)
  assert (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2)).
  intros.
  assert (eqa1 a1 a1) as e3 by (apply tet with (t2 := a2); auto).
  generalize (tf1 a1 a1 e3); intro ts1.
  generalize (tf2 a1 a2 e2); intro ts2.
  generalize (ftspb a1 a2 e1); intro tsp.

  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
  generalize (tygt2 (substc a1 v B)
                    (substc a1 v'1 B'1)
                    (substc a2 v'0 B'0)
                    (eqb1 a1 a1 e3)
                    (eqb2 a1 a2 e2)); sp.
  implies_ts_or (substc a2 v' B') X.
  apply uv2 in X; sp.

  (* We prove the third clause *)
  sp.

  exists A A'0 v v'0 B B'0; sp.
  generalize (tygt A A'1 A'0 eqa1 eqa2); sp.

  assert (eqa1 a' a') as e1 by (apply tet with (t2 := a); auto).
  assert (eqa2 a' a') as e2 by (rw <- eqta; sp).

  generalize (tf1 a a' e); intro ts1.
  generalize (tf2 a' a' e2); intro ts2.
  generalize (ftspb a a' e); intro tspb.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
  generalize (tygt2 (substc a v B)
                    (substc a' v'1 B'1)
                    (substc a' v'0 B'0)
                    (eqb1 a a' e)
                    (eqb2 a' a' e2)); sp.
Qed.
*)

Lemma type_family_trans2 {p} :
  forall lib C (ts : cts(p)) T1 T2 T3 eqa1 eqb1 eqa2 eqb2 A v B A' v' B',
    (forall x y z a b c, C x y z = C a b c -> x = a # y = b)
    -> (forall x y z c, C x y z = C x y c -> z = c)
    -> computes_to_valc lib T2 (C A v B)
    -> type_sys_props lib ts A A' eqa1
    -> (forall (a a' : CTerm) (e : eqa1 a a'),
          type_sys_props lib ts
                         (substc a v B)
                         (substc a' v' B')
                         (eqb1 a a' e))
    -> type_family lib C ts T1 T2 eqa1 eqb1
    -> type_family lib C ts T2 T3 eqa2 eqb2
    -> eq_term_equals eqa1 eqa2
       # (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2))
       # type_family lib C ts T1 T3 eqa1 eqb1.
Proof.
  introv c1 c2 co tspa ftspb tf1 tf2.
  allunfold @type_family; exrepnd.
  ccomputes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.
  ccomputes_to_eqval.
  applydup c1 in eq; repd; subst; apply c2 in eq; subst; GC.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.

  (* We prove the first clause *)
  assert (eq_term_equals eqa1 eqa2)
         as eqta
         by (implies_ts_or A' tf4; apply uv in tf4; sp).

  (* We prove the second clause *)
  assert (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
            eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2)).
  intros.
  generalize (tf2 a1 a2 e2); intro ts2.
  generalize (ftspb a1 a2 e1); intro tsp.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
  implies_ts_or (substc a2 v' B') ts2.
  apply uv2 in ts2; sp.

  (* We prove the third clause *)
  sp.

  exists A1 A'0 v1 v'0 B1 B'0; sp; spcast; sp.
  generalize (tymt A A1 A'0 eqa1 eqa2); sp.

  assert (eqa1 a' a') as e1 by (apply tet with (t2 := a); auto).
  assert (eqa2 a' a') as e2 by (rw <- eqta; sp).

  generalize (tf1 a a' e); intro ts1.
  generalize (tf2 a' a' e2); intro ts2.
  generalize (ftspb a' a' e1); intro tspb.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 tymt2.
  generalize (tymt2 (substc a' v B)
                    (substc a v1 B1)
                    (substc a' v'0 B'0)
                    (eqb1 a a' e)
                    (eqb2 a' a' e2)); sp.
Qed.

Lemma type_family_cequivc {p} :
  forall lib C (ts : cts(p)) T1 T2 eqa eqb A1 v1 B1 A2 v2 B2 A v B,
    cequivc lib T1 T2
    -> computes_to_valc lib T1 (C A1 v1 B1)
    -> computes_to_valc lib T2 (C A2 v2 B2)
    -> cequivc lib A1 A2
    -> bcequivc lib [v1] B1 [v2] B2
    -> ts A1 A eqa
    -> (forall (a1 a2 : CTerm) (e : eqa a1 a2),
          type_sys_props lib ts
                         (substc a1 v1 B1)
                         (substc a2 v B)
                         (eqb a1 a2 e))
    -> type_sys_props lib ts A1 A eqa
    -> type_family lib C ts T1 T2 eqa eqb.
Proof.
  introv ceq co1 co2 ca cb tsa ftspb tspa.

  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.

  unfold type_family.
  exists A1 A2 v1 v2 B1 B2; sp; spcast; sp.

  assert (eqa a' a') as e' by (apply tet with (t2 := a); sp).

  generalize (ftspb a' a' e'); intro i.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2.
  generalize (tyvr2 (substc a' v1 B1) (substc a' v2 B2)); intro k.
  dest_imp k h.
  dest_imp k h.
  apply bcequivc1 with (t := a') in cb; auto.

  generalize (ftspb a a' e); intro i.
  generalize (ftspb a' a' e'); intro j.

  generalize (type_sys_props_eq lib ts (substc a v1 B1) (substc a' v1 B1) (substc a' v B) (eqb a a' e) (eqb a' a' e')); intro l; repeat (dest_imp l h).
  generalize (type_sys_props_ts_trans3 lib ts (substc a v1 B1) (substc a' v1 B1) (substc a' v2 B2) (substc a' v B) (eqb a a' e) (eqb a' a' e') (eqb a' a' e')); sp.
Qed.

Lemma type_family_cequivc2 {p} :
  forall lib C (ts : cts(p)) T1 T2 eqa eqb A1 v1 B1 A2 v2 B2 A v B,
    cequivc lib T1 T2
    -> computes_to_valc lib T1 (C A1 v1 B1)
    -> computes_to_valc lib T2 (C A2 v2 B2)
    -> cequivc lib A1 A2
    -> bcequivc lib [v1] B1 [v2] B2
    -> ts A A1 eqa
    -> (forall (a1 a2 : CTerm) (e : eqa a1 a2),
          type_sys_props lib ts
                         (substc a1 v B)
                         (substc a2 v1 B1)
                         (eqb a1 a2 e))
    -> type_sys_props lib ts A A1 eqa
    -> type_family lib C ts T1 T2 eqa eqb.
Proof.
  introv ceq co1 co2 ca cb tsa ftspb tspa.

  apply @type_family_cequivc
        with
        (A1 := A1)
        (v1 := v1)
        (B1 := B1)
        (A2 := A2)
        (v2 := v2)
        (B2 := B2)
        (A := A)
        (v := v)
        (B := B); sp;
  try (complete (apply (type_sys_props_sym lib); sp)).

  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum; sp.

  assert (eqa a2 a1) as e1 by sp.
  assert (eqa a1 a1) as e2 by (apply tet with (t2 := a2); sp).
  assert (eqa a2 a2) as e3 by (apply tet with (t2 := a1); sp).

  apply type_sys_props_sym; sp.
  apply type_sys_props_eqb_comm; sp.
Qed.

(*
Lemma type_family_eq_term_equals :
  forall T1 T2 eqa1 eqa2 eqb1 eqb2 ts C,
    (forall a1 a2 (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
       eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2))
    -> type_family C ts T1 T2 eqa1 eqb1
    -> eq_term_equals eqa2 eqa1
    -> type_family C ts T1 T2 eqa2 eqb2.
Proof.
  introv feqtb tf eqta.
  allunfold type_family; exrepd.
  exists A A' v v' B B'; sp.
Qed.
*)

Lemma is_per_iff {p} :
  forall eq1 eq2,
    (forall x y : @CTerm p, inhabited (eq1 x y) <=> inhabited (eq2 x y))
    -> is_per eq1
    -> is_per eq2.
Proof.
  unfold is_per; introv iff isper1.
  destruct isper1 as [sym tran]; sp.
  discover; sp.
  apply iff.
  apply tran with (y := y); sp; apply iff; sp.
Qed.

Lemma eq_term_equals_implies_inhabited {p} :
  forall a b,
    @eq_term_equals p a b
    -> (inhabited a <=> inhabited b).
Proof.
  unfold eq_term_equals, inhabited; sp; split; sp; exists t.
  allrw <-; sp.
  allrw; sp.
Qed.

Lemma is_per_sym {p} :
  forall (a b : @CTerm p) eq,
    is_per eq
    -> inhabited (eq a b)
    -> inhabited (eq b a).
Proof.
  introv isper inh.
  allunfold @is_per; sp.
Qed.

Lemma is_per_trans {p} :
  forall (a b c : @CTerm p) eq,
    is_per eq
    -> inhabited (eq a b)
    -> inhabited (eq b c)
    -> inhabited (eq a c).
Proof.
  introv isper inh.
  allunfold @is_per; sp.
  generalize (isper a b c); sp.
Qed.

Lemma type_sys_props_pertype_eq_term_equals {p} :
  forall lib (ts : cts(p)) R eq1 eq2,
    (forall x y, type_sys_props lib ts (mkc_apply2 R x y) (mkc_apply2 R x y) (eq1 x y))
    -> (forall x y, ts (mkc_apply2 R x y) (mkc_apply2 R x y) (eq2 x y))
    -> (forall x y, eq_term_equals (eq1 x y) (eq2 x y)).
Proof.
  introv tsp tseq; intros.
  generalize (tseq x y); intro j.
  generalize (tsp x y); intro k.
  repeat (dest_imp k h).
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  implies_ts_or (mkc_apply2 R x y) j.
  apply uv in j; sp.
Qed.

Lemma weq_eq_term_equals {p} :
  forall lib (eqa1 eqa2 : per(p))
         eqb1 eqb2 t1 t2,
    (forall (a1 a2 : CTerm) (e1 : eqa1 a1 a2) (e2 : eqa2 a1 a2),
       eq_term_equals (eqb1 a1 a2 e1) (eqb2 a1 a2 e2))
    -> eq_term_equals eqa1 eqa2
    -> weq lib eqa1 eqb1 t1 t2
    -> weq lib eqa2 eqb2 t1 t2.
Proof.
  introv eqbeq eqaeq weqt.
  induction weqt as [t t' a f a' f' e c c' h h'].
  duplicate e as e'.
  rw eqaeq in e.
  apply @weq_cons with (a := a) (a' := a') (f := f) (f' := f') (e := e); sp.
  apply h'.
  generalize (eqbeq a a' e' e); intro eqb.
  rw eqb; sp.
Qed.

Lemma weq_sym {p} :
  forall lib eqa eqb t1 t2 v1 v2 B1 B2 (ts : cts(p)),
    term_equality_symmetric eqa
    -> term_equality_transitive eqa
    -> (forall (a1 a2 : CTerm) (e : eqa a1 a2),
          type_sys_props lib ts
                         (substc a1 v1 B1)
                         (substc a2 v2 B2)
                         (eqb a1 a2 e))
    -> weq lib eqa eqb t1 t2
    -> weq lib eqa eqb t2 t1.
Proof.
  introv teqsa teqta ftsp weq1.
  induction weq1 as [t t' a f a' f' e c c' h h'].
  duplicate e as e'.
  apply teqsa in e.
  apply @weq_cons with (a := a') (f := f') (a' := a) (f' := f) (e := e); sp.
  apply h'; sp.
  generalize (eq_term_equals_sym_tsp2 lib ts eqa eqb v1 B1 v2 B2); introv i.
  dest_imp i hyp; sp.
  generalize (i a a' e' e); intro eqeb.
  rw eqeb.
  generalize (ftsp a' a e); intro tsp.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum; sp.
Qed.

Lemma eq_family_trans1 {p} :
  forall lib eqa eqb
         a a1 a2 t1 t2
         ts v1 B1 v2 B2
         (e1 : eqa a a1) (e2 : eqa a a2),
    (forall (a1 a2 : @CTerm p) (e : eqa a1 a2),
       type_sys_props lib ts
                      (substc a1 v1 B1)
                      (substc a2 v2 B2)
                      (eqb a1 a2 e))
    -> eqb a a1 e1 t1 t2
    -> eqb a a2 e2 t1 t2.
Proof.
  introv ftsp eqb1.
  generalize (ftsp a a1 e1); intro tsp1.
  onedtsp uv1 tys1 tyt1 tyst1 tyvr1 tes1 tet1 tevr1 tygs1 tygt1 dum1; sp.
  generalize (ftsp a a2 e2); intro tsp2.
  onedtsp uv2 tys2 tyt2 tyst2 tyvr2 tes2 tet2 tevr2 tygs2 tygt2 dum2; sp.
  generalize (uv2 (substc a1 v2 B2) (eqb a a1 e1)); intro i; sp.
  rw i; sp.
Qed.

Lemma weq_trans {p} :
  forall lib eqa eqb t1 t2 t3 ts v1 B1 v2 B2,
    term_equality_symmetric eqa
    -> term_equality_transitive eqa
    -> (forall (a1 a2 : @CTerm p) (e : eqa a1 a2),
          type_sys_props lib ts
                         (substc a1 v1 B1)
                         (substc a2 v2 B2)
                         (eqb a1 a2 e))
    -> weq lib eqa eqb t1 t2
    -> weq lib eqa eqb t2 t3
    -> weq lib eqa eqb t1 t3.
Proof.
  introv teqsa teqta ftsp weq1.
  generalize t3; clear t3.
  induction weq1 as [t t' a f a' f' e c c' h h'].
  introv weq2.
  inversion weq2 as [x g a'0 f'0 e0 d d' h1].
  ccomputes_to_eqval.
  assert (eqa a a'0) as e' by (apply teqta with (t2 := a'); sp).
  apply @weq_cons with (a := a) (f := f) (a' := a'0) (f' := f'0) (e := e');
    try (complete (spcast; sp)); introv hyp.
  apply h' with (b' := b'); sp.
  apply (eq_family_trans1 lib) with (a1 := a'0) (ts := ts) (v1 := v1) (B1 := B1) (v2 := v2) (B2 := B2) (e1 := e'); sp.
  apply h1.
  generalize (eq_term_equals_sym_tsp2 lib ts eqa eqb v1 B1 v2 B2); intro i; sp.
  duplicate e0 as e1.
  apply teqsa in e0.
  duplicate e' as e2.
  apply teqsa in e'.
  generalize (i a' a'0 e1 e0); intro eq1.
  rw eq1.
  generalize (i a a'0 e2 e'); intro eq2.
  rw eq2 in hyp.
  apply (eq_family_trans1 lib) with (a1 := a) (ts := ts) (v1 := v1) (B1 := B1) (v2 := v2) (B2 := B2) (e1 := e'); sp.
  generalize (ftsp a'0 a e'); intro tsp.
  onedtsp uv1 tys1 tyt1 tyst1 tyvr1 tes1 tet1 tevr1 tygs1 tygt1 dum1; sp.
  apply tet1 with (t2 := b); sp.
Qed.

(*
Lemma weq_cequivc2 :
  forall eqa eqb ts v1 B1 v2 B2 a a' e f f' b b',
    term_equality_respecting eqa
    -> term_equality_symmetric eqa
    -> term_equality_transitive eqa
    -> (forall (a1 a2 : CTerm) (e : eqa a1 a2),
          type_sys_props ts
                         (substc a1 v1 B1)
                         (substc a2 v2 B2)
                         (eqb a1 a2 e))
    -> weq eqa eqb (mkc_apply f b) (mkc_apply f b)
    -> eqb a a' e b b'
    -> cequivc f f'
    -> weq eqa eqb (mkc_apply f b) (mkc_apply f' b').
Proof.
  introv tera tesa teta ftspb weq1 eqb1 ceq.
  generalize f' b' eqb1 ceq; clear ceq eqb1 b' f'.
  remember (mkc_apply f b).
  generalize Heqc; clear Heqc.
  induction weq1.
  introv eq eqb1 ceq; subst.
  generalize (cequivc_mkc_sup t' t'0 a' f'); intros i.
  repeat (dest_imp i hyp); exrepnd.
  rename b' into f'0.
  unfold term_equality_respecting in tera.
  generalize (tera a' a'0); intro j.
  repeat (dest_imp j hyp).
  apply teta with (t2 := a); sp.
  apply weq_cons with (a := a') (f := f') (a' := a'0) (f' := f'0) (e := j); sp.
  apply X with (b := b'); sp.

  generalize (eq_term_equals_sym_tsp2 ts eqa eqb v1 B1 v2 B2); introv i.
  repeat (dest_imp i hyp); repnd.
  assert (eqa a' a) as e' by sp.
  generalize (i a a' e e'); intro eqt; rw eqt.
  generalize (ftspb a' a e'); intro tspb.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
  apply tes.
  generalize (eq_family_trans1 eqa eqb a' a'0 a b b' ts v1 B1 v2 B2 j e'); sp.

Abort.
*)

Lemma weq_cequivc {p} :
  forall lib eqa eqb t t1 t2 ts v1 B1 v2 B2,
    term_equality_respecting lib eqa
    -> term_equality_symmetric eqa
    -> term_equality_transitive eqa
    -> (forall (a1 a2 : @CTerm p) (e : eqa a1 a2),
          type_sys_props lib ts
                         (substc a1 v1 B1)
                         (substc a2 v2 B2)
                         (eqb a1 a2 e))
    -> weq lib eqa eqb t t1
    -> cequivc lib t1 t2
    -> weq lib eqa eqb t t2.
Proof.
  introv tera tesa teta ftspb weq1.
  generalize t2; clear t2.
  induction weq1 as [t t' a f a' f' e c c' h h'].
  introv ceq.
  rename t' into t1.
  rename a' into a1.
  rename f' into f1.
  spcast.
  generalize (cequivc_mkc_sup lib t1 t2 a1 f1); intros i.
  repeat (dest_imp i hyp); exrepnd.
  rename a' into a2.
  rename b' into f2.
  unfold term_equality_respecting in tera.
  generalize (tera a1 a2); intro j.
  repeat (dest_imp j hyp); spcast; sp.
  apply teta with (t2 := a); sp.
  generalize (teta a a1 a2); intro k; repeat (dest_imp k hyp).
  apply @weq_cons with (a := a) (f := f) (a' := a2) (f' := f2) (e := k);
    try (complete (spcast; sp)); introv hyp.
  apply h' with (b' := b'); sp.

  generalize (eq_term_equals_sym_tsp2 lib ts eqa eqb v1 B1 v2 B2 teta ftspb); introv i.
  repeat (dest_imp i hyp); repnd.
  assert (eqa a a) as e' by (apply teta with (t2 := a1); sp).
  generalize (i3 a a1 e e'); intro eqt1; rw eqt1.
  generalize (i3 a a2 k e'); intro eqt2; rw eqt2 in hyp; sp.

  apply sp_implies_cequivc_apply; sp.
Qed.

Lemma type_sys_props_cequivc {p} :
  forall lib (ts : cts(p)) A B C eq,
    type_sys_props lib ts A B eq
    -> cequivc lib A C
    -> ts A C eq.
Proof.
  introv tsp ceq.
  onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt tymt.
  generalize (tyvr A C); sp.
Qed.

Lemma iff_inhabited_if_eq_term_equals {p} :
  forall (eq1 eq2 : per(p)), (eq1 <=2=> eq2) -> (inhabited eq1 <=> inhabited eq2).
Proof.
  introv eqs.
  unfold inhabited; split; intro k; exrepnd; exists t;
  generalize (eqs t t); clear eqs; intro eqs;
  allrw; sp; allrw <-; sp.
Qed.

Lemma type_sys_props_pertype_eq_term_equals1 {p} :
  forall lib (ts : cts(p)) R R1 R2 eq1 eq2,
    (forall x y, type_sys_props lib ts (mkc_apply2 R x y) (mkc_apply2 R1 x y) (eq1 x y))
    -> (forall x y, ts (mkc_apply2 R x y) (mkc_apply2 R2 x y) (eq2 x y))
    -> (forall x y, (eq1 x y) <=2=> (eq2 x y)).
Proof.
  introv tsp k; intros t1 t2.
  generalize (k t1 t2); clear k; intro k.
  generalize (tsp t1 t2); clear tsp; intro tsp; repeat (autodimp tsp hyp).
  generalize (type_sys_props_eq_term_equals4
                lib ts
                (mkc_apply2 R t1 t2)
                (mkc_apply2 R2 t1 t2)
                (mkc_apply2 R1 t1 t2)
                (eq2 t1 t2) (eq1 t1 t2) k tsp); sp.
Qed.

Lemma type_sys_props_pertype_eq_term_equals2 {p} :
  forall lib (ts : cts(p)) R1 R2 R3 eq1 eq2,
    (forall x y, type_sys_props lib ts (mkc_apply2 R1 x y) (mkc_apply2 R2 x y) (eq1 x y))
    -> (forall x y, ts (mkc_apply2 R2 x y) (mkc_apply2 R3 x y) (eq2 x y))
    -> (forall x y, (eq1 x y) <=2=> (eq2 x y)).
Proof.
  introv tsp k; intros t1 t2.
  generalize (k t1 t2); clear k; intro k.
  generalize (tsp t1 t2); clear tsp; intro tsp; repeat (autodimp tsp hyp).
  generalize (type_sys_props_eq_term_equals3
                lib ts
                (mkc_apply2 R3 t1 t2)
                (mkc_apply2 R2 t1 t2)
                (mkc_apply2 R1 t1 t2)
                (eq2 t1 t2) (eq1 t1 t2) k tsp); sp.
Qed.


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import ZArith Lists.List.
Import ListNotations.
Open Scope list.
Open Scope positive.

From Tries Require Import Canonical.
Import PTree.

From Utils Require Import Utils Monad.
Import StateMonad.
From Pyrosome Require Import Theory.Core Proof.TreeProofs.

Section WithVar.
  Context (V : Type)
    {V_Eqb : Eqb V}
    {V_default : WithDefault V}.

  Notation named_list := (@named_list V).
  Notation named_map := (@named_map V).
  Notation term := (@term V).
  Notation ctx := (@ctx V).
  Notation sort := (@sort V).
  Notation subst := (@subst V).
  Notation rule := (@rule V).
  Notation lang := (@lang V).

  Record renaming :=
    MkRenaming {
        p_to_v : tree V
      ; v_to_p : named_list positive
      ; next_id : positive
      }.

  Local Notation ST := (state renaming).

  Definition alloc (n : V) : ST positive :=
    fun r =>
      (r.(next_id),
        MkRenaming (set r.(next_id) n r.(p_to_v))
          ((n,r.(next_id))::r.(v_to_p))
          (r.(next_id)+1)).

  Definition to_p (v : V) : ST positive :=
    fun r =>
      match named_list_lookup_err r.(v_to_p) v with
      | Some p => (p,r)
      | None => alloc v r
      end.

  Fixpoint rename_term (e : term) : ST (Term.term positive) :=
    match e with
    | var x =>
        @! let x' <- to_p x in
          ret var x'
    | con n s =>
        @! let s' <- list_Mmap rename_term s in
          let n' <- to_p n in
          ret con n' s'
    end.

  Definition rename_sort (t : sort) : ST _ :=
    let (n,s) := t in
    @! let s' <- list_Mmap rename_term s in
      let n' <- to_p n in
      ret scon n' s'.

  Definition rename_ctx (c : ctx) : ST _ :=
    list_Mmap (fun '(x,t) =>
                 @! let t' <- rename_sort t in
                   let x' <- to_p x in
                   ret (x',t')) c.

  Definition rename_rule r : ST _ :=
    match r with
    | sort_rule c args =>
        @! let c' <- rename_ctx c in
          let args' <- list_Mmap to_p args in
          ret sort_rule c' args'
    | term_rule c args t =>
        @! let c' <- rename_ctx c in
          let args' <- list_Mmap to_p args in
          let t' <- rename_sort t in
          ret term_rule c' args' t'
    | sort_eq_rule c t1 t2 =>
        @! let c' <- rename_ctx c in
          let t1' <- rename_sort t1 in
          let t2' <- rename_sort t2 in
          ret sort_eq_rule c' t1' t2'
    | term_eq_rule c e1 e2 t =>
        @! let c' <- rename_ctx c in
          let e1' <- rename_term e1 in
          let e2' <- rename_term e2 in
          let t' <- rename_sort t in
          ret term_eq_rule c' e1' e2' t'
    end.

  Definition rename_lang : lang -> ST _ :=
    list_Mmap (fun '(x,r) =>
                 @! let r' <- rename_rule r in
                   let x' <- to_p x in
                   ret (x',r')).

  Definition empty_rename : renaming :=
    MkRenaming (empty _) [] 1.

  Section Unrename.

    Context (r : renaming).

    Definition of_p (p : positive) : V :=
      unwrap_with_default (get p r.(p_to_v)).

    Fixpoint unrename_pf p : pf V :=
      match p with
      | pvar x => pvar (of_p x)
      | pcon n s => pcon (of_p n) (map unrename_pf s)
      | ptrans p1 p2 => ptrans (unrename_pf p1) (unrename_pf p2)
      | psym p => psym (unrename_pf p)
      | pconv p1 p2 => pconv (unrename_pf p1) (unrename_pf p2)
      end.
  End Unrename.

End WithVar.


Require Import Omega.
Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
Require Import Event.
Require Import Time.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Thread.
Require Import Configuration.

Require Import SimMemory.
Require Import SimPromises.
Require Import SimLocal.
Require Import FulfillStep.
Require Import MemoryReorder.

Set Implicit Arguments.

Lemma reorder_promise_read_diff
      lc1 lc1'
      lc2 lc2'
      mem0
      mem1
      loc1 from1 to1 val1 released1 kind1
      loc2 to2 val2 released2 ord2
      (STEP1: Local.promise_step lc1 mem0 loc1 from1 to1 val1 released1 lc1' mem1 kind1)
      (STEP2: Local.read_step lc2 mem1 loc2 to2 val2 released2 ord2 lc2')
      (LOCTS: (loc1, to1) <> (loc2, to2)):
  <<STEP1: Local.read_step lc2 mem0 loc2 to2 val2 released2 ord2 lc2'>>.
Proof.
  inv STEP1. inv STEP2.
  hexploit MemoryFacts.MemoryFacts.promise_get_inv_diff; eauto. i. des.
  esplits; eauto.
  econs; eauto.
Qed.

Lemma reorder_promise_promise_diff
      lc1 lc1'
      lc2 lc2'
      mem0 sc0
      mem1
      mem2
      loc1 from1 to1 val1 released1 kind1
      loc2 from2 to2 val2 released2 kind2
      (STEP1: Local.promise_step lc1 mem0 loc1 from1 to1 val1 released1 lc1' mem1 kind1)
      (STEP2: Local.promise_step lc2 mem1 loc2 from2 to2 val2 released2 lc2' mem2 kind2)
      (LOCAL1: Local.wf lc1 mem0)
      (LOCAL2: Local.wf lc2 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0)
      (DISJ: Local.disjoint lc1 lc2)
      (REL_CLOSED: forall promises2' mem1' kind1' (PROMISE1: Memory.promise (Local.promises lc2) mem0 loc2 from2 to2 val2 released2 promises2' mem1' kind1'),
          Memory.closed_opt_view released2 mem1'):
  exists mem1',
    <<STEP1: Local.promise_step lc2 mem0 loc2 from2 to2 val2 released2 lc2' mem1' kind2>> /\
    <<STEP2: Local.promise_step lc1 mem1' loc1 from1 to1 val1 released1 lc1' mem2 kind1>>.
Proof.
  exploit Local.promise_step_disjoint; try exact STEP1; eauto. i. des.
  inv STEP1. inv STEP2. ss.
  inv PROMISE.
  { inv PROMISE0.
    - exploit MemoryReorder.add_add; try exact MEM; try exact MEM0; eauto. i. des.
      esplits.
      + econs.
        * econs; eauto.
        * eapply REL_CLOSED. econs; eauto.
      + econs.
        * econs; eauto.
        * eapply Memory.add_closed_opt_view; eauto.
    - exploit MemoryReorder.add_split; try exact MEM; try exact MEM0; eauto. i. des.
      { subst. exfalso. eapply Memory.disjoint_get; try apply DISJOINT2; s; cycle 1.
        - eapply Memory.split_get0. eauto.
        - erewrite Memory.add_o; eauto. condtac; [|des; congr]. ss.
      }
      esplits.
      + econs.
        * econs 2; eauto.
        * eapply REL_CLOSED. econs 2; eauto.
      + econs.
        * econs; eauto.
        * eapply Memory.split_closed_opt_view; eauto.
    - exploit MemoryReorder.add_lower; try exact MEM; try exact MEM0; eauto. i. des.
      { subst. exfalso. eapply Memory.disjoint_get; try apply DISJOINT2; s; cycle 1.
        - eapply Memory.lower_get0. eauto.
        - erewrite Memory.add_o; eauto. condtac; [|des; congr]. ss.
      }
      esplits.
      + econs.
        * econs 3; eauto.
        * eapply REL_CLOSED. econs 3; eauto.
      + econs.
        * econs; eauto.
        * eapply Memory.lower_closed_opt_view; eauto.
  }
  { inv PROMISE0.
    - exploit MemoryReorder.split_add; try exact MEM; try exact MEM0; eauto. i. des.
      esplits.
      + econs.
        * econs; eauto.
        * eapply REL_CLOSED. econs; eauto.
      + econs.
        * econs; eauto.
        * eapply Memory.add_closed_opt_view; eauto.
    - exploit MemoryReorder.split_split; try exact MEM; try exact MEM0; eauto.
      { ii. inv H. exfalso. eapply Memory.disjoint_get; try apply DISJ.
        - eapply Memory.split_get0. eauto.
        - eapply Memory.split_get0. eauto.
      }
      i. des.
      { subst. exfalso. eapply Memory.disjoint_get'; try (symmetry; apply DISJ).
        - inv MEM. inv SPLIT. apply TS12.
        - inv PROMISES. inv SPLIT. apply TS23.
        - eapply Memory.split_get0. eauto.
        - eapply Memory.split_get0. eauto.
      }
      esplits.
      + econs.
        * econs 2; eauto.
        * eapply REL_CLOSED. econs 2; eauto.
      + econs.
        * econs; eauto.
        * eapply Memory.split_closed_opt_view; eauto.
    - exploit MemoryReorder.split_lower_diff; try exact MEM; try exact MEM0; eauto.
      { ii. inv H. exfalso. eapply Memory.disjoint_get; try apply DISJ.
        - eapply Memory.split_get0. eauto.
        - eapply Memory.lower_get0. eauto.
      }
      i. des.
      { subst. exfalso. eapply Memory.disjoint_get'; try (symmetry; apply DISJ).
        - inv MEM1. inv LOWER. eauto.
        - inv MEM. inv SPLIT. eauto.
        - eapply Memory.lower_get0. eauto.
        - eapply Memory.split_get0. eauto.
      }
      esplits.
      + econs.
        * econs 3; eauto.
        * eapply REL_CLOSED. econs 3; eauto.
      + econs.
        * econs; eauto.
        * eapply Memory.lower_closed_opt_view; eauto.
  }
  { inv PROMISE0.
    - exploit MemoryReorder.lower_add; try exact MEM; try exact MEM0; eauto. i. des.
      esplits.
      + econs.
        * econs; eauto.
        * eapply REL_CLOSED. econs; eauto.
      + econs.
        * econs; eauto.
        * eapply Memory.add_closed_opt_view; eauto.
    - exploit MemoryReorder.lower_split; try exact MEM; try exact MEM0; eauto. i. des.
      unguardH FROM1. des.
      { inv FROM1. exfalso. eapply Memory.disjoint_get; try apply DISJ.
        - eapply Memory.lower_get0. eauto.
        - eapply Memory.split_get0. eauto.
      }
      inv FROM0.
      esplits.
      + econs.
        * econs 2; eauto.
        * eapply REL_CLOSED. econs 2; eauto.
      + econs.
        * econs; eauto.
        * eapply Memory.split_closed_opt_view; eauto.
    - exploit MemoryReorder.lower_lower; try exact MEM; try exact MEM0; eauto. i. des.
      { subst. exfalso. eapply Memory.disjoint_get; try apply DISJ.
        - eapply Memory.lower_get0. eauto.
        - eapply Memory.lower_get0. eauto.
      }
      esplits.
      + econs.
        * econs 3; eauto.
        * eapply REL_CLOSED. econs 3; eauto.
      + econs.
        * econs; eauto.
        * eapply Memory.lower_closed_opt_view; eauto.
  }
Qed.

Lemma reorder_promise_write_diff
      lc1 lc1'
      lc2 lc2'
      sc0 mem0
      mem1
      sc2 mem2
      loc1 from1 to1 val1 released1 kind1
      loc2 from2 to2 val2 releasedm2 released2 ord2 kind2
      (STEP1: Local.promise_step lc1 mem0 loc1 from1 to1 val1 released1 lc1' mem1 kind1)
      (STEP2: Local.write_step lc2 sc0 mem1 loc2 from2 to2 val2 releasedm2 released2 ord2 lc2' sc2 mem2 kind2)
      (REL_WF: View.opt_wf releasedm2)
      (REL_CLOSED: Memory.closed_opt_view releasedm2 mem0)
      (LOCAL1: Local.wf lc1 mem0)
      (LOCAL2: Local.wf lc2 mem0)
      (DISJ: Local.disjoint lc1 lc2)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0):
  exists mem1',
    <<STEP1: Local.write_step lc2 sc0 mem0 loc2 from2 to2 val2 releasedm2 released2 ord2 lc2' sc2 mem1' kind2>> /\
    <<STEP2: Local.promise_step lc1 mem1' loc1 from1 to1 val1 released1 lc1' mem2 kind1>>.
Proof.
  exploit Local.promise_step_future; eauto. i. des.
  exploit Local.promise_step_disjoint; eauto. i. des.
  exploit write_promise_fulfill; eauto.
  { inv STEP1. eapply Memory.promise_closed_opt_view; eauto. }
  i. des.
  exploit reorder_promise_promise_diff; try exact STEP1; try exact STEP0; eauto.
  { i. subst.
    exploit Memory.promise_op; eauto. i.
    eapply TViewFacts.op_closed_released; try exact x0; eauto.
    apply LOCAL2.
  }
  i. des.
  esplits; eauto.
  eapply promise_fulfill_write_exact; eauto.
Qed.

Lemma reorder_promise_program_diff
      loc from to val released kind lc1 lc1'
      e2 lang2 st2 st2' lc2 lc2'
      sc0 mem0
      mem1
      sc2 mem2
      (STEP1: Local.promise_step lc1 mem0 loc from to val released lc1' mem1 kind)
      (STEP2: Thread.program_step e2 (Thread.mk lang2 st2 lc2 sc0 mem1) (Thread.mk lang2 st2' lc2' sc2 mem2))
      (E2: forall val released ord, ThreadEvent.is_reading e2 <> Some (loc, to, val, released, ord))
      (LOCAL1: Local.wf lc1 mem0)
      (LOCAL2: Local.wf lc2 mem0)
      (DISJ: Local.disjoint lc1 lc2)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0):
  exists mem1',
    <<STEP1: Thread.program_step e2 (Thread.mk lang2 st2 lc2 sc0 mem0) (Thread.mk lang2 st2' lc2' sc2 mem1')>> /\
    <<STEP2: Local.promise_step lc1 mem1' loc from to val released lc1' mem2 kind>>.
Proof.
  inv STEP2. inv LOCAL; ss.
  - (* silent *)
    esplits; eauto. econs; [|econs 1]; eauto.
  - (* read *)
    exploit reorder_promise_read_diff; eauto.
    { ii. inv H. eapply E2. eauto. }
    i. des. esplits; eauto. econs; [|econs 2]; eauto.
  - (* write *)
    exploit reorder_promise_write_diff; eauto; try by viewtac. i. des.
    esplits; eauto. econs; [|econs 3]; eauto.
  - (* update *)
    exploit reorder_promise_read_diff; eauto.
    { ii. inv H. eapply E2. eauto. }
    i. des.
    exploit Local.read_step_future; eauto. i. des.
    exploit Local.read_step_disjoint; try symmetry; eauto. i.
    exploit reorder_promise_write_diff; try symmetry; eauto. i. des.
    esplits; eauto. econs; [|econs 4]; eauto.
  - inv LOCAL0.
    esplits; eauto. econs; [|econs 5]; eauto. econs; eauto.
  - inv LOCAL0.
    esplits; eauto. econs; [|econs 6]; eauto. econs; eauto.
Qed.


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 Qprime Cprime P Q Aprime C A X Y Z : Universe, ((wd_ Qprime Cprime /\ (wd_ Cprime P /\ (wd_ P Q /\ (wd_ Qprime Q /\ (wd_ Qprime P /\ (wd_ Cprime Q /\ (wd_ Aprime P /\ (wd_ Q Aprime /\ (wd_ Aprime A /\ (wd_ Cprime C /\ (wd_ P A /\ (wd_ P C /\ (wd_ Q C /\ (wd_ C A /\ (wd_ Cprime Aprime /\ (wd_ X Y /\ (wd_ A Q /\ (wd_ P Y /\ (wd_ Y Z /\ (wd_ X P /\ (col_ P Q Z /\ (col_ Aprime P A /\ (col_ Cprime P C /\ (col_ P C Y /\ col_ P A X)))))))))))))))))))))))) -> col_ Y P Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From compcert Require Import Globalenvs Smallstep AST Integers Events Behaviors Errors Memory.
Require Import Coqlib.
Require Import ITreelib.
Require Import ImpPrelude.
Require Import Skeleton.
Require Import PCM.
Require Import STS Behavior.
Require Import Any.
Require Import ModSem.
Require Import Imp.

Require Import Imp2Csharpminor.
Require Import Imp2CsharpminorMatch.
Require Import Imp2CsharpminorGenv.

From compcert Require Import Csharpminor.

Set Implicit Arguments.

Ltac unfold_Int64_modulus := unfold Int64.modulus, Int64.wordsize, Wordsize_64.wordsize in *.
Ltac unfold_Int64_max_signed := unfold Int64.max_signed, Int64.half_modulus in *; unfold_Int64_modulus.
Ltac unfold_Int64_min_signed := unfold Int64.min_signed, Int64.half_modulus in *; unfold_Int64_modulus.
Ltac unfold_Ptrofs_modulus := unfold Ptrofs.modulus, Ptrofs.wordsize, Wordsize_Ptrofs.wordsize in *.
Ltac unfold_Ptrofs_half_modulus := unfold Ptrofs.half_modulus in *; unfold_Ptrofs_modulus.
Ltac unfold_Int_modulus := unfold Int.modulus, Int.wordsize, Wordsize_32.wordsize in *.
Ltac unfold_Int_max_signed := unfold Int.max_signed, Int.half_modulus in *; unfold_Int_modulus.
Ltac unfold_Int_min_signed := unfold Int.min_signed, Int.half_modulus in *; unfold_Int_modulus.

Section ARITH.

  Context `{Σ: GRA.t}.
  Context `{builtins : builtinsTy}.

  Lemma int64_ptrofs :
    Ptrofs.modulus = Int64.modulus.
  Proof. unfold_Int64_modulus. unfold_Ptrofs_modulus. des_ifs. Qed.

  Lemma int64_ext
        i0 i1
        (INTVAL: (Int64.intval i0) = (Int64.intval i1))
    :
      i0 = i1.
  Proof.
    destruct i0, i1. ss. clarify. f_equal. apply proof_irrelevance.
  Qed.

  Lemma int64_mod_ext
        i0 i1
        (INTVAL: ((Int64.intval i0) mod Int64.modulus)%Z = ((Int64.intval i1) mod Int64.modulus)%Z)
    :
      i0 = i1.
  Proof.
    destruct i0, i1. ss. rewrite Z.mod_small in INTVAL; try lia. rewrite Z.mod_small in INTVAL; try lia.
    eapply int64_ext; eauto.
  Qed.

  Lemma ptrofs_ext
        i0 i1
        (INTVAL: (Ptrofs.intval i0) = (Ptrofs.intval i1))
    :
      i0 = i1.
  Proof.
    destruct i0, i1. ss. clarify. f_equal. apply proof_irrelevance.
  Qed.

  Lemma ptrofs_mod_ext
        i0 i1
        (INTVAL: ((Ptrofs.intval i0) mod Ptrofs.modulus)%Z = ((Ptrofs.intval i1) mod Ptrofs.modulus)%Z)
    :
      i0 = i1.
  Proof.
    destruct i0, i1. ss. rewrite Z.mod_small in INTVAL; try lia. rewrite Z.mod_small in INTVAL; try lia.
    eapply ptrofs_ext; eauto.
  Qed.

  Lemma unwrap_Ptrofs_Int64_z
        (z: Z)
        (UB: modrange_64 z = true)
    :
      (Ptrofs.unsigned (Ptrofs.of_int64 (Int64.repr (z)))) = z.
  Proof.
    unfold_modrange_64. bsimpl. des.
    apply sumbool_to_bool_true in UB.
    apply sumbool_to_bool_true in UB0.
    unfold Ptrofs.of_int64.
    hexploit (Int64.unsigned_repr z).
    { unfold Int64.max_unsigned. unfold_Int64_modulus. split; try nia. }
    i. rewrite H. clear H.
    apply (Ptrofs.unsigned_repr z).
    unfold Ptrofs.max_unsigned. unfold_Ptrofs_modulus. des_ifs. split; try nia.
  Qed.

  Lemma unwrap_Ptrofs_repr_z
        z
        (UB: modrange_64 z = true)
    :
      (Ptrofs.unsigned (Ptrofs.repr z)) = z.
  Proof.
    unfold_modrange_64. bsimpl. des.
    apply sumbool_to_bool_true in UB.
    apply sumbool_to_bool_true in UB0.
    apply Ptrofs.unsigned_repr.
    unfold Ptrofs.max_unsigned. unfold_Ptrofs_modulus. des_ifs. lia.
  Qed.

  Lemma map_val_vadd_comm
        src a b v
        (VADD: vadd a b = Some v)
    :
      Values.Val.addl (map_val src a) (map_val src b) = (map_val src v).
  Proof.
    destruct a; destruct b; ss; clarify.
    - ss. repeat f_equal.
      unfold Int64.add.
      rewrite ! Int64.unsigned_repr_eq.
      apply int64_mod_ext.
      f_equal.
      Local Transparent Int64.repr.
      ss. rewrite ! Int64.Z_mod_modulus_eq.
      rewrite <- Z.add_mod; try lia.
      unfold_Int64_modulus. ss.
      Local Opaque Int64.repr.
    - uo; des_ifs. unfold scale_int in *. des_ifs. ss.
      unfold Ptrofs.of_int64 in *.
      f_equal. unfold map_ofs in *.
      unfold scale_ofs in *.
      unfold Z.divide in d. des. clarify. rewrite Z_div_mult in *; try nia.
      assert (COMM: (8 * z)%Z = (z * 8)%Z); try nia. rewrite <- COMM in *; clear COMM.
      rewrite Z.mul_add_distr_l in *. remember (8 * z)%Z as b. remember (8 * ofs)%Z as a.
      clear Heqb Heqa ofs z blk. move a before b.
      rewrite Int64.unsigned_repr_eq.
      rewrite <- int64_ptrofs.
      unfold Ptrofs.add. rewrite <- Ptrofs.unsigned_repr_eq.
      rewrite Ptrofs.repr_unsigned. rewrite ! Ptrofs.unsigned_repr_eq.
      apply ptrofs_ext.
      Local Transparent Ptrofs.repr.
      ss. rewrite ! Ptrofs.Z_mod_modulus_eq.
      rewrite <- Z.add_mod; try lia.
      unfold_Ptrofs_modulus. ss.
      Local Opaque Ptrofs.repr.
    - uo; des_ifs. unfold scale_int in *. des_ifs. ss.
      unfold Ptrofs.of_int64 in *.
      f_equal. unfold map_ofs in *.
      unfold scale_ofs in *.
      unfold Z.divide in d. des. clarify. rewrite Z_div_mult in *; try nia.
      assert (COMM: (8 * z)%Z = (z * 8)%Z); try nia. rewrite <- COMM in *; clear COMM.
      rewrite Z.mul_add_distr_l in *. remember (8 * z)%Z as b. remember (8 * ofs)%Z as a.
      clear Heqb Heqa ofs z blk. move a before b.
      rewrite Int64.unsigned_repr_eq.
      rewrite <- int64_ptrofs.
      unfold Ptrofs.add. rewrite <- Ptrofs.unsigned_repr_eq.
      rewrite Ptrofs.repr_unsigned. rewrite ! Ptrofs.unsigned_repr_eq.
      apply ptrofs_ext.
      Local Transparent Ptrofs.repr.
      ss. rewrite ! Ptrofs.Z_mod_modulus_eq.
      rewrite <- Z.add_mod; try lia.
      unfold_Ptrofs_modulus. ss.
      Local Opaque Ptrofs.repr.
  Qed.

  Lemma map_val_vsub_comm
        src a b v
        (VSUB: vsub a b = Some v)
    :
      Values.Val.subl (map_val src a) (map_val src b) = map_val src v.
  Proof.
    Local Transparent Int64.repr. Local Transparent Ptrofs.repr.
    destruct a; destruct b; ss; clarify.
    - ss. repeat f_equal.
      unfold Int64.sub. rewrite ! Int64.unsigned_repr_eq.
      apply int64_mod_ext. f_equal.
      ss. rewrite ! Int64.Z_mod_modulus_eq.
      rewrite <- Zminus_mod; try lia.
    - uo; des_ifs. unfold scale_int in *. des_ifs. ss. unfold Ptrofs.of_int64 in *.
      f_equal. unfold map_ofs in *. unfold scale_ofs in *.
      unfold Z.divide in d. des. clarify. rewrite Z_div_mult in *; try nia.
      assert (COMM: (8 * z)%Z = (z * 8)%Z); try nia. rewrite <- COMM in *; clear COMM.
      rewrite Z.mul_sub_distr_l in *. remember (8 * z)%Z as b. remember (8 * ofs)%Z as a.
      clear Heqb Heqa ofs z blk. move a before b.
      rewrite Int64.unsigned_repr_eq.
      rewrite <- int64_ptrofs.
      unfold Ptrofs.sub. rewrite <- Ptrofs.unsigned_repr_eq.
      rewrite Ptrofs.repr_unsigned. rewrite ! Ptrofs.unsigned_repr_eq.
      apply ptrofs_ext.
      ss. rewrite ! Ptrofs.Z_mod_modulus_eq.
      rewrite <- Zminus_mod; try lia.
    - uo; des_ifs.
      2:{ exfalso; apply n. f_equal. bsimpl. apply Nat.eqb_eq in Heq0. clarify. }
      apply Nat.eqb_eq in Heq0. clarify; ss. repeat f_equal.
      unfold Ptrofs.of_int64 in *. unfold map_ofs in *. unfold scale_ofs in *.
      rewrite Z.mul_sub_distr_l in *. remember (8 * ofs0)%Z as b. remember (8 * ofs)%Z as a.
      clear Heqb Heqa ofs ofs0 e blk0. move a before b.
      unfold Ptrofs.to_int64.
      unfold Ptrofs.sub. ss.
      rewrite ! Ptrofs.Z_mod_modulus_eq.
      rewrite ! int64_ptrofs. rewrite <- Zminus_mod.
      apply int64_mod_ext.
      ss. rewrite ! Int64.Z_mod_modulus_eq.
      rewrite ! Zmod_mod. ss.
      Local Opaque Int64.repr. Local Opaque Ptrofs.repr.
  Qed.

  Lemma map_val_vmul_comm
        src a b v
        (VMUL: vmul a b = Some v)
    :
      Values.Val.mull (map_val src a) (map_val src b) = map_val src v.
  Proof.
    Local Transparent Int64.repr.
    destruct a; destruct b; ss; clarify.
    ss. repeat f_equal.
    unfold Int64.mul. rewrite ! Int64.unsigned_repr_eq.
    apply int64_mod_ext. f_equal.
    ss. rewrite ! Int64.Z_mod_modulus_eq.
    rewrite <- Zmult_mod; try lia.
    Local Opaque Int64.repr.
  Qed.

End ARITH.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Object Primitives                                      *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib.
Require Import Maps.
Require Import AuxStateDataType.
Require Import FlatMemory.
Require Import AbstractDataType.
Require Import Integers.
Require Import Values.
Require Import Constant.
Require Import RealParams.

Section OBJ_PMM.

  Context `{real_params: RealParams}.

  (** primitve: returns whether i-th page has type "normal"*)
  Function is_at_norm_spec (i: Z) (adt: RData) : option Z :=
    match (ikern adt, ihost adt) with
      | (true, true) =>
        if zle_lt 0 i maxpage then
          match ZMap.get i (AT adt) with
            | ATValid _ st _ =>
              if ATType_dec st ATNorm then Some 1
              else Some 0
            | _ => None
          end
        else None
      | _ => None
    end.

  (** primitve: returns whether i-th page is allocated or not*)
  Function get_at_u_spec (i: Z) (adt: RData) : option Z :=
    match (ikern adt, ihost adt) with
      | (true, true) =>
        if zle_lt 0 i maxpage then
          match ZMap.get i (AT adt) with
            | ATValid true _ _ => Some 1
            | ATValid _ _ _ => Some 0
            | _ => None
          end
        else None
      | _ => None
    end.

  (** primitve: returns whether i-th page is allocated or not*)
  Function get_at_c_spec (i: Z) (adt: RData) : option Z :=
    match (ikern adt, ihost adt) with
      | (true, true) =>
        if zle_lt 0 i maxpage then
          match ZMap.get i (AT adt) with
            | ATValid _ _ n => Some n
            | _ => None
          end
        else None
      | _ => None
    end.

  (** primitve: get the number of pages*)
  Function get_nps_spec (adt: RData) : option Z :=
    match (ikern adt, ihost adt) with
      | (true, true) => Some (nps adt)
      | _ => None
    end.

  (** primitve: set the allocated-bit of the i-th page*)
  Function set_at_u_spec (i: Z) (b: Z) (adt: RData): option RData :=
    match (ikern adt, ihost adt) with
      | (true, true) =>
        if zle_lt 0 i maxpage then
          match ZtoBool b with
            | Some b' =>
              match ZMap.get i (AT adt) with
                | ATValid b1 ATNorm n => Some adt {AT: ZMap.set i (ATValid b' ATNorm n) (AT adt)}
                | _ => None
              end
            | _ => None
          end
        else None
      | _ => None
    end.

  (** primitve: set the type of the i-th page*)
  Function set_at_norm_spec (i: Z) (n: Z) (adt: RData): option RData :=
    match (ikern adt, ihost adt) with
      | (true, true) =>
        if zle_lt 0 i maxpage then
          match ZtoATType n with
            | Some t => Some adt {AT: ZMap.set i (ATValid false t 0) (AT adt)}
            | _ => None
          end
        else None
      | _ => None
    end.

  Function set_at_c_spec (i: Z) (n: Z) (adt: RData): option RData :=
    match (ikern adt, ihost adt) with
      | (true, true) =>
        if zle_lt 0 i maxpage then
          match ZMap.get i (AT adt) with
            | ATValid b ATNorm _ => Some adt {AT: ZMap.set i (ATValid b ATNorm n) (AT adt)}
            | _ => None
          end
        else None
      | _ => None
    end.

  Function set_at_c0_spec (i: Z) (n: Z) (adt: RData): option RData :=
    match (ikern adt, ihost adt) with
      | (true, true) =>
        if zle_lt 0 i maxpage then
          match ZMap.get i (AT adt) with
            | ATValid true ATNorm _ =>
              Some adt {AT: ZMap.set i (ATValid true ATNorm n) (AT adt)}
            | _ => None
          end
        else None
      | _ => None
    end.

  (** primitve: set number of pages*)
  Function set_nps_spec (n: Z) (adt: RData): option RData :=
    match (ikern adt, ihost adt) with
      | (true, true) => Some adt {nps: n}
      | _ => None
    end.

  (** primitive: initialize the allocation table*)
  Function mem_init_spec (mbi_adr: Z) (adt: RData) : option RData :=
    match (init adt, pg adt, ikern adt, ihost adt) with
      | (false, false, true, true) =>
        Some adt {MM: real_mm} {MMSize: real_size} {vmxinfo: real_vmxinfo} {AT: real_AT (AT adt)}
             {nps: real_nps} {init: true}
      | _ => None
    end.

  (** primitve: free the i-th page, only used in the refienment proof*)
  Function pfree'_spec (i: Z) (adt: RData): option RData :=
    match (ikern adt, ihost adt, init adt) with
      | (true, true, true) =>
        if zle_lt 0 i maxpage then
          match (ZMap.get i (AT adt), ZMap.get i (pperm adt))  with
            | (ATValid true ATNorm 0, PGAlloc) =>
              Some adt {AT: ZMap.set i (ATValid false ATNorm 0) (AT adt)}
                   {pperm: ZMap.set i PGUndef (pperm adt)}
            | _ => None
          end
        else None
      | _ => None
    end.

  (** primitve: alloc a page and returns the page index*)
  Function palloc'_spec (adt: RData): option (RData * Z) :=
    match (ikern adt, init adt, ihost adt) with
      | (true, true, true) =>
          match first_free (AT adt) (nps adt) with
            | inleft (exist i _) =>
              Some (adt {AT: ZMap.set i (ATValid true ATNorm 0) (AT adt)}
                        {pperm: ZMap.set i PGAlloc (pperm adt)}, i)
            | _ => Some (adt, 0)
          end
      | _ => None
    end.

End OBJ_PMM.

Require Import liblayers.compat.CompatGenSem.
Require Import liblayers.compat.CompatLayers.
Require Import CommonTactic.
Require Import RefinementTactic.
Require Import Observation.

Section OBJ_SIM.

  Context `{Hobs: Observation}.

  Context `{data : CompatData(Obs:=Obs) RData}.
  Context `{data0 : CompatData(Obs:=Obs) RData}.

  Context `{Hstencil: Stencil}.
  Context `{Hmem: Mem.MemoryModel}.
  Context `{Hmwd: UseMemWithData mem}.

  Notation HDATAOps := (cdata (cdata_prf := data) RData).
  Notation LDATAOps := (cdata (cdata_prf := data0) RData).

  Context `{rel_prf: CompatRel _ (Obs:=Obs) (memory_model_ops:= memory_model_ops) _
                               (stencil_ops:= stencil_ops) HDATAOps LDATAOps}.

  (** ** The low level specifications exist*)
  Section MEMINIT_SIM.

    Context `{real_params: RealParams}.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_init}.
    Context {re3: relate_impl_AT}.
    Context {re4: relate_impl_nps}.
    Context {re5: relate_impl_MM}.
    Context {re6: relate_impl_vmxinfo}.

    Lemma mem_init_exist:
      forall s habd habd' labd i f,
        mem_init_spec i habd = Some habd'
        -> relate_AbData s f habd labd
        -> exists labd', mem_init_spec i labd = Some labd'
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold mem_init_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_init_eq; eauto; intros.
      exploit relate_impl_AT_eq; eauto; intros.
      revert H; subrewrite. subdestruct.
      inv HQ. refine_split'; trivial.

      apply relate_impl_init_update.
      apply relate_impl_nps_update.
      apply relate_impl_AT_update.
      apply relate_impl_vmxinfo_update.
      apply relate_impl_MMSize_update.
      apply relate_impl_MM_update. assumption.
    Qed.

    Context {mt1: match_impl_init}.
    Context {mt2: match_impl_nps}.
    Context {mt3: match_impl_AT}.
    Context {mt4: match_impl_MM}.
    Context {mt5: match_impl_vmxinfo}.

    Lemma mem_init_match:
      forall s d d' m i f,
        mem_init_spec i d = Some d'
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold mem_init_spec; intros. subdestruct. inv H.
      eapply match_impl_init_update.
      eapply match_impl_nps_update.
      eapply match_impl_AT_update.
      eapply match_impl_vmxinfo_update.
      eapply match_impl_MMSize_update.
      eapply match_impl_MM_update. assumption.
    Qed.

    Context {inv: PreservesInvariants (HD:= data) mem_init_spec}.
    Context {inv0: PreservesInvariants (HD:= data0) mem_init_spec}.

    Lemma mem_init_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem mem_init_spec)
            (id ↦ gensem mem_init_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      exploit mem_init_exist; eauto 1; intros [labd' [HP HM]].
      match_external_states_simpl.
      eapply mem_init_match; eauto.
    Qed.

  End MEMINIT_SIM.

  Section AT_SETTER_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_AT}.
    Context {mt1: match_impl_AT}.

    Section SET_AT_U_SIM.

      Lemma set_at_u_exist:
        forall s habd habd' labd i z f,
          set_at_u_spec i z habd = Some habd'
          -> relate_AbData s f habd labd
          -> exists labd', set_at_u_spec i z labd = Some labd'
                           /\ relate_AbData s f habd' labd'.
      Proof.
        unfold set_at_u_spec; intros.
        exploit relate_impl_iflags_eq; eauto. inversion 1.
        exploit relate_impl_AT_eq; eauto; intros.
        revert H; subrewrite. subdestruct.
        inv HQ. refine_split'; trivial.
        eapply relate_impl_AT_update. assumption.
      Qed.

      Lemma set_at_u_match:
        forall s d d' m i z f,
          set_at_u_spec i z d = Some d'
          -> match_AbData s d m f
          -> match_AbData s d' m f.
      Proof.
        unfold set_at_u_spec; intros. subdestruct.
        inv H. eapply match_impl_AT_update. assumption.
      Qed.

      Context {inv: PreservesInvariants (HD:= data) set_at_u_spec}.
      Context {inv0: PreservesInvariants (HD:= data0) set_at_u_spec}.

      Lemma set_at_u_sim :
        forall id,
          sim (crel RData RData) (id ↦ gensem set_at_u_spec)
              (id ↦ gensem set_at_u_spec).
      Proof.
        intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
        exploit set_at_u_exist; eauto 1; intros [labd' [HP HM]].
        match_external_states_simpl.
        eapply set_at_u_match; eauto.
      Qed.

    End SET_AT_U_SIM.

    Section SET_AT_C_SIM.

      Lemma set_at_c_exist:
        forall s habd habd' labd i z f,
          set_at_c_spec i z habd = Some habd'
          -> relate_AbData s f habd labd
          -> exists labd', set_at_c_spec i z labd = Some labd'
                           /\ relate_AbData s f habd' labd'.
      Proof.
        unfold set_at_c_spec; intros.
        exploit relate_impl_iflags_eq; eauto. inversion 1.
        exploit relate_impl_AT_eq; eauto; intros.
        revert H; subrewrite. subdestruct.
        inv HQ. refine_split'; trivial.
        eapply relate_impl_AT_update. assumption.
      Qed.

      Lemma set_at_c_match:
        forall s d d' m i z f,
          set_at_c_spec i z d = Some d'
          -> match_AbData s d m f
          -> match_AbData s d' m f.
      Proof.
        unfold set_at_c_spec; intros. subdestruct.
        inv H. eapply match_impl_AT_update. assumption.
      Qed.

      Context {inv: PreservesInvariants (HD:= data) set_at_c_spec}.
      Context {inv0: PreservesInvariants (HD:= data0) set_at_c_spec}.

      Lemma set_at_c_sim :
        forall id,
          sim (crel RData RData) (id ↦ gensem set_at_c_spec)
              (id ↦ gensem set_at_c_spec).
      Proof.
        intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
        exploit set_at_c_exist; eauto 1; intros [labd' [HP HM]].
        match_external_states_simpl.
        eapply set_at_c_match; eauto.
      Qed.

    End SET_AT_C_SIM.

    Section SET_AT_C0_SIM.

      Lemma set_at_c0_exist:
        forall s habd habd' labd i z f,
          set_at_c0_spec i z habd = Some habd'
          -> relate_AbData s f habd labd
          -> exists labd', set_at_c0_spec i z labd = Some labd'
                           /\ relate_AbData s f habd' labd'.
      Proof.
        unfold set_at_c0_spec; intros.
        exploit relate_impl_iflags_eq; eauto. inversion 1.
        exploit relate_impl_AT_eq; eauto; intros.
        revert H; subrewrite. subdestruct.
        inv HQ. refine_split'; trivial.
        eapply relate_impl_AT_update. assumption.
      Qed.

      Lemma set_at_c0_match:
        forall s d d' m i z f,
          set_at_c0_spec i z d = Some d'
          -> match_AbData s d m f
          -> match_AbData s d' m f.
      Proof.
        unfold set_at_c0_spec; intros. subdestruct.
        inv H. eapply match_impl_AT_update. assumption.
      Qed.

      Context {inv: PreservesInvariants (HD:= data) set_at_c0_spec}.
      Context {inv0: PreservesInvariants (HD:= data0) set_at_c0_spec}.

      Lemma set_at_c0_sim :
        forall id,
          sim (crel RData RData) (id ↦ gensem set_at_c0_spec)
              (id ↦ gensem set_at_c0_spec).
      Proof.
        intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
        exploit set_at_c0_exist; eauto 1; intros [labd' [HP HM]].
        match_external_states_simpl.
        eapply set_at_c0_match; eauto.
      Qed.

    End SET_AT_C0_SIM.

  End AT_SETTER_SIM.

  Section AT_GETTER_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_AT}.

    Lemma is_at_norm_exist:
      forall s habd labd i z f,
        is_at_norm_spec i habd = Some z
        -> relate_AbData s f habd labd
        -> is_at_norm_spec i labd = Some z.
    Proof.
      unfold is_at_norm_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_AT_eq; eauto; intros.
      revert H; subrewrite.
    Qed.

    Lemma get_at_u_exist:
      forall s habd labd i z f,
        get_at_u_spec i habd = Some z
        -> relate_AbData s f habd labd
        -> get_at_u_spec i labd = Some z.
    Proof.
      unfold get_at_u_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_AT_eq; eauto; intros.
      revert H; subrewrite.
    Qed.

    Lemma get_at_c_exist:
      forall s habd labd i z f,
        get_at_c_spec i habd = Some z
        -> relate_AbData s f habd labd
        -> get_at_c_spec i labd = Some z.
    Proof.
      unfold get_at_c_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_AT_eq; eauto; intros.
      revert H; subrewrite.
    Qed.

    Lemma get_at_c_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem get_at_c_spec)
            (id ↦ gensem get_at_c_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData).
      match_external_states_simpl.
      erewrite get_at_c_exist; eauto. reflexivity.
    Qed.

    Lemma is_at_norm_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem is_at_norm_spec)
            (id ↦ gensem is_at_norm_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData).
      match_external_states_simpl.
      erewrite is_at_norm_exist; eauto. reflexivity.
    Qed.

    Lemma get_at_u_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem get_at_u_spec)
            (id ↦ gensem get_at_u_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData).
      match_external_states_simpl.
      erewrite get_at_u_exist; eauto. reflexivity.
    Qed.

  End AT_GETTER_SIM.

  Section GET_NPS_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_nps}.

    Lemma get_nps_exist:
      forall s habd labd z f,
        get_nps_spec habd = Some z
        -> relate_AbData s f habd labd
        -> get_nps_spec labd = Some z.
    Proof.
      unfold get_nps_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_nps_eq; eauto; intros.
      revert H; subrewrite.
    Qed.

    Lemma get_nps_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem get_nps_spec)
            (id ↦ gensem get_nps_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData).
      match_external_states_simpl.
      erewrite get_nps_exist; eauto. reflexivity.
    Qed.

  End GET_NPS_SIM.

  Section PALLOC'_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_init}.
    Context {re3: relate_impl_AT}.
    Context {re4: relate_impl_nps}.
    Context {re5: relate_impl_pperm}.

    Lemma palloc'_exist:
      forall s habd habd' labd i f,
        palloc'_spec habd = Some (habd', i)
        -> relate_AbData s f habd labd
        -> exists labd', palloc'_spec labd = Some (labd', i)
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold palloc'_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_init_eq; eauto; intros.
      exploit relate_impl_AT_eq; eauto; intros.
      exploit relate_impl_nps_eq; eauto; intros.
      exploit relate_impl_pperm_eq; eauto; intros.
      revert H. subrewrite.
      subdestruct; inv HQ; refine_split'; trivial.

      apply relate_impl_pperm_update.
      apply relate_impl_AT_update. assumption.
    Qed.

    Context {mt1: match_impl_pperm}.
    Context {mt2: match_impl_AT}.

    Lemma palloc'_match:
      forall s d d' m i f,
        palloc'_spec d = Some (d', i)
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold palloc'_spec; intros. subdestruct; inv H; trivial.
      eapply match_impl_pperm_update.
      eapply match_impl_AT_update. assumption.
    Qed.

    Context {inv: PreservesInvariants (HD:= data) palloc'_spec}.
    Context {inv0: PreservesInvariants (HD:= data0) palloc'_spec}.

    Lemma palloc'_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem palloc'_spec)
            (id ↦ gensem palloc'_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      exploit palloc'_exist; eauto 1; intros (labd' & HP & HM).
      match_external_states_simpl.
      eapply palloc'_match; eauto.
    Qed.

  End PALLOC'_SIM.

  Section PFREE'_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_init}.
    Context {re3: relate_impl_AT}.
    Context {re4: relate_impl_nps}.
    Context {re5: relate_impl_pperm}.

    Lemma pfree'_exist:
      forall s habd habd' labd i f,
        pfree'_spec i habd = Some habd'
        -> relate_AbData s f habd labd
        -> exists labd', pfree'_spec i labd = Some labd'
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold pfree'_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_init_eq; eauto; intros.
      exploit relate_impl_AT_eq; eauto; intros.
      exploit relate_impl_pperm_eq; eauto; intros.
      revert H. subrewrite.
      subdestruct; inv HQ; refine_split'; trivial.

      apply relate_impl_pperm_update.
      apply relate_impl_AT_update. assumption.
    Qed.

    Context {mt1: match_impl_pperm}.
    Context {mt2: match_impl_AT}.

    Lemma pfree'_match:
      forall s d d' m i f,
        pfree'_spec i d = Some d'
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold pfree'_spec; intros. subdestruct; inv H; trivial.
      eapply match_impl_pperm_update.
      eapply match_impl_AT_update. assumption.
    Qed.

    Context {inv: PreservesInvariants (HD:= data) pfree'_spec}.
    Context {inv0: PreservesInvariants (HD:= data0) pfree'_spec}.

    Lemma pfree'_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem pfree'_spec)
            (id ↦ gensem pfree'_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      exploit pfree'_exist; eauto 1; intros (labd' & HP & HM).
      match_external_states_simpl.
      eapply pfree'_match; eauto.
    Qed.

  End PFREE'_SIM.

End OBJ_SIM.


From hahn Require Import Hahn.
Require Import PromisingLib.
From Promising Require Import Event.
From imm Require Import Prog.
From imm Require Import ProgToExecution.
From imm Require Import Events.
Require Import Event_imm_promise.

Set Implicit Arguments.
Remove Hints plus_n_O.

Definition lts_step (tid : thread_id) (pe : ProgramEvent.t) (s1 s2 : state) : Prop :=
  exists (labels : list label),
    ⟪ISTEP: istep tid labels s1 s2⟫ /\
    ⟪LABS : lab_imm_promise labels pe⟫.

Definition thread_lts (tid : thread_id) : Language.t ProgramEvent.t :=
  @Language.mk ProgramEvent.t
    (list Instr.t) state
    init
    is_terminal
    (lts_step tid).


(* * FOL Reductions *)

From Undecidability.DiophantineConstraints Require Import H10C.
From Undecidability.DiophantineConstraints.Util Require Import H10UPC_facts.
From Undecidability.FOL Require Import Syntax.Facts Deduction.FragmentNDFacts Semantics.Tarski.FragmentSoundness Semantics.Tarski.FragmentFacts Syntax.BinSig Semantics.Kripke.FragmentCore  Semantics.Kripke.FragmentSoundness Semantics.Kripke.FragmentToTarski.
From Undecidability.Shared Require Import Dec.
From Undecidability.Shared.Libs.PSL Require Import Numbers.
From Coq Require Import Arith Lia List.
From Undecidability.FOL.Reductions Require Import H10UPC_to_FOL_friedman H10UPC_to_FOL_constructions.

(* ** Validity *)

(*
Idea: The relation (###) has the following properties:#
#
#
#n ~ p: n is left component of p#
#
#
#p ~ n: p is right component of p#
#
#
#p ~ p: the special relationship of H10UPC#
#
#
#n ~ m: n = m. Special case n=0, m=1: #
#
          The instance h10 of H10UPC is a yes-instance. #
#
          This is to facilitate Friedman translation#
#
*)

Set Default Goal Selector "!".

Require Import Undecidability.Synthetic.Definitions.

(* Final collection of undecidability reductions *)
Section undecResults.

  Definition minimalSignature (f:funcs_signature) (p:preds_signature) : Prop :=
    match f,p with
     {|syms := F; ar_syms := aF|},{|preds := P; ar_preds := aP|}
       => (F -> False) /\ exists pp : P, aP pp = 2
    end.

  Lemma sig_is_minimal : minimalSignature sig_empty sig_binary.
  Proof.
  split.
  * intros [].
  * now exists tt.
  Qed.

  Theorem validReduction : H10UPC_SAT ⪯ @valid sig_empty sig_binary falsity_off.
  Proof.
  exists (fun l => @F falsity_off l). split.
  * apply transport.
  * apply inverseTransport.
  Qed.

  Theorem satisReduction : complement H10UPC_SAT ⪯ @satis sig_empty sig_binary falsity_on.
  Proof.
  exists (fun l => @F falsity_on l → falsity). split.
  * apply satisTransport.
  * apply satisInverseTransport.
  Qed.

  Theorem proveReduction : H10UPC_SAT ⪯ (fun (k:@form sig_empty sig_binary frag_operators falsity_off) => nil ⊢M k).
  Proof.
  exists (fun l => @F falsity_off l). split.
  * apply proofTransport.
  * apply inverseProofTransport.
  Qed.

  Theorem classicalProveReduction :
    H10UPC_SAT ⪯ (fun (k:@form sig_empty sig_binary frag_operators falsity_off) => nil ⊢C k).
  Proof.
  exists (fun l => @F falsity_off l). split.
  * apply classicalProvabilityTransport.
  * apply classicalProvabilityInverseTransport.
  Qed.

  Theorem kripkeValidReduction : H10UPC_SAT ⪯ @kvalid sig_empty sig_binary falsity_off.
  Proof.
  exists (fun l => @F falsity_off l). split.
  * apply kripkeTransport.
  * apply kripkeInverseTransport.
  Qed.

  Theorem kripkeSatisReduction : complement H10UPC_SAT ⪯ @ksatis sig_empty sig_binary falsity_on.
  Proof.
  exists (fun l => @F falsity_on l → falsity). split.
  * apply ksatisTransport.
  * apply ksatisInverseTransport.
  Qed.

End undecResults.