Require Export cgraphs.cgraphs.genericinv.
Require Export cgraphs.multiparty.langdef.
Require Export cgraphs.multiparty.rtypesystem.
Require Export cgraphs.multiparty.mutil.

Ltac sdec := repeat case_decide; simplify_eq; simpl in *; eauto; try done.
Ltac smap := repeat (rewrite lookup_alter_spec || rewrite lookup_insert_spec || rewrite lookup_delete_spec || sdec).

Section pushpop.

  Lemma pop_push_None `{Countable A, Countable B} {V}
      (p p' : A) (q q' : B) (x : V) (bufs : bufsT A B V) :
    p ≠ p' ∨ q ≠ q' ->
    pop p' q' bufs = None ->
    pop p' q' (push p q x bufs) = None.
  Proof.
    intros Hne Hpop.
    unfold pop,push in *.
    smap; destruct (bufs !! q'); smap;
    destruct (g !! p'); smap;
    destruct l; smap; destruct Hne; smap.
  Qed.

  Lemma pop_push_Some `{Countable A, Countable B} {V}
      (p p' : A) (q q' : B) (x x' : V) (bufs bufs' : bufsT A B V) :
    pop p' q' bufs = Some (x', bufs') ->
    pop p' q' (push p q x bufs) = Some (x', push p q x bufs').
  Proof.
    unfold pop,push.
    intros Q. smap;
    destruct (bufs !! q'); smap;
    destruct (g !! p'); smap;
    destruct l; smap; do 2 f_equal;
    apply map_eq; intro; smap;
    f_equal; apply map_eq; intro; smap.
  Qed.

  Lemma pop_push_single `{Countable A, Countable B} {V}
      (p : A) (q : B) (x : V) (bufs : bufsT A B V) :
    is_present p q bufs ->
    pop p q bufs = None ->
    pop p q (push p q x bufs) = Some (x, bufs).
  Proof.
    intros Hpres Hpop.
    unfold is_present,pop,push in *.
    smap; destruct (bufs !! q) eqn:E; smap;
    destruct (g !! p) eqn:F; smap;
    destruct l; smap.
    do 2 f_equal. apply map_eq; intro; smap.
    rewrite E. f_equal.
    apply map_eq. intro. smap.
  Qed.

  Lemma pop_is_present `{Countable A, Countable B} {V}
      (p p' : A) (q q' : B) (x : V) (bufs bufs' : bufsT A B V) :
    pop p' q' bufs = Some (x, bufs') ->
    is_present p q bufs -> is_present p q bufs'.
  Proof.
    intros Hpop Hpres.
    unfold pop,is_present in *.
    destruct (bufs !! q') eqn:E; smap.
    destruct (g !! p') eqn:E'; smap.
    destruct l eqn:E''; smap.
    destruct (bufs !! q) eqn:F; smap.
  Qed.

  Lemma pop_swap `{Countable A, Countable B} {V}
      (p p' : A) (q q' : B) (x y : V) (bufs bufs' bufs'' : bufsT A B V) :
    q ≠ q' ->
    pop p q bufs = Some (x, bufs') ->
    pop p' q' bufs = Some (y, bufs'') ->
    match pop p q bufs'' with
    | None => False
    | Some (z,_) => x = z
    end.
  Proof.
    unfold pop. intros.
    destruct (bufs !! q) eqn:E; smap.
    destruct (g !! p) eqn:E'; smap.
    destruct l eqn:E''; smap.
    destruct (bufs !! q') eqn:F; smap.
    destruct (g0 !! p') eqn:F'; smap.
    destruct l eqn:F''; smap.
    destruct (bufs !! q) eqn:Q; smap.
    destruct (g !! p) eqn:Q'; smap.
  Qed.

  Lemma pop_swap' `{Countable A, Countable B} {V}
      (p p' : A) (q q' : B) (x y : V) (bufs bufs' bufs'' : bufsT A B V) :
    q ≠ q' ->
    pop p q bufs = Some (x, bufs') ->
    pop p' q' bufs = Some (y, bufs'') ->
    ∃ bufs''', pop p q bufs'' = Some (x, bufs''').
  Proof.
    intros.
    eapply pop_swap in H1; eauto.
    destruct (pop p q bufs''); sdec. destruct p0. subst.
    eauto.
  Qed.

  Definition dom_valid {A} (bufss : bufsT participant participant A) (d : gset participant) :=
    ∀ p, match bufss !! p with
         | Some bufs => p ∈ d ∧ ∀ q, q ∈ d ->
            match bufs !! q with Some _ => True | None => False end
         | None => p ∉ d
         end.

  Lemma dom_valid_push {A} d p q x (bufss : bufsT participant participant A) :
    p ∈ d ->
    dom_valid bufss d ->
    dom_valid (push p q x bufss) d.
  Proof.
    intros Hin Hdom p'.
    unfold dom_valid in *.
    specialize (Hdom p').
    unfold push. smap;
    destruct (bufss !! p') eqn:E; smap.
    destruct Hdom. split; eauto.
    intros q. specialize (H0 q).
    smap. destruct (g !! q) eqn:F; smap.
  Qed.

  Lemma dom_valid_is_present {A} p q (bufs : bufsT participant participant A) d :
    dom_valid bufs d ->
    p ∈ d -> q ∈ d ->
    is_present p q bufs.
  Proof.
    intros Hdv Hp Hq.
    unfold dom_valid, is_present in *.
    specialize (Hdv q).
    destruct (bufs !! q); smap. destruct Hdv.
    specialize (H0 p).
    destruct (g !! p); smap.
  Qed.

  Lemma dom_valid_empty {A} : dom_valid (∅ : bufsT participant participant A) ∅.
  Proof.
    intros ?. rewrite lookup_empty. set_solver.
  Qed.

  Lemma dom_valid_empty_inv {A} d : dom_valid (∅ : bufsT participant participant A) d -> d = ∅.
  Proof.
    intros Hdom. cut (¬ ∃ x, x ∈ d); try set_solver.
    intros []. unfold dom_valid in *.
    specialize (Hdom x).
    rewrite lookup_empty in Hdom. set_solver.
  Qed.

  Lemma dom_valid_pop {A} p q (bufs bufs' : bufsT participant participant A) x d :
    pop p q bufs = Some (x, bufs') ->
    dom_valid bufs d ->
    dom_valid bufs' d.
  Proof.
    intros Hpop Hdom r.
    specialize (Hdom r).
    unfold pop in *.
    destruct (bufs !! q) eqn:E; smap.
    destruct (g !! p) eqn:E'; smap.
    destruct l eqn:E''; smap.
    destruct (bufs !! r) eqn:F; smap.
    destruct Hdom; split; smap.
    intros q. specialize (H0 q). smap.
  Qed.

  Lemma dom_valid_delete {A} p d (bufss : bufsT participant participant A) :
    dom_valid bufss d ->
    dom_valid (delete p bufss) (d ∖ {[ p ]}).
  Proof.
    intros Hdv.
    unfold dom_valid in *.
    intros q. specialize (Hdv q).
    rewrite lookup_delete_spec. smap; first set_solver.
    destruct (bufss !! q); smap; set_solver.
  Qed.

  Lemma pop_delete_None `{Countable A, Countable B} {V}
    (p : A) (q q' : B) (m : bufsT A B V):
    pop p q m = None ->
    pop p q (delete q' m) = None.
  Proof.
    unfold pop in *. intros.
    rewrite lookup_delete_spec. sdec.
    destruct (m !! q); sdec.
    destruct (g !! p); eauto.
    destruct l; sdec.
  Qed.

  Lemma bufs_empty_delete {A} (bufs : bufsT participant participant A) p :
    bufs_empty bufs -> bufs_empty (delete p bufs).
  Proof.
    intros ???. eauto using pop_delete_None.
  Qed.

  Lemma pop_delete_Some `{Countable A, Countable B} {V} (p : A) (q q' : B) (x : V) bufss bufs' :
    q ≠ q' ->
    pop p q bufss = Some (x, bufs') ->
    pop p q (delete q' bufss) = Some (x, delete q' bufs').
  Proof.
    intros ? Hpop. unfold pop in *.
    rewrite !lookup_delete_spec. smap.
    destruct (bufss !! q) eqn:E; smap.
    destruct (g !! p) eqn:F; smap.
    destruct l; smap.
    do 2 f_equal.
    apply map_eq. intro.
    smap; rewrite !lookup_delete_spec; smap.
  Qed.

  Lemma pop_pop_None `{Countable A, Countable B} {V} (p p' : A) (q q' : B) (x : V) bufs bufs' :
    pop p q bufs = Some (x, bufs') ->
    pop p' q' bufs = None ->
    pop p' q' bufs' = None.
  Proof.
    intros H1 H2.
    unfold pop in *.
    destruct (bufs !! q) eqn:E; smap.
    destruct (g !! p) eqn:E'; smap.
    destruct l eqn:E''; smap;
    destruct (bufs !! q') eqn:F; smap;
    destruct (g !! p') eqn:F'; smap;
    try destruct l eqn:F''; smap;
    destruct (g0 !! p') eqn:G; smap;
    destruct l eqn:G'; smap.
  Qed.

  Lemma pop_commute `{Countable A, Countable B} {V} (p p' : A) (q q' : B) (x y : V) bufs bufs1 bufs2 bufs12 :
    pop p q bufs = Some (x, bufs1) ->
    pop p' q' bufs = Some (y, bufs2) ->
    pop p q bufs2 = Some (x, bufs12) ->
    pop p' q' bufs1 = Some (y, bufs12).
  Proof.
    intros H1 H2 H3.
    unfold pop in *.
    destruct (bufs !! q) eqn:E; smap.
    destruct (bufs !! q') eqn:F; smap.
    destruct (bufs2 !! q) eqn:G; smap.
    destruct (g !! p) eqn:E'; smap.
    destruct (g0 !! p') eqn:F'; smap.
    destruct (g1 !! p) eqn:G'; smap.
    destruct l eqn:E'';
    destruct l0 eqn:F'';
    destruct l1 eqn:G''; smap.
    - revert G; smap. intros; smap. revert G'; smap. intros; smap.
    - revert G; smap. intros; smap. revert G'; smap.
      intros. destruct (g !! p'); smap.
      do 2 f_equal. apply map_eq. intros. smap.
      f_equal. apply map_eq; intros; smap.
    - revert G; smap. intros.
      destruct (bufs !! q'); smap.
      destruct (g0 !! p'); smap.
      do 2 f_equal. apply map_eq. intros. smap.
  Qed.

End pushpop.

Section bufs_typed.

  Lemma sbufs_typed_push
      (bufs : bufsT participant participant sentryT)
      (σs : gmap participant session_type)
      (n : nat) (i : fin n) (p q : participant) ts ss :
    sbufs_typed bufs σs ->
    σs !! p = Some (SendT n q ts ss) ->
    sbufs_typed (push p q (fin_to_nat i,ts i) bufs) (<[p:=ss i]> σs).
  Proof.
    intros. edestruct sbufs_typed_send; eauto.
  Qed.

  Lemma sbufs_typed_pop
      (bufs : bufsT participant participant sentryT)
      (σs : gmap participant session_type)
      (bufs' : bufsT participant participant sentryT)
      (n : nat) (p q : participant) t i ts ss :
    sbufs_typed bufs σs ->
    σs !! q = Some (RecvT n p ts ss) ->
    pop p q bufs = Some((i,t),bufs') ->
      ∃ i', i = fin_to_nat i' ∧ t = ts i' ∧
            sbufs_typed bufs' (<[ q := ss i' ]> σs).
  Proof.
    intros. eapply sbufs_typed_recv; eauto.
  Qed.

  Lemma sbufs_Some_present p q n ts ss (i : fin n)
      (bufs : bufsT participant participant sentryT)
      (σs : gmap participant session_type) :
    sbufs_typed bufs σs ->
    σs !! p = Some (SendT n q ts ss) ->
    is_present p q bufs.
  Proof.
    intros. edestruct sbufs_typed_send; eauto. Unshelve. eauto.
  Qed.

  Lemma sbufs_typed_dealloc p
      (bufs : bufsT participant participant sentryT)
      (σs : gmap participant session_type) :
    sbufs_typed bufs σs ->
    σs !! p = Some EndT ->
    sbufs_typed (delete p bufs) (delete p σs).
  Proof.
    intros. eapply sbufs_typed_end; eauto.
  Qed.

  Lemma sbufs_typed_end_empty p
      (bufs : bufsT participant participant sentryT)
      (σs : gmap participant session_type) :
    sbufs_typed bufs σs ->
    σs !! p = Some EndT ->
    buf_empty bufs p.
  Proof.
    intros. edestruct sbufs_typed_end; eauto.
  Qed.

  Lemma sbufs_typed_empty_inv
      (bufs : bufsT participant participant sentryT)
      (σs : gmap participant session_type) :
    sbufs_typed bufs σs ->
    bufs = ∅ -> σs = ∅.
  Proof.
    intros.
    eapply sbufs_typed_dom in H. subst.
    rewrite dom_empty_L in H. symmetry in H.
    rewrite dom_empty_iff_L in H. done.
  Qed.

  Lemma sbufs_typed_pop' (σs : gmap participant session_type)
    (bufs bufs' : bufsT participant participant sentryT)
    (n : nat) (p q : participant) t i ts ss :
    σs !! q = Some (RecvT n p ts ss) ->
    pop p q bufs = Some((i,t),bufs') ->
    sbufs_typed bufs σs -> ∃ i', i = fin_to_nat i' ∧ t = ts i' ∧
      sbufs_typed bufs' (<[ q := ss i' ]> σs).
  Proof.
    intros.
    eapply sbufs_typed_pop; first done; eauto.
  Qed.

  Lemma sbufs_typed_empty :
    sbufs_typed ∅ ∅.
  Proof.
    constructor; sdec. rewrite !dom_empty_L //.
  Qed.

  Definition entries_typed (bufs : bufsT participant participant entryT)
                           (sbufs : bufsT participant participant sentryT) : rProp :=
    [∗ map] p ↦ bfs;sbfs ∈ bufs;sbufs,
      [∗ map] q ↦ buf;sbuf ∈ bfs;sbfs,
        [∗ list] e;se ∈ buf;sbuf, ⌜⌜ e.1 = se.1 ⌝⌝ ∗ val_typed e.2 se.2.

  Definition bufs_typed (bufs : bufsT participant participant entryT)
                        (σs : gmap participant session_type) : rProp :=
    ∃ sbufs, ⌜⌜ sbufs_typed sbufs σs ⌝⌝ ∗ entries_typed bufs sbufs.

  Global Instance bufs_typed_params : Params bufs_typed 1 := {}.

  Global Instance session_typed_leibniz : LeibnizEquiv session_type.
  Proof.
    intros ???. apply session_type_extensionality. done.
  Qed.

  Global Instance sbufs_typed_Proper bufs : Proper ((≡) ==> (≡)) (sbufs_typed bufs).
  Proof.
    intros ???. apply leibniz_equiv in H. subst. reflexivity.
  Qed.

  Global Instance bufs_typed_Proper bufs : Proper ((≡) ==> (≡)) (bufs_typed bufs).
  Proof. solve_proper. Qed.

  Definition same_structure (bufs : bufsT participant participant entryT) (sbufs : bufsT participant participant sentryT) :=
    ∀ p, match bufs !! p, sbufs !! p with
         | Some bfs, Some sbfs =>
           ∀ q, match bfs !! q, sbfs !! q with
                | Some buf, Some sbuf =>
                  ∀ i, match buf !! i, sbuf !! i with
                       | Some (i,v),Some(i',t) => i = i'
                       | None,None => True
                       | _,_ => False
                       end
                | None,None => True
                | _,_ => False
                end
          | None,None => True
          | _,_ => False
          end.

  Lemma entries_typed_same_structure bufs sbufs :
    entries_typed bufs sbufs -∗ ⌜ same_structure bufs sbufs ⌝.
  Proof.
    iIntros "H".
    unfold entries_typed.
    iIntros (p).
    iDestruct (big_sepM2_dom with "H") as %Q.
    destruct (bufs !! p) eqn:E;
    destruct (sbufs !! p) eqn:F; eauto.
    - iDestruct (big_sepM2_lookup_acc with "H") as "[H _]"; eauto.
      iIntros (q).
      clear Q bufs sbufs E F.
      iDestruct (big_sepM2_dom with "H") as %Q.
      destruct (g !! q) eqn:E;
      destruct (g0 !! q) eqn:F; eauto.
      + iIntros (i).
        iDestruct (big_sepM2_lookup_acc with "H") as "[H _]"; eauto.
        clear Q E F g g0.
        iDestruct (big_sepL2_length with "H") as %Q.
        destruct (l !! i) eqn:E;
        destruct (l0 !! i) eqn:F; eauto.
        * iDestruct (big_sepL2_lookup_acc with "H") as "[[% _] _]"; eauto.
          destruct p0,p1; sdec.
        * exfalso.
          apply lookup_lt_Some in E.
          apply lookup_ge_None in F. lia.
        * exfalso.
          apply lookup_lt_Some in F.
          apply lookup_ge_None in E. lia.
      + exfalso.
        assert (q ∈ dom g). { apply elem_of_dom. rewrite E //. }
        assert (q ∉ dom g0). { apply not_elem_of_dom. done. }
        rewrite Q in H. set_solver.
      + exfalso.
        assert (q ∈ dom g0). { apply elem_of_dom. rewrite F //. }
        assert (q ∉ dom g). { apply not_elem_of_dom. done. }
        rewrite -Q in H. set_solver.
    - exfalso.
      assert (p ∈ dom bufs). { apply elem_of_dom. rewrite E //. }
      assert (p ∉ dom sbufs). { apply not_elem_of_dom. done. }
      rewrite Q in H. set_solver.
    - exfalso.
      assert (p ∈ dom sbufs). { apply elem_of_dom. rewrite F //. }
      assert (p ∉ dom bufs). { apply not_elem_of_dom. done. }
      rewrite -Q in H. set_solver.
  Qed.

  Lemma push_is_Some `{Countable A, Countable B} {V} p q r x (bufs : bufsT A B V) :
    is_Some (bufs !! r) -> is_Some (push p q x bufs !! r).
  Proof.
    intros [].
    unfold push.
    smap. rewrite H1. smap.
  Qed.

  Lemma delete_push `{Countable A, Countable B} {V} p q x (bufs : bufsT A B V) :
    delete q (push p q x bufs) = delete q bufs.
  Proof.
    apply map_eq. intros i. smap.
  Qed.

  Lemma delete_alter `{Countable A} {V} (i : A) (m : gmap A V) f :
    delete i (alter f i m) = delete i m.
  Proof.
    apply map_eq. intro. smap.
  Qed.

  Lemma entries_typed_push  bufs sbufs p q i v t :
    is_present p q sbufs ->
    val_typed v t -∗
    entries_typed bufs sbufs -∗
    entries_typed (push p q (i, v) bufs) (push p q (i, t) sbufs).
  Proof.
    iIntros (Hpres) "Hv He".
    iDestruct (big_sepM2_lookup_iff with "He") as %Q.
    assert (is_Some (sbufs !! q)) as [x1 Hx1].
    { unfold is_present in *. destruct (sbufs !! q); smap. }
    assert (is_Some (bufs !! q)) as [x2 Hx2] by rewrite Q //.
    assert (is_Some (push p q (i, v) bufs !! q)) as [] by eauto using push_is_Some.
    assert (is_Some (push p q (i, t) sbufs !! q)) as [] by eauto using push_is_Some.
    unfold entries_typed.
    rewrite big_sepM2_delete; eauto.
    iApply big_sepM2_delete; eauto.
    rewrite !delete_push.
    iDestruct "He" as "[H He2]". iFrame.
    unfold is_present in *.
    rewrite Hx1 in Hpres.
    destruct (x1 !! p) eqn:G; sdec. clear Hpres Q.
    iDestruct (big_sepM2_lookup_iff with "H") as %Q.
    assert (is_Some (x2 !! p)) as [l' G'] by rewrite Q //.
    rewrite big_sepM2_delete; eauto.
    iDestruct "H" as "[H1 H2]".
    unfold push in *.
    revert H H0.
    smap. rewrite Hx1 Hx2. simpl. intros. smap.
    assert (is_Some (alter (λ buf : list (nat * val), buf ++ [(i, v)]) p x2 !! p)) as [].
    { smap. rewrite G' //. }
    assert (is_Some (alter (λ buf : list (nat * type), buf ++ [(i, t)]) p x1 !! p)) as [].
    { smap. rewrite G //. }
    iApply big_sepM2_delete; eauto.
    rewrite !delete_alter. iFrame.
    revert H H0. smap. rewrite G G'.
    intros. smap.
    rewrite big_sepL2_snoc. iFrame. simpl. done.
  Qed.

  Lemma bufs_typed_push' (bufss : bufsT participant participant entryT)
                        (σs : gmap participant session_type)
                        (n : nat) (i : fin n) (p q : participant) ts ss v :
    σs !! p = Some (SendT n q ts ss) ->
    val_typed v (ts i) ∗ bufs_typed bufss σs ⊢
        bufs_typed (push p q (fin_to_nat i,v) bufss) (<[p:=ss i]> σs).
  Proof.
    iIntros (Hp) "[Hv H]".
    iDestruct "H" as (sbufs Hsbufs) "H".
    iExists (push p q (fin_to_nat i, ts i) sbufs).
    iSplit.
    - iPureIntro. eapply sbufs_typed_push; eauto.
    - iApply (entries_typed_push with "Hv H"); eauto.
      eapply sbufs_Some_present; done.
  Qed.

  Lemma entries_typed_can_pop p q bufs bufs' sbufs  i v :
    pop p q bufs = Some ((i,v),bufs') ->
    entries_typed bufs sbufs -∗
    ⌜ ∃ t sbufs', pop p q sbufs = Some ((i,t),sbufs') ⌝.
  Proof.
    iIntros (Hpop) "H".
    iDestruct (entries_typed_same_structure with "H") as %Q.
    iPureIntro.
    unfold pop in *.
    destruct (bufs !! q) eqn:E; smap.
    destruct (g !! p) eqn:E'; smap.
    destruct l eqn:E''; smap.
    specialize (Q q).
    rewrite E in Q.
    destruct (sbufs !! q) eqn:F; smap.
    specialize (Q p).
    rewrite E' in Q.
    destruct (g0 !! p) eqn:F'; smap.
    specialize (Q 0). simpl in *.
    destruct l eqn:F''; smap. destruct s. smap.
  Qed.

  Lemma entries_typed_pop p q i v t bufs bufs' sbufs sbufs' :
    pop p q bufs = Some (i, v, bufs') ->
    pop p q sbufs = Some (i, t, sbufs') ->
    entries_typed bufs sbufs ⊢ val_typed v t ∗ entries_typed bufs' sbufs'.
  Proof.
    iIntros (Hpop Hspop) "H".
    unfold pop in *.
    destruct (bufs !! q) eqn:E; smap.
    destruct (g !! p) eqn:E'; smap.
    destruct l eqn:E''; smap.
    destruct (sbufs !! q) eqn:F; smap.
    destruct (g0 !! p) eqn:F'; smap.
    destruct l eqn:F''; smap.
    unfold entries_typed.
    rewrite !big_sepM2_insert_delete.
    rewrite big_sepM2_delete; eauto.
    iDestruct "H" as "[H H2]". iFrame.
    rewrite big_sepM2_delete; eauto.
    iDestruct "H" as "[H H2]". iFrame.
    rewrite big_sepL2_cons.
    iDestruct "H" as "[H H2]". iFrame.
    iDestruct "H" as "[H H2]". iFrame.
  Qed.

  Lemma bufs_typed_pop' (σs : gmap participant session_type)
    (bufs bufs' : bufsT participant participant entryT)
    (n : nat) (p q : participant) v i ts ss :
    σs !! q = Some (RecvT n p ts ss) ->
    pop p q bufs = Some((i,v),bufs') ->
    bufs_typed bufs σs ⊢ ∃ i', ⌜⌜ i = fin_to_nat i' ⌝⌝ ∗
      val_typed v (ts i') ∗ bufs_typed bufs' (<[ q := ss i' ]> σs).
  Proof.
    iIntros (Hp Hpop) "H".
    iDestruct "H" as (sbufs Hsbufs) "H".
    iDestruct (entries_typed_can_pop with "H") as %(t & sbufs' & Hspop); eauto.
    edestruct sbufs_typed_pop' as [i' [? [? ?]]]; eauto.
    iExists i'.
    iSplit; first done. subst.
    edestruct sbufs_typed_pop' as (i & Q1 & Q2 & Hsbufs'); eauto; sdec.
    iDestruct (entries_typed_pop with "H") as "[Hv H]"; eauto. iFrame.
    unfold bufs_typed.
    iExists _; eauto with iFrame.
  Qed.

  Lemma bufs_typed_push (bufss : bufsT participant participant entryT)
    (σs : gmap participant session_type)
    (n : nat) (i : fin n) (p q : participant) ts ss v :
    σs !! p ≡ Some (SendT n q ts ss) ->
    val_typed v (ts i) ∗ bufs_typed bufss σs ⊢
      bufs_typed (push p q (fin_to_nat i,v) bufss) (<[p:=ss i]> σs).
  Proof.
    iIntros (H) "[H1 H2]".
    inversion H. remember (SendT n q ts ss).
    inversion H2; simplify_eq.
    (* rewrite -(H4 i). *)
    iApply bufs_typed_push'; first done. iFrame.
    (* rewrite (H3 i) //. *)
  Qed.

  Lemma bufs_typed_pop (σs : gmap participant session_type)
    (bufs bufs' : bufsT participant participant entryT)
    (n : nat) (p q : participant) v i ts ss :
    σs !! q ≡ Some (RecvT n p ts ss) ->
    pop p q bufs = Some((i,v),bufs') ->
    bufs_typed bufs σs ⊢ ∃ i', ⌜⌜ i = fin_to_nat i' ⌝⌝ ∗
      val_typed v (ts i') ∗ bufs_typed bufs' (<[ q := ss i' ]> σs).
  Proof.
    intros H. inversion H. simplify_eq. intros.
    (* remember (RecvT n p ts ss). *)
    (* inversion H2; simplify_eq. symmetry in H0. *)
    (* intros. *)
    eapply bufs_typed_pop' in H1; last done.
    iIntros "H".
    iDestruct (H1 with "H") as (j ->) "[Hv H]".
    iExists _. iSplit; first done. iFrame.
  Qed.

  Lemma entries_typed_delete p bufs sbufs :
    buf_empty sbufs p ->
    entries_typed bufs sbufs ⊢ entries_typed (delete p bufs) (delete p sbufs).
  Proof.
    iIntros (Hbe) "H".
    unfold buf_empty in *.
    iDestruct (big_sepM2_lookup_iff with "H") as %Q.
    specialize (Q p).
    destruct (sbufs !! p) eqn:E.
    - destruct Q. destruct H0. rewrite E //.
      unfold entries_typed.
      rewrite big_sepM2_delete; eauto.
      iDestruct "H" as "[H1 H2]". iFrame.
      iAssert ([∗ map] buf;sbuf ∈ x;g, emp)%I with "[H1]" as "H".
      iApply (big_sepM2_mono with "H1"). 2: { iClear "H". done. }
      intros. simpl.
      assert (y2 = []); first eauto. subst.
      iIntros "H".
      iDestruct (big_sepL2_nil_inv_r with "H") as %->.
      iClear "H". done.
    - unfold entries_typed.
      destruct (bufs !! p) eqn:F.
      + rewrite E F in Q.
        destruct Q. destruct H; eauto. sdec.
      + rewrite delete_notin //.
        rewrite delete_notin //.
  Qed.

  Lemma bufs_empty_buf_empty bufs p :
    bufs_empty bufs -> buf_empty bufs p.
  Proof.
    intros H???q buf?.
    specialize (H q p).
    unfold pop in *.
    rewrite H0 H1 in H.
    destruct buf; sdec.
  Qed.

  Lemma buf_empty_pop p p' q v  bufs bufs' :
    q ≠ p ->
    pop p' q bufs = Some (v, bufs') ->
    buf_empty bufs' p ->
    buf_empty bufs p.
  Proof.
    intros Hneq Hpop Hbe.
    intros bf ? q' buf ?.
    unfold buf_empty in *.
    eapply Hbe; eauto.
    unfold pop in *.
    destruct (bufs !! q) eqn:E; smap.
    destruct (g !! p') eqn:E'; smap.
    destruct l eqn:E''; smap.
  Qed.

  Lemma bufs_typed_dealloc bufss σs p :
    σs !! p ≡ Some EndT ->
    bufs_typed bufss σs ⊢
    bufs_typed (delete p bufss) (delete p σs).
  Proof.
    iIntros (Hpp) "H".
    assert (σs !! p = Some EndT) as Hp.
    { inversion Hpp. inversion H1. simplify_eq. rewrite H //. }
    clear Hpp.
    iDestruct "H" as (sbufs Hsbufs) "H".
    iExists (delete p sbufs).
    iSplit. { iPureIntro. apply sbufs_typed_dealloc; done. }
    iApply entries_typed_delete; eauto using sbufs_typed_end_empty.
  Qed.

  Lemma entries_typed_empty : emp ⊣⊢ entries_typed ∅ ∅.
  Proof.
    unfold entries_typed.
    rewrite big_sepM2_empty //.
  Qed.

  Lemma bufs_typed_empty :
    emp ⊢ bufs_typed ∅ ∅.
  Proof.
    iIntros "_".
    iExists ∅.
    iSplit; eauto using sbufs_typed_empty.
    iApply entries_typed_empty. done.
  Qed.

  Lemma entries_typed_empty_inv sbufs :
    entries_typed ∅ sbufs ⊢ ⌜⌜ sbufs = ∅ ⌝⌝.
  Proof.
    iIntros "H".
    iDestruct (big_sepM2_empty_r with "H") as %->.
    rewrite <-entries_typed_empty. done.
  Qed.

  Lemma entries_typed_empty_inv_r bufs :
    entries_typed bufs ∅ ⊢ ⌜⌜ bufs = ∅ ⌝⌝.
  Proof.
    iIntros "H".
    iDestruct (big_sepM2_empty_l with "H") as %->.
    rewrite <-entries_typed_empty. done.
  Qed.

  Lemma bufs_typed_empty_inv σs :
    bufs_typed ∅ σs ⊢ ⌜⌜ σs = ∅ ⌝⌝.
  Proof.
    iIntros "H".
    iDestruct "H" as (sbufs Hsbufs) "H".
    iDestruct (entries_typed_empty_inv with "H") as %->.
    apply sbufs_typed_empty_inv in Hsbufs as ->; try done.
    (* rewrite <-entries_typed_empty; done. done. *)
  Qed.

  Lemma dom_valid_init {A} n d :
    (∀ k, k ∈ d <-> k < n) ->
    dom_valid (init_chans n : bufsT participant participant A) d.
  Proof.
    intros Hd. unfold dom_valid. intros p. unfold init_chans.
    destruct (decide (p < n)).
    - rewrite -(fin_to_nat_to_fin _ _ l).
      rewrite fin_gmap_lookup.
      split. { rewrite Hd. rewrite fin_to_nat_to_fin //. }
      intros.
      destruct (decide (q < n)).
      + rewrite -(fin_to_nat_to_fin _ _ l0).
        rewrite fin_gmap_lookup //.
      + naive_solver lia.
    - rewrite fin_gmap_lookup_ne; try lia.
      naive_solver lia.
  Qed.

  Lemma bufs_empty_init_chans {A} n :
    bufs_empty (init_chans n : bufsT participant participant A).
  Proof.
    intros ??.
    unfold pop.
    destruct (init_chans n !! q) eqn:E; smap.
    destruct (g !! p) eqn:E'; smap.
    destruct l eqn:E''; smap.
    exfalso.
    destruct (decide (q < n)).
    - rewrite -(fin_to_nat_to_fin _ _ l) in E.
      rewrite fin_gmap_lookup in E. sdec.
      destruct (decide (p < n)).
      + rewrite -(fin_to_nat_to_fin _ _ l1) in E'.
        rewrite fin_gmap_lookup in E'. sdec.
      + rewrite fin_gmap_lookup_ne in E'; sdec. lia.
    - rewrite fin_gmap_lookup_ne in E; sdec. lia.
  Qed.

  Lemma sbufs_typed_init n σs :
    consistent n σs ->
    sbufs_typed (init_chans n) (fin_gmap n σs).
  Proof. done. Qed.

  Lemma bufs_typed_init n σs :
    consistent n σs ->
    emp ⊢ bufs_typed (init_chans n) (fin_gmap n σs).
  Proof.
    iIntros (Hcons) "_".
    unfold bufs_typed.
    iExists (init_chans n).
    iSplit. { iPureIntro. apply sbufs_typed_init. done. }
    iApply big_sepM2_intro.
    - intros k.
      unfold init_chans.
      destruct (decide (k < n)).
      + rewrite -!(fin_to_nat_to_fin _ _ l).
        rewrite !fin_gmap_lookup. split; eauto.
      + rewrite fin_gmap_lookup_ne; last lia.
        rewrite fin_gmap_lookup_ne; last lia.
        split; intros []; sdec.
    - iModIntro. iIntros (k x1 x2 Hx1 Hx2).
      destruct (decide (k < n)); last first.
      { rewrite fin_gmap_lookup_ne in Hx1; last lia. sdec. }
      rewrite -!(fin_to_nat_to_fin _ _ l) in Hx1.
      rewrite -!(fin_to_nat_to_fin _ _ l) in Hx2.
      rewrite fin_gmap_lookup in Hx1.
      rewrite fin_gmap_lookup in Hx2. sdec.
      iApply big_sepM2_intro.
      + intros m.
        destruct (decide (m < n)).
        * rewrite -!(fin_to_nat_to_fin _ _ l0).
          rewrite !fin_gmap_lookup. split; eauto.
        * rewrite fin_gmap_lookup_ne; last lia.
          rewrite fin_gmap_lookup_ne; last lia.
          split; intros []; sdec.
      + iModIntro. iIntros (m x1 x2 Hx1 Hx2).
        destruct (decide (m < n)); last first.
        { rewrite fin_gmap_lookup_ne in Hx1; last lia. sdec. }
        rewrite -!(fin_to_nat_to_fin _ _ l0) in Hx1.
        rewrite -!(fin_to_nat_to_fin _ _ l0) in Hx2.
        rewrite fin_gmap_lookup in Hx1.
        rewrite fin_gmap_lookup in Hx2. sdec.
  Qed.

  Lemma dom_valid_same_dom {A} (m : bufsT participant participant A) d :
    dom_valid m d -> ∀ p, is_Some (m !! p) <-> p ∈ d.
  Proof.
    intros Hdv p.
    specialize (Hdv p).
    destruct (m !! p); split; try set_solver; eauto.
    intros []. sdec.
  Qed.

  Lemma entries_typed_same_dom bufs sbufs :
    entries_typed bufs sbufs ⊢ ⌜ dom bufs = dom sbufs ⌝.
  Proof.
    iIntros "H". unfold entries_typed.
    iApply big_sepM2_dom; eauto.
  Qed.

  Lemma bufs_typed_recv bufss σs p :
    is_Some (σs !! p) ->
    bufs_typed bufss σs ⊢ ⌜ is_Some (bufss !! p) ⌝.
  Proof.
    iIntros (Hp) "H".
    iDestruct "H" as (sbufs Hsbufs) "H".
    eapply sbufs_typed_dom in Hsbufs.
    iDestruct (entries_typed_same_dom with "H") as %Hdom.
    iPureIntro.
    apply elem_of_dom. rewrite Hdom Hsbufs.
    apply elem_of_dom. done.
  Qed.

  Lemma entries_typed_can_progress bufs sbufs σs :
    can_progress sbufs σs ->
    entries_typed bufs sbufs ⊢ ⌜ can_progress bufs σs ⌝.
  Proof.
    iIntros (Hcp) "H".
    unfold can_progress in *.
    destruct Hcp as (q & σ & H1 & H2).
    destruct σ; unfold can_progress; eauto.
    destruct H2 as (y & bufs' & Hbufs').
    iExists _,_. iSplit; eauto. simpl.
    iDestruct (entries_typed_same_structure with "H") as %Q.
    iPureIntro. clear H1 t s σs.
    unfold pop in *.
    destruct (sbufs !! q) eqn:E; smap.
    destruct (g !! p) eqn:E'; smap.
    destruct l eqn:E''; smap.
    specialize (Q q).
    rewrite E in Q.
    destruct (bufs !! q) eqn:F; smap.
    specialize (Q p).
    rewrite E' in Q.
    destruct (g0 !! p) eqn:F'; smap.
    specialize (Q 0). simpl in *.
    destruct l eqn:F''; smap.
  Qed.

  Lemma bufs_typed_progress bufss σs :
    bufs_typed bufss σs ⊢ ⌜ bufss = ∅ ∨ can_progress bufss σs ⌝.
  Proof.
    iIntros "H".
    iDestruct "H" as (bufs Hbufs) "H".
    apply sbufs_typed_progress in Hbufs as []; subst.
    - iLeft. rewrite entries_typed_empty_inv_r. eauto.
    - iRight. iApply entries_typed_can_progress; eauto.
  Qed.

End bufs_typed.

Section invariant.
  Definition state_inv (es : list expr) (h : heap) (x : object) (in_l : multiset clabel) : rProp :=
    match x with
    | Thread n =>
      ⌜⌜ in_l ≡ ε ⌝⌝ ∗ (* rtyped (default UnitV (es !! n)) UnitT *)
      match es !! n with
      | Some e => rtyped0 e UnitT
      | None => emp
      end
    | Chan n => ∃ σs : gmap participant session_type,
      ⌜⌜ in_l ≡ map_to_multiset σs ⌝⌝ ∗
      bufs_typed (gmap_slice h n) σs
    end%I.

  Definition invariant (es : list expr) (h : heap) := inv (state_inv es h).
End invariant.

Global Instance state_inv_proper es h v : Proper ((≡) ==> (⊣⊢)) (state_inv es h v).
Proof. solve_proper_prepare. destruct v; [solve_proper|by setoid_rewrite H]. Qed.
Global Instance state_inv_params : Params (@state_inv) 3. Defined.

Lemma gmap_slice_push `{Countable A,Countable B,Countable C} {V}
    (p : A) (c : B) (q : C) (x : V) (m : bufsT A (B*C) V) :
  gmap_slice (push p (c, q) x m) c = push p q x (gmap_slice m c).
Proof.
  unfold push. rewrite gmap_slice_alter. case_decide; simplify_eq. done.
Qed.

Lemma gmap_slice_pop `{Countable A,Countable B,Countable C} {V}
    (p : A) (c : B) (q : C) (x : V) (m m' : bufsT A (B*C) V) :
  pop p (c,q) m = Some(x,m') ->
  pop p q (gmap_slice m c) = Some(x,gmap_slice m' c).
Proof.
  unfold pop. intros. rewrite gmap_slice_lookup.
  destruct (m !! (c, q)); smap.
  destruct (g !! p); smap.
  destruct l; smap. do 2 f_equal.
  apply map_eq. intro. smap;
  rewrite gmap_slice_insert; smap.
Qed.

Lemma gmap_slice_pop_ne `{Countable A,Countable B,Countable C} {V}
    (p : A) (c c' : B) (q : C) (x : V) (m m' : bufsT A (B*C) V) :
  c ≠ c' ->
  pop p (c,q) m = Some(x,m') ->
  gmap_slice m c' = gmap_slice m' c'.
Proof.
  unfold pop. intros.
  destruct (m !! (c, q)); smap.
  destruct (g !! p); smap.
  destruct l; smap.
  rewrite gmap_slice_insert. smap.
Qed.

Lemma relabelT_id : ∀ σ, relabelT id σ ≡ σ.
Proof.
  cofix IH. intro.
  apply session_type_equiv_alt.
  destruct σ; simpl; constructor; try done; intro; apply IH.
Qed.

Lemma preservation (threads threads' : list expr) (chans chans' : heap) :
  step threads chans threads' chans' ->
  invariant threads chans ->
  invariant threads' chans'.
Proof.
  unfold invariant.
  intros [i H]. destruct H.
  destruct H as [????????HH].
  intros Hinv.
  destruct HH; rewrite ?right_id.
  - (* Pure step *)
    eapply inv_impl; last done.
    iIntros ([] x) "H"; simpl; eauto.
    iDestruct "H" as "[H1 H2]". iFrame.
    rewrite list_lookup_insert_spec. case_decide; eauto.
    destruct H2. subst. rewrite H0.
    iDestruct (rtyped0_ctx with "H2") as (t) "[H1 H2]"; eauto.
    iApply "H2". iApply pure_step_rtyped0; eauto.
  - (* Send *)
    eapply (inv_exchange (Thread i) (Chan c)); last done; try apply _.
    + intros v x []. iIntros "H".
      destruct v; simpl.
      * rewrite list_lookup_insert_spec. case_decide; naive_solver.
      * setoid_rewrite gmap_slice_alter. case_decide; naive_solver.
    + iIntros (y0) "H". simpl. rewrite H0.
      iDestruct "H" as (HH) "H".
      iDestruct (rtyped0_ctx with "H") as (t) "[H1 H2]"; eauto. simpl.
      iDestruct "H1" as (n r t' i' [-> ->]) "[H1 H1']".
      iDestruct "H1" as (r0 ?) "H1". simplify_eq.
      iExists _. iFrame.
      iIntros (x) "H". simpl in *.
      iDestruct "H" as (σs Hσs) "H".
      iExists (p, relabelT π (r i')).
      rewrite list_lookup_insert; last by eapply lookup_lt_Some.
      iSplitL "H2".
      * iIntros "H1".
        iSplit; eauto.
        iApply "H2". simpl. eauto.
      * iExists (<[ p := relabelT π (r i') ]> σs).
        iSplit.
        -- iPureIntro. eapply map_to_multiset_update. done.
        -- rewrite gmap_slice_push.
           eapply map_to_multiset_lookup in Hσs.
           iApply (bufs_typed_push _ _ _ _ _ _ _ (relabelT π ∘ r)); eauto with iFrame.
           rewrite Hσs. econstructor.
           apply session_type_equiv_alt. done.
  - (* Receive *)
    eapply (inv_exchange (Thread i) (Chan c)); last done; try apply _.
    + intros v x []. iIntros "H".
      destruct v; simpl.
      * rewrite list_lookup_insert_spec. case_decide; naive_solver.
      * iDestruct "H" as (σs) "H". iExists σs.
        erewrite gmap_slice_pop_ne; last done; eauto.
    + iIntros (y0) "H". simpl. rewrite H0.
      iDestruct "H" as (HH) "H".
      iDestruct (rtyped0_ctx with "H") as (t) "[H1 H2]"; eauto. simpl.
      iDestruct "H1" as (n t' r Q) "H1".
      iDestruct "H1" as (r0 HH') "H1". simplify_eq.
      iExists _. iFrame.
      iIntros (x) "H". simpl.
      iDestruct "H" as (σs Hσs) "H".
      eapply map_to_multiset_lookup in Hσs as Hp.
      apply gmap_slice_pop in H1.
      iDestruct (bufs_typed_pop with "H") as (i' ?) "[Hv H]"; eauto.
      { rewrite Hp. econstructor. apply session_type_equiv_alt. simpl. done. }
      subst. rewrite list_lookup_insert; last by eapply lookup_lt_Some.
      iExists (q, relabelT π (r i')).
      iSplitL "H2 Hv".
      * iIntros "H1".
        iSplit; eauto.
        iApply "H2". simpl. simplify_eq.
        remember (SumNT n (λ i : fin n, PairT (ChanT (r i)) (t' i))).
        inversion Q; simplify_eq.
        iExists _,_,_. iSplit; first done.
        specialize (H2 i'). simpl in *.
        inversion H2; simplify_eq.
        iExists _,_. iSplit; first done.
        rewrite -H7. iFrame.
        inversion H6. simplify_eq.
        iExists _. iSplit; first done. unfold own_ep. simpl. done.
      * iExists (<[ q := relabelT π (r i') ]> σs). iFrame. iPureIntro.
        by eapply map_to_multiset_update.
  - (* Close *)
    eapply (inv_dealloc (Thread i) (Chan c)); last done; try apply _.
    + intros v x []. iIntros "H".
      destruct v; simpl.
      * rewrite list_lookup_insert_spec. case_decide; naive_solver.
      * setoid_rewrite gmap_slice_delete. case_decide; naive_solver.
    + iIntros (y0) "H". simpl. rewrite H0.
      iDestruct "H" as (HH) "H".
      iDestruct (rtyped0_ctx with "H") as (t) "[H1 H2]"; eauto. simpl.
      iDestruct "H1" as (->) "H1".
      iDestruct "H1" as (r0 HH') "H1". simplify_eq.
      iExists _. iFrame. simpl.
      iIntros (x) "H".
      iDestruct "H" as (σs Hσs) "H".
      rewrite list_lookup_insert; last by eapply lookup_lt_Some.
      iSplitL "H2".
      * iSplit; eauto. by iApply "H2".
      * iExists (delete p σs).
        iSplit.
        -- iPureIntro. by eapply map_to_multiset_delete.
        -- rewrite gmap_slice_delete. case_decide; simplify_eq.
           apply map_to_multiset_lookup in Hσs.
           iApply bufs_typed_dealloc; last done.
           rewrite Hσs. constructor.
           apply session_type_equiv_alt. simpl. done.
  - (* Fork *)
    eapply (inv_alloc_lrs (Thread i) (Chan c)
              n (λ i, Thread (length es + fin_to_nat i))); last done;
      first apply _; first apply _.
    + intros m1 m2. intro HH. simplify_eq.
      eapply fin_to_nat_inj. lia.
    + split_and!; eauto. intros m. split_and; eauto.
      intros HH. simplify_eq.
      apply lookup_lt_Some in H0. lia.
    + intros v' x (Hn1 & Hn2 & Hn3). iIntros "H".
      destruct v'; simpl.
      * iDestruct "H" as "[? H]". iFrame.
        rewrite lookup_app list_lookup_insert_spec list.insert_length.
        case_decide.
        { destruct H3. simplify_eq. }
        destruct (es !! n0) eqn:E; eauto.
        unfold init_threads.
        rewrite fin_list_lookup_ne; eauto.
        cut (n0 - length es < n -> False); try lia.
        intros HH.
        specialize (Hn3 (nat_to_fin HH)). eapply Hn3.
        f_equal. rewrite fin_to_nat_to_fin.
        eapply lookup_ge_None in E. lia.
      * iDestruct "H" as (σs Hσs) "H".
        iExists σs. iSplit; eauto.
        rewrite gmap_slice_union gmap_slice_unslice.
        case_decide; simplify_eq.
        rewrite left_id //.
    + iIntros (x) "H". simpl.
      iDestruct "H" as (σs Hσs) "H".
      assert (gmap_slice h c = ∅) as ->.
      {
        eapply map_eq. intro. rewrite gmap_slice_lookup H1 lookup_empty //.
      }
      iDestruct (bufs_typed_empty_inv with "H") as "H".
      iDestruct "H" as %HH.
      iPureIntro. subst. rewrite map_to_multiset_empty in Hσs. done.
    + iIntros (m x) "H". simpl.
      iDestruct "H" as "[H1 H]". iFrame.
      destruct (es !! (length es + m)) eqn:E; eauto.
      eapply lookup_lt_Some in E. lia.
    + iIntros (y0) "H". simpl. rewrite H0.
      iDestruct "H" as (HH) "H".
      iDestruct (rtyped0_ctx with "H") as (t) "[H1 H2]"; eauto. simpl.
      iDestruct "H1" as (σs [Hteq Hcons]) "H1".
      iExists (0, σs 0%fin).
      iExists (λ m, (S (fin_to_nat m), σs (FS m))).
      iSplitL "H2".
      {
        rewrite lookup_app list_lookup_insert; eauto using lookup_lt_Some.
        iIntros "H".
        iSplit; eauto. iApply "H2". simpl.
        remember (ChanT (σs 0%fin)).
        inversion Hteq; simplify_eq.
        iExists _. iSplit; first done.
        unfold own_ep.
        rewrite relabelT_id. done.
      }
      iSplitR.
      {
        iExists (fin_gmap (S n) σs).
        rewrite gmap_slice_union.
        assert (gmap_slice h c = ∅) as ->.
        { eapply map_eq. intro. rewrite gmap_slice_lookup lookup_empty //. }
        iSplit.
        { iPureIntro. rewrite <-fin_multiset_gmap.
          rewrite fin_multiset_S //. }
        rewrite gmap_slice_unslice. case_decide; simplify_eq.
        rewrite right_id.
        iApply bufs_typed_init; eauto.
      }
      iApply (big_sepS_impl with "H1"). iModIntro.
      iIntros (m _) "Ht Ho".
      iSplit; eauto.
      rewrite lookup_app_r. 2: { rewrite list.insert_length. lia. }
      rewrite list.insert_length.
      replace (length es + m - length es) with (fin_to_nat m) by lia.
      rewrite fin_list_lookup H2.
      simpl.
      remember (ChanT (σs 0%fin)).
      inversion Hteq; simplify_eq.
      unfold own_ep. setoid_rewrite relabelT_id.
      eauto with iFrame.
Qed.

Lemma preservationN (threads threads' : list expr) (chans chans' : heap) :
  steps threads chans threads' chans' ->
  invariant threads chans ->
  invariant threads' chans'.
Proof. induction 1; eauto using preservation. Qed.

Lemma invariant_init (e : expr) :
  typed ∅ e UnitT -> invariant [e] ∅.
Proof.
  intros H.
  eapply inv_impl; last eauto using inv_init.
  intros. simpl. iIntros "[% H]".
  unfold state_inv. destruct v.
  - destruct n; simpl.
    + subst. iSplit; eauto.
      iApply rtyped_rtyped0_iff.
      iApply typed_rtyped. done.
    + subst. iFrame. eauto.
  - iExists ∅.
    iSplit; first done. rewrite gmap_slice_empty.
    by iApply bufs_typed_empty.
Qed.

Lemma invariant_holds e threads chans :
  typed ∅ e UnitT -> steps [e] ∅ threads chans -> invariant threads chans.
Proof. eauto using invariant_init, preservationN. Qed.


Require Export prosa.analysis.facts.preemption.job.nonpreemptive.

(** Furthermore, we assume the fully non-preemptive task model. *)
Require Import prosa.model.preemption.fully_nonpreemptive.
Require Import prosa.model.task.preemption.fully_nonpreemptive.

(** * Task's Run to Completion Threshold *)
(** In this section, we prove that instantiation of function [task run
    to completion threshold] to the fully non-preemptive model
    indeed defines a valid run-to-completion threshold function. *)
Section TaskRTCThresholdFullyNonPreemptive.

  (** Consider any type of tasks ... *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.

  (**  ... and any type of jobs associated with these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** Consider any arrival sequence with consistent arrivals. *)
  Variable arr_seq : arrival_sequence Job.
  Hypothesis H_arrival_times_are_consistent : consistent_arrival_times arr_seq.

  (** Next, consider any ideal non-preemptive uniprocessor schedule of
      this arrival sequence ... *)
  Variable sched : schedule (ideal.processor_state Job).
  Hypothesis H_nonpreemptive_sched : nonpreemptive_schedule  sched.

  (** ... where jobs do not execute before their arrival or after completion. *)
  Hypothesis H_jobs_must_arrive_to_execute : jobs_must_arrive_to_execute sched.
  Hypothesis H_completed_jobs_dont_execute : completed_jobs_dont_execute sched.

  (** First we prove that if the cost of a job j is equal to 0, then
      [job_run_to_completion_threshold j = 0] ...  *)
  Fact job_rtc_threshold_is_0:
    forall j,
      job_cost j = 0 ->
      job_run_to_completion_threshold j = 0.
  Proof.
    intros.
    apply/eqP; rewrite eqn_leq; apply/andP; split; last by done.
    unfold job_run_to_completion_threshold.
      by rewrite H3; compute.
  Qed.

  (** ... and ε otherwise. *)
  Fact job_rtc_threshold_is_ε:
    forall j,
      job_cost j > 0 ->
      arrives_in arr_seq j ->
      job_run_to_completion_threshold j = ε.
  Proof.
    intros ? ARRj POSj; unfold ε in *.
    unfold job_run_to_completion_threshold.
    rewrite job_last_nps_is_job_cost.
      by rewrite subKn.
  Qed.

  (** Consider a task with a positive cost. *)
  Variable tsk : Task.
  Hypothesis H_positive_cost : 0 < task_cost tsk.

  (** Then, we prove that [task_run_to_completion_threshold] function
      defines a valid task's run to completion threshold. *)
  Lemma fully_nonpreemptive_valid_task_run_to_completion_threshold:
    valid_task_run_to_completion_threshold arr_seq tsk.
  Proof.
    intros; split.
    - by unfold task_rtc_bounded_by_cost.
    - intros j ARR TSK.
      rewrite -TSK /task_run_to_completion_threshold /fully_nonpreemptive.
      edestruct (posnP (job_cost j)) as [ZERO|POS].
      + by rewrite job_rtc_threshold_is_0.
      + by erewrite job_rtc_threshold_is_ε; eauto 2.
  Qed.

End TaskRTCThresholdFullyNonPreemptive.
Hint Resolve fully_nonpreemptive_valid_task_run_to_completion_threshold : basic_facts.


(**********************************************************************)
(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

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

(**********************************************************************)
(*                           Residuals.v                              *)
(*                                                                    *)
(* adapted from Residuals.v for Lambda Calculus                       *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import Lambda.Test.
Require Import Lambda.General.
Require Import Lambda.Terms.
Require Import Lambda.Substitution.
Require Import Lambda.Redexes.
Require Import Omega.

(*************************************************)
(* Parallel beta reduction with residual tracing *)
(*************************************************)

(* (residuals U V W) means W are residuals of redexes U by step V *)

Inductive residuals : redexes -> redexes -> redexes -> Prop :=
  | Res_Var : forall i, residuals (Var i) (Var i) (Var i)
  | Res_Ap :
      forall U1 V1 W1 : redexes,
      residuals U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      residuals U2 V2 W2 ->
      forall (b : bool), residuals (Ap b U1 U2) (Ap false V1 V2) (Ap b W1 W2)
   | Res_Fun :
      forall U V W ,
      residuals U V W -> residuals (Fun U) (Fun V) (Fun W)
  | Res_redex :
      forall U1 V1 W1 : redexes,
      residuals U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      residuals U2 V2 W2 ->
      forall (b : bool),
      residuals (Ap b (Fun U1) U2) (Ap true (Fun V1) V2) (subst_r W2 W1)
.

Hint Resolve Res_Var Res_Fun Res_Ap Res_redex.

Lemma residuals_function :
 forall U V W : redexes,
 residuals U V W -> forall (W' : redexes) (R : residuals U V W'), W' = W.
Proof.
(* Remark use of name R necessary for uniform expression of next line *)
simple induction 1; intros; inversion R; auto with arith.
elim H1 with W0; elim H3 with W3; trivial with arith.
elim H1 with W1; trivial with arith.
elim H1 with W0; elim H3 with W3; trivial with arith.
Qed.

(* Commutation theorem *)

Lemma residuals_lift_rec :
 forall U1 U2 U3 : redexes,
 residuals U1 U2 U3 ->
 forall k n : nat,
 residuals (lift_rec_r U1 n k) (lift_rec_r U2 n k) (lift_rec_r U3 n k).
Proof.
simple induction 1; simpl in |- *; intros; auto with arith; split_all.
assert(n = 0+n) by omega. rewrite H4 at 5.
unfold subst_r.  rewrite lift_rec_subst_rec.
eapply2 Res_redex.
Qed.

Lemma residuals_lift :
 forall U1 U2 U3 : redexes,
 residuals U1 U2 U3 ->
 forall k : nat, residuals (lift_r k U1) (lift_r k U2) (lift_r k U3).
Proof.
unfold lift_r in |- *; intros; apply residuals_lift_rec; trivial with arith.
Qed.
Hint Resolve residuals_lift.

Lemma residuals_subst_rec :
 forall U1 U2 U3 : redexes,
 residuals U1 U2 U3 -> forall V1 V2 V3,
 residuals V1 V2 V3 ->
 forall k : nat,
 residuals (subst_rec_r U1 V1 k) (subst_rec_r U2 V2 k) (subst_rec_r U3 V3 k).
Proof.
simple induction 1; simpl in |- *; auto with arith; split_all.
 unfold insert_Var in |- *; elim (compare k i); auto with arith.
simple induction a; auto with arith.
unfold subst_r.
assert(k = 0+k) by omega. rewrite H5.
rewrite subst_rec_subst_rec; auto with arith.
eapply2 Res_redex.
Qed.
Hint Resolve residuals_subst_rec.

(***************************)
(* The Commutation Theorem *)
(***************************)

Theorem commutation :
 forall U1 U2 U3 V1 V2 V3 : redexes,
 residuals U1 U2 U3 ->
 residuals V1 V2 V3 ->
 residuals (subst_r V1 U1) (subst_r V2 U2) (subst_r V3 U3).
Proof.
unfold subst_r in |- *; auto with arith.
Qed.

Lemma residuals_comp : forall U V W : redexes, residuals U V W -> comp U V.
Proof.
simple induction 1; simpl in |- *; auto with arith.
Qed.

Lemma preservation1 :
 forall U V UV : redexes,
 residuals U V UV ->
 forall (T : redexes) (UVT : union U V T), residuals T V UV.
Proof.
(* Remark use of name UVT for uniform command below *)
simple induction 1; simple induction T; intros; inversion UVT;
 auto with arith.
rewrite (max_false b); auto with arith.
inversion H8; auto with arith.
Qed.

Lemma preservation :
 forall U V W UV : redexes,
 union U V W -> residuals U V UV -> residuals W V UV.
Proof.
intros; apply preservation1 with U; auto with arith.
Qed.

Lemma mutual_residuals_comp :
 forall (W U UW : redexes) (RU : residuals U W UW)
   (V VW : redexes) (RV : residuals V W VW), comp UW VW.
Proof.
simple induction W; split_all.
inversion_clear RU; inversion_clear RV; trivial with arith.
2: inversion_clear RU; inversion_clear RV; trivial with arith;
 eapply2 Comp_Fun.
induction b; split_all.
2: inversion_clear RU; inversion_clear RV;
apply Comp_Ap;[ eapply2 H| eapply2 H0].

inversion RU; inversion RV; subst. invsub.
apply subst_preserve_comp.
assert(residuals (Fun U1) (Fun V1) (Fun W1)). eapply2 Res_Fun.
assert(residuals (Fun U0) (Fun V1) (Fun W0)). eapply2 Res_Fun.
assert(comp (Fun W1) (Fun W0)) by
eapply2 (H (Fun U1) (Fun W1) H1 (Fun U0) (Fun W0) H2).
inversion H3. subst. auto.
eapply2 H0.
Qed.

(* We take residuals only by regular redexes *)

Lemma residuals_regular :
 forall U V W : redexes, residuals U V W -> regular V.
Proof.
simple induction 1; simpl in |- *; auto with arith.
Qed.

(* Conversely, residuals by compatible regular redexes always exist
   (and are unique by residuals_function lemma above) *)

Lemma residuals_intro :
 forall U V : redexes,
 comp U V -> regular V -> exists W : redexes, residuals U V W.
Proof.
simple induction 1; simpl in |- *; split_all; eauto.
2: elim H1; split_all; eauto.
gen_case H4 b2.
2: elim H1; elim H3; split_all; exist (Ap b1 x0 x).
gen2_case H1 H4 V1.
elim H1; elim H3; split_all.
inversion H7; subst.
inversion H0. subst.
exist (subst_r x W).
Qed.

(* Residuals preserve regularity *)

Lemma residuals_preserve_regular :
 forall U V W : redexes, residuals U V W -> regular U -> regular W.
Proof.
simple induction 1; simpl in |- *; auto with arith.
simple induction b.
split_all.
gen3_case H1 H0 H4 U1.
gen2_case H0 H1 W1; inversion H0.
split_all.
split_all.
split_all.
split_all.
gen_case H4 b;
eapply2 subst_rec_preserve_regular.
Qed.


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

(* $Id: Ring_normalize.v 14641 2011-11-06 11:59:10Z herbelin $ *)

Require Import LegacyRing_theory.
Require Import Quote.

Set Implicit Arguments.
Unset Boxed Definitions.

Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m.
Proof.
  intros.
  apply index_eq_prop.
  generalize H.
  case (index_eq n m); simpl in |- *; trivial; intros.
  contradiction.
Qed.

Section semi_rings.

Variable A : Type.
Variable Aplus : A -> A -> A.
Variable Amult : A -> A -> A.
Variable Aone : A.
Variable Azero : A.
Variable Aeq : A -> A -> bool.

(* Section definitions. *)

(******************************************)
(* Normal abtract Polynomials             *)
(******************************************)
(* DEFINITIONS :
- A varlist is a sorted product of one or more variables : x, x*y*z
- A monom is a constant, a varlist or the product of a constant by a varlist
  variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT.
- A canonical sum is either a monom or an ordered sum of monoms
  (the order on monoms is defined later)
- A normal polynomial it either a constant or a canonical sum or a constant
  plus a canonical sum
*)

(* varlist is isomorphic to (list var), but we built a special inductive
   for efficiency *)
Inductive varlist : Type :=
  | Nil_var : varlist
  | Cons_var : index -> varlist -> varlist.

Inductive canonical_sum : Type :=
  | Nil_monom : canonical_sum
  | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum
  | Cons_varlist : varlist -> canonical_sum -> canonical_sum.

(* Order on monoms *)

(* That's the lexicographic order on varlist, extended by :
  - A constant is less than every monom
  - The relation between two varlist is preserved by multiplication by a
  constant.

  Examples :
  3 < x < y
  x*y < x*y*y*z
  2*x*y < x*y*y*z
  x*y < 54*x*y*y*z
  4*x*y < 59*x*y*y*z
*)

Fixpoint varlist_eq (x y:varlist) {struct y} : bool :=
  match x, y with
  | Nil_var, Nil_var => true
  | Cons_var i xrest, Cons_var j yrest =>
      andb (index_eq i j) (varlist_eq xrest yrest)
  | _, _ => false
  end.

Fixpoint varlist_lt (x y:varlist) {struct y} : bool :=
  match x, y with
  | Nil_var, Cons_var _ _ => true
  | Cons_var i xrest, Cons_var j yrest =>
      if index_lt i j
      then true
      else andb (index_eq i j) (varlist_lt xrest yrest)
  | _, _ => false
  end.

(* merges two variables lists *)
Fixpoint varlist_merge (l1:varlist) : varlist -> varlist :=
  match l1 with
  | Cons_var v1 t1 =>
      (fix vm_aux (l2:varlist) : varlist :=
         match l2 with
         | Cons_var v2 t2 =>
             if index_lt v1 v2
             then Cons_var v1 (varlist_merge t1 l2)
             else Cons_var v2 (vm_aux t2)
         | Nil_var => l1
         end)
  | Nil_var => fun l2 => l2
  end.

(* returns the sum of two canonical sums  *)
Fixpoint canonical_sum_merge (s1:canonical_sum) :
 canonical_sum -> canonical_sum :=
  match s1 with
  | Cons_monom c1 l1 t1 =>
      (fix csm_aux (s2:canonical_sum) : canonical_sum :=
         match s2 with
         | Cons_monom c2 l2 t2 =>
             if varlist_eq l1 l2
             then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2)
             else
              if varlist_lt l1 l2
              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
              else Cons_monom c2 l2 (csm_aux t2)
         | Cons_varlist l2 t2 =>
             if varlist_eq l1 l2
             then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2)
             else
              if varlist_lt l1 l2
              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
              else Cons_varlist l2 (csm_aux t2)
         | Nil_monom => s1
         end)
  | Cons_varlist l1 t1 =>
      (fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
         match s2 with
         | Cons_monom c2 l2 t2 =>
             if varlist_eq l1 l2
             then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2)
             else
              if varlist_lt l1 l2
              then Cons_varlist l1 (canonical_sum_merge t1 s2)
              else Cons_monom c2 l2 (csm_aux2 t2)
         | Cons_varlist l2 t2 =>
             if varlist_eq l1 l2
             then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2)
             else
              if varlist_lt l1 l2
              then Cons_varlist l1 (canonical_sum_merge t1 s2)
              else Cons_varlist l2 (csm_aux2 t2)
         | Nil_monom => s1
         end)
  | Nil_monom => fun s2 => s2
  end.

(* Insertion of a monom in a canonical sum *)
Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} :
 canonical_sum :=
  match s2 with
  | Cons_monom c2 l2 t2 =>
      if varlist_eq l1 l2
      then Cons_monom (Aplus c1 c2) l1 t2
      else
       if varlist_lt l1 l2
       then Cons_monom c1 l1 s2
       else Cons_monom c2 l2 (monom_insert c1 l1 t2)
  | Cons_varlist l2 t2 =>
      if varlist_eq l1 l2
      then Cons_monom (Aplus c1 Aone) l1 t2
      else
       if varlist_lt l1 l2
       then Cons_monom c1 l1 s2
       else Cons_varlist l2 (monom_insert c1 l1 t2)
  | Nil_monom => Cons_monom c1 l1 Nil_monom
  end.

Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} :
 canonical_sum :=
  match s2 with
  | Cons_monom c2 l2 t2 =>
      if varlist_eq l1 l2
      then Cons_monom (Aplus Aone c2) l1 t2
      else
       if varlist_lt l1 l2
       then Cons_varlist l1 s2
       else Cons_monom c2 l2 (varlist_insert l1 t2)
  | Cons_varlist l2 t2 =>
      if varlist_eq l1 l2
      then Cons_monom (Aplus Aone Aone) l1 t2
      else
       if varlist_lt l1 l2
       then Cons_varlist l1 s2
       else Cons_varlist l2 (varlist_insert l1 t2)
  | Nil_monom => Cons_varlist l1 Nil_monom
  end.

(* Computes c0*s *)
Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} :
 canonical_sum :=
  match s with
  | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t)
  | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t)
  | Nil_monom => Nil_monom
  end.

(* Computes l0*s  *)
Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} :
 canonical_sum :=
  match s with
  | Cons_monom c l t =>
      monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
  | Cons_varlist l t =>
      varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
  | Nil_monom => Nil_monom
  end.

(* Computes c0*l0*s  *)
Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist)
 (s:canonical_sum) {struct s} : canonical_sum :=
  match s with
  | Cons_monom c l t =>
      monom_insert (Amult c0 c) (varlist_merge l0 l)
        (canonical_sum_scalar3 c0 l0 t)
  | Cons_varlist l t =>
      monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t)
  | Nil_monom => Nil_monom
  end.

(* returns the product of two canonical sums *)
Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} :
 canonical_sum :=
  match s1 with
  | Cons_monom c1 l1 t1 =>
      canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2)
        (canonical_sum_prod t1 s2)
  | Cons_varlist l1 t1 =>
      canonical_sum_merge (canonical_sum_scalar2 l1 s2)
        (canonical_sum_prod t1 s2)
  | Nil_monom => Nil_monom
  end.

(* The type to represent concrete semi-ring polynomials *)
Inductive spolynomial : Type :=
  | SPvar : index -> spolynomial
  | SPconst : A -> spolynomial
  | SPplus : spolynomial -> spolynomial -> spolynomial
  | SPmult : spolynomial -> spolynomial -> spolynomial.

Fixpoint spolynomial_normalize (p:spolynomial) : canonical_sum :=
  match p with
  | SPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom
  | SPconst c => Cons_monom c Nil_var Nil_monom
  | SPplus l r =>
      canonical_sum_merge (spolynomial_normalize l) (spolynomial_normalize r)
  | SPmult l r =>
      canonical_sum_prod (spolynomial_normalize l) (spolynomial_normalize r)
  end.

(* Deletion of useless 0 and 1 in canonical sums *)
Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum :=
  match s with
  | Cons_monom c l t =>
      if Aeq c Azero
      then canonical_sum_simplify t
      else
       if Aeq c Aone
       then Cons_varlist l (canonical_sum_simplify t)
       else Cons_monom c l (canonical_sum_simplify t)
  | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t)
  | Nil_monom => Nil_monom
  end.

Definition spolynomial_simplify (x:spolynomial) :=
  canonical_sum_simplify (spolynomial_normalize x).

(* End definitions. *)

(* Section interpretation. *)

(*** Here a variable map is defined and the interpetation of a spolynom
  acording to a certain variables map. Once again the choosen definition
  is generic and could be changed ****)

Variable vm : varmap A.

(* Interpretation of list of variables
 * [x1; ... ; xn ] is interpreted as (find v x1)* ... *(find v xn)
 * The unbound variables are mapped to 0. Normally this case sould
 * never occur. Since we want only to prove correctness theorems, which form
 * is : for any varmap and any spolynom ... this is a safe and pain-saving
 * choice *)
Definition interp_var (i:index) := varmap_find Azero i vm.

(* Local *) Definition ivl_aux :=
              (fix ivl_aux (x:index) (t:varlist) {struct t} : A :=
                 match t with
                 | Nil_var => interp_var x
                 | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t')
                 end).

Definition interp_vl (l:varlist) :=
  match l with
  | Nil_var => Aone
  | Cons_var x t => ivl_aux x t
  end.

(* Local *) Definition interp_m (c:A) (l:varlist) :=
              match l with
              | Nil_var => c
              | Cons_var x t => Amult c (ivl_aux x t)
              end.

(* Local *) Definition ics_aux :=
              (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A :=
                 match s with
                 | Nil_monom => a
                 | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t)
                 | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t)
                 end).

(* Interpretation of a canonical sum *)
Definition interp_cs (s:canonical_sum) : A :=
  match s with
  | Nil_monom => Azero
  | Cons_varlist l t => ics_aux (interp_vl l) t
  | Cons_monom c l t => ics_aux (interp_m c l) t
  end.

Fixpoint interp_sp (p:spolynomial) : A :=
  match p with
  | SPconst c => c
  | SPvar i => interp_var i
  | SPplus p1 p2 => Aplus (interp_sp p1) (interp_sp p2)
  | SPmult p1 p2 => Amult (interp_sp p1) (interp_sp p2)
  end.

(* End interpretation. *)

Unset Implicit Arguments.

(* Section properties. *)

Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq.

Hint Resolve (SR_plus_comm T).
Hint Resolve (SR_plus_assoc T).
Hint Resolve (SR_plus_assoc2 T).
Hint Resolve (SR_mult_comm T).
Hint Resolve (SR_mult_assoc T).
Hint Resolve (SR_mult_assoc2 T).
Hint Resolve (SR_plus_zero_left T).
Hint Resolve (SR_plus_zero_left2 T).
Hint Resolve (SR_mult_one_left T).
Hint Resolve (SR_mult_one_left2 T).
Hint Resolve (SR_mult_zero_left T).
Hint Resolve (SR_mult_zero_left2 T).
Hint Resolve (SR_distr_left T).
Hint Resolve (SR_distr_left2 T).
(*Hint Resolve (SR_plus_reg_left T).*)
Hint Resolve (SR_plus_permute T).
Hint Resolve (SR_mult_permute T).
Hint Resolve (SR_distr_right T).
Hint Resolve (SR_distr_right2 T).
Hint Resolve (SR_mult_zero_right T).
Hint Resolve (SR_mult_zero_right2 T).
Hint Resolve (SR_plus_zero_right T).
Hint Resolve (SR_plus_zero_right2 T).
Hint Resolve (SR_mult_one_right T).
Hint Resolve (SR_mult_one_right2 T).
(*Hint Resolve (SR_plus_reg_right T).*)
Hint Resolve refl_equal sym_equal trans_equal.
(* Hints Resolve refl_eqT sym_eqT trans_eqT. *)
Hint Immediate T.

Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y.
Proof.
  simple induction x; simple induction y; contradiction || (try reflexivity).
  simpl in |- *; intros.
  generalize (andb_prop2 _ _ H1); intros; elim H2; intros.
  rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity.
Qed.

Remark ivl_aux_ok :
 forall (v:varlist) (i:index),
   ivl_aux i v = Amult (interp_var i) (interp_vl v).
Proof.
  simple induction v; simpl in |- *; intros.
  trivial.
  rewrite H; trivial.
Qed.

Lemma varlist_merge_ok :
 forall x y:varlist,
   interp_vl (varlist_merge x y) = Amult (interp_vl x) (interp_vl y).
Proof.
  simple induction x.
  simpl in |- *; trivial.
  simple induction y.
  simpl in |- *; trivial.
  simpl in |- *; intros.
  elim (index_lt i i0); simpl in |- *; intros.

  repeat rewrite ivl_aux_ok.
  rewrite H. simpl in |- *.
  rewrite ivl_aux_ok.
  eauto.

  repeat rewrite ivl_aux_ok.
  rewrite H0.
  rewrite ivl_aux_ok.
  eauto.
Qed.

Remark ics_aux_ok :
 forall (x:A) (s:canonical_sum), ics_aux x s = Aplus x (interp_cs s).
Proof.
  simple induction s; simpl in |- *; intros.
  trivial.
  reflexivity.
  reflexivity.
Qed.

Remark interp_m_ok :
 forall (x:A) (l:varlist), interp_m x l = Amult x (interp_vl l).
Proof.
  destruct l as [| i v].
  simpl in |- *; trivial.
  reflexivity.
Qed.

Lemma canonical_sum_merge_ok :
 forall x y:canonical_sum,
   interp_cs (canonical_sum_merge x y) = Aplus (interp_cs x) (interp_cs y).

simple induction x; simpl in |- *.
trivial.

simple induction y; simpl in |- *; intros.
(* monom and nil *)
eauto.

(* monom and monom *)
generalize (varlist_eq_prop v v0).
elim (varlist_eq v v0).
intros; rewrite (H1 I).
simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
repeat rewrite interp_m_ok.
rewrite (SR_distr_left T).
repeat rewrite <- (SR_plus_assoc T).
apply f_equal with (f := Aplus (Amult a (interp_vl v0))).
trivial.

elim (varlist_lt v v0); simpl in |- *.
repeat rewrite ics_aux_ok.
rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.

rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
 eauto.

(* monom and varlist *)
generalize (varlist_eq_prop v v0).
elim (varlist_eq v v0).
intros; rewrite (H1 I).
simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
repeat rewrite interp_m_ok.
rewrite (SR_distr_left T).
repeat rewrite <- (SR_plus_assoc T).
apply f_equal with (f := Aplus (Amult a (interp_vl v0))).
rewrite (SR_mult_one_left T).
trivial.

elim (varlist_lt v v0); simpl in |- *.
repeat rewrite ics_aux_ok.
rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
 eauto.

simple induction y; simpl in |- *; intros.
(* varlist and nil *)
trivial.

(* varlist and monom *)
generalize (varlist_eq_prop v v0).
elim (varlist_eq v v0).
intros; rewrite (H1 I).
simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
repeat rewrite interp_m_ok.
rewrite (SR_distr_left T).
repeat rewrite <- (SR_plus_assoc T).
rewrite (SR_mult_one_left T).
apply f_equal with (f := Aplus (interp_vl v0)).
trivial.

elim (varlist_lt v v0); simpl in |- *.
repeat rewrite ics_aux_ok.
rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
 eauto.

(* varlist and varlist *)
generalize (varlist_eq_prop v v0).
elim (varlist_eq v v0).
intros; rewrite (H1 I).
simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
repeat rewrite interp_m_ok.
rewrite (SR_distr_left T).
repeat rewrite <- (SR_plus_assoc T).
rewrite (SR_mult_one_left T).
apply f_equal with (f := Aplus (interp_vl v0)).
trivial.

elim (varlist_lt v v0); simpl in |- *.
repeat rewrite ics_aux_ok.
rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
 eauto.
Qed.

Lemma monom_insert_ok :
 forall (a:A) (l:varlist) (s:canonical_sum),
   interp_cs (monom_insert a l s) =
   Aplus (Amult a (interp_vl l)) (interp_cs s).
intros; generalize s; simple induction s0.

simpl in |- *; rewrite interp_m_ok; trivial.

simpl in |- *; intros.
generalize (varlist_eq_prop l v); elim (varlist_eq l v).
intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok;
 repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T);
 eauto.
elim (varlist_lt l v); simpl in |- *;
 [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
 | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
    rewrite ics_aux_ok; eauto ].

simpl in |- *; intros.
generalize (varlist_eq_prop l v); elim (varlist_eq l v).
intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok;
 repeat rewrite ics_aux_ok; rewrite (SR_distr_left T);
 rewrite (SR_mult_one_left T); eauto.
elim (varlist_lt l v); simpl in |- *;
 [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
 | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
    rewrite ics_aux_ok; eauto ].
Qed.

Lemma varlist_insert_ok :
 forall (l:varlist) (s:canonical_sum),
   interp_cs (varlist_insert l s) = Aplus (interp_vl l) (interp_cs s).
intros; generalize s; simple induction s0.

simpl in |- *; trivial.

simpl in |- *; intros.
generalize (varlist_eq_prop l v); elim (varlist_eq l v).
intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok;
 repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T);
 rewrite (SR_mult_one_left T); eauto.
elim (varlist_lt l v); simpl in |- *;
 [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
 | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
    rewrite ics_aux_ok; eauto ].

simpl in |- *; intros.
generalize (varlist_eq_prop l v); elim (varlist_eq l v).
intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok;
 repeat rewrite ics_aux_ok; rewrite (SR_distr_left T);
 rewrite (SR_mult_one_left T); eauto.
elim (varlist_lt l v); simpl in |- *;
 [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
 | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
    rewrite ics_aux_ok; eauto ].
Qed.

Lemma canonical_sum_scalar_ok :
 forall (a:A) (s:canonical_sum),
   interp_cs (canonical_sum_scalar a s) = Amult a (interp_cs s).
simple induction s.
simpl in |- *; eauto.

simpl in |- *; intros.
repeat rewrite ics_aux_ok.
repeat rewrite interp_m_ok.
rewrite H.
rewrite (SR_distr_right T).
repeat rewrite <- (SR_mult_assoc T).
reflexivity.

simpl in |- *; intros.
repeat rewrite ics_aux_ok.
repeat rewrite interp_m_ok.
rewrite H.
rewrite (SR_distr_right T).
repeat rewrite <- (SR_mult_assoc T).
reflexivity.
Qed.

Lemma canonical_sum_scalar2_ok :
 forall (l:varlist) (s:canonical_sum),
   interp_cs (canonical_sum_scalar2 l s) = Amult (interp_vl l) (interp_cs s).
simple induction s.
simpl in |- *; trivial.

simpl in |- *; intros.
rewrite monom_insert_ok.
repeat rewrite ics_aux_ok.
repeat rewrite interp_m_ok.
rewrite H.
rewrite varlist_merge_ok.
repeat rewrite (SR_distr_right T).
repeat rewrite <- (SR_mult_assoc T).
repeat rewrite <- (SR_plus_assoc T).
rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)).
reflexivity.

simpl in |- *; intros.
rewrite varlist_insert_ok.
repeat rewrite ics_aux_ok.
repeat rewrite interp_m_ok.
rewrite H.
rewrite varlist_merge_ok.
repeat rewrite (SR_distr_right T).
repeat rewrite <- (SR_mult_assoc T).
repeat rewrite <- (SR_plus_assoc T).
reflexivity.
Qed.

Lemma canonical_sum_scalar3_ok :
 forall (c:A) (l:varlist) (s:canonical_sum),
   interp_cs (canonical_sum_scalar3 c l s) =
   Amult c (Amult (interp_vl l) (interp_cs s)).
simple induction s.
simpl in |- *; repeat rewrite (SR_mult_zero_right T); reflexivity.

simpl in |- *; intros.
rewrite monom_insert_ok.
repeat rewrite ics_aux_ok.
repeat rewrite interp_m_ok.
rewrite H.
rewrite varlist_merge_ok.
repeat rewrite (SR_distr_right T).
repeat rewrite <- (SR_mult_assoc T).
repeat rewrite <- (SR_plus_assoc T).
rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)).
reflexivity.

simpl in |- *; intros.
rewrite monom_insert_ok.
repeat rewrite ics_aux_ok.
repeat rewrite interp_m_ok.
rewrite H.
rewrite varlist_merge_ok.
repeat rewrite (SR_distr_right T).
repeat rewrite <- (SR_mult_assoc T).
repeat rewrite <- (SR_plus_assoc T).
rewrite (SR_mult_permute T c (interp_vl l) (interp_vl v)).
reflexivity.
Qed.

Lemma canonical_sum_prod_ok :
 forall x y:canonical_sum,
   interp_cs (canonical_sum_prod x y) = Amult (interp_cs x) (interp_cs y).
simple induction x; simpl in |- *; intros.
trivial.

rewrite canonical_sum_merge_ok.
rewrite canonical_sum_scalar3_ok.
rewrite ics_aux_ok.
rewrite interp_m_ok.
rewrite H.
rewrite (SR_mult_assoc T a (interp_vl v) (interp_cs y)).
symmetry  in |- *.
eauto.

rewrite canonical_sum_merge_ok.
rewrite canonical_sum_scalar2_ok.
rewrite ics_aux_ok.
rewrite H.
trivial.
Qed.

Theorem spolynomial_normalize_ok :
 forall p:spolynomial, interp_cs (spolynomial_normalize p) = interp_sp p.
simple induction p; simpl in |- *; intros.

reflexivity.
reflexivity.

rewrite canonical_sum_merge_ok.
rewrite H; rewrite H0.
reflexivity.

rewrite canonical_sum_prod_ok.
rewrite H; rewrite H0.
reflexivity.
Qed.

Lemma canonical_sum_simplify_ok :
 forall s:canonical_sum, interp_cs (canonical_sum_simplify s) = interp_cs s.
simple induction s.

reflexivity.

(* cons_monom *)
simpl in |- *; intros.
generalize (SR_eq_prop T a Azero).
elim (Aeq a Azero).
intro Heq; rewrite (Heq I).
rewrite H.
rewrite ics_aux_ok.
rewrite interp_m_ok.
rewrite (SR_mult_zero_left T).
trivial.

intros; simpl in |- *.
generalize (SR_eq_prop T a Aone).
elim (Aeq a Aone).
intro Heq; rewrite (Heq I).
simpl in |- *.
repeat rewrite ics_aux_ok.
rewrite interp_m_ok.
rewrite H.
rewrite (SR_mult_one_left T).
reflexivity.

simpl in |- *.
repeat rewrite ics_aux_ok.
rewrite interp_m_ok.
rewrite H.
reflexivity.

(* cons_varlist *)
simpl in |- *; intros.
repeat rewrite ics_aux_ok.
rewrite H.
reflexivity.

Qed.

Theorem spolynomial_simplify_ok :
 forall p:spolynomial, interp_cs (spolynomial_simplify p) = interp_sp p.
intro.
unfold spolynomial_simplify in |- *.
rewrite canonical_sum_simplify_ok.
apply spolynomial_normalize_ok.
Qed.

(* End properties. *)
End semi_rings.

Implicit Arguments Cons_varlist.
Implicit Arguments Cons_monom.
Implicit Arguments SPconst.
Implicit Arguments SPplus.
Implicit Arguments SPmult.

Section rings.

(* Here the coercion between Ring and Semi-Ring will be useful *)

Set Implicit Arguments.

Variable A : Type.
Variable Aplus : A -> A -> A.
Variable Amult : A -> A -> A.
Variable Aone : A.
Variable Azero : A.
Variable Aopp : A -> A.
Variable Aeq : A -> A -> bool.
Variable vm : varmap A.
Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq.

Hint Resolve (Th_plus_comm T).
Hint Resolve (Th_plus_assoc T).
Hint Resolve (Th_plus_assoc2 T).
Hint Resolve (Th_mult_comm T).
Hint Resolve (Th_mult_assoc T).
Hint Resolve (Th_mult_assoc2 T).
Hint Resolve (Th_plus_zero_left T).
Hint Resolve (Th_plus_zero_left2 T).
Hint Resolve (Th_mult_one_left T).
Hint Resolve (Th_mult_one_left2 T).
Hint Resolve (Th_mult_zero_left T).
Hint Resolve (Th_mult_zero_left2 T).
Hint Resolve (Th_distr_left T).
Hint Resolve (Th_distr_left2 T).
(*Hint Resolve (Th_plus_reg_left T).*)
Hint Resolve (Th_plus_permute T).
Hint Resolve (Th_mult_permute T).
Hint Resolve (Th_distr_right T).
Hint Resolve (Th_distr_right2 T).
Hint Resolve (Th_mult_zero_right T).
Hint Resolve (Th_mult_zero_right2 T).
Hint Resolve (Th_plus_zero_right T).
Hint Resolve (Th_plus_zero_right2 T).
Hint Resolve (Th_mult_one_right T).
Hint Resolve (Th_mult_one_right2 T).
(*Hint Resolve (Th_plus_reg_right T).*)
Hint Resolve refl_equal sym_equal trans_equal.
(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
Hint Immediate T.

(*** Definitions *)

Inductive polynomial : Type :=
  | Pvar : index -> polynomial
  | Pconst : A -> polynomial
  | Pplus : polynomial -> polynomial -> polynomial
  | Pmult : polynomial -> polynomial -> polynomial
  | Popp : polynomial -> polynomial.

Fixpoint polynomial_normalize (x:polynomial) : canonical_sum A :=
  match x with
  | Pplus l r =>
      canonical_sum_merge Aplus Aone (polynomial_normalize l)
        (polynomial_normalize r)
  | Pmult l r =>
      canonical_sum_prod Aplus Amult Aone (polynomial_normalize l)
        (polynomial_normalize r)
  | Pconst c => Cons_monom c Nil_var (Nil_monom A)
  | Pvar i => Cons_varlist (Cons_var i Nil_var) (Nil_monom A)
  | Popp p =>
      canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var
        (polynomial_normalize p)
  end.

Definition polynomial_simplify (x:polynomial) :=
  canonical_sum_simplify Aone Azero Aeq (polynomial_normalize x).

Fixpoint spolynomial_of (x:polynomial) : spolynomial A :=
  match x with
  | Pplus l r => SPplus (spolynomial_of l) (spolynomial_of r)
  | Pmult l r => SPmult (spolynomial_of l) (spolynomial_of r)
  | Pconst c => SPconst c
  | Pvar i => SPvar A i
  | Popp p => SPmult (SPconst (Aopp Aone)) (spolynomial_of p)
  end.

(*** Interpretation *)

Fixpoint interp_p (p:polynomial) : A :=
  match p with
  | Pconst c => c
  | Pvar i => varmap_find Azero i vm
  | Pplus p1 p2 => Aplus (interp_p p1) (interp_p p2)
  | Pmult p1 p2 => Amult (interp_p p1) (interp_p p2)
  | Popp p1 => Aopp (interp_p p1)
  end.

(*** Properties *)

Unset Implicit Arguments.

Lemma spolynomial_of_ok :
 forall p:polynomial,
   interp_p p = interp_sp Aplus Amult Azero vm (spolynomial_of p).
simple induction p; reflexivity || (simpl in |- *; intros).
rewrite H; rewrite H0; reflexivity.
rewrite H; rewrite H0; reflexivity.
rewrite H.
rewrite (Th_opp_mult_left2 T).
rewrite (Th_mult_one_left T).
reflexivity.
Qed.

Theorem polynomial_normalize_ok :
 forall p:polynomial,
   polynomial_normalize p =
   spolynomial_normalize Aplus Amult Aone (spolynomial_of p).
simple induction p; reflexivity || (simpl in |- *; intros).
rewrite H; rewrite H0; reflexivity.
rewrite H; rewrite H0; reflexivity.
rewrite H; simpl in |- *.
elim
 (canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var
    (spolynomial_normalize Aplus Amult Aone (spolynomial_of p0)));
 [ reflexivity
 | simpl in |- *; intros; rewrite H0; reflexivity
 | simpl in |- *; intros; rewrite H0; reflexivity ].
Qed.

Theorem polynomial_simplify_ok :
 forall p:polynomial,
   interp_cs Aplus Amult Aone Azero vm (polynomial_simplify p) = interp_p p.
intro.
unfold polynomial_simplify in |- *.
rewrite spolynomial_of_ok.
rewrite polynomial_normalize_ok.
rewrite (canonical_sum_simplify_ok A Aplus Amult Aone Azero Aeq vm T).
rewrite (spolynomial_normalize_ok A Aplus Amult Aone Azero Aeq vm T).
reflexivity.
Qed.

End rings.

Infix "+" := Pplus : ring_scope.
Infix "*" := Pmult : ring_scope.
Notation "- x" := (Popp x) : ring_scope.
Notation "[ x ]" := (Pvar x) (at level 0) : ring_scope.

Delimit Scope ring_scope with ring.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  Ifnot, see <http://www.gnu.org/licenses/>.

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

 *)

Require Export continuity_type.
Require Export psquash.

Definition rule_continuity2 {o}
           (F f : @NTerm o)
           (H : barehypotheses) :=
    mk_rule
      (mk_baresequent H (mk_conclax (mk_psquash (continuous_type F f))))
      [
        mk_baresequent H (mk_conclax (mk_member F (mk_fun (mk_fun mk_int mk_int) mk_int))),
        mk_baresequent H (mk_conclax (mk_member f (mk_fun mk_int mk_int)))
      ]
      [].

Lemma rule_continuity2_true {p} :
  forall lib
         (F f : NTerm)
         (H : @barehypotheses p),
    rule_true lib (rule_continuity2
                     F f
                     H).
Proof.
  unfold rule_continuity2, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  rename Hyp into hyp1.
  rename Hyp0 into hyp2.
  destruct hyp1 as [wc1 hyp1].
  destruct hyp2 as [wc2 hyp2].
  destseq; allsimpl; proof_irr; GC.
  unfold closed_extract; simpl.

  exists (@covered_axiom p (nh_vars_hyps H)).

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

  vr_seq_true.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as h; exrepnd; clear hyp1.

  vr_seq_true in hyp2.
  pose proof (hyp2 s1 s2 eqh sim) as k; exrepnd; clear hyp2.

  lsubst_tac.

  assert ((newvarlst [F, f]
           <> newvarlst
                [F, f, mk_var (newvarlst [F, f]),
                 mk_var (newvarlst [F, f, mk_var (newvarlst [F, f])])])
            # (newvarlst [F, f]
               <> newvarlst [F, f, mk_var (newvarlst [F, f])])
            # (newvarlst [F, f, mk_var (newvarlst [F, f])]
               <> newvarlst
                    [F, f, mk_var (newvarlst [F, f]),
                     mk_var (newvarlst [F, f, mk_var (newvarlst [F, f])])])
            # (!LIn (newvarlst
                       [F, f, mk_var (newvarlst [F, f]),
                        mk_var (newvarlst [F, f, mk_var (newvarlst [F, f])])])
                (free_vars f))
            # (!LIn (newvarlst [F, f, mk_var (newvarlst [F, f])]) (free_vars f))
            # (!LIn (newvarlst [F, f]) (free_vars f))
            # (!LIn (newvarlst
                       [F, f, mk_var (newvarlst [F, f]),
                        mk_var (newvarlst [F, f, mk_var (newvarlst [F, f])])])
                (free_vars F))
            # (!LIn (newvarlst [F, f, mk_var (newvarlst [F, f])]) (free_vars F))
            # (!LIn (newvarlst [F, f]) (free_vars F))) as d.
  { repeat gen_newvar.
    repeat get_newvar_prop.
    allsimpl; allrw in_app_iff.
    allrw not_over_or; sp. }
  repnd.

  prove_and teq.

  - apply tequality_mkc_squash.
    allrw @member_eq.
    allrw <- @member_member_iff.
    allrw @tequality_mkc_member_sp; repnd.
    allrw @fold_equorsq.

    unfold continuous_type, continuous_type_aux; simpl.
    lsubst_tac.

    apply tequality_product; dands; eauto with slow.

    { allrw @lsubstc_mkc_tnat.
      apply type_tnat. }

    introv e1.
    repeat substc_lsubstc_vars3.
    lsubst_tac.

    apply tequality_isect; dands.

    { unfold int2int.
      lsubst_tac.
      repeat one_lift_lsubst2_concl.
      apply tequality_fun; dands.
      - apply tequality_int.
      - introv x; apply tequality_int. }

    introv e2.

    repeat substc_lsubstc_vars3.
    repeat one_lift_lsubst_concl.
    apply tequality_mkc_ufun; dands.

    { unfold agree_upto_b_type.
      repeat one_lift_lsubst_concl.
      repeat one_lift_lsubst2_concl.

      apply tequality_isect; dands.

      - apply tequality_set; dands.

        { apply tequality_int. }

        introv e3.
        repeat substc_lsubstc_vars3.
        repeat one_lift_lsubst_concl.
        apply tequality_mkc_member_sp; dands.

        + unfold mk_natk_aux.
          repeat one_lift_lsubst_concl.
          repeat one_lift_lsubst2_concl.
          apply tequality_set; dands.

          { apply tequality_int. }

          introv e4.

          repeat substc_lsubstc_vars3.
          repeat one_lift_lsubst_concl.
          apply tequality_mkc_prod; dands.

          { repeat one_lift_lsubst2_concl.
            repeat one_lift_lsubst_concl.
            repeat (rw @lsubstc_cons_var).

            clear_cv.

            apply tequality_mkc_le.
            apply equality_in_int in e4.
            unfold equality_of_int in e4; exrepnd.
            exists (0%Z) k (0%Z) k; dands; spcast; auto;
            try (complete (unfold computes_to_valc; simpl;
                           unfold computes_to_value; dands;
                           eauto with slow)).

            destruct (Z_le_gt_dec 0 k); tcsp.
            right; dands; omega. }

          revert e1 e4.

          repeat one_lift_lsubst2_concl.
          repeat one_lift_lsubst_concl.
          repeat (rw @lsubstc_cons_var).
          lsubstc_snoc.
          introv e1 e4 inh1.

          apply equality_in_int_and_inhabited_le_implies_equality_in_nat in e4; auto.
          apply equality_in_tnat in e1.
          apply equality_in_tnat in e4.
          unfold equality_of_nat in e1.
          unfold equality_of_nat in e4.
          exrepnd.

          apply tequality_mkc_less_than.
          exists (Z.of_nat k) (Z.of_nat k3) (Z.of_nat k) (Z.of_nat k3).
          dands; spcast; auto.

          destruct (Z_lt_ge_dec (Z.of_nat k) (Z.of_nat k3)); tcsp.
          right; dands; omega.

        + right.
          unfold absolute_value, mk_natk_aux.
          repeat one_lift_lsubst2_concl.
          repeat one_lift_lsubst_concl.
          repeat one_lift_lsubst2_concl.
          repeat (rw @lsubstc_cons_var).
          revert e3; intro e3.
          fold (absolute_value_c a1).
          fold (absolute_value_c a'1).
          spcast.
          apply cequivc_absolute_value; auto.

      - introv e3.
        clear_cv.
        repeat substc_lsubstc_vars3.
        repeat one_lift_lsubst_concl.
        repeat one_lift_lsubst2_concl.
        repeat (rw @lsubstc_cons_var).
        lsubstc_snoc.
        clear_cv.

        apply tequality_mkc_equality_sp; dands.

        { apply tequality_int. }

        { revert k0.
          repeat one_lift_lsubst2_concl; intro k.
          apply equality_in_set in e3; repnd.
          dorn k.

          - left.
            apply equality_in_fun in k; repnd.
            apply k; auto.

          - right.
            apply equality_in_int_implies_cequiv in e4; spcast.
            apply implies_cequivc_apply; auto.
        }

        { revert e2; intro e2.
          unfold int2int in e2.
          repeat (one_lift_lsubst_hyp e2).
          repeat (one_lift_lsubst2_hyp e2).
          apply equality_in_set in e3; repnd.
          left.
          apply equality_in_fun in e2; repnd.
          apply e2; auto.
        }
    }

    { clear_cv.
      repeat one_lift_lsubst2_concl.
      intro inh.
      lsubstc_snoc_concl.
      revert h1 h0; intros h0 h1.
      unfold member in h0.
      repeat (one_lift_lsubst_hyp h0).
      eapply cequorsq_equality_trans2 in h1;[clear h0|exact h0].
      repeat (one_lift_lsubst2_hyp h1).
      apply tequality_mkc_equality_sp; dands.

      { apply tequality_int. }

      { left.
        apply equality_in_fun in h1; repnd.
        apply h1.
        repeat (one_lift_lsubst_concl).
        repeat (one_lift_lsubst2_concl).

        revert k1 k0; intros k0 k1.
        unfold member in k0.
        repeat (one_lift_lsubst_hyp k0).
        repeat (one_lift_lsubst2_hyp k0).
        repeat (one_lift_lsubst2_hyp k1).
        eapply cequorsq_equality_trans2 in k1;[clear k0|exact k0].
        auto.
      }

      { left.
        apply equality_in_fun in h1; repnd.
        apply h1; auto. }
    }

  - apply equality_in_mkc_squash; dands; spcast; auto;
    try computes_to_value_refl.

    allrw @member_eq.
    allrw <- @member_member_iff.
    allrw @tequality_mkc_member_sp; repnd.
    allrw @fold_equorsq.

    pose proof (continuity_axiom lib (lsubstc F wt0 s1 ct2)) as cont.
    autodimp cont hyp.
    {
      revert h1; unfold member; intro h.
      repeat (one_lift_lsubst_hyp h).
      allfold (@int2int p).
      allrw (@lsubstc_int2int).
      repeat (one_lift_lsubst2_hyp h).
      auto.
    }

    pose proof (cont (lsubstc f wt s1 ct1)) as cont1; clear cont.
    autodimp cont1 hyp.
    {
      revert k1; unfold member; intro h.
      repeat (one_lift_lsubst_hyp h).
      repeat (one_lift_lsubst2_hyp h).
      auto.
    }

    exrepnd.
    unfold continuous_type, continuous_type_aux; simpl.
    repeat (one_lift_lsubst_concl).
    repeat (one_lift_lsubst2_concl).
    exists (@mkc_pair p (mkc_nat b) mkc_axiom).

    rw @tequality_mkc_squash in teq.
    apply tequality_refl in teq.
    rw @fold_type in teq.
    unfold continuous_type, continuous_type_aux in teq; simpl in teq.
    repeat (one_lift_lsubst_hyp teq).
    repeat (one_lift_lsubst2_hyp teq).

    apply member_product2; dands; auto.

    apply tequality_product in teq; repnd.
    pose proof (teq (mkc_nat b) (mkc_nat b)) as teq2; clear teq.
    allrw @fold_type.

    keepdimp teq2 teq.
    {
      apply equality_in_tnat.
      exists b; dands; spcast; eauto with slow;
      apply computes_to_valc_refl; eauto with slow.
    }

    exists (@mkc_nat p b) (@mkc_axiom p); dands; spcast; auto.

    { apply computes_to_valc_refl; eauto with slow. }

    { repeat substc_lsubstc_vars3.
      repeat one_lift_lsubst_concl.
      repeat (one_lift_lsubst_hyp teq2).
      allrw (@lsubstc_int2int).
      clear_cv.

      apply tequality_isect in teq2; repnd.

      apply equality_in_isect; dands; auto.

      intros g1 g2 e1.
      pose proof (teq2 g1 g2 e1) as teq3; clear teq2.
      allrw @fold_type.
      repeat substc_lsubstc_vars3.
      repeat one_lift_lsubst_concl.
      repeat (one_lift_lsubst_hyp teq3).
      clear_cv.
      apply tequality_refl in teq3.
      rw @fold_type in teq3.

      apply tequality_mkc_ufun in teq3; repnd.
      apply equality_in_ufun; dands; auto.
      intro inh.
      autodimp teq3 hyp;[].
      apply tequality_refl in teq2.
      apply tequality_refl in teq3.
      allrw @fold_type.

      revert teq3.
      lsubstc_snoc_concl.
      intro teq3.
      apply tequality_mkc_equality_sp in teq3; repnd.

      pose proof (cont0 g1) as cont1; clear cont0.
      autodimp cont1 hyp.
      { apply equality_refl in e1; auto. }

      keepdimp cont1 cont2.
      {
        introv r1 r2 l.
        unfold agree_upto_b_type in inh.
        repeat (one_lift_lsubst_hyp inh).
        apply equality_of_int_imp_tt.
        unfold inhabited_type in inh; exrepnd.
        rw @equality_in_isect in inh0; repnd.
        pose proof (inh0 t2 t2) as inh; clear inh0.
        repeat (one_lift_lsubst2_hyp inh1).
        repeat (one_lift_lsubst2_hyp inh2).
        repeat (one_lift_lsubst2_hyp inh).
        autodimp inh hyp.
        {
          rw @tequality_set in inh1; repnd.
          assert (equality lib t2 t2 mkc_int) as ei.
          {
            apply equality_in_int.
            exists i; dands; spcast; auto;
            apply computes_to_valc_iff_reduces_toc; eauto with slow.
          }

          rw @equality_in_set; dands; auto; [].
          applydup inh1 in ei as inh3; clear inh1 inh2.
          repeat substc_lsubstc_vars3.
          apply tequality_refl in inh3.
          allrw @fold_type.
          repeat one_lift_lsubst_concl.
          repeat (one_lift_lsubst_hyp inh3).
          exists (@mkc_axiom p).
          rw <- @member_member_iff.
          apply tequality_mkc_member_sp in inh3; repnd.
          allrw @fold_type.
          clear inh3.

          unfold absolute_value, mk_natk_aux.
          unfold absolute_value, mk_natk_aux in inh1.
          repeat one_lift_lsubst2_concl.
          repeat one_lift_lsubst_concl.
          repeat one_lift_lsubst2_concl.
          repeat (rw @lsubstc_cons_var).
          fold (absolute_value_c t2).

          repeat (one_lift_lsubst_hyp inh1).
          repeat (one_lift_lsubst2_hyp inh1).
          rw @tequality_set in inh1; repnd.

          pose proof (inh1 (absolute_value_c t2) (absolute_value_c t2)) as inh.
          keepdimp inh ai.
          {
            apply equality_in_int.
            unfold equality_of_int.
            exists (Z.abs i).
            dands; spcast; apply computes_to_valc_absolute_value; auto;
            apply computes_to_valc_iff_reduces_toc; eauto with slow.
          }

          apply equality_in_set; dands; auto; clear inh1;[].

          repeat substc_lsubstc_vars3.
          apply tequality_refl in inh.
          allrw @fold_type.
          repeat (one_lift_lsubst_hyp inh).
          repeat (one_lift_lsubst2_hyp inh).
          repeat (one_lift_lsubst_concl).
          repeat (one_lift_lsubst2_concl).
          clear_cv.

          apply type_mkc_prod in inh; repnd.
          apply inhabited_prod2.

          prove_and ty1; GC.

          prove_and it1;[|prove_and ty2]; auto; GC.

          {
            repeat (one_lift_lsubst_hyp inh1).
            repeat (one_lift_lsubst2_hyp inh1).
            repeat (one_lift_lsubst_concl).
            repeat (one_lift_lsubst2_concl).
            lsubstc_snoc_concl.
            lsubstc_snoc_hyp inh1.
            apply inhabited_le.
            exists (0%Z) (Z.abs i).
            dands; spcast;
            try (complete (unfold computes_to_valc; simpl;
                           unfold computes_to_value; dands;
                           eauto with slow));
            try (complete (apply computes_to_valc_absolute_value; auto;
                           apply computes_to_valc_iff_reduces_toc; eauto with slow)).
            destruct i; allsimpl; try omega; apply Pos2Z.is_nonneg.
          }

          {
            autodimp inh hyp.
            repeat (one_lift_lsubst_hyp inh).
            repeat (one_lift_lsubst2_hyp inh).
            repeat (one_lift_lsubst_concl).
            repeat (one_lift_lsubst2_concl).
            lsubstc_snoc_concl.
            lsubstc_snoc_hyp inh.
            apply inhabited_less_than.
            exists (Z.abs i) (Z.of_nat b).
            dands; spcast;
            try (complete (unfold computes_to_valc; simpl;
                           unfold computes_to_value; dands;
                           eauto with slow));
            try (complete (apply computes_to_valc_absolute_value; auto;
                           apply computes_to_valc_iff_reduces_toc; eauto with slow)).
            revert l; intro l.
            destruct i; allsimpl; try omega; rw <- Znat.positive_nat_Z; apply Znat.inj_lt; auto.
          }
        }

        repeat substc_lsubstc_vars3.
        repeat (one_lift_lsubst_hyp inh).
        repeat (one_lift_lsubst2_hyp inh).
        revert inh.
        lsubstc_snoc_concl.
        intro inh.
        revert k1; intro k1.
        rw @equality_in_fun in k1; repnd.
        pose proof (k1 t1 t2) as ef; autodimp ef hyp.
        {
          apply equality_in_int.
          exists i; dands; spcast; auto;
          apply computes_to_valc_iff_reduces_toc; eauto with slow.
        }

        apply equality_in_mkc_equality in inh; repnd.
        apply equality_in_int.
        eapply equality_trans;[exact ef|]; auto.
      }

      rw @member_eq.
      rw <- @member_equality_iff.
      repeat (one_lift_lsubst2_concl).
      apply equality_in_int.
      unfold equality_of_int_tt in cont1; exrepnd.
      exists k; dands; spcast; auto.
    }
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C P T Y X : Universe, ((wd_ P T /\ (wd_ X Y /\ (wd_ P Y /\ (wd_ P X /\ (wd_ B T /\ (wd_ B P /\ (wd_ C B /\ (wd_ Y B /\ (wd_ A C /\ (wd_ A B /\ (col_ T P Y /\ (col_ P Y X /\ col_ B C Y)))))))))))) -> col_ P T X)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition check_timer_became_asserted_spec0 (timer: Pointer) (cntx_ctl: Z64) (adt: RData) : option (RData * Z) :=
    match timer, cntx_ctl with
    | (_timer_base, _timer_ofst), VZ64 _cntx_ctl =>
      when _t'5 == get_timer_asserted_spec (_timer_base, _timer_ofst) adt;
      rely is_int _t'5;
      if (negb (_t'5 =? 0)) then
        Some (adt, 0)
      else
        rely is_int64 _cntx_ctl;
        when _t'1 == timer_is_masked_spec (VZ64 _cntx_ctl) adt;
        rely is_int _t'1;
        when adt == set_timer_masked_spec (_timer_base, _timer_ofst) _t'1 adt;
        when _t'2 == get_timer_masked_spec (_timer_base, _timer_ofst) adt;
        rely is_int _t'2;
        if (_t'2 =? 0) then
          when _t'4 == timer_condition_met_spec (VZ64 _cntx_ctl) adt;
          rely is_int _t'4;
          let _t'3 := (_t'4 =? 1) in
          if _t'3 then
            Some (adt, 1)
          else
            Some (adt, 0)
        else
          let _t'3 := 0 in
          Some (adt, 0)
     end
    .

End SpecLow.


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

(***
Modulus : 2^256 - 2^32 - 977
Base: 21 + 1/3
***)

Definition curve : CurveParameters :=
  {|
    sz := 12%nat;
    base := 21 + 1/3;
    bitwidth := 32;
    s := 2^256;
    c := [(1, 977); (2^32, 1)];
    carry_chains := Some [[0; 11]; [1; 0; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11]; [1; 0]]%nat;

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

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

    mul_code := None;

    square_code := None;

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

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


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.
Require Export Category.Construction.Opposite.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Definition Opposite_Functor `(F : C ⟶ D) : C^op ⟶ D^op :=
  @Build_Functor (C^op) (D^op) F
    (λ (x y : C ^op) (f : x ~{ C ^op }~> y), @fmap C D F y x f)
    (λ (x y : C ^op) (f g : x ~{ C ^op }~> y), @fmap_respects _ _ F y x f g)
    (λ x : C ^op, fmap_id)
    (λ (x y z : C ^op) (f : y ~{ C ^op }~> z)
      (g : x ~{ C ^op }~> y), @fmap_comp _ _ F _ _ _ g f).

Notation "F ^op" := (@Opposite_Functor _ _ F)
  (at level 7, format "F ^op") : functor_scope.

Corollary Opposite_Functor_invol `{F : C ⟶ D} : (F^op)^op = F.
Proof. reflexivity. Qed.

Definition contramap `{F : C^op ⟶ D} `(f : x ~{C}~> y) :
  F y ~{D}~> F x := fmap (op f).