Require Import VST.concurrency.conclib.
Require Import VST.floyd.proofauto.
Require Import VST.atomics.general_locks.
Require Import Coq.Sets.Ensembles.
Require Import bst.puretree.
Require Import bst.bst_template_giveup.
Require Import bst.giveup_lib.
Require Import bst.giveup_traverse.
Require Import VST.atomics.verif_lock_atomic.
Require Import VST.floyd.library.

(* Write insert_spec following the template style.
We need to write some specs of helper functions: insertOp, traverse and findnext
1) insert_spec:
           ∀ t. <bst_ref p | bst t>  insert2 (treebox t, int x, void *value)
                <t'. bst_ref p | bst t' ∧ insert t k v = t' >
2) insertOp_spec:
          {N /\  x \in range} insertOp(pn *pn, int x, void *value)
          {t'. N ∧ t' = (<[x:=k]> t) }
3) traverse_spec:
          < ...  | bst t> traverse(pn *pn, int x, void *value)
          <v. bst t /\ lock_inv >
4) findnext_spec:
          {x \in range  /\ ...} findNext(pn *pn, int x, void *value)
          {v. ((v = 1 /\ ....) \/ (v = 0 /\  ...)) /\  ... } *)

(* insert spec *)
Program Definition lookup_spec :=
  DECLARE _lookup
  ATOMIC TYPE (rmaps.ConstType (val * share * val * Z * globals * gname * gname))
  OBJ M INVS ∅
  WITH b, sh, lock, x, gv, g, g_root
  PRE [ tptr (tptr t_struct_tree_t), tint ]
    PROP (writable_share sh; and (Z.le Int.min_signed x) (Z.le x Int.max_signed))
    PARAMS (b; Vint (Int.repr x)) GLOBALS (gv)
    SEP (mem_mgr gv; nodebox_rep g g_root sh lock b) | (tree_rep g g_root M)
  POST[ tptr tvoid ]
  EX ret: val,
    PROP ()
    LOCAL ()
    SEP (mem_mgr gv; nodebox_rep g g_root sh lock b) |
    (!! (ret = match M !! x with Some v => v | None => nullval end) && tree_rep g g_root M).

Definition spawn_spec := DECLARE _spawn spawn_spec.

Definition Gprog : funspecs :=
    ltac:(with_library prog [acquire_spec; release_spec; makelock_spec;
     surely_malloc_spec; inrange_spec; lookup_spec;
     traverse_spec; findnext_spec; treebox_new_spec]).

Check empty_range.

Check range_incl.
Lemma range_info_incl: forall tg o ri rn r_root,
  range_info_in_tree ((ri, rn), o) r_root tg -> keys_in_range_ghost tg r_root -> sorted_ghost_tree tg ->
  range_incl rn r_root = true.
Proof.
  induction 1; intros.
  - inv H. apply range_incl_refl.
  - inv H. apply range_incl_refl.
  - apply keys_in_range_ghost_subtrees in H0 as (? & ? & ?); auto.
    inv H1.
    unfold range_incl in *; destruct rn, range; simpl in *.
    apply andb_prop in IHrange_info_in_tree as [->]; auto.
    eapply less_than_equal_trans; first eassumption.
    apply less_than_to_less_than_equal.
    apply andb_prop in H0 as [_ ?]; auto.
  - apply keys_in_range_ghost_subtrees in H0 as (? & ? & ?); auto.
    inv H1.
    unfold range_incl in *; destruct rn, range; simpl in *.
    apply andb_prop in IHrange_info_in_tree as [? ->]; auto.
    rewrite andb_true_r.
    eapply less_than_equal_trans; last eassumption.
    apply less_than_to_less_than_equal.
    apply andb_prop in H0 as [? _]; auto.
Qed.

Lemma range_info_not_in_gmap: forall tg x ri rn r_root,
    sorted_ghost_tree tg -> key_in_range x rn = true ->
    keys_in_range_ghost tg r_root ->
    range_info_in_tree ((ri, rn), Some None) r_root tg -> tree_to_gmap tg !! x = None.
Proof.
  induction tg; intros; simpl.
  { apply lookup_empty. }
  apply keys_in_range_ghost_subtrees in H1 as (? & ? & ?); auto.
  inv H; inv H2.
  - inv H5.
  - exploit range_info_incl; eauto; intros Hrange.
    pose proof (key_in_range_incl _ _ _ H0 Hrange) as Hx.
    apply andb_prop in Hx as []; simpl in *.
    rewrite -> lookup_insert_ne by lia.
    rewrite lookup_union_None; split.
    + eapply IHtg1; eauto.
    + destruct (eq_dec (tree_to_gmap tg2 !! x) None); auto.
      apply In_tree_to_gmap, Hltr in n; lia.
  - exploit range_info_incl; eauto; intros Hrange.
    pose proof (key_in_range_incl _ _ _ H0 Hrange) as Hx.
    apply andb_prop in Hx as []; simpl in *.
    rewrite -> lookup_insert_ne by lia.
    rewrite lookup_union_None; split.
    + destruct (eq_dec (tree_to_gmap tg1 !! x) None); auto.
      apply In_tree_to_gmap, Hgtl in n; lia.
    + eapply IHtg2; eauto.
Qed.

Lemma range_info_in_tree_In: forall tg x v ga gb rn r_root,
    range_info_in_tree (rn, Some (Some (x, v, ga, gb))) r_root tg ->
    In_ghost x tg.
Proof.
  induction tg; intros.
  { inv H. inv H0. }
  inv H.
  - inv H1. now constructor 1.
  - constructor 2. eapply IHtg1; eauto.
  - constructor 3. eapply IHtg2; eauto.
Qed.

Lemma range_info_in_gmap: forall x v ga gb tg rn r_root,
    sorted_ghost_tree tg ->
    range_info_in_tree (rn, Some (Some (x, v, ga, gb))) r_root tg ->
    tree_to_gmap tg !! x = Some v.
Proof.
  induction tg; intros; simpl.
  { inv H0. inv H1. }
  inv H. inv H0.
  - inv H1. apply lookup_insert.
  - exploit Hgtl. { eapply range_info_in_tree_In; eauto. }
    intros; rewrite -> lookup_insert_ne by lia.
    eapply lookup_union_Some_l, IHtg1; eauto.
  - exploit Hltr. { eapply range_info_in_tree_In; eauto. }
    intros; rewrite -> lookup_insert_ne by lia.
    rewrite lookup_union_r.
    + eapply IHtg2; eauto.
    + destruct (eq_dec (tree_to_gmap tg1 !! x) None); auto.
      apply In_tree_to_gmap, Hgtl in n; lia.
Qed.

Lemma ghost_tree_rep_public_half_ramif: forall tg g_root p lk pn lockn r_root g g_in,
    find_ghost_set tg g_root p lk !! g_in = Some (pn, lockn) ->
    ghost_tree_rep tg p g_root lk g r_root |--
    EX r a, !! (range_info_in_tree ((p, lk, r), a) r_root tg) &&
                       (ghost_tree_rep tg p g_root lk g r_root).
Proof.
  intros.
  generalize dependent g_root.
  generalize dependent lk.
  generalize dependent p.
  induction tg; intros p lk g_root; simpl in *; intros; unfold ltree.
  - destruct (decide(g_root = g_in)).
    + subst.
      rewrite lookup_singleton in H.
      subst.
      iIntros "(H1 & H2)".
      iExists _, _. iFrame.
      iPureIntro. (split; auto); by econstructor.
    + eapply lookup_singleton_None with (x:= (p, lk)) in n.
      rewrite H in n. inversion n.
  - destruct r_root.
    destruct (decide(g_root = g_in)); Intros pt.
    + subst.
      apply lookup_insert_rev in H.
      inversion H; subst.
      iIntros "(((H & H1) & H2) & H3)".
      iExists _, _. iFrame "H2 H3".
      iSplit. iPureIntro. by econstructor.
      iExists _. iFrame.
    + apply lookup_insert_Some in H.
      destruct H.
      * destruct H; rewrite H in n1; contradiction.
      * destruct H.
        rewrite lookup_union_Some_raw in H0.
        destruct H0.
        ** destruct tg1. destruct tg2.
           simpl in *; unfold ltree.
           *** rewrite lookup_singleton_Some in H0.
               iIntros "(((H & H1) & H2) & (H3 & H4))".
               iExists _, _. iFrame "H2 H3 H4".
               iSplit. iPureIntro. by constructor.
               iExists _. iFrame "H H1".
           *** simpl in *; unfold ltree.
               rewrite lookup_singleton_Some in H0.
               destruct H0. inversion H1. subst.
               iIntros "(((H & H1) & (H2 & H3)) & H4)".
               iExists _, _.
               iSplit. iPureIntro. by constructor.
               iExists _. iFrame "H H1 H2 H3 H4".
           *** simpl in *; unfold ltree. clear IHtg2.
               specialize (IHtg1 v v0 g0).
               specialize (IHtg1 H0).
               simpl in IHtg1.
               iIntros "(((H & H1) & H2) & H4)".
               iExists _, _.
               iSplit. iPureIntro. by constructor.
               iExists _. iFrame "H H1 H2 H4".
        ** destruct H0. clear IHtg1.
           specialize (IHtg2 v2 v3 g1).
           specialize (IHtg2 H1).
           iIntros "(((H & H1) & H2) & H3)".
           iExists _, _.
           iSplit. iPureIntro. by constructor.
           iExists _. iFrame "H H1 H2 H3".
Qed.

(* Proving lookup function satisfies spec *)
Lemma body_lookup: semax_body Vprog Gprog f_lookup lookup_spec.
Proof.
  start_function.
  unfold nodebox_rep.
  Intros np.
  forward_call (t_struct_pn, gv).
  Intros nb.
  Intros lsh.
  forward.
  forward.
  sep_apply in_tree_duplicate.
  set (AS := atomic_shift _ _ _ _ _).
  set Q1:= fun (b : ( bool * (val * (share * (gname * node_info))))%type) =>
              if b.1 then AS else AS.
  (* traverse(pn, x, value) *)
  forward_call (nb, np, lock, x, nullval, gv, g, g_root, Q1).
  {
    Exists Vundef. entailer !.
    iIntros "(((H1 & H2) & H3) & H4)". iCombine "H2 H1 H3 H4" as "H".
    iVST.
    apply sepcon_derives; [| cancel_frame].
    iIntros "AU".
    unfold atomic_shift; iAuIntro; unfold atomic_acc; simpl.
    iMod "AU" as (m) "[Hm HClose]".
    iModIntro. iExists _. iFrame.
    iSplit; iFrame.
    iIntros "H1".
    iSpecialize ("HClose" with "H1"). auto.
    iDestruct "HClose" as "[HClose _]".
    iIntros (pt) "[H _]".
    iMod ("HClose" with "H") as "H".
    iModIntro.
    unfold Q1.
    destruct (decide (pt.1 = true)). { rewrite e; iFrame. }
    { apply not_true_is_false in n; rewrite n; iFrame. }
  }
  Intros pt.
  destruct pt as (fl & (p & (gsh & (g_in & r)))).
  simpl in H5.
  destruct fl.
  destruct H5 as (HGh & HP).
  - unfold Q1.
    forward_if(
        PROP ( )
          LOCAL (temp _v nullval; temp _t'2 Vtrue; temp _t'7 np; temp _pn__2 nb; gvars gv;
            temp _t b; temp _x (vint x))
          SEP (AS * mem_mgr gv *
                 data_at Ews t_struct_pn (p, p) nb * in_tree g g_in p r.1.1.2 *
                 in_tree g g_root np lock * malloc_token Ews t_struct_pn nb *
                 data_at sh (tptr t_struct_tree_t) np b *
                 field_at lsh t_struct_tree_t (DOT _lock) lock np *
                 node_lock_inv_pred g p g_in r)).
    + pose proof (Int.one_not_zero); easy.
    + simpl. forward. entailer !.
    + unfold node_lock_inv_pred, node_rep, tree_rep_R.
      rewrite -> if_true by auto.
      Intros.
      forward.
      (* alloc a pointer of lock for pointer p*)
      gather_SEP AS (in_tree g g_in p _).
      viewshift_SEP 0 (AS * (in_tree g g_in p r.1.1.2) * (EX lsh, !!(readable_share lsh) &&
                       field_at lsh t_struct_tree_t (DOT _lock) r.1.1.2 p)).
      { go_lower. apply lock_alloc. }
      Intros lsh1.
      forward.
      forward_call (r.1.1.2, Q nullval).
      {
        iIntros "(((((((((((((((AU & H1) & H2) & H3) & H4) & H5) & H6) & H7) & H8) & H9) & G1) & G2) & G3) & G4) & G5) & _)".
        iCombine "AU H1 H2" as "HH1".
        iCombine "G1 G2 H9 G3 G4 G5" as "HH2".
        iCombine "HH1 HH2" as "HH3".
        iVST.
        rewrite <- 5sepcon_assoc; rewrite <- sepcon_comm.
        apply sepcon_derives; [| cancel_frame].
        unfold atomic_shift; iIntros "((AU & (#H1 & H2)) & (H3 & (H4 & (H5 & (H6 & (H7 & _))))))"
        ; iAuIntro; unfold atomic_acc; simpl.
        iMod "AU" as (m) "[Hm HClose]".
        iModIntro.
        iPoseProof (tree_rep_insert _ g g_root g_in p r.1.1.2 with "[$Hm $H1]") as "InvLock".
        iDestruct "InvLock" as (R O) "((K1 & K2) & K3)".
        iDestruct "K2" as (lsh2) "(% & (K2 & KInv))".
        iDestruct "KInv" as (bl) "(KAt & KInv)".
        destruct bl.
        ++ iExists (). iFrame "KAt".
           iSplit.
           {
             iIntros "H".
             iFrame.
             iAssert (ltree g g_in p r.1.1.2 (node_lock_inv_pred g p g_in (R, Some O)))
               with "[H K2]" as "HInv".
             { iExists _. iSplit; try done. iFrame "K2". iExists true. iFrame. }
             iSpecialize ("K3" with "[$HInv $K1]").
             iDestruct "K3" as "(K3 & _)".
             iSpecialize ("HClose" with "K3").
             iFrame.
           }
           iIntros (_) "(H & _)".
           iDestruct "K3" as "[_ K3]".
           iPoseProof (public_agree g_in r (R, Some O) with "[$K1 $H5]") as "%Hx".
           destruct r.
           inversion Hx; subst.
           simpl.
           (* join lsh1 with lsh2 = Lsh *)
           destruct H10 as (Hf & Hrs).
           iPoseProof (lock_join with "[$H2 $K2]") as "K2"; try iSplit; auto.
           iDestruct "K2" as (Lsh) "(% & K2)".
           (* done pushing back pointer of lock into ltree *)
           iAssert (ltree g g_in p R.1.2 (node_lock_inv_pred g p g_in (R, Some O)))
             with "[H3 H4 H5 H6 H7 K2 H]" as "LT".
           {
             iExists Lsh. iFrame. iSplit; try done.
             iExists false; iFrame "H1 H H3 H4 H5 H6 H7".
             iSplit. try done.
             unfold tree_rep_R. rewrite -> if_true; auto.
           }
            unfold ltree.
            iSpecialize ("K3" with "[$K1 $LT]").
            iDestruct "K3" as "(K3 & _)".
            iDestruct "HClose" as "(_ & HClose)".
            iSpecialize ("HClose" $! nullval).
            iApply "HClose".
            unfold tree_rep at 1.
            iDestruct "K3" as (tg p1 lk1) "((%K3 & K4) & K5)".
            destruct K3 as (K31 & K32 & K33 & K34).
            iPoseProof (node_exist_in_tree g (find_ghost_set tg g_root p1 lk1) p
                         with "[H1 K5]") as "%Hy".
            { iFrame "H1". iFrame. }
            iPoseProof (ghost_tree_rep_public_half_ramif _ _ _ _ _ _ (Neg_Infinity, Pos_Infinity)
                                                         with "[$K4]") as "GT".
            { apply Hy. }
            iDestruct "GT" as (r a) "(%GT1 & GT2)".
            (*r : range, a : ghost_info === Some None \/ Some (Some....) *)
            simpl in *.
            iFrame.
            iSplit.
            iPureIntro.
            simpl in *.
            subst.
            Check range_info_not_in_gmap.
            erewrite -> (range_info_not_in_gmap _ _ _ r (Neg_Infinity, Pos_Infinity)); eauto.
            eapply key_in_range_incl. apply H1.
            assert (range_incl R.2 r = true). admit. auto.
            assert (a = Some None). admit.
            subst; eauto.
            (* need to have range_incl R.2 r = true --- R.2 in r *)
            Check @sepalg.join node_info (@Join_G node_ghost) (R, Some O) _ (p1, lk1, r, a).
            assert ((∃ x : node_info, @sepalg.join node_info (@Join_G node_ghost) (R, Some O) x (p1, lk1, r, a))). {
              Search sepalg.join .
              unfold sepalg.join. unfold Join_G. auto.
              admit.
           }
           iExists _, _, _. iFrame. iSplit; done.
         ++ (* contradiction *)
           unfold node_lock_inv_pred at 1.
           iDestruct "KInv" as "(? & KInv)".
           unfold node_rep.
           iDestruct "KInv" as "((((((? & KInv) & ?) & ?) & ?) & ?) & ?)".
           iPoseProof (field_at_conflict Ews t_struct_tree_t (DOT _t) p
                      with "[$H3 $KInv]") as "HF"; eauto; simpl; lia.
      }
     (* free *)
     forward_call (t_struct_pn, nb, gv).
     { assert_PROP (nb <> nullval) by entailer !. rewrite if_false; auto; cancel. }
     forward.
     unfold nodebox_rep.
     Exists nullval np lsh. entailer !.
  - simpl in H2.
    unfold Q1.
    destruct H5 as ( ?  & v2 & g21 & g22 & ?).
    simpl.
    forward_if (
        PROP ( )
     LOCAL (temp _v v2;temp _t'2 Vfalse; temp _t'7 np; temp _pn__2 nb; gvars gv; temp _t b;
     temp _x (vint x))
     SEP (AS; mem_mgr gv; seplog.emp; data_at Ews t_struct_pn (p, p) nb; in_tree g g_in p r.1.1.2;
     my_half g_in Tsh r *
       (!! (repable_signed (number2Z r.1.2.1)
          ∧ repable_signed (number2Z r.1.2.2) ∧ is_pointer_or_null r.1.1.2) &&
          field_at Ews t_struct_tree_t (DOT _t) r.1.1.1 p *
     field_at Ews t_struct_tree_t (DOT _min) (vint (number2Z r.1.2.1)) p *
     field_at Ews t_struct_tree_t (DOT _max) (vint (number2Z r.1.2.2)) p *
     malloc_token Ews t_struct_tree_t p * in_tree g g_in p r.1.1.2 *
     (EX (ga gb : gname) (x0 : Z) (v0 pa pb locka lockb : val),
       !! (r.2 = Some (Some (x0, v0, ga, gb))
           ∧ Int.min_signed ≤ x0 ≤ Int.max_signed
             ∧ is_pointer_or_null pa
               ∧ is_pointer_or_null locka
                 ∧ is_pointer_or_null pb
                   ∧ is_pointer_or_null lockb ∧ tc_val (tptr Tvoid) v0 ∧ key_in_range x0 r.1.2 = true) &&
     data_at Ews t_struct_tree (vint x0, (v0, (pa, pb))) r.1.1.1 *
     malloc_token Ews t_struct_tree r.1.1.1 * in_tree g ga pa locka * in_tree g gb pb lockb *
     in_tree g g_root np lock * malloc_token Ews t_struct_pn nb * data_at sh (tptr t_struct_tree_t) np b*
     field_at lsh t_struct_tree_t (DOT _lock) lock np)))).
    + unfold node_lock_inv_pred, node_rep, tree_rep_R.
      rewrite -> if_false; auto.
      simpl in H1, H2, H3, H4. simpl.
      Intros g1' g2' x1 v1' p1 p2 lock1 lock2.
      forward. forward. forward.
      Exists g1' g2' x1 v1' p1 p2 lock1 lock2.
      entailer !. apply derives_refl.
    + pose proof Int.one_not_zero; easy.
    + Intros g1 g2 x1 v1 p1 p2 lock1 lock2.
      forward.
      gather_SEP AS (in_tree g g_in p _).
      viewshift_SEP 0 (AS * (in_tree g g_in p r.1.1.2) * (EX lsh, !!(readable_share lsh) &&
                       field_at lsh t_struct_tree_t (DOT _lock) r.1.1.2 p)).
      { go_lower. apply lock_alloc. }
      Intros lsh1.
      forward.
      forward_call (r.1.1.2, Q v2).
      {
        iIntros "(((((((((((((((((((AU & H1) & H2) & H3) & _) & H4) & H5) & H6) & H7) & H8) & H9) & G1) & G2) & G3) & G4) & G5) & G6) & G7) & G8) & G9)".
        iCombine "AU H1 H2 H5 H6 H7 H8 H9 G2 G3 G4 G5" as "HH".
        iVST.
        rewrite <- 6sepcon_assoc; rewrite <- sepcon_comm.
        apply sepcon_derives; [| cancel_frame].
        unfold atomic_shift; iIntros "(AU & (#HT & (H1 & (H2 & (H3 & (H4 & (H5 & (H6 & (H7 & (H8 & (#HT1 & #HT2)))))))))))"; iAuIntro; unfold atomic_acc; simpl.
        iMod "AU" as (m) "[Hm HClose]".
        iModIntro.
        iPoseProof (tree_rep_insert _ g g_root g_in p r.1.1.2 x v2 p1 p2 lock1 lock2 with "[$Hm $HT]") as "InvLock".
        iDestruct "InvLock" as (R O) "((K1 & K2) & K3)".
        iDestruct "K2" as (lsh2) "(% & (K2 & KInv))".
        iDestruct "KInv" as (bl) "(KAt & KInv)".
        destruct bl.
        + iExists ().
          iFrame "KAt".
          iSplit.
          { iIntros "H". iFrame.
            iAssert (ltree g g_in p r.1.1.2 (node_lock_inv_pred g p g_in (R, Some O)))
              with "[H K2]" as "HInv".
            { iExists _; iSplit; iFrame; try done. iExists true; iFrame. }
            iSpecialize ("K3" with "[$HInv $K1]").
            iDestruct "K3" as "(K3 & _)".
            iSpecialize ("HClose" with "K3"); auto.
          }
          iIntros (_) "(H & _)".
          iDestruct "K3" as "[_ K3]".
          iDestruct "HClose" as "(_ & HClose)".
          iSpecialize ("HClose" $! v2).
          simpl.
          iApply "HClose".
          unfold tree_rep at 1.
          iPoseProof (public_agree g_in r (R, Some O) with "[$K1 $H2]") as "%Hx".
          destruct r.
          inversion Hx. subst.
          rewrite H6 in H10.
          inversion H10; subst x1 v2 g21 g22.
          destruct H15 as (Hf & Hrs).
          (* join lsh1 with lsh2 = Lsh *)
          iPoseProof (lock_join with "[$H1 $K2]") as "K2"; try iSplit; auto.
           iDestruct "K2" as (Lsh) "(% & K2)".
           (* done pushing back pointer of lock into ltree *)
           iAssert (ltree g g_in p (R, Some O).1.1.2 (node_lock_inv_pred g p g_in (R, Some O)) )
             with "[H2 H3 H4 H5 H6 H7 H8 K2 H]" as "LT".
           {
             iExists Lsh; iFrame. iSplit; try done.
             iExists false. iFrame "HT H H2 H3 H4 H5 H6".
             iSplit; try done.
             unfold tree_rep_R.
             rewrite -> if_false; auto.
             iExists g1, g2, x, v1, p1, p2, lock1, lock2.
             iFrame "HT1 HT2 H7 H8".
             iPureIntro.
             repeat (split; auto).
           }
           iSpecialize ("K3" with "[$K1 $LT]").
           iDestruct "K3" as "(K3 & K4)".
           iDestruct "K3" as (tg pk lk) "((%K3 & K34) & K35)".
           destruct K3 as (K31 & K32 & K33 & K34).
            iPoseProof (node_exist_in_tree g (find_ghost_set tg g_root pk lk) p
                         with "[K4 K35]") as "%Hy".
            { iFrame "HT". iFrame. }
            iPoseProof (ghost_tree_rep_public_half_ramif _ _ _ _ _ _ (Neg_Infinity, Pos_Infinity)
                                                         with "[$K34]") as "GT".
            { apply Hy. }
            iDestruct "GT" as (r a) "(%GT1 & GT2)".
            iSplit. iPureIntro.
            simpl in *.
            subst.
            Check range_info_in_gmap _ _ _ _ _ _ (Neg_Infinity, Pos_Infinity).
            erewrite (range_info_in_gmap _ _ _ _ _ _ (Neg_Infinity, Pos_Infinity)); eauto.
            assert (a = Some (Some (x, v1, g1, g2))). admit.
            subst. eauto.
            unfold tree_rep.
            iExists _, _, _. iFrame. iPureIntro. (split; auto).
        + unfold node_lock_inv_pred at 1, node_rep.
          iDestruct "KInv" as "(? & KInv)".
          iDestruct "KInv" as "((((((? & KInv) & ?) & ?) & ?) & ?) & ?)".
          iPoseProof (field_at_conflict Ews t_struct_tree_t (DOT _t) p
                      with "[$H3 $KInv]") as "HF"; try easy; auto.
     }
     (* free *)
     forward_call (t_struct_pn, nb, gv).
     { assert_PROP (nb <> nullval) by entailer !. rewrite if_false; auto. cancel. }
     forward.
     unfold nodebox_rep, ltree.
     Exists v2 np lsh.
     entailer !.  by iIntros "_".
Admitted.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
Require Import Relation_Operators.
From fcsl
Require Import axioms pred prelude ordtype finmap pcm unionmap heap.
From DiSeL
Require Import Freshness State EqTypeX Protocols Worlds NetworkSem Rely.
From DiSeL
Require Import Actions Injection Process Always HoareTriples InferenceRules.
From DiSeL
Require Import SeqLib.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Module CalculatorProtocol.
Section CalculatorProtocol.

Definition input := seq nat.

(* Partially defined function, e.g.,
   addition or multiplication require precisely two arguments *)

Variable f : input -> option nat.
Variable prec : input -> bool.
Hypothesis prec_valid :
  forall i, prec i -> exists v, f i = Some v.

(* Calculator nodes *)
Variable cs: seq nid.
Variable cls : seq nid.
(* All nodes *)
Notation nodes := (cs ++ cls).
(* All nodes are unique *)
Hypothesis Huniq : uniq nodes.

(* Protocol:

- "Clients" can send messages with requests as long as the request
  satisfies the precondition prec.

- "Clients" can receive messages from "servers" (i.e., calculators).

- "Servers" can receive messages as long as they satisfy the
  precondition and record the sender and the arguments in the
  permission list.

- "Servers" can respond to clients accordingly, given that the result
  satisfies the arguments.

*)

(* Defining state-space *)

(* Calculator server state *)
Definition st := ptr_nat 1.
(*
Calculator state:
  - client node id
  - server node id
  - client-provided id (e.g., hash of the input)
  - client input
*)

Definition perm := (nid * nat * (seq nat))%type.
Definition cstate := seq perm.

Definition all_valid (s : cstate) := all (fun e => prec e.2) s.

(* Local state coherence *)
Definition localCoh (n : nid) : Pred heap :=
  [Pred h | exists (s : cstate), h = st :-> s /\ all_valid s].

(* Tags *)
Definition req : nat := 0.
Definition resp : nat := 1.

Definition tags := [:: req; resp].

(* Coherent messages *)
Definition cohMsg (ms: msg TaggedMessage) : Prop :=
  let body := content ms in
  if tag body == resp then
    [/\ from ms \in cs, to ms \in cls &
        exists v args, tms_cont body = [:: v] ++ args]
  else [/\ tag body == req,
        from ms \in cls, to ms \in cs &
        exists args,
          tms_cont body = args /\
          prec args].

Definition soupCoh : Pred soup :=
  [Pred s | valid s /\ forall m ms, find m s = Some ms -> cohMsg ms].

Definition calcoh d : Prop :=
  let: dl := dstate d in
  let: ds := dsoup d in
  [/\ soupCoh ds, dom dl =i nodes,
   valid dl &
   forall n, n \in nodes -> localCoh n (getLocal n d)].

(* Axioms of the coherence predicate *)
Lemma l1 d: calcoh d -> valid (dstate d).
Proof. by case. Qed.

Lemma l2 d: calcoh d -> valid (dsoup d).
Proof. by case; case. Qed.

Lemma l3 d: calcoh d -> dom (dstate d) =i nodes.
Proof. by case. Qed.

(* Wrapping up the coherence predicate *)
Definition CalCoh := CohPred (CohPredMixin l1 l2 l3).

(* TODO: This lemma seems very generic, it is exactly the same in TPC.
   Refactor it! *)
Lemma consume_coh d m : CalCoh d -> soupCoh (consume_msg (dsoup d) m).
Proof.
move=>C; split=>[|m' msg]; first by apply: consume_valid; rewrite (cohVs C).
case X: (m == m');[move/eqP: X=><-{m'}|].
- case/(find_mark (cohVs C))=>tms[E]->{msg}.
  by case:(C); case=>_/(_ m tms E).
rewrite eq_sym in X.
rewrite (mark_other (cohVs C) X)=>E.
by case:(C); case=>_; move/(_ m' msg E).
Qed.

Lemma trans_updDom this d s :
  this \in nodes -> CalCoh d -> dom (upd this s (dstate d)) =i nodes.
Proof.
move=>D C z; rewrite -(cohDom C) domU inE/=.
by case: ifP=>///eqP->{z}; rewrite (cohDom C) D; apply: cohVl C.
Qed.

(****************************************************)
(********* Getter lemmas for local state ************)
(****************************************************)

Lemma cs_in_nodes n : n \in cs -> n \in nodes.
Proof. by rewrite mem_cat=>->. Qed.

Lemma cohSt n d (C : CalCoh d) s:
  find st (getLocal n d) = Some s ->
  dyn_tp s = cstate.
Proof.
case: (C)=>_ _ _ G; case H: (n \in nodes).
- by move:(G _ H); case=>s'[]->_; rewrite findPt//=; case=><-.
rewrite /getLocal; rewrite -(cohDom C) in H.
by case: dom_find H=>//->; rewrite find0E.
Qed.

Definition getSt n d (C : CalCoh d) : cstate :=
  match find st (getLocal n d) as f return _ = f -> _ with
    Some v => fun epf => icast (sym_eq (cohSt C epf)) (dyn_val v)
  | _ => fun epf => [::]
  end (erefl _).

Lemma getStK n d (C : CalCoh d)  s :
  getLocal n d = st :-> s -> getSt n C = s.
Proof.
move=>E; rewrite /getSt/=.
move: (cohSt C); rewrite !E/==>H.
by apply: eqc.
Qed.

Lemma getStE n i j C C' (pf : n \in nodes) :
  getLocal n j = getLocal n i ->
  @getSt n j C' = @getSt n i C.
Proof.
case: {-1}(C)=>_ _ _/(_ _ pf).
by move=>[s][E]_; rewrite (getStK C E) E; move/(getStK C' )->.
Qed.

Lemma getStE' n i j C C' (pf : n \in nodes) :
  @getSt n j C' = @getSt n i C ->
  getLocal n j = getLocal n i.
Proof.
case: {-1}(C)=>_ _ _/(_ _ pf).
move=>[s][E]_; rewrite (getStK C E) E=>H.
case: {-1}(C')=>_ _ _/(_ _ pf)=>[][s'][E']_.
by rewrite (getStK C' E') in H; subst s'.
Qed.

(****************************************************)

Notation coh := CalCoh.

(*** Server Transitions ***)

Section ServerReceiveTransition.

Definition sr_wf d (_ : coh d) (this from : nid) msg :=
  prec msg.

Definition sr_step : receive_step_t coh :=
  fun this (from : nid) (m : seq nat) d (pf : coh d) (pt : this \in nodes) =>
    if this \in cs
    then let s := getSt this pf in
         st :-> ((from, this, m) :: s)
    else getLocal this d.

(* This looks extremely similar to TPC, so, perhaps this should be
   refactored as well. *)
Lemma sr_step_coh : r_step_coh_t sr_wf req sr_step.
Proof.
move=>d from this m C pf tms D F Wf T/=.
rewrite /sr_step; case X: (this \in cs); last first.
- split=>/=; first by apply: consume_coh.
  + by apply: trans_updDom.
  + by rewrite validU; apply: cohVl C.
  by move=>n Ni/=; case: (C)=>_ _ _/(_ n Ni)=>L; rewrite -(getLocalU)// (cohVl C).
split=>/=; first by apply: consume_coh.
- by apply: trans_updDom.
- by rewrite validU; apply: cohVl C.
move=>n Ni/=; rewrite /localCoh/=.
rewrite /getLocal/=findU; case: ifP=>B/=; last by case: (C)=>_ _ _/(_ n Ni).
move/eqP: B X=>Z/eqP X; subst n; rewrite (cohVl C)/=.
have Y: all_valid (getSt this C).
by case: {-1}(C)=>_ _ _/(_ _ pf)[]s[]/(getStK C)->.
exists ((from, this, tms_cont tms) :: (getSt this C)); split=>//.
rewrite /all_valid/= in Y *; rewrite Y.
by rewrite /sr_wf in Wf; rewrite Wf.
Qed.

Definition server_recv_trans := ReceiveTrans sr_step_coh.

End ServerReceiveTransition.

Section ServerSendTransition.

Definition entry_finder (to : nid) msg :=
  let: ans := head 0 msg in
  fun e : perm =>
    let: (n, _, args) := e in
    [&& n == to, f args == Some ans &
        msg == ans :: args].

Definition can_send (s : cstate) to msg :=
  has (entry_finder to msg) s.

Definition ss_safe (this to : nid)
           (d : dstatelet) (msg : seq nat) :=
  to \in cls /\ this \in cs /\
  exists (C : coh d),
  has (entry_finder to msg) (getSt this C).

Lemma ss_safe_coh this to d m : ss_safe this to d m -> coh d.
Proof. by case=>_[]_[]. Qed.

Lemma ss_safe_in this to d m : ss_safe this to d m ->
                             this \in nodes /\ to \in nodes.
Proof.
by rewrite !mem_cat; case=>->[->]_; split=>//; rewrite orbC.
Qed.

Lemma ss_safe_this this to d m :
  ss_safe this to d m -> this \in cs.
Proof. by case=>_[?][]. Qed.

Definition ss_step (this to : nid) (d : dstatelet)
           (msg : seq nat)
           (pf : ss_safe this to d msg) :=
  let C := ss_safe_coh pf in
  let s := getSt this C in
  Some (st :-> remove_elem s (to, this, (behead msg))).

Lemma ss_step_coh : s_step_coh_t coh resp ss_step.
Proof.
move=>this to d msg pf h[]->{h}.
have C : (coh d) by case: pf=>?[_][].
split=>/=.
- split=>[|i ms/=]; first by rewrite valid_fresh (cohVs C).
  rewrite findUnL; last by rewrite valid_fresh (cohVs C).
  case: ifP=>E; first by case: C=>[[Vs]]H _ _ _; move/H.
  move/findPt_inv=>[Z G]; subst i ms.
  split; rewrite ?(proj2 (ss_safe_in pf))?(ss_safe_this pf)//.
  case: pf=>?[C'][tf]/hasP[]=>[[[n]]]h args
             _/andP[/eqP]Z1/andP[/eqP Z2]/eqP Z3//=.
  case: pf=>[_][_][C']/hasP[[[x1] x2]]x3 H/andP[Z1]/andP[Z2]/eqP->.
  by exists (head 0 msg), x3.
- move=>z.
  move: (getSt this (ss_safe_coh pf) )=>G.
  rewrite -(cohDom C) domU inE/= (cohVl C).
  by case: ifP=>///eqP->{z}; rewrite (cohDom C)(proj1 (ss_safe_in pf)).
- by rewrite validU; apply: cohVl C.
move=>n Ni. rewrite /localCoh/=.
rewrite /getLocal/=findU; case: ifP=>B/=; last by case: C=>_ _ _/(_ n Ni).
move/eqP: B=>Z; subst n; rewrite (cohVl C).
exists (remove_elem (getSt this (ss_safe_coh pf)) (to, this, behead msg)).
split=>//; apply: remove_elem_all.
by case: {-1}(ss_safe_coh pf)=>_ _ _/(_ _ Ni)[]s[]/(getStK (ss_safe_coh pf))->.
Qed.

Lemma ss_safe_def this to d msg :
      ss_safe this to d msg <->
      exists b pf, @ss_step this to d msg pf = Some b.
Proof.
split=>[pf/=|]; last by case=>?[].
set b := let C := ss_safe_coh pf in
         let s := getSt this C in
         st :-> remove_elem s (to, this, (behead msg)).
by exists b, pf.
Qed.

Definition server_send_trans :=
  SendTrans ss_safe_coh ss_safe_in ss_safe_def ss_step_coh.

End ServerSendTransition.

(**************************)
(*** Client transitions ***)
(**************************)

Section ClientSendTransition.

Definition cs_safe (this to : nid)
           (d : dstatelet) (msg : seq nat) :=
  [/\ to \in cs, this \in cls, coh d & prec msg].

Lemma cs_safe_coh this to d m : cs_safe this to d m -> coh d.
Proof. by case=>_[]. Qed.

Lemma cs_safe_in this to d m : cs_safe this to d m ->
                             this \in nodes /\ to \in nodes.
Proof.
by rewrite !mem_cat; case=>->->/=_ _; split=>//; rewrite orbC.
Qed.

Definition cs_step (this to : nid) (d : dstatelet)
           (msg : seq nat)
           (pf : cs_safe this to d msg) :=
  let C := cs_safe_coh pf in
  let s := getSt this C in
  Some (st :-> ((this, to, msg)::s)).

Lemma cs_step_coh : s_step_coh_t coh req cs_step.
Proof.
move=>this to d msg pf h[]->{h}.
have C : (coh d) by case: pf=>?[].
split=>/=.
- split=>[|i ms/=]; first by rewrite valid_fresh (cohVs C).
  rewrite findUnL; last by rewrite valid_fresh (cohVs C).
  case: ifP=>E; first by case: C=>[[Vs]]H _ _ _; move/H.
  move/findPt_inv=>[Z G]; subst i ms.
  split=>//; rewrite ?(proj2 (cs_safe_in pf));
  rewrite ?(proj2 (cs_safe_in pf))?(cs_safe_this pf)//=;
  by case: pf=>// _ _ _; exists msg.
- move=>z; move: (getSt this (cs_safe_coh pf))=>G.
  rewrite -(cohDom C) domU inE/= (cohVl C).
  by case: ifP=>///eqP->{z}; rewrite (cohDom C)(proj1 (cs_safe_in pf)).
- by rewrite validU; apply: cohVl C.
move=>n Ni. rewrite /localCoh/=.
rewrite /getLocal/=findU; case: ifP=>B; last by case: C=>_ _ _/(_ n Ni).
move/eqP: B=>Z; subst n; rewrite (cohVl C)/=.
exists ((this, to, msg) :: getSt this (cs_safe_coh pf)); split=>//.
have Y: all_valid (getSt this (cs_safe_coh pf)).
by case: {-1}(cs_safe_coh pf)=>_ _ _/(_ _ Ni)[]s[]/(getStK (cs_safe_coh pf))->.
by rewrite /=Y andbC/=; case: (pf).
Qed.

Lemma cs_safe_def this to d msg :
      cs_safe this to d msg <->
      exists b pf, @cs_step this to d msg pf = Some b.
Proof.
split=>[pf/=|]; last by case=>?[].
set b := let C := cs_safe_coh pf in
         let s := getSt this C in
         st :-> ((this, to, msg)::s).
by exists b, pf.
Qed.

Definition client_send_trans :=
  SendTrans cs_safe_coh cs_safe_in cs_safe_def cs_step_coh.

End ClientSendTransition.

Section ClientReceiveTransition.

Definition cr_wf d (C : coh d) this from (msg : seq nat) :=
  let s := getSt this C in
  let: args := (behead msg) in
  [&& (this, from, args) \in s &
     size msg > 2].

Definition cr_step : receive_step_t coh :=
  fun this (from : nid) (m : seq nat) d (pf : coh d) (pt : this \in nodes) =>
    let s := getSt this pf : seq perm in
    st :-> remove_elem s (this, from, (behead m) : seq nat).

Lemma cr_step_coh : r_step_coh_t cr_wf resp cr_step.
Proof.
move=>d from this m C pf tms D F Wf T/=.
rewrite /sr_step; case X: (this \in cs); last first.
- split=>/=; first by apply: consume_coh.
  + by apply: trans_updDom.
  + by rewrite validU; apply: cohVl C.
  move=>n Ni/=; rewrite /localCoh/=.
  rewrite /getLocal/=findU; case: ifP=>B/=; last by case: (C)=>_ _ _/(_ n Ni).
  move/eqP: B X=>Z/eqP X; subst n; rewrite (cohVl C)/=.
  exists (remove_elem (getSt this C) (this, from, behead tms)).
  split=>//; apply: remove_elem_all.
  by case: {-1}(C)=>_ _ _/(_ _ Ni)[]s[]/(getStK (C))->.
split=>/=; first by apply: consume_coh.
- by apply: trans_updDom.
- by rewrite validU; apply: cohVl C.
move=>n Ni/=; rewrite /localCoh/=.
rewrite /getLocal/=findU; case: ifP=>B/=; last by case: (C)=>_ _ _/(_ n Ni).
move/eqP: B X=>Z/eqP X; subst n; rewrite (cohVl C)/=.
exists (remove_elem (getSt this C) (this, from, behead tms)).
split=>//; apply: remove_elem_all.
by case: {-1}(C)=>_ _ _/(_ _ Ni)[]s[]/(getStK (C))->.
Qed.

Definition client_recv_trans := ReceiveTrans cr_step_coh.

End ClientReceiveTransition.

Section Protocol.

Variable l : Label.

Definition cal_sends :=    [:: server_send_trans; client_send_trans].
Definition cal_receives := [:: server_recv_trans; client_recv_trans].

Program Definition CalculatorProtocol : protocol :=
  @Protocol _ l _ cal_sends cal_receives _ _.

End Protocol.
End CalculatorProtocol.

Module Exports.

Definition CalculatorProtocol := CalculatorProtocol.

Definition CalCoh := CalCoh.

Definition server_send_trans := server_send_trans.
Definition server_recv_trans := server_recv_trans.
Definition client_send_trans := client_send_trans.
Definition client_recv_trans := client_recv_trans.

Definition req := req.
Definition resp := resp.
Notation input := (seq nat).
Definition cstate := cstate.

Definition getSt := getSt.
Definition getStK := getStK.
Definition getStE := getStE.
Definition getStE' := getStE'.

End Exports.

End CalculatorProtocol.

(**************************************************)
(*
Overall Implementation effort:

4 person-hours

*)
(**************************************************)

Export CalculatorProtocol.Exports.


(* ** Reduction from ZF' to finite ZF *)

From Undecidability.FOL
     Require Import Syntax.Facts Semantics.Tarski.FullFacts Deduction.FullNDFacts.

From Undecidability.FOL.Sets
     Require Import ZF.

Require Import Lia.

From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Definition add_om phi :=
  ax_om1 → ax_om2 → phi.

Theorem reduction_entailment phi :
  entailment_ZF' phi <-> entailment_HF (add_om phi).
Proof.
  split; intros Hp D I rho HE HI.
  - intros H1 H2. apply Hp; trivial.
    intros sigma psi [<-|[<-|[<-|[<-|[<-|[<-|[<-|[]]]]]]]]; trivial.
    all: apply HI; unfold HF; intuition.
  - apply Hp; fold sat; trivial. 2,3: apply HI; unfold ZF'; intuition eauto 7.
    intros sigma psi [<-|[<-|[<-|[<-|[<-|[]]]]]]. all: apply HI; unfold ZF'; intuition.
Qed.

Theorem reduction_deduction phi :
  deduction_ZF' phi <-> deduction_HF (add_om phi).
Proof.
  unfold deduction_ZF', deduction_HF, add_om. rewrite !imps.
  split; intros H; apply (Weak H); unfold ZFeq', HFeq, ZF', HF; firstorder.
Qed.


Set Implicit Arguments.

Require Import Coq.Lists.List.
Require Import Coq.Relations.Relations.
Require Import Common.Types.
Require Import Bag.TotalOrder.
Require Import Bag.Bag2.
Require Import Common.AllDiff.
Require Import Common.Bisimulation.
Require Import FwOF.FwOFSignatures.

Local Open Scope list_scope.
Local Open Scope equiv_scope.
Local Open Scope bag_scope.

(** This is a really trivial functor. RELATION_DEFINITIONS is just a bunch of definitions. *)
Module Make (Import AtomsAndController : ATOMS_AND_CONTROLLER) <: RELATION_DEFINITIONS.

  Import AtomsAndController.
  Import Machine.
  Import Atoms.

  Definition affixSwitch (sw : switchId) (ptpk : portId * packet) :=
    match ptpk with
      | (pt,pk) => (sw,pt,pk)
    end.

  Definition ConsistentDataLinks (links : list dataLink) : Prop :=
    forall (lnk : dataLink),
      In lnk links ->
      topo (src lnk) = Some (dst lnk).

  Definition LinkHasSrc (sws : bag switch_le) (link : dataLink) : Prop :=
    exists switch,
      In switch (to_list sws) /\
      fst (src link) = swId switch /\
      In (snd (src link)) (pts switch).

  Definition LinkHasDst (sws : bag switch_le) (link : dataLink) : Prop :=
    exists switch,
      In switch (to_list sws) /\
      fst (dst link) = swId switch /\
      In (snd (dst link)) (pts switch).

  Definition LinksHaveSrc (sws : bag switch_le) (links : list dataLink) :=
    forall link, In link links -> LinkHasSrc sws link.

  Definition LinksHaveDst (sws : bag switch_le) (links : list dataLink) :=
    forall link, In link links -> LinkHasDst sws link.

  Definition UniqSwIds (sws : bag switch_le) := AllDiff swId (to_list sws).

  Definition ofLinkHasSw (sws : bag switch_le) (ofLink : openFlowLink) :=
    exists sw,
      In sw (to_list sws) /\
      of_to ofLink = swId sw.

  Definition OFLinksHaveSw (sws : bag switch_le) (ofLinks : list openFlowLink) :=
    forall ofLink, In ofLink ofLinks -> ofLinkHasSw sws ofLink.

  Definition DevicesFromTopo (devs : state) :=
    forall swId0 swId1 pt0 pt1,
      Some (swId0,pt0) = topo (swId1,pt1) ->
      exists sw0 sw1 lnk,
        (* TODO(arjun): might as well be lists now. *)
        In sw0 (to_list (switches devs)) /\
        In sw1 (to_list (switches devs)) /\
        In lnk (links devs) /\
        swId sw0 = swId0 /\
        swId sw1 = swId1 /\
        src lnk = (swId1,pt1) /\
        dst lnk = (swId0, pt0).

  Definition NoBarriersInCtrlm (sws : bag switch_le) :=
    forall sw,
      In sw (to_list sws) ->
      forall m,
        In m (to_list (ctrlm sw)) ->
        NotBarrierRequest m.

  Record concreteState := ConcreteState {
    devices : state;
    concreteState_flowTableSafety : FlowTablesSafe (switches devices);
    concreteState_consistentDataLinks : ConsistentDataLinks (links devices);
    linksHaveSrc : LinksHaveSrc (switches devices) (links devices);
    linksHaveDst : LinksHaveDst (switches devices) (links devices);
    uniqSwIds : UniqSwIds (switches devices);
    ctrlP : P (switches devices) (ofLinks devices) (ctrl devices);
    uniqOfLinkIds : AllDiff of_to (ofLinks devices);
    ofLinksHaveSw : OFLinksHaveSw (switches devices) (ofLinks devices);
    devicesFromTopo : DevicesFromTopo devices;
    swsHaveOFLinks : SwitchesHaveOpenFlowLinks (switches devices) (ofLinks devices);
    noBarriersInCtrlm : NoBarriersInCtrlm (switches devices)
  }.

  Implicit Arguments ConcreteState [].

  Definition concreteStep (st : concreteState) (obs : option observation)
    (st0 : concreteState) :=
    step (devices st) obs (devices st0).

  Inductive abstractStep : abst_state -> option observation -> abst_state ->
    Prop :=
  | AbstractStep : forall sw pt pk lps,
    abstractStep
      ({| (sw,pt,pk) |} <+> lps)
      (Some (sw,pt,pk))
      (unions (map (transfer sw) (abst_func sw pt pk)) <+> lps).

  Definition relate_switch (sw : switch) : abst_state :=
    match sw with
      | Switch swId _ tbl inp outp ctrlm switchm =>
        from_list (map (affixSwitch swId) (to_list inp)) <+>
        unions (map (transfer swId) (to_list outp)) <+>
        unions (map (select_packet_out swId) (to_list ctrlm)) <+>
        unions (map (select_packet_in swId) (to_list switchm))
    end.

  Definition relate_dataLink (link : dataLink) : abst_state :=
    match link with
      | DataLink _ pks (sw,pt) =>
        from_list (map (fun pk => (sw,pt,pk)) pks)
    end.

  Definition relate_openFlowLink (link : openFlowLink) : abst_state :=
    match link with
      | OpenFlowLink sw switchm ctrlm =>
        unions (map (select_packet_out sw) ctrlm) <+>
        unions (map (select_packet_in sw) switchm)
    end.

  Definition relate (st : state) : abst_state :=
    unions (map relate_switch (to_list (switches st))) <+>
    unions (map relate_dataLink (links st)) <+>
    unions (map relate_openFlowLink (ofLinks st)) <+>
    relate_controller (ctrl st).

  Definition bisim_relation : relation concreteState abst_state :=
    fun (st : concreteState) (ast : abst_state) =>
      ast = (relate (devices st)).

  Module AtomsAndController := AtomsAndController.

End Make.


Require Import Verdi.TraceRelations.

Require Import VerdiRaft.Raft.
Require Import VerdiRaft.CommonTheorems.
Require Import VerdiRaft.LogMatchingInterface.
Require Import VerdiRaft.StateMachineSafetyInterface.
Require Import VerdiRaft.AppliedEntriesMonotonicInterface.
Require Import VerdiRaft.MaxIndexSanityInterface.
Require Import VerdiRaft.StateMachineCorrectInterface.
Require Import VerdiRaft.LastAppliedCommitIndexMatchingInterface.
Require Import VerdiRaft.TraceUtil.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Require Import VerdiRaft.SortedInterface.

Require Import VerdiRaft.OutputGreatestIdInterface.

Section OutputGreatestId.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {lmi : log_matching_interface}.
  Context {si : sorted_interface}.
  Context {aemi : applied_entries_monotonic_interface}.
  Context {smsi : state_machine_safety_interface}.
  Context {misi : max_index_sanity_interface}.
  Context {smci : state_machine_correct_interface}.
  Context {lacimi : lastApplied_commitIndex_match_interface}.

  Lemma in_output_changed :
    forall client id tr o,
      ~ key_in_output_trace client id tr ->
      key_in_output_trace client id (tr ++ o) ->
      key_in_output_trace client id o.
  Proof using.
    intros. unfold key_in_output_trace in *.
    break_exists_exists.
    intuition. do_in_app; intuition.
    exfalso. eauto.
  Qed.

  Lemma key_in_output_list_split :
    forall client id l l',
      key_in_output_list client id (l ++ l') ->
      key_in_output_list client id l \/ key_in_output_list client id l'.
  Proof using.
    intros.
    unfold key_in_output_list in *.
    break_exists; do_in_app; intuition eauto.
  Qed.

  Lemma key_in_output_list_empty :
    forall client id,
      ~ key_in_output_list client id [].
  Proof using.
    intuition.
    unfold key_in_output_list in *.
    break_exists; intuition.
  Qed.

  Lemma doLeader_key_in_output_list :
    forall st h out st' m client id,
      doLeader st h = (out, st', m) ->
      ~ key_in_output_list client id out.
  Proof using.
    intros. unfold doLeader, advanceCommitIndex in *.
    repeat break_match; find_inversion; intuition;
    find_apply_lem_hyp key_in_output_list_empty; auto.
  Qed.

  Lemma handleInput_key_in_output_list :
    forall st h i out st' m client id,
      handleInput h i st = (out, st', m) ->
      ~ key_in_output_list client id out.
  Proof using.
    intros. unfold handleInput, handleTimeout, handleClientRequest, tryToBecomeLeader in *.
    repeat break_match; find_inversion; intuition eauto using key_in_output_list_empty;
    unfold key_in_output_list in *; break_exists; simpl in *; intuition; congruence.
  Qed.

  Lemma has_key_own_key :
    forall e,
      has_key (eClient e) (eId e) e = true.
  Proof using.
    intros. unfold has_key. break_match; subst; simpl in *.
    break_if; repeat (do_bool; intuition).
  Qed.

  Lemma has_key_true_necessary :
    forall client id e,
      has_key client id e = true ->
      eClient e = client /\ eId e = id.
  Proof using.
    intros. unfold has_key in *. break_match.
    simpl in *. subst.
    break_if; repeat (do_bool; intuition); try congruence.
  Qed.

  Lemma applyEntries_cache :
    forall l h st os st' o client id id' o',
      id < id' ->
      applyEntries h st l = (os, st') ->
      In (ClientResponse client id o) os ->
      getLastId st client <> Some (id', o').
  Proof using.
    induction l; intros; simpl in *; intuition.
    - find_inversion. simpl in *. intuition.
    - unfold cacheApplyEntry, applyEntry in *.
      repeat break_match; repeat find_inversion; simpl in *; intuition; eauto;
      try solve
          [find_inversion; find_rewrite; find_inversion; do_bool; lia];
      try solve [find_inversion; repeat find_rewrite; congruence].
      + do_bool. destruct (clientId_eq_dec (eClient a) client).
        * subst. find_rewrite. find_inversion.
          eapply IHl; [eapply Nat.lt_le_trans; eauto|idtac|idtac|]; eauto.
          unfold getLastId.
          simpl. eauto using get_set_same.
        * eapply IHl; eauto.
          unfold getLastId in *.
          simpl. rewrite get_set_diff; eauto.
      + do_bool. destruct (clientId_eq_dec (eClient a) client).
        * repeat find_rewrite. congruence.
        * eapply IHl; eauto.
          unfold getLastId in *.
          simpl. rewrite get_set_diff; eauto.
      + do_bool. destruct (clientId_eq_dec (eClient a) client).
        * repeat find_rewrite. find_inversion.
          eapply IHl; [eapply Nat.lt_le_trans; eauto|idtac|idtac|]; eauto.
          unfold getLastId.
          simpl. eauto using get_set_same.
        * eapply IHl; eauto.
          unfold getLastId in *.
          simpl. rewrite get_set_diff; eauto.
      + do_bool. destruct (clientId_eq_dec (eClient a) client).
        * repeat find_rewrite. congruence.
        * eapply IHl; eauto.
          unfold getLastId in *.
          simpl. rewrite get_set_diff; eauto.
  Qed.

  Lemma applyEntries_before :
    forall l h st os st' o client id id',
      id < id' ->
      applyEntries h st l = (os, st') ->
      In (ClientResponse client id o) os ->
      before_func (has_key client id) (has_key client id') l.
  Proof using.
    induction l; intros; simpl in *; intuition.
    - find_inversion. simpl in *. intuition.
    - repeat break_match.
      + subst.
        find_inversion. do_in_app. intuition.
        * do_in_map. find_inversion. eauto using has_key_own_key.
        * { destruct (has_key client id' a) eqn:?; eauto.
            exfalso.
            unfold cacheApplyEntry, applyEntry in *.
            find_apply_lem_hyp has_key_true_necessary. intuition.
            repeat break_match; repeat find_rewrite; find_inversion; do_bool; subst_max.
            - find_eapply_lem_hyp applyEntries_cache; eauto; lia.
            - find_eapply_lem_hyp applyEntries_cache; eauto; lia.
            - find_eapply_lem_hyp applyEntries_cache; eauto;
              unfold getLastId in *; simpl in *; eauto using get_set_same.
            - find_eapply_lem_hyp applyEntries_cache; eauto;
              unfold getLastId in *; simpl in *; eauto using get_set_same.
          }
      + simpl in *. find_inversion.
        { destruct (has_key client id' a) eqn:?; eauto.
          exfalso.
          unfold cacheApplyEntry, applyEntry in *.
          find_apply_lem_hyp has_key_true_necessary. intuition.
          repeat break_match; repeat find_rewrite; find_inversion; do_bool; subst.
            - find_eapply_lem_hyp applyEntries_cache; eauto; lia.
            - find_eapply_lem_hyp applyEntries_cache; eauto; lia.
            - eapply applyEntries_cache in Heqp0; eauto;
                unfold getLastId in *; simpl in *; eauto using get_set_same.
            - eapply applyEntries_cache in Heqp0; eauto;
                unfold getLastId in *; simpl in *; eauto using get_set_same.
          }
  Qed.

  Lemma entries_contiguous :
    forall net,
      raft_intermediate_reachable net ->
      (forall h, contiguous_range_exact_lo (log (nwState net h)) 0).
  Proof using lmi.
    intros. find_apply_lem_hyp log_matching_invariant.
    unfold log_matching, log_matching_hosts in *.
    intuition.
    unfold contiguous_range_exact_lo. intuition; eauto.
    find_apply_hyp_hyp. lia.
  Qed.

  Lemma doGenericServer_key_in_output_list :
    forall net h os st' ms id' client id,
      raft_intermediate_reachable net ->
      doGenericServer h (nwState net h) = (os, st', ms) ->
      key_in_output_list client id os ->
      id < id' ->
      before_func (has_key client id) (has_key client id') (applied_entries (update name_eq_dec (nwState net) h st')).
  Proof using lacimi smci si lmi.
    intros.
    find_copy_apply_lem_hyp logs_sorted_invariant.
    pose proof entries_contiguous.
    match goal with
      | H : context [contiguous_range_exact_lo] |- _ =>
        specialize (H net)
    end.
    concludes. simpl in *.
    find_copy_apply_lem_hyp state_machine_correct_invariant.
    unfold state_machine_correct in *. intuition.
    unfold logs_sorted in *. intuition.
    unfold key_in_output_list in *.
    match goal with | H : exists _, _ |- _ => destruct H as [o] end.
    unfold doGenericServer in *. break_let. simpl in *.
    find_inversion. simpl in *.
    pose proof Heqp as Heqp'.
    eapply applyEntries_before in Heqp; eauto.
    match goal with
      | H : before_func _ _ ?l |- _=>
        eapply before_func_prepend with
        (l' := (rev (removeAfterIndex (log (nwState net h))
                                      (lastApplied (nwState net h)))))
          in H
    end; eauto;
    [|intros;
       find_apply_lem_hyp In_rev;
       apply Bool.not_true_iff_false;
       intuition; unfold has_key in *;
       break_match; break_if; repeat (do_bool; intuition); simpl in *;
       eapply_prop_hyp client_cache_complete In; eauto;
       break_exists; intuition; simpl in *;
       subst;
       match goal with
         | Ha : context [applyEntries], Hg : getLastId _ _ = Some (?x, _) |- _ =>
           eapply applyEntries_cache with (id' := x) in Ha
       end; eauto; lia;
       intuition; find_rewrite; repeat find_rewrite].
    rewrite <- rev_app_distr in *.
    eapply before_func_prefix; eauto.
    use_applyEntries_spec. subst. simpl in *.
    break_if.
    - do_bool.
        erewrite findGtIndex_removeAfterIndex_i_lt_i' in *; eauto.
        match goal with
          | |- context [applied_entries (update _ ?sigma ?h ?st)] =>
            pose proof applied_entries_update sigma h st
        end. conclude_using intuition.
        intuition; simpl in *;
        unfold raft_data in *; simpl in *; find_rewrite; auto using Prefix_refl.
        unfold applied_entries in *.
        break_exists. intuition. repeat find_rewrite.
        eapply contiguous_sorted_subset_prefix; eauto using removeAfterIndex_contiguous, removeAfterIndex_sorted.
        intros.
        find_copy_apply_lem_hyp removeAfterIndex_In_le; eauto.
        find_apply_lem_hyp removeAfterIndex_in.
        apply removeAfterIndex_le_In; eauto; try lia.
        find_copy_apply_lem_hyp commitIndex_lastApplied_match_invariant.
        unfold commitIndex_lastApplied_match in *. simpl in *.
        match goal with
          | _ : ?x >= ?y |- _ =>
            assert (y <= x) by lia
        end.
        eapply_prop_hyp le le; eauto. intuition.
     - do_bool.
        erewrite findGtIndex_removeAfterIndex_i'_le_i in *; eauto.
        match goal with
          | |- context [applied_entries (update _ ?sigma ?h ?st)] =>
            pose proof applied_entries_update sigma h st
        end. conclude_using intuition.
        intuition; simpl in *;
        unfold raft_data in *; simpl in *; find_rewrite; auto using Prefix_refl.
        unfold applied_entries in *.
        break_exists. intuition. repeat find_rewrite.
        eapply contiguous_sorted_subset_prefix; eauto using removeAfterIndex_contiguous, removeAfterIndex_sorted.
        intros.
        find_copy_apply_lem_hyp removeAfterIndex_In_le; eauto.
        find_apply_lem_hyp removeAfterIndex_in.
        apply removeAfterIndex_le_In; eauto; try lia.
        find_copy_apply_lem_hyp lastApplied_lastApplied_match_invariant.
        unfold lastApplied_lastApplied_match in *. simpl in *.
        match goal with
          | _ : ?x >= ?y |- _ =>
            assert (y <= x) by lia
        end.
        eapply_prop_hyp le le; eauto. intuition.
  Qed.

  Lemma output_implies_greatest :
    forall failed net failed' net' o client id id',
      raft_intermediate_reachable net ->
      @step_failure _ _ failure_params (failed, net) (failed', net') o ->
      key_in_output_trace client id o ->
      id < id' ->
      before_func (has_key client id) (has_key client id') (applied_entries (nwState net')).
  Proof using lacimi smci si lmi.
    intros.
    invcs H0; simpl in *;
    try match goal with
          | _ : key_in_output_trace _ _ [] |- _ =>
            unfold key_in_output_trace in *; break_exists; simpl in *; intuition
        end.
    - unfold key_in_output_trace in *.
      break_exists; simpl in *; intuition.
      find_inversion.
      unfold RaftNetHandler in *.
      repeat break_let. repeat find_inversion. simpl in *.
      find_eapply_lem_hyp RIR_handleMessage; eauto.
      find_copy_eapply_lem_hyp RIR_doLeader; simpl in *; rewrite_update; eauto.
      find_apply_lem_hyp key_in_output_list_split.
      intuition; [exfalso; eapply doLeader_key_in_output_list; eauto|].
      match goal with
        | _ : doLeader ?st ?h = _, _ : doGenericServer _ ?d = _ |- _ =>
          replace st with ((update name_eq_dec (nwState net) h st) h) in *;
            [|rewrite_update; auto]
      end.
      find_apply_lem_hyp doLeader_appliedEntries.
      rewrite_update. repeat find_rewrite_lem update_overwrite.
      unfold data in *. simpl in *.
      match goal with
        | _ : raft_intermediate_reachable (mkNetwork ?ps ?st),
              H : doGenericServer ?h ?r = _ |- _ =>
          replace r with (nwState (mkNetwork ps st) h) in H by (simpl in *; rewrite_update; auto)
      end.
      find_eapply_lem_hyp doGenericServer_key_in_output_list; [|idtac|eauto|]; eauto.
      simpl in *. find_rewrite_lem update_overwrite. auto.
    - unfold key_in_output_trace in *.
      break_exists; simpl in *; intuition.
      find_inversion.
      unfold RaftInputHandler in *.
      repeat break_let. repeat find_inversion. simpl in *.
      find_copy_eapply_lem_hyp RIR_handleInput; eauto.
      find_copy_eapply_lem_hyp RIR_doLeader; simpl in *; rewrite_update; eauto.
      find_apply_lem_hyp key_in_output_list_split.
      intuition; [exfalso; eapply handleInput_key_in_output_list; eauto|].
      find_apply_lem_hyp key_in_output_list_split.
      intuition; [exfalso; eapply doLeader_key_in_output_list; eauto|].
      match goal with
        | _ : doLeader ?st ?h = _, _ : doGenericServer _ ?d = _ |- _ =>
          replace st with ((update name_eq_dec (nwState net) h st) h) in *;
            [|rewrite_update; auto]
      end.
      find_apply_lem_hyp doLeader_appliedEntries.
      rewrite_update. repeat find_rewrite_lem update_overwrite.
      unfold data in *. simpl in *.
      match goal with
        | _ : raft_intermediate_reachable (mkNetwork ?ps ?st),
              H : doGenericServer ?h ?r = _ |- _ =>
          replace r with (nwState (mkNetwork ps st) h) in H by (simpl in *; rewrite_update; auto)
      end.
      find_eapply_lem_hyp doGenericServer_key_in_output_list; [|idtac|eauto|]; eauto.
      simpl in *. find_rewrite_lem update_overwrite. auto.
  Qed.

  Section inner.
    Variable client : clientId.
    Variables id id' : nat.
    Variable id_lt_id' : id < id'.

    Program Instance TR : TraceRelation step_failure :=
      {
        init := step_failure_init;
        T := key_in_output_trace client id ;
        T_dec := key_in_output_trace_dec client id ;
        R := fun s => before_func (has_key client id) (has_key client id') (applied_entries (nwState (snd s)))
      }.
    Next Obligation.
      simpl in *.
      find_apply_lem_hyp step_failure_star_raft_intermediate_reachable.
      find_eapply_lem_hyp applied_entries_monotonic'; eauto.
      break_exists; repeat find_rewrite.
      eauto using before_func_app.
    Defined.
    Next Obligation.
      unfold key_in_output_trace in *. intuition.
      break_exists; intuition.
    Defined.
    Next Obligation.
      find_apply_lem_hyp step_failure_star_raft_intermediate_reachable.
      find_apply_lem_hyp in_output_changed; auto.
      eauto using output_implies_greatest.
    Defined.

  Theorem output_greatest_id :
    forall failed net tr,
      step_failure_star step_failure_init (failed, net) tr ->
      key_in_output_trace client id tr ->
      before_func (has_key client id) (has_key client id') (applied_entries (nwState net)).
  Proof using id_lt_id' lacimi smci aemi si lmi.
    intros. pose proof (trace_relations_work (failed, net) tr).
    concludes. intuition.
  Qed.
  End inner.

  Instance ogii : output_greatest_id_interface.
  Proof.
    split. unfold greatest_id_for_client. intros.
    eauto using output_greatest_id.
  Qed.
End OutputGreatestId.


From iris.base_logic.lib Require Export invariants fractional.
From iris.algebra Require Export frac.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
Import uPred.

Class cinvG Σ := cinv_inG :> inG Σ fracR.
Definition cinvΣ : gFunctors := #[GFunctor fracR].

Instance subG_cinvΣ {Σ} : subG cinvΣ Σ → cinvG Σ.
Proof. solve_inG. Qed.

Section defs.
  Context `{invG Σ, cinvG Σ}.

  Definition cinv_own (γ : gname) (p : frac) : iProp Σ := own γ p.

  Definition cinv (N : namespace) (γ : gname) (P : iProp Σ) : iProp Σ :=
    (∃ P', □ ▷ (P ↔ P') ∗ inv N (P' ∨ cinv_own γ 1%Qp))%I.
End defs.

Instance: Params (@cinv) 5.

Section proofs.
  Context `{invG Σ, cinvG Σ}.

  Global Instance cinv_own_timeless γ p : Timeless (cinv_own γ p).
  Proof. rewrite /cinv_own; apply _. Qed.

  Global Instance cinv_contractive N γ : Contractive (cinv N γ).
  Proof. solve_contractive. Qed.
  Global Instance cinv_ne N γ : NonExpansive (cinv N γ).
  Proof. exact: contractive_ne. Qed.
  Global Instance cinv_proper N γ : Proper ((≡) ==> (≡)) (cinv N γ).
  Proof. exact: ne_proper. Qed.

  Global Instance cinv_persistent N γ P : Persistent (cinv N γ P).
  Proof. rewrite /cinv; apply _. Qed.

  Global Instance cinv_own_fractionnal γ : Fractional (cinv_own γ).
  Proof. intros ??. by rewrite -own_op. Qed.
  Global Instance cinv_own_as_fractionnal γ q :
    AsFractional (cinv_own γ q) (cinv_own γ) q.
  Proof. split. done. apply _. Qed.

  Lemma cinv_own_valid γ q1 q2 : cinv_own γ q1 -∗ cinv_own γ q2 -∗ ✓ (q1 + q2)%Qp.
  Proof. apply (own_valid_2 γ q1 q2). Qed.

  Lemma cinv_own_1_l γ q : cinv_own γ 1 -∗ cinv_own γ q -∗ False.
  Proof.
    iIntros "H1 H2".
    iDestruct (cinv_own_valid with "H1 H2") as %[]%(exclusive_l 1%Qp).
  Qed.

  Lemma cinv_iff N γ P P' :
    ▷ □ (P ↔ P') -∗ cinv N γ P -∗ cinv N γ P'.
  Proof.
    iIntros "#HP' Hinv". iDestruct "Hinv" as (P'') "[#HP'' Hinv]".
    iExists _. iFrame "Hinv". iNext. iAlways. iSplit.
    - iIntros "?". iApply "HP''". iApply "HP'". done.
    - iIntros "?". iApply "HP'". iApply "HP''". done.
  Qed.

  Lemma cinv_alloc E N P : ▷ P ={E}=∗ ∃ γ, cinv N γ P ∗ cinv_own γ 1.
  Proof.
    iIntros "HP".
    iMod (own_alloc 1%Qp) as (γ) "H1"; first done.
    iMod (inv_alloc N _ (P ∨ own γ 1%Qp)%I with "[HP]"); first by eauto.
    iExists _. iFrame. iExists _. iFrame. iIntros "!> !# !>". iSplit; by iIntros "?".
  Qed.

  Lemma cinv_cancel E N γ P : ↑N ⊆ E → cinv N γ P -∗ cinv_own γ 1 ={E}=∗ ▷ P.
  Proof.
    iIntros (?) "#Hinv Hγ". iDestruct "Hinv" as (P') "[#HP' Hinv]".
    iInv N as "[HP|>Hγ']" "Hclose".
    - iMod ("Hclose" with "[Hγ]") as "_"; first by eauto. iModIntro. iNext.
      iApply "HP'". done.
    - iDestruct (cinv_own_1_l with "Hγ Hγ'") as %[].
  Qed.

  Lemma cinv_open E N γ p P :
    ↑N ⊆ E →
    cinv N γ P -∗ cinv_own γ p ={E,E∖↑N}=∗ ▷ P ∗ cinv_own γ p ∗ (▷ P ={E∖↑N,E}=∗ True).
  Proof.
    iIntros (?) "#Hinv Hγ". iDestruct "Hinv" as (P') "[#HP' Hinv]".
    iInv N as "[HP | >Hγ']" "Hclose".
    - iIntros "!> {$Hγ}". iSplitL "HP".
      + iNext. iApply "HP'". done.
      + iIntros "HP". iApply "Hclose". iLeft. iNext. by iApply "HP'".
    - iDestruct (cinv_own_1_l with "Hγ' Hγ") as %[].
  Qed.
End proofs.

Typeclasses Opaque cinv_own cinv.


Require Import ClassicalExtras.

Require Import TraceModel.
Require Import Stream.
Require Import Properties.
Require Import Galois.

Require Import FunctionalExtensionality.

Set Bullet Behavior "Strict Subproofs".

Section UndefBehavior.
  Variable event : Events.

  Variable endstate : Endstates.

  Definition undef := unit.
  Definition endstateUB : Endstates :=
    {| es := (es endstate + undef);
       an_es := inr tt
    |}.
  Definition UB : es endstateUB := inr tt.
  Hint Unfold UB.

  Definition endstateS := endstateUB.
  Definition endstateT := endstateUB.

  Definition traceS := @trace event endstateS.
  Definition traceT := @trace event endstateT.
  Definition finprefS := @finpref event endstateS.
  Definition finprefT := @finpref event endstateT.

  Definition propS := @prop traceS.
  Definition propT := @prop traceT.
  Definition fpropS := @fprop event endstateS.
  Definition fpropT := @fprop event endstateT.

  (* Definition prefixST (m__s : finprefS) (t__t : traceT) : Prop := *)
  (*   match m__s with *)
  (*   | fstop l__t (inl e__t) => *)
  (*     match t__t with *)
  (*     | tstop l__s e__s => e__t = e__s /\ l__t = l__s *)
  (*     | _ => False *)
  (*     end *)
  (*   | fstop _ (inr _) => False *)
  (*   | ftbd l__t => *)
  (*     match t__t with *)
  (*     | tstop l__s _ | tsilent l__s => Stream.list_list_prefix l__t l__s *)
  (*     | tstream s__s => Stream.list_stream_prefix l__t s__s *)
  (*     end *)
  (*   end. *)

  Definition rel : traceS -> traceT -> Prop :=
    fun t__s t__t => t__s = t__t \/ exists m, (t__s = tstop m UB /\ prefix (ftbd m) t__t).
  Hint Unfold rel.

  Definition GC_traceT_traceS : Galois_Connection traceT traceS :=
    induced_connection rel.

  Definition τ : propS -> propT := α GC_traceT_traceS.
  Lemma τ_def : forall πS t__t,
      (τ πS) t__t <-> (exists t__s, t__s = t__t /\ πS t__s) \/ (exists m, prefix (ftbd m) t__t /\ πS (tstop m UB)).
  Proof.
    intros πS t__t.
    unfold τ, GC_traceT_traceS, induced_connection, low_rel; simpl.
    split.
    - intros H.
      destruct H as [t__s [H1 H2]].
      destruct H2 as [H2 | H2].
      + left; eexists; split; eauto.
      + destruct H2 as [m [H2 H3]]; subst.
        right.
        eexists; split; try split; eauto.
    - intros H.
      destruct H as [[t__s [H1 H2]] | [m [H2 H3]]].
      + eexists; split; eauto.
      + eexists; split; eauto.
  Qed.

  Definition σ : propT -> propS := γ GC_traceT_traceS.

  Lemma σ_def : forall πT t__s,
      (σ πT) t__s <-> (forall t__t, t__s = t__t -> πT t__t) /\ (forall t__t m, t__s = tstop m UB -> (prefix (ftbd m) t__t -> πT t__t)).
  Proof.
    intros πT t__s.
    unfold σ, GC_traceT_traceS, induced_connection, up_rel; simpl.
    split.
    - intros H.
      split.
      + eauto.
      + intros t__t m H0 H1; subst.
        apply H.
        right.
        exists m. split; auto.
    - intros H x Hrel.
      destruct H as [H1 H2].
      inversion Hrel.
      + eauto.
      + destruct H as [m [Hm1 Hm2]].
        subst.
        eauto.
  Qed.

  Lemma σ_def' : forall πT t__s,
      (σ πT) t__s <-> (exists t__t, (forall m, t__s <> tstop m UB) /\ t__s = t__t /\ πT t__t) \/
                    (exists m, t__s = tstop m UB /\ (forall t__t, prefix (ftbd m) t__t -> πT t__t)).
  Proof.
    intros πT t__s.
    rewrite σ_def.
    split.
    - intros H. destruct H.
      destruct t__s as [l [e | []] | l | s]; eauto;
        now (left; eexists; split; eauto).
    - intros H. destruct H.
      + destruct H as [t__t [Hdiff [Heq H]]]; subst.
        split.
        * intros t__t0 H0; subst; eauto.
        * intros t__t0 m H0 H1. subst.
          now specialize (Hdiff m).
      + destruct H as [m [Heq H]]; subst.
        split.
        * intros t__t H0; subst.
          apply H; simpl.
          now apply list_list_prefix_ref.
        * intros t__t m0 H0 H1; subst; inversion H0; subst.
          now auto.
  Qed.

  Lemma τ_preserves_dense : forall (π : propS),
      Dense π -> Dense (τ π).
  Proof.
    unfold Dense, τ, GC_traceT_traceS, induced_connection, low_rel; simpl.
    intros π HDense.
    intros t__t Hfin.
    destruct t__t as [l e | l | s].
    - exists (tstop l e). split.
      apply HDense. econstructor; eexists; eauto.
      left; eauto.
    - destruct Hfin as [l' [e' Hn]].
      inversion Hn.
    - destruct Hfin as [l' [e' Hn]].
      inversion Hn.
  Qed.

  Lemma σ_does_not_preserve_dense : exists (π : propT),
      Dense π /\ not (Dense (σ π)).
  Proof.
    exists (fun t__t => exists m e, t__t = tstop m e).
    split.
    - unfold Dense.
      intros t Hfin.
      inversion Hfin; now auto.
    - unfold Dense, σ, GC_traceT_traceS, induced_connection, up_rel; simpl.
      intros Hn.
      specialize (Hn (tstop nil UB)).
      assert (finite (tstop (nil : list (ev event)) UB)) by (econstructor; now eauto).
      specialize (Hn H (tsilent nil)).
      assert (rel (tstop nil UB) (tsilent nil)) by (right; eexists; now eauto).
      specialize (Hn H0).
      destruct Hn as [? [? Hn]].
      inversion Hn.
  Qed.

End UndefBehavior.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.ComputerDivision.
Require map.Map.

(* Why3 assumption *)
Definition unit := unit.

Axiom t : Type.
Parameter t_WhyType : WhyType t.
Existing Instance t_WhyType.

Parameter max: Z.

Parameter to_int: t -> Z.

(* Why3 assumption *)
Definition in_bounds (n:Z): Prop := (0%Z <= n)%Z /\ (n <= max)%Z.

Axiom to_int_in_bounds : forall (n:t), (in_bounds (to_int n)).

Axiom extensionality : forall (x:t) (y:t), ((to_int x) = (to_int y)) ->
  (x = y).

Parameter zero_unsigned: t.

Axiom zero_unsigned_is_zero : ((to_int zero_unsigned) = 0%Z).

Axiom address : Type.
Parameter address_WhyType : WhyType address.
Existing Instance address_WhyType.

Parameter to_int1: address -> Z.

(* Why3 assumption *)
Definition in_bounds1 (n:Z): Prop := (0%Z <= n)%Z /\
  (n <= 1461501637330902918203684832716283019655932542975%Z)%Z.

Axiom to_int_in_bounds1 : forall (n:address), (in_bounds1 (to_int1 n)).

Axiom extensionality1 : forall (x:address) (y:address),
  ((to_int1 x) = (to_int1 y)) -> (x = y).

Parameter zero_unsigned1: address.

Axiom zero_unsigned_is_zero1 : ((to_int1 zero_unsigned1) = 0%Z).

Axiom uint256 : Type.
Parameter uint256_WhyType : WhyType uint256.
Existing Instance uint256_WhyType.

Parameter to_int2: uint256 -> Z.

(* Why3 assumption *)
Definition in_bounds2 (n:Z): Prop := (0%Z <= n)%Z /\
  (n <= 115792089237316195423570985008687907853269984665640564039457584007913129639935%Z)%Z.

Axiom to_int_in_bounds2 : forall (n:uint256), (in_bounds2 (to_int2 n)).

Axiom extensionality2 : forall (x:uint256) (y:uint256),
  ((to_int2 x) = (to_int2 y)) -> (x = y).

Parameter zero_unsigned2: uint256.

Axiom zero_unsigned_is_zero2 : ((to_int2 zero_unsigned2) = 0%Z).

(* Why3 assumption *)
Inductive array (a:Type) :=
  | mk_array : Z -> (map.Map.map Z a) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(array a)): (map.Map.map Z a) :=
  match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a} (v:(array a)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z): a :=
  (map.Map.get (elts a1) i).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z) (v:a): (array
  a) := (mk_array (length a1) (map.Map.set (elts a1) i v)).

(* Why3 goal *)
Theorem WP_parameter_transfer : forall (usfrom:address) (usto:address)
  (usval:uint256) (usorig:Z) (usorig1:(map.Map.map Z uint256)),
  ((0%Z <= usorig)%Z /\ (((to_int1 usto) < usorig)%Z /\
  (((to_int1 usfrom) < usorig)%Z /\
  ((to_int2 usval) <= (to_int2 (map.Map.get usorig1 (to_int1 usto))))%Z))) ->
  let o := (to_int1 usfrom) in (((0%Z <= o)%Z /\ (o < usorig)%Z) ->
  (in_bounds2 ((to_int2 (map.Map.get usorig1 o)) - (to_int2 usval))%Z)).
(* Why3 intros usfrom usto usval usorig usorig1 (h1,(h2,(h3,h4))) o (h5,h6). *)
intros usfrom usto usval usorig usorig1 (h1,(h2,(h3,h4))) o (h5,h6).

Qed.


(*** Implementing Large Bounded Arithmetic via pairs *)
Require Import Coq.ZArith.ZArith.
Require Import Crypto.LegacyArithmetic.Interface.
Require Import Crypto.LegacyArithmetic.InterfaceProofs.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.Notations.
Require Import Crypto.Util.LetIn.
Import Bug5107WorkAround.

Require Crypto.LegacyArithmetic.BaseSystem.
Require Crypto.LegacyArithmetic.Pow2Base.

Local Open Scope nat_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.

Local Coercion Z.of_nat : nat >-> Z.
Local Notation eta x := (fst x, snd x).

(** The list is low to high; the tuple is low to high *)
Definition tuple_decoder {n W} {decode : decoder n W} {k : nat} : decoder (k * n) (tuple W k)
  := {| decode w := BaseSystem.decode (Pow2Base.base_from_limb_widths (repeat n k))
                                      (List.map decode (List.rev (Tuple.to_list _ w))) |}.
Global Arguments tuple_decoder : simpl never.
Hint Extern 3 (decoder _ (tuple ?W ?k)) => let kv := (eval simpl in (Z.of_nat k)) in apply (fun n decode => (@tuple_decoder n W decode k : decoder (kv * n) (tuple W k))) : typeclass_instances.

Section ripple_carry_definitions.
  (** tuple is high to low ([to_list] reverses) *)
  Fixpoint ripple_carry_tuple' {T} (f : T -> T -> bool -> bool * T) k
    : forall (xs ys : tuple' T k) (carry : bool), bool * tuple' T k
    := match k return forall (xs ys : tuple' T k) (carry : bool), bool * tuple' T k with
       | O => f
       | S k' => fun xss yss carry => dlet xss := xss in
                                      dlet yss := yss in
                                      let (xs, x) := eta xss in
                                      let (ys, y) := eta yss in
                                      dlet addv := (@ripple_carry_tuple' _ f k' xs ys carry) in
                                      let (carry, zs) := eta addv in
                                      dlet fxy := (f x y carry) in
                                      let (carry, z) := eta fxy in
                                      (carry, (zs, z))
       end.

  Definition ripple_carry_tuple {T} (f : T -> T -> bool -> bool * T) k
    : forall (xs ys : tuple T k) (carry : bool), bool * tuple T k
    := match k return forall (xs ys : tuple T k) (carry : bool), bool * tuple T k with
       | O => fun xs ys carry => (carry, tt)
       | S k' => ripple_carry_tuple' f k'
       end.
End ripple_carry_definitions.

Global Instance ripple_carry_adc
       {W} (adc : add_with_carry W) {k}
  : add_with_carry (tuple W k)
  := { adc := ripple_carry_tuple adc k }.

Global Instance ripple_carry_subc
       {W} (subc : sub_with_carry W) {k}
  : sub_with_carry (tuple W k)
  := { subc := ripple_carry_tuple subc k }.

(** constructions on [tuple W 2] *)
Section tuple2.
  Section select_conditional.
    Context {W}
            {selc : select_conditional W}.

    Definition select_conditional_double (b : bool) (x : tuple W 2) (y : tuple W 2) : tuple W 2
      := dlet x := x in
         dlet y := y in
         let (x1, x2) := eta x in
         let (y1, y2) := eta y in
         (selc b x1 y1, selc b x2 y2).

    Global Instance selc_double : select_conditional (tuple W 2)
      := { selc := select_conditional_double }.
  End select_conditional.

  Section load_immediate.
    Context (n : Z) {W}
            {ldi : load_immediate W}.

    Definition load_immediate_double (r : Z) : tuple W 2
      := (ldi (r mod 2^n), ldi (r / 2^n)).

    (** Require a [decoder] instance to aid typeclass search in
        resolving [n] *)
    Global Instance ldi_double {decode : decoder n W} : load_immediate (tuple W 2)
      := { ldi := load_immediate_double }.
  End load_immediate.

  Section bitwise_or.
    Context {W}
            {or : bitwise_or W}.

    Definition bitwise_or_double (x : tuple W 2) (y : tuple W 2) : tuple W 2
      := dlet x := x in
         dlet y := y in
         let (x1, x2) := eta x in
         let (y1, y2) := eta y in
         (or x1 y1, or x2 y2).

    Global Instance or_double : bitwise_or (tuple W 2)
      := { or := bitwise_or_double }.
  End bitwise_or.

  Section bitwise_and.
    Context {W}
            {and : bitwise_and W}.

    Definition bitwise_and_double (x : tuple W 2) (y : tuple W 2) : tuple W 2
      := dlet x := x in
         dlet y := y in
         let (x1, x2) := eta x in
         let (y1, y2) := eta y in
         (and x1 y1, and x2 y2).

    Global Instance and_double : bitwise_and (tuple W 2)
      := { and := bitwise_and_double }.
  End bitwise_and.

  Section spread_left.
    Context (n : Z) {W}
            {ldi : load_immediate W}
            {shl : shift_left_immediate W}
            {shr : shift_right_immediate W}.

    Definition spread_left_from_shift (r : W) (count : Z) : tuple W 2
      := dlet r := r in
         (shl r count, if count =? 0 then ldi 0 else shr r (n - count)).

    (** Require a [decoder] instance to aid typeclass search in
        resolving [n] *)
    Global Instance sprl_from_shift {decode : decoder n W} : spread_left_immediate W
      := { sprl := spread_left_from_shift }.
  End spread_left.

  Section shl_shr.
    Context (n : Z) {W}
            {ldi : load_immediate W}
            {shl : shift_left_immediate W}
            {shr : shift_right_immediate W}
            {or : bitwise_or W}.

    Definition shift_left_immediate_double (r : tuple W 2) (count : Z) : tuple W 2
      := dlet r := r in
         let (r1, r2) := eta r in
         (if count =? 0
          then r1
          else if count <? n
               then shl r1 count
               else ldi 0,
          if count =? 0
          then r2
          else if count <? n
               then or (shr r1 (n - count)) (shl r2 count)
               else shl r1 (count - n)).

    Definition shift_right_immediate_double (r : tuple W 2) (count : Z) : tuple W 2
      := dlet r := r in
         let (r1, r2) := eta r in
         (if count =? 0
          then r1
          else if count <? n
               then or (shr r1 count) (shl r2 (n - count))
               else shr r2 (count - n),
          if count =? 0
          then r2
          else if count <? n
               then shr r2 count
               else ldi 0).

    (** Require a [decoder] instance to aid typeclass search in
        resolving [n] *)
    Global Instance shl_double {decode : decoder n W} : shift_left_immediate (tuple W 2)
      := { shl := shift_left_immediate_double }.
    Global Instance shr_double {decode : decoder n W} : shift_right_immediate (tuple W 2)
      := { shr := shift_right_immediate_double }.
  End shl_shr.

  Section shrd.
    Context (n : Z) {W}
            {ldi : load_immediate W}
            {shrd : shift_right_doubleword_immediate W}.

    Definition shift_right_doubleword_immediate_double (high low : tuple W 2) (count : Z) : tuple W 2
      := dlet high := high in
         dlet low := low in
         let (high1, high2) := eta high in
         let (low1, low2) := eta low in
         (if count =? 0
          then low1
          else if count <? n
               then shrd low2 low1 count
               else if count <? 2 * n
                    then shrd high1 low2 (count - n)
                    else shrd high2 high1 (count - 2 * n),
          if count =? 0
          then low2
          else if count <? n
               then shrd high1 low2 count
               else if count <? 2 * n
                    then shrd high2 high1 (count - n)
                    else shrd (ldi 0) high2 (count - 2 * n)).

    (** Require a [decoder] instance to aid typeclass search in
        resolving [n] *)
    Global Instance shrd_double {decode : decoder n W} : shift_right_doubleword_immediate (tuple W 2)
      := { shrd := shift_right_doubleword_immediate_double }.
  End shrd.

  Section double_from_half.
    Context {half_n : Z} {W}
            {mulhwll : multiply_low_low W}
            {mulhwhl : multiply_high_low W}
            {mulhwhh : multiply_high_high W}
            {adc : add_with_carry W}
            {shl : shift_left_immediate W}
            {shr : shift_right_immediate W}
            {ldi : load_immediate W}.

    Definition mul_double (a b : W) : tuple W 2
      := dlet a              := a in
         dlet b              := b in
         let out : tuple W 2 := (mulhwll a b, mulhwhh a b) in
         dlet out            := out in
         dlet tmp            := mulhwhl a b in
         dlet addv           := (ripple_carry_adc adc out (shl tmp half_n, shr tmp half_n) false) in
         let (_, out)        := eta addv in
         dlet tmp            := mulhwhl b a in
         dlet addv           := (ripple_carry_adc adc out (shl tmp half_n, shr tmp half_n) false) in
         let (_, out)        := eta addv in
         out.

    (** Require a dummy [decoder] for these instances to allow
            typeclass inference of the [half_n] argument *)
    Global Instance mul_double_multiply {decode : decoder (2 * half_n) W} : multiply_double W
      := { muldw a b := mul_double a b }.
  End double_from_half.

  Global Instance mul_double_multiply_low_low {W} {muldw : multiply_double W}
    : multiply_low_low (tuple W 2)
    := { mulhwll a b := muldw (fst a) (fst b) }.
  Global Instance mul_double_multiply_high_low {W} {muldw : multiply_double W}
    : multiply_high_low (tuple W 2)
    := { mulhwhl a b := muldw (snd a) (fst b) }.
  Global Instance mul_double_multiply_high_high {W} {muldw : multiply_double W}
    : multiply_high_high (tuple W 2)
    := { mulhwhh a b := muldw (snd a) (snd b) }.
End tuple2.

Global Arguments mul_double half_n {_ _ _ _ _ _ _} _ _.


Require Import sepcomp.semantics.
Require Import sepcomp.semantics_lemmas.

(** * Cooperating Interaction Semantics *)

(** Cooperating semantics impose additional constraints; in particular, they
   specialize interaction semantics to CompCert memories and require that the
   memories produced by coresteps are [forward] wrt. the initial memory. See
   [core/mem_lemmas.v] for the defn. of [mem_forward]. *)

Require Import compcert.common.Memory.
Require Import sepcomp.mem_lemmas.
Record CoopCoreSem {G C} :=
  { coopsem :> CoreSemantics G C mem
  ; corestep_fwd :
      forall g c m c' m' (CS: corestep coopsem g c m c' m'),
      mem_forward m m'
  ; corestep_rdonly:
      forall g c m c' m' (CS: corestep coopsem g c m c' m') b,
      Mem.valid_block m b -> readonly m b m'}.

Implicit Arguments CoopCoreSem [].

Definition MemSem2CoopCoreSem {G C} (s:@MemSem G C): @CoopCoreSem G C.
Proof.
eapply Build_CoopCoreSem with (coopsem := s).
apply semantics_lemmas.corestep_fwd.
apply semantics_lemmas.corestep_rdonly.
Defined.

Section CoopCoreSemLemmas.
Context {G C: Type}.
Variable coopsem: CoopCoreSem G C.

Lemma corestepN_fwd: forall ge c m c' m' n,
  corestepN coopsem ge n c m c' m' ->
  mem_forward m m'.
Proof.
intros until n; revert c m.
induction n; simpl; auto.
inversion 1; apply mem_forward_refl; auto.
intros c m [c2 [m2 [? ?]]].
apply mem_forward_trans with (m2 := m2).
apply corestep_fwd in H; auto.
eapply IHn; eauto.
Qed.

Lemma corestep_star_fwd: forall g c m c' m'
  (CS:corestep_star coopsem g c m c' m'),
  mem_forward m m'.
Proof.
  intros. destruct CS.
  eapply corestepN_fwd.
  apply H.
Qed.

Lemma corestep_plus_fwd: forall g c m c' m'
  (CS:corestep_plus coopsem g c m c' m'),
  mem_forward m m'.
Proof.
   intros. destruct CS.
   eapply corestepN_fwd.
   apply H.
Qed.

Lemma corestepN_rdonly: forall ge c m c' m' n,
  corestepN coopsem ge n c m c' m' -> forall b
  (VB: Mem.valid_block m b), readonly m b m'.
Proof.
intros until n; revert c m.
induction n; simpl; auto.
inversion 1; intros. apply readonly_refl.
intros c m [c2 [m2 [? ?]]].
intros. apply readonly_trans with (m2 := m2).
eapply corestep_rdonly; eauto.
eapply IHn; eauto. eapply corestep_fwd; eauto.
Qed.

Lemma corestep_plus_rdonly ge c m c' m'
  (CS: corestep_plus coopsem ge c m c' m') b
  (VB: Mem.valid_block m b): readonly m b m'.
Proof.
  destruct CS. eapply corestepN_rdonly; eauto.
Qed.

Lemma corestep_star_rdonly ge c m c' m'
  (CS: corestep_star coopsem ge c m c' m') b
  (VB: Mem.valid_block m b): readonly m b m'.
Proof.
  destruct CS. eapply corestepN_rdonly; eauto.
Qed.

End CoopCoreSemLemmas.


(* ** Imports and settings *)
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp Require Import word_ssrZ.
Require Import xseq.
Require Export xseq ZArith strings word utils var type warray_.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Unset Elimination Schemes.

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

Variant glob_value :=
  | Gword : forall (ws:wsize), word ws -> glob_value
  | Garr  : forall (p:positive), WArray.array p -> glob_value.

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

Definition glob_decl := (var * glob_value)%type.

Notation glob_decls  := (seq glob_decl).


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 G Aprime Aprimeprime Bprime Cprime Bprimeprime Bprimeprimeprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Bprime A /\ (wd_ Bprime C /\ (wd_ Aprime B /\ (wd_ Aprime C /\ (wd_ Cprime A /\ (wd_ Cprime B /\ (wd_ Aprimeprime Bprimeprime /\ (wd_ Aprime Bprimeprimeprime /\ (wd_ Aprime Bprime /\ (wd_ Bprime Bprimeprimeprime /\ (wd_ G Aprime /\ (wd_ G Aprimeprime /\ (wd_ G Bprimeprime /\ (wd_ Aprime Bprimeprime /\ (wd_ Bprimeprime Bprimeprimeprime /\ (wd_ G Bprimeprimeprime /\ (wd_ Aprime Aprimeprime /\ (wd_ B G /\ (wd_ Bprimeprime B /\ (wd_ A G /\ (wd_ Aprimeprime A /\ (col_ Aprime Bprime Bprimeprimeprime /\ (col_ G Bprimeprime Bprimeprimeprime /\ (col_ Bprimeprime B G /\ (col_ Cprime A B /\ (col_ Bprime A C /\ (col_ G Aprime Aprimeprime /\ (col_ Aprimeprime A G /\ (col_ Aprime B C /\ (col_ Aprime Bprimeprime Aprime /\ (col_ A Aprimeprime Aprime /\ col_ A B G)))))))))))))))))))))))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*

  Copyright 2014 Cornell University

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

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

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

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

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

*)

Require Export type_sys_useful.
Require Import dest_close.

Lemma close_type_system_func {p} :
  forall lib (ts : cts(p))
         T T'
         (eq : per)
         A A' v v' B B' eqa eqb,
    type_system lib ts
    -> defines_only_universes lib ts
    -> computes_to_valc lib T (mkc_function A v B)
    -> computes_to_valc lib T' (mkc_function A' v' B')
    -> close lib ts A A' eqa
    -> (forall (a a' : CTerm) (e : eqa a a'),
          close lib ts (substc a v B) (substc a' v' B') (eqb a a' e))
    -> (forall (a a' : CTerm) (e : eqa a a'),
          type_system lib ts ->
          defines_only_universes lib ts ->
          type_sys_props lib (close lib ts) (substc a v B) (substc a' v' B')
                         (eqb a a' e))
    -> (forall t t' : CTerm,
          eq t t' <=> (forall (a a' : CTerm) (e : eqa a a'), eqb a a' e (mkc_apply t a) (mkc_apply t' a')))
    -> per_func lib (close lib ts) T T' eq
    -> type_sys_props lib (close lib ts) A A' eqa
    -> type_sys_props lib (close lib ts) T T' eq.
Proof.
  introv X X0 c1 c2 X1 clb recb eqiff per IHX1.

  rw @type_sys_props_iff_type_sys_props3.
  prove_type_sys_props3 SCase; intros.

  + SCase "uniquely_valued".
    dclose_lr.

    SSCase "CL_func".
    allunfold @per_func; exrepd.
    generalize (eq_term_equals_type_family lib T T3 eqa0 eqa eqb0 eqb (close lib ts) A v B A' v' B' mkc_function); intro i.
    repeat (autodimp i hyp; try (complete (introv e; eqconstr e; sp))); repnd.

    unfold eq_term_equals; sp.
    rw t0; rw eqiff; split; sp.

    duplicate e as e'; rw <- i0 in e.
    generalize (i1 a a' e' e); intro k.
    rw k; sp.

    duplicate e as e'; rw i0 in e.
    generalize (i1 a a' e e'); intro k.
    rw <- k; sp.

  + SCase "type_symmetric"; repdors; subst;
    dclose_lr;
    apply CL_func;
    clear per;
    allunfold @per_func; exrepd;
    unfold per_func;
    exists eqa0 eqb0; sp;
    allrw <-; sp.

  + SCase "type_value_respecting"; repdors; subst;
    apply CL_func; unfold per_func; exists eqa eqb; sp.

    duplicate c1 as ct.
    apply @cequivc_mkc_function with (T' := T3) in ct; sp.

    apply @type_family_cequivc
          with
          (A1 := A)
          (v1 := v)
          (B1 := B)
          (A2 := A'0)
          (v2 := v'0)
          (B2 := B'0)
          (A := A')
          (v := v')
          (B := B'); sp.

    duplicate c2 as ct.
    apply @cequivc_mkc_function with (T' := T3) in ct; sp.

    apply @type_family_cequivc2
          with
          (A1 := A')
          (v1 := v')
          (B1 := B')
          (A2 := A'0)
          (v2 := v'0)
          (B2 := B'0)
          (A := A)
          (v := v)
          (B := B); sp.

  + SCase "term_symmetric".
    unfold term_equality_symmetric; sp.
    onedtsp e pp p0 p1 c t t0 t3 tygs tygt dum.
    apply eqiff; sp.
    assert (eqa a a) as eqaa by (apply t0 with (t2 := a'); auto).
    assert (eqa a' a) as e' by auto.
    assert (eq t1 t2) as eq12 by auto.
    apply eqiff with (a := a') (a' := a) (e := e') in eq12; auto.

    generalize (eq_term_equals_sym_tsp lib (close lib ts) eqa eqb a a' eqaa e0 e'
                                       v B v' B'); intro i.
    autodimp i h; repnd.

    (* Now we prove the equality between the applies *)
    unfold eq_term_equals in i.
    apply i in eq12.
    generalize (recb a a' e0); sp.
    onedtsp X5 X6 X7 X8 X9 X10 X11 X4 tygs1 tygt1 dum1; sp.

  + SCase "term_transitive".
    unfold term_equality_transitive; sp.
    apply eqiff; sp.
    assert (eq t1 t2) as eqt12 by auto.
    assert (eq t2 t3) as eqt23 by auto.
    assert (eq t1 t2) as eq12 by auto.
    assert (eq t2 t3) as eq23 by auto.
    apply eqiff with (a := a) (a' := a') (e := e) in eqt12; auto.
    apply eqiff with (a := a) (a' := a') (e := e) in eqt23; auto.

    assert (eqb a a' e (mkc_apply t2 a') (mkc_apply t2 a));
      try (complete (generalize (recb a a' e); sp;
                     onedtsp X6 X7 X8 X9 X10 X11 X12 X5 tygs1 tygt1 dum1; sp;
                     apply X12 with (mkc_apply t2 a'); auto;
                     apply X12 with (mkc_apply t2 a); auto)).

    assert (eq t2 t2) as eqt2;
      try (complete (apply eqiff with (a := a) (a' := a') (e := e) in eqt2; auto;
                     generalize (recb a a' e); sp;
                     allunfold @type_sys_props; sp)).

    apply eqiff; sp.
    duplicate eq23 as eq2.
    apply eqiff with (a := a0) (a' := a'0) (e := e0) in eq23; auto.
    assert (eqa a'0 a'0) as eqa'
           by (unfold type_sys_props in IHX1; sp; apply IHX7 with (t2 := a0); sp).
    apply eqiff with (a := a'0) (a' := a'0) (e := eqa') in eq2; auto.

    assert (eq_term_equals (eqb a0 a'0 e0) (eqb a'0 a'0 eqa')) as eqteq;
      try (complete (unfold eq_term_equals in eqteq;
                     apply eqteq in eq2;
                     generalize (recb a0 a'0 e0); sp;
                     onedtsp X6 X7 X8 X9 X10 X11 X12 X5 tygs1 tygt1 dum1; sp;
                     apply X12 with (t2 := mkc_apply t3 a'0); sp)).

    allunfold @per_func; exrepd.
    generalize (eq_term_equals_type_family
                  lib T T' eqa0 eqa eqb0 eqb (close lib ts)
                  A v B A' v' B' mkc_function); intro i.
    repeat (autodimp i hyp; try (complete (introv f; eqconstr f; sp))).
    repnd.
    apply eq_term_equals_sym; sp.

  + SCase "term_value_respecting".
    unfold term_equality_respecting; sp.
    apply eqiff; sp.
    assert (eq t t) as eqtt by auto.
    apply eqiff with (a := a) (a' := a') (e := e) in eqtt; auto.

    generalize (recb a a' e); sp.
    onedtsp X5 X6 X7 X8 X9 X10 X11 X4 tygs1 tygt1 dum1; sp.
    apply X11 with (t2 := mkc_apply t a'); auto.
    apply X4.
    apply term_equality_refl with (t2 := mkc_apply t a); auto.

    spcast; apply sp_implies_cequivc_apply; sp.

  + SCase "type_gsymmetric"; repdors; subst; split; sp; dclose_lr;
    apply CL_func;
    clear per;
    allunfold @per_func; exrepd.

    (* 1 *)
    generalize (eq_term_equals_type_family
                  lib T T3 eqa0 eqa eqb0 eqb (close lib ts)
                  A v B A' v' B' mkc_function); intro i.
    repeat (autodimp i hyp; try (complete (introv e; eqconstr e; sp))).
    repnd.

    unfold per_func.
    exists eqa eqb; sp.

    rw t0; split; intro pp; sp.

    duplicate e as e'.
    rw i0 in e.
    generalize (pp a a' e); intro j.
    generalize (i1 a a' e e'); intro eqt.
    rw eqt in j; sp.

    duplicate e as e'.
    rw <- i0 in e.
    generalize (pp a a' e); intro j.
    generalize (i1 a a' e' e); intro eqt.
    rw <- eqt in j; sp.

    (* 2 *)
    generalize (eq_term_equals_type_family2
                  lib T3 T eqa0 eqa eqb0 eqb (close lib ts)
                  A v B A' v' B' mkc_function); intro i;
    repeat (autodimp i hyp; try (complete (introv e; eqconstr e; sp)));
    repnd.

    unfold per_func.
    exists eqa eqb; sp.

    rw t0; split; intro pp; sp.

    duplicate e as e'.
    rw i0 in e.
    generalize (pp a a' e); intro j.
    generalize (i1 a a' e e'); intro eqt.
    rw eqt in j; sp.

    duplicate e as e'.
    rw <- i0 in e.
    generalize (pp a a' e); intro j.
    generalize (i1 a a' e' e); intro eqt.
    rw <- eqt in j; sp.

  + SCase "type_gtransitive"; sp.

  + SCase "type_mtransitive".
    repdors; subst; dclose_lr;
    try (move_term_to_top (per_func lib (close lib ts) T T4 eq2));
    try (move_term_to_top (per_func lib (close lib ts) T' T4 eq2)).

    (* 1 *)
    clear per.
    allunfold @per_func; exrepd.

    generalize (eq_term_equals_type_family2
                  lib T3 T eqa1 eqa eqb1 eqb (close lib ts)
                  A v B A' v' B' mkc_function); intro i.
    repeat (autodimp i hyp; try (complete (introv e; eqconstr e; sp))).
    repnd.

    generalize (type_family_trans2
                  lib mkc_function (close lib ts) T3 T T4 eqa eqb eqa0 eqb0 A v B A' v' B');
      intro j.
    repeat (autodimp j hyp; try (complete (introv e; eqconstr e; sp))).
    repnd.

    dands; apply CL_func; unfold per_func; exists eqa eqb; sp; allrw.

    split; intro pp; sp.

    assert (eqa1 a a') as e' by (rw <- i0; auto).
    generalize (pp a a' e'); intro k.
    generalize (i1 a a' e' e); intro l.
    rw <- l; sp.

    assert (eqa a a') as e' by (rw i0; auto).
    generalize (pp a a' e'); intro k.
    generalize (i1 a a' e e'); intro l.
    rw l; sp.

    split; intro pp; sp.

    assert (eqa0 a a') as e' by (rw <- j0; auto).
    generalize (pp a a' e'); intro k.
    generalize (j1 a a' e e'); intro l.
    rw l; sp.

    assert (eqa a a') as e' by (rw j0; auto).
    generalize (pp a a' e'); intro k.
    generalize (j1 a a' e' e); intro l.
    rw <- l; sp.

    (* 2 *)
    clear per.
    allunfold @per_func; exrepd.

    generalize (eq_term_equals_type_family2
                  lib T3 T' eqa1 eqa eqb1 eqb (close lib ts)
                  A' v' B' A v B mkc_function); intro i.
    repeat (autodimp i hyp;
            try (complete (introv e; eqconstr e; sp));
            try (complete (apply type_sys_props_sym; sp))).
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
    intros.
    apply type_sys_props_sym.
    apply type_sys_props_eqb_comm; sp.
    apply tet with (t2 := a'); sp.
    apply tet with (t2 := a); sp.
    repnd.

    generalize (type_family_trans2
                  lib mkc_function (close lib ts) T3 T' T4 eqa eqb eqa0 eqb0 A' v' B' A v B); intro j.
    repeat (autodimp j hyp;
            try (complete (introv e; eqconstr e; sp));
            try (complete (apply type_sys_props_sym; sp))).
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
    intros.
    apply type_sys_props_sym.
    apply type_sys_props_eqb_comm; sp.
    apply tet with (t2 := a'); sp.
    apply tet with (t2 := a); sp.
    repnd.

    dands; apply CL_func; unfold per_func; exists eqa eqb; sp; allrw.

    split; intro pp; sp.

    assert (eqa1 a a') as e' by (rw <- i0; auto).
    generalize (pp a a' e'); intro k.
    generalize (i1 a a' e' e); intro l.
    rw <- l; sp.

    assert (eqa a a') as e' by (rw i0; auto).
    generalize (pp a a' e'); intro k.
    generalize (i1 a a' e e'); intro l.
    rw l; sp.

    split; intro pp; sp.

    assert (eqa0 a a') as e' by (rw <- j0; auto).
    generalize (pp a a' e'); intro k.
    generalize (j1 a a' e e'); intro l.
    rw l; sp.

    assert (eqa a a') as e' by (rw j0; auto).
    generalize (pp a a' e'); intro k.
    generalize (j1 a a' e' e); intro l.
    rw <- l; sp.
Qed.