Require Import RamifyCoq.CertiGC.gc_spec.

Lemma typed_true_tag: forall (to : nat) (g : LGraph) (index : nat),
    typed_true tint
               (force_val
                  (option_map (fun b : bool => Val.of_bool (negb b))
                              (bool_val_i
                                 (Val.of_bool
                                    (negb (Int.lt (Int.repr (raw_tag
                                                               (vlabel g (to, index))))
                                                  (Int.repr 251))))))) ->
    ~ no_scan g (to, index).
Proof.
  intros. remember (Int.lt (Int.repr (raw_tag (vlabel g (to, index))))
                           (Int.repr 251)). unfold typed_true in H.
  destruct b; simpl in H. 2: inversion H. symmetry in Heqb. apply lt_repr in Heqb.
  - unfold no_scan. rep_omega.
  - red. pose proof (raw_tag_range (vlabel g (to, index))). rep_omega.
  - red. rep_omega.
Qed.

Lemma typed_false_tag: forall (to : nat) (g : LGraph) (index : nat),
    typed_false tint
               (force_val
                  (option_map (fun b : bool => Val.of_bool (negb b))
                              (bool_val_i
                                 (Val.of_bool
                                    (negb (Int.lt (Int.repr (raw_tag
                                                               (vlabel g (to, index))))
                                                  (Int.repr 251))))))) ->
    no_scan g (to, index).
Proof.
  intros. remember (Int.lt (Int.repr (raw_tag (vlabel g (to, index))))
                           (Int.repr 251)). unfold typed_false in H.
  destruct b; simpl in H. 1: inversion H. symmetry in Heqb.
  apply lt_repr_false in Heqb.
  - unfold no_scan. rep_omega.
  - red. pose proof (raw_tag_range (vlabel g (to, index))). rep_omega.
  - red. rep_omega.
Qed.

Lemma body_do_scan: semax_body Vprog Gprog f_do_scan do_scan_spec.
Proof.
  start_function.
  forward.
  forward_loop (EX n: nat, EX g': LGraph, EX t_info': thread_info,
                PROP (super_compatible (g', t_info', roots) f_info outlier;
                      forward_condition g' t_info' from to;
                      thread_info_relation t_info t_info';
                      closure_has_index g' to (to_index + n);
                      scan_vertex_while_loop from to (nat_seq to_index n) g g')
                LOCAL
                (temp _s (offset_val (- WORD_SIZE)
                                     (vertex_address g' (to, (to_index + n)%nat)));
                 temp _from_start (gen_start g' from);
                 temp _from_limit (limit_address g' t_info' from);
                 temp _next (next_address t_info' to))
                SEP (all_string_constants rsh gv; fun_info_rep rsh f_info fi;
               outlier_rep outlier; graph_rep g'; thread_info_rep sh t_info' ti))
  break: (EX g' : LGraph, EX t_info' : thread_info,
          PROP (super_compatible (g', t_info', roots) f_info outlier;
                forward_condition g' t_info' from to;
                do_scan_relation from to to_index g g';
                thread_info_relation t_info t_info')
          LOCAL ()
          SEP (all_string_constants rsh gv; fun_info_rep rsh f_info fi;
               outlier_rep outlier; graph_rep g'; thread_info_rep sh t_info' ti)).
  - Exists O g t_info. destruct H as [? [? [? ?]]].
    replace (to_index + 0)%nat with to_index by omega. entailer!.
    split; [|split]; [red; auto | apply tir_id | constructor].
  - Intros n g' t_info'. remember (to_index + n)%nat as index.
    unfold next_address, thread_info_rep. Intros.
    unfold heap_struct_rep. destruct H5 as [? [? [? ?]]].
    destruct H6 as [? [? [? [? ?]]]].
    assert (0 <= Z.of_nat to < 12). {
      clear -H5 H14. destruct H5 as [_ [_ ?]]. red in H14.
      pose proof (spaces_size (ti_heap t_info')).
      rewrite Zlength_correct in H0. rep_omega. }
    destruct (gt_gs_compatible _ _ H5 _ H14) as [? [? ?]]. rewrite nth_space_Znth in *.
    remember (Znth (Z.of_nat to) (spaces (ti_heap t_info'))) as sp_to.
    assert (isptr (space_start sp_to)) by (rewrite <- H18; apply start_isptr).
    remember (map space_tri (spaces (ti_heap t_info'))).
    assert (@Znth (val * (val * val)) (Vundef, (Vundef, Vundef))
                  (Z.of_nat to) l = space_tri sp_to). {
      subst l sp_to. now rewrite Znth_map by (rewrite spaces_size; rep_omega). }
    forward; rewrite H22; unfold space_tri. 1: entailer!.
    unfold vertex_address, vertex_offset. rewrite offset_offset_val.
    simpl vgeneration; simpl vindex.
    replace (WORD_SIZE * (previous_vertices_size g' to index + 1) + - WORD_SIZE) with
        (WORD_SIZE * (previous_vertices_size g' to index))%Z by rep_omega.
    unfold gen_start at 1. rewrite if_true by assumption. rewrite H18.
    remember (WORD_SIZE * used_space sp_to)%Z as used_offset.
    remember (WORD_SIZE * previous_vertices_size g' to index)%Z as index_offset.
    freeze [0; 1; 2; 4; 5] FR.
    gather_SEP (graph_rep g') (heap_rest_rep (ti_heap t_info')).
    assert (
        forall b i,
          Vptr b i = space_start sp_to ->
          graph_rep g' * heap_rest_rep (ti_heap t_info') |--
      !! (WORD_SIZE * total_space sp_to + Ptrofs.unsigned i <= Ptrofs.max_unsigned)). {
      intros. sep_apply (graph_and_heap_rest_data_at_ _ _ _ H14 H5).
      assert (space_start sp_to = gen_start g' to) by
          (unfold gen_start; rewrite if_true by assumption;
           rewrite <- H18; reflexivity). rewrite H24 in H23.
      sep_apply (generation_data_at__ptrofs g' t_info' to b i H23).
      unfold gen_size; rewrite nth_space_Znth; entailer!. }
    assert_PROP (force_val
                   (sem_cmp_pp Clt (offset_val index_offset (space_start sp_to))
                               (offset_val used_offset (space_start sp_to))) =
                 Vint (if if zlt index_offset used_offset then true else false
                       then Int.one else Int.zero)). { (**)
      remember (space_start sp_to). destruct v; try contradiction. inv_int i.
      specialize (H23 b (Ptrofs.repr ofs) eq_refl).
      rewrite Ptrofs.unsigned_repr in H23 by rep_omega. sep_apply H23. Intros.
      assert (0 <= ofs + used_offset <= Ptrofs.max_unsigned). {
        subst.
        pose proof (space_order (Znth (Z.of_nat to) (spaces (ti_heap t_info')))).
        rep_omega. }
      assert (0 <= ofs + index_offset <= Ptrofs.max_unsigned). {
        subst. red in H8. pose proof (pvs_ge_zero g' to (to_index + n)%nat).
        pose proof (pvs_mono g' to _ _ H8). rep_omega. } apply prop_right.
      rewrite force_sem_cmp_pp; [|rewrite isptr_offset_val; assumption..].
      simpl. rewrite !ptrofs_add_repr, if_true. 2: reflexivity.
      unfold Ptrofs.ltu. rewrite !Ptrofs.unsigned_repr; auto. f_equal.
      if_tac; if_tac; try reflexivity; omega. }
    forward_if (gen_has_index g' to index).
    + remember (Znth (Z.of_nat to) (spaces (ti_heap t_info'))) as sp_to.
      sep_apply (graph_and_heap_rest_data_at_ _ _ _ H14 H5).
      unfold generation_data_at_.
      assert (gen_start g' to = space_start sp_to) by
          (subst; unfold gen_start; rewrite if_true; assumption). rewrite H31.
      rewrite data_at__memory_block. Intros. rewrite sizeof_tarray_int_or_ptr.
      2: unfold gen_size; apply total_space_range.
      remember (WORD_SIZE * used_space sp_to)%Z as used_offset.
      remember (to_index + n)%nat as index.
      remember (WORD_SIZE * previous_vertices_size g' to index)%Z as index_offset.
      destruct (space_start sp_to); try contradiction. simpl. unfold test_order_ptrs.
      simpl. case (peq b b); intros. 2: contradiction. simpl.
      assert (sepalg.nonidentity (nth_sh g' to)). {
        apply readable_nonidentity, writable_readable_share. unfold nth_sh.
        apply generation_share_writable. }
      assert (forall offset,
                 0 <= offset <= used_offset ->
                 memory_block (nth_sh g' to) (WORD_SIZE * gen_size t_info' to)
                              (Vptr b i) * TT * FRZL FR |--
        weak_valid_pointer (Vptr b (Ptrofs.add i (Ptrofs.repr offset)))). {
        intros. change (Vptr b (Ptrofs.add i (Ptrofs.repr offset))) with
            (offset_val offset (Vptr b i)).
        sep_apply (memory_block_weak_valid_pointer
                     (nth_sh g' to) (WORD_SIZE * gen_size t_info' to)
                     (Vptr b i) offset); auto.
        3: apply extend_weak_valid_pointer.
        - subst. unfold gen_size. split. 1: apply (proj1 H34).
          transitivity (WORD_SIZE * used_space (nth_space t_info' to))%Z.
          + rewrite nth_space_Znth. apply (proj2 H34).
          + apply Zmult_le_compat_l. apply (proj2 (space_order _)). rep_omega.
        - clear -H3 H7. destruct H7 as [? [? ?]].
          rewrite <- H0.
          rep_omega. }
      apply andp_right; apply H34.
      * subst. split. 1: pose proof (pvs_ge_zero g' to (to_index + n)%nat); rep_omega.
        apply Zmult_le_compat_l. 2: rep_omega. rewrite <- H20.
        apply pvs_mono. assumption.
      * split; [|omega]; subst; apply Z.mul_nonneg_nonneg;
                                  [rep_omega | apply space_order].
    + assert (index_offset < used_offset). {
        now destruct (zlt index_offset used_offset); [|rewrite H24 in H25; unfold typed_true in H25]. }
      forward. entailer!. red. rewrite <- H20 in H26.
      rewrite <- Z.mul_lt_mono_pos_l in H26 by rep_omega.
      apply pvs_lt_rev in H26. assumption.
    + assert (~ index_offset < used_offset). {
        destruct (zlt index_offset used_offset); trivial.
        now rewrite H24 in H25; unfold typed_false in H25. }
      forward. thaw FR. unfold thread_info_rep, heap_struct_rep.
      Exists g' t_info'. unfold forward_condition. entailer!.
      split; [red; auto | exists n; split; trivial].
      unfold gen_has_index. rewrite <- H20 in H26.
      rewrite <- Z.mul_lt_mono_pos_l in H26 by rep_omega. intro; apply H26.
      now apply pvs_mono_strict.
    + clear H8 H23 H24. Intros. thaw FR. freeze [1;2;3;4;5;6] FR.
      assert (graph_has_v g' (to, index)) by easy.
      localize [vertex_rep (nth_sh g' to) g' (to, index)].
      assert (readable_share (nth_sh g' to)) by
          (unfold nth_sh; apply writable_readable_share, generation_share_writable).
      unfold vertex_rep, vertex_at. Intros.
      assert (offset_val (- WORD_SIZE) (vertex_address g' (to, index)) =
              offset_val index_offset (space_start sp_to)). {
        unfold vertex_address. rewrite offset_offset_val. unfold vertex_offset.
        simpl vgeneration. simpl vindex.
        replace (WORD_SIZE * (previous_vertices_size g' to index + 1) + - WORD_SIZE)
          with index_offset by rep_omega.
        f_equal. unfold gen_start.
        rewrite if_true by assumption; now rewrite H18. }
      rewrite H25. forward. rewrite <- H25.
      gather_SEP (data_at (nth_sh g' to) tuint (Z2val (make_header g' (to, index)))
            (offset_val (- WORD_SIZE) (vertex_address g' (to, index))))
     (data_at (nth_sh g' to)
       (tarray int_or_ptr_type (Zlength (make_fields_vals g' (to, index))))
       (make_fields_vals g' (to, index)) (vertex_address g' (to, index))).
      replace_SEP 0 (vertex_rep (nth_sh g' to) g' (to, index)) by
          (unfold vertex_rep, vertex_at; entailer!).
      unlocalize [graph_rep g']. 1: apply graph_vertex_ramif_stable; assumption.
      forward. forward. assert (gen_unmarked g' to). {
        eapply (svwl_gen_unmarked from to _ g); eauto.
        destruct H0 as [_ [_ [? _]]]. assumption. }
      specialize (H26 H14 _ H8).
      rewrite make_header_Wosize, make_header_tag by assumption. deadvars!.
      fold (next_address t_info' to). thaw FR.
      fold (heap_struct_rep sh l (ti_heap_p t_info')).
      (* gather_SEP 5 6 1. *)
      gather_SEP
        (data_at sh thread_info_type _ _)
        (heap_struct_rep sh l _ ) (heap_rest_rep _).
      replace_SEP 0 (thread_info_rep sh t_info' ti) by
          (unfold thread_info_rep; entailer!).
      forward_if
        (EX g'': LGraph, EX t_info'': thread_info,
         PROP (super_compatible (g'', t_info'', roots) f_info outlier;
               forward_condition g'' t_info'' from to;
               thread_info_relation t_info t_info'';
               (no_scan g' (to, index) /\ g'' = g') \/
               (~ no_scan g' (to, index) /\
                scan_vertex_for_loop
                  from to (to, index)
                  (nat_inc_list (length (vlabel g' (to, index)).(raw_fields))) g' g''))
         LOCAL (temp _tag (vint (raw_tag (vlabel g' (to, index))));
                temp _sz (vint (Zlength (raw_fields (vlabel g' (to, index)))));
                temp _s (offset_val (- WORD_SIZE) (vertex_address g'' (to, index)));
                temp _from_start (gen_start g'' from);
                temp _from_limit (limit_address g'' t_info'' from);
                temp _next (next_address t_info'' to))
         SEP (thread_info_rep sh t_info'' ti; graph_rep g'';
              fun_info_rep rsh f_info fi;
              all_string_constants rsh gv; outlier_rep outlier)).
      * apply typed_true_tag in H27.
        remember (Zlength (raw_fields (vlabel g' (to, index)))).
        assert (1 <= z < Int.max_signed). {
          subst z. pose proof (raw_fields_range (vlabel g' (to, index))). split; [omega|].
          transitivity (two_power_nat 22); [omega | vm_compute; reflexivity]. }
        forward_loop
          (EX i: Z, EX g3: LGraph, EX t_info3: thread_info,
           PROP (scan_vertex_for_loop
                   from to (to, index)
                   (sublist 0 (i - 1)
                            (nat_inc_list
                               (length (vlabel g' (to, index)).(raw_fields)))) g' g3;
                super_compatible (g3, t_info3, roots) f_info outlier;
                forward_condition g3 t_info3 from to;
                thread_info_relation t_info t_info3;
                1 <= i <= z + 1)
           LOCAL (temp _tag (vint (raw_tag (vlabel g' (to, index))));
                  temp _j (vint i);
                  temp _sz (vint z);
                  temp _s (offset_val (- WORD_SIZE) (vertex_address g3 (to, index)));
                  temp _from_start (gen_start g3 from);
                  temp _from_limit (limit_address g3 t_info3 from);
                  temp _next (next_address t_info3 to))
           SEP (all_string_constants rsh gv;
                outlier_rep outlier;
                fun_info_rep rsh f_info fi;
                graph_rep g3;
                thread_info_rep sh t_info3 ti))
          continue: (EX i: Z, EX g3: LGraph, EX t_info3: thread_info,
           PROP (scan_vertex_for_loop
                   from to (to, index)
                   (sublist 0 i
                            (nat_inc_list
                               (length (vlabel g' (to, index)).(raw_fields)))) g' g3;
                super_compatible (g3, t_info3, roots) f_info outlier;
                forward_condition g3 t_info3 from to;
                thread_info_relation t_info t_info3;
                1 <= i + 1 <= z + 1)
           LOCAL (temp _tag (vint (raw_tag (vlabel g' (to, index))));
                  temp _j (vint i);
                  temp _sz (vint z);
                  temp _s (offset_val (- WORD_SIZE) (vertex_address g3 (to, index)));
                  temp _from_start (gen_start g3 from);
                  temp _from_limit (limit_address g3 t_info3 from);
                  temp _next (next_address t_info3 to))
           SEP (all_string_constants rsh gv;
                fun_info_rep rsh f_info fi;
                outlier_rep outlier;
                graph_rep g3;
                thread_info_rep sh t_info3 ti)).
        -- forward. Exists 1 g' t_info'. replace (1 - 1) with 0 by omega.
           autorewrite with sublist. unfold forward_condition. entailer!.
           split; [apply svfl_nil | red; auto].
        -- Intros i g3 t_info3. forward_if (i <= z).
           ++ forward. entailer!.
           ++ forward. assert (i = z + 1) by omega. subst i. clear H33 H34.
              replace (z + 1 - 1) with z in H29 by omega.
              remember (raw_fields (vlabel g' (to, index))) as r.
              replace (sublist 0 z (nat_inc_list (Datatypes.length r))) with
                  (nat_inc_list (Datatypes.length r)) in H29.
              ** Exists g3 t_info3. entailer!.
              ** rewrite sublist_all; trivial. rewrite Z.le_lteq. right.
                 subst z. rewrite !Zlength_correct, nat_inc_list_length. reflexivity.
           ++ Intros.
              change (Tpointer tvoid {| attr_volatile := false;
                                        attr_alignas := Some 2%N |}) with
                  int_or_ptr_type.
              assert (isptr (vertex_address g3 (to, index))). {
                erewrite <- svfl_vertex_address; eauto. rewrite <- H18 in H21.
                2: apply graph_has_v_in_closure; assumption. clear -H21 H14.
                unfold vertex_address. unfold gen_start. simpl.
                rewrite if_true by assumption. rewrite isptr_offset_val. assumption. }
              assert (graph_has_gen g3 to) by
                  (eapply svfl_graph_has_gen in H29; [rewrite <- H29|]; assumption).
              assert (graph_has_v g3 (to, index)) by
                  (eapply svfl_graph_has_v in H29; [apply H29| assumption..]).
              forward_call (rsh, sh, gv, fi, ti, g3, t_info3, f_info, roots,
                            outlier, from, to, 0, (@inr Z _ ((to, index), i - 1))).
              ** simpl snd. apply prop_right.
                 split; [split; [split|]|]; [|reflexivity..].
                 rewrite sem_add_pi_ptr_special;
                   [| rewrite isptr_offset_val; assumption | rep_omega]. simpl.
                 rewrite offset_offset_val. do 2 f_equal. rep_omega.
              ** split; [|split; [|split; [|split; [|split; [|split]]]]];
                   try assumption. 2: rep_omega. red. split; [|split;[|split]].
                 --- assumption.
                 --- eapply svfl_raw_fields in H29;
                       [rewrite <- H29; omega | assumption..].
                 --- rewrite <- H26. symmetry.
                     eapply svfl_raw_mark in H29; [apply H29 | assumption..|].
                     simpl. omega.
                 --- simpl; auto.
              ** Intros vret. destruct vret as [[g4 t_info4] roots']. simpl fst in *.
                 simpl snd in *. simpl in H37. subst roots'. Exists i g4 t_info4.
                 destruct H38 as [? [? [? ?]]].
                 assert (gen_start g3 from = gen_start g4 from) by
                     (eapply fr_gen_start; eauto).
                 assert (limit_address g3 t_info3 from =
                         limit_address g4 t_info4 from). {
                   unfold limit_address. rewrite H45.
                   do 2 f_equal. apply (proj2 H42). }
                 assert (next_address t_info3 to = next_address t_info4 to) by
                     (unfold next_address; f_equal; apply (proj1 H42)). entailer!.
                 split; [|split; [|split]]; try easy.
                 --- remember (nat_inc_list
                                 (Datatypes.length
                                    (raw_fields (vlabel g' (to,
                                                            (to_index + n)%nat))))).
                     assert (i <= Zlength l). {
                       subst l. rewrite Zlength_correct, nat_inc_list_length.
                       rewrite Zlength_correct in H34. omega. }
                     rewrite (sublist_split 0 (i - 1) i) by omega.
                     rewrite (sublist_one (i - 1) i) by omega.
                     apply svfl_add_tail with roots g3; trivial.
                     assert (Z.of_nat (Znth (i - 1) l) = i - 1). {
                       rewrite <- nth_Znth by omega. subst l.
                       rewrite nat_inc_list_nth; [rewrite Z2Nat.id; omega|].
                       rewrite <- ZtoNat_Zlength. rewrite Zlength_correct in H52.
                       rewrite nat_inc_list_length in H52. rewrite Nat2Z.inj_lt.
                       rewrite !Z2Nat.id; omega. } rewrite H53. assumption.
                 --- apply tir_trans with t_info3; assumption.
                 --- f_equal. symmetry. eapply fr_vertex_address; eauto.
                     apply graph_has_v_in_closure; assumption.
        -- Intros i g3 t_info3. forward. rewrite add_repr. Exists (i + 1) g3 t_info3.
           replace (i + 1 - 1) with i by omega. entailer!.
      * apply typed_false_tag in H27. forward. Exists g' t_info'.
        unfold forward_condition. entailer!. easy.
      * Intros g'' t_info''. assert (isptr (vertex_address g'' (to, index))). {
          assert (isptr (vertex_address g' (to, index))). {
            unfold vertex_address. rewrite isptr_offset_val. unfold gen_start.
            rewrite <- H18 in H21. rewrite if_true; assumption. }
          destruct H30 as [[? ?] | [? ?]]. 1: subst g''; assumption.
          eapply svfl_vertex_address in H32;
            [rewrite <- H32 | | apply graph_has_v_in_closure]; assumption. }
        pose proof (raw_fields_range (vlabel g' (to, index))). forward.
        -- entailer!. split. 1: rep_omega.
           assert (two_power_nat 22 < Int.max_signed) by (vm_compute; reflexivity).
           rewrite Int.signed_repr; rep_omega.
        -- change (Tpointer tvoid {| attr_volatile := false;
                                     attr_alignas := Some 2%N |}) with int_or_ptr_type.
           simpl sem_binary_operation'. rewrite add_repr.
           assert (force_val (sem_add_ptr_int
                                int_or_ptr_type Unsigned
                                (offset_val (- WORD_SIZE)
                                            (vertex_address g'' (to, index)))
                                (vint (1 + Zlength
                                             (raw_fields (vlabel g' (to, index))))))
                   = offset_val (- WORD_SIZE)
                                (vertex_address g''
                                                (to, (to_index + (n + 1))%nat))). {
             rewrite sem_add_pi_ptr_special.
             - assert (Zlength (raw_fields (vlabel g' (to, index))) =
                       Zlength (raw_fields (vlabel g'' (to, index)))). {
                 destruct H30 as [[? ?] | [? ?]]. 1: subst g''; reflexivity.
                 erewrite svfl_raw_fields; eauto. } rewrite H33.
               simpl. replace (to_index + (n + 1))%nat with (S index) by omega.
               unfold vertex_address. rewrite !offset_offset_val.
               unfold vertex_offset. simpl vgeneration. simpl vindex. f_equal.
               rewrite pvs_S. unfold vertex_size. rep_omega.
             - rewrite isptr_offset_val. assumption.
             - split. 1: rep_omega.
               assert (two_power_nat 22 < Int.max_unsigned) by
                   (vm_compute; reflexivity). omega. } rewrite H33. clear H33.
           assert (closure_has_index g'' to (to_index + (n + 1))). {
             replace (to_index + (n + 1))%nat with (index + 1)%nat by omega.
             cut (gen_has_index g'' to index). 1: red; intros; red in H33; omega.
             destruct H30 as [[? ?] | [? ?]].
             - subst g''. destruct H23. assumption.
             - eapply svfl_graph_has_v in H33; eauto. destruct H33. assumption. }
           Exists (n + 1)%nat g'' t_info''. destruct H27 as [? [? [? ?]]]. entailer!.
           clear H37 H38 H39 H40. replace (n + 1)%nat with (S n) by omega.
           rewrite nat_seq_S, Nat.add_comm. destruct H30 as [[? ?] | [? ?]].
           ++ subst g''. split; [| apply svwl_add_tail_no_scan]; easy.
           ++ split; [|apply svwl_add_tail_scan with g']; easy.
  - Intros g' t_info'. forward. Exists g' t_info'. entailer!.
Qed.


Require Export DEX_ElemLemmas.

Import DEX_BigStepWithTypes.DEX_BigStepWithTypes DEX_BigStep.DEX_Dom DEX_Prog.

(*   Opaque BigStep.Dom.Heap.update.
 *)
Section p.

Variable kobs: L.t.
Variable p:DEX_ExtendedProgram.
Variable se : DEX_PC -> L.t.
Variable reg : DEX_PC -> (* option DEX_ClassName -> *) DEX_PC -> Prop.
Variable m : DEX_Method.
(* Variable lookupswitch_hyp : well_formed_lookupswitch m. *)

Ltac soap2_intra_normal_aux Hreg_in H Hreg r lvl Hget_ori Hvalue_opt_in k k':=
  specialize Hreg_in with r;
  inversion Hreg_in as [k k' Hget Hget' Hleq Hleq'| Hvalue_opt_in];
  try (apply H in Hreg; apply leql_join_each in Hreg; inversion Hreg as [Hleql1 Hleql1'];
    apply not_leql_trans with (k2:=lvl) in Hleq; auto);
  try (apply H in Hreg; apply not_leql_trans with (k2:=lvl) in Hleq; auto);
  try (rewrite Hget in Hget_ori; inversion Hget_ori; subst; auto).

(* High Branching *)
Lemma soap2_intra_normal :
 forall sgn pc pc2 pc2' i r1 rt1 r1' rt1' r2 r2' rt2 rt2' ,
   instructionAt m pc = Some i ->
   NormalStep se reg m sgn i (pc,r1) rt1 (pc2,r2) rt2 ->
   NormalStep se reg m sgn i (pc,r1') rt1' (pc2',r2') rt2' ->
   pc2 <> pc2' ->
   st_in kobs rt1 rt1' (pc,r1) (pc,r1') ->

    forall j, reg pc j -> ~ L.leql (se j) kobs.
Proof.
  intros sgn pc pc2 pc2' i r1 rt1 r1' rt1' r2 r2' rt2 rt2' Hins Hstep Hstep' Hpc Hst_in j Hreg.
  destruct i; simpl in Hins, Hstep, Hstep', Hst_in;
  inversion_clear Hstep in Hins Hstep' Hpc Hst_in;
  inversion_clear Hstep' in Hpc Hst_in; subst;
  apply inv_st_in in Hst_in;
  DiscrimateEq; try (elim Hpc; reflexivity); try (contradiction).
  (* If_icmp *)
  inversion Hst_in as [Heqset Hreg_in].
    (* ra *)
    assert (Hreg_in':=Hreg_in).
    soap2_intra_normal_aux Hreg_in H8 Hreg ra (se j) H5 Hvalue_opt_in k k'.
    (* rb *)
    soap2_intra_normal_aux Hreg_in' H8 Hreg rb (se j) H6 Hvalue_opt_in' k k'.
    (* both are low *)
    rewrite <- H3 in Hvalue_opt_in; rewrite <- H4 in Hvalue_opt_in';
    rewrite <- H14 in Hvalue_opt_in; rewrite <- H15 in Hvalue_opt_in'.
    inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
    inversion Hvalue_opt_in' as [v2 v2' Hvalue_in' | Hnone'];
    inversion Hvalue_in; inversion Hvalue_in'.
    subst; contradiction.
  inversion Hst_in as [Heqset Hreg_in].
    (* ra *)
    assert (Hreg_in':=Hreg_in).
    soap2_intra_normal_aux Hreg_in H9 Hreg ra (se j) H6 Hvalue_opt_in k k'.
    (* rb *)
    soap2_intra_normal_aux Hreg_in' H9 Hreg rb (se j) H7 Hvalue_opt_in' k k'.
    (* both are low *)
    rewrite <- H4 in Hvalue_opt_in; rewrite <- H5 in Hvalue_opt_in';
    rewrite <- H14 in Hvalue_opt_in; rewrite <- H15 in Hvalue_opt_in'.
    inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
    inversion Hvalue_opt_in' as [v2 v2' Hvalue_in' | Hnone'];
    inversion Hvalue_in; inversion Hvalue_in'.
    subst; contradiction.
  (* If_z *)
  inversion Hst_in as [Heq_set Hreg_in].
    soap2_intra_normal_aux Hreg_in H4 Hreg r (se j) H2 Hvalue_opt_in k1 k1'.
    rewrite <- H1 in Hvalue_opt_in; rewrite <- H8 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst; contradiction.
  inversion Hst_in as [Heq_set Hreg_in].
    soap2_intra_normal_aux Hreg_in H5 Hreg r (se j) H3 Hvalue_opt_in k1 k1'.
    rewrite <- H2 in Hvalue_opt_in; rewrite <- H8 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst; contradiction.
Qed.

End p.


(** * A box to mirror a server over untrusted channels using encryption while preventing timing side channels (part of TCB) *)
Require Import Coq.Program.Basics Coq.NArith.NArith Coq.Lists.List.
Require Import FunctionApp EncryptionInterface TrustedTickBox TrustedEncryptBox TrustedDecryptBox.
Require Import Common.

Local Open Scope list_scope.
Local Open Scope program_scope.

Set Implicit Arguments.

(** ** Summary

    We implement a box that presents the interface of a server storing
    unencrypted data.  It handles "set" and "get eventually" requests,
    and raises "value changed" and "remote corrupted".

    We assume the remote server has a "compare and set" event; we use
    this to be robust to update messages lost over the network.  It is
    the client's responsibility to set up the tick-box intervals so
    that we get an updated server value sufficiently close to our
    sending that CAS succeeds.

    We maintain the following internal state:
    - [remoteStateE] - state we think the remote server has right now (encrypted)
    - [localStateD] - state we want the remote server to have (decrypted)

    We implement the following events:

    Client Events:

    - [ssbClientGetUpdate] - When the client requests an
      update from the server, we request an update from our remote
      server, hidden behind a tick box.

    - [ssbClientSet (newD : rawDataT)] - When the client requests a
      SET, we set [localStateD] to [newD], and schedule a remote
      update.

    Server Events:

    - [ssbServerGotUpdate (newE : encryptedDataT)] - When the server
      provides us with an update, we decrypt it to [newD].  If we
      fail, we inform the client that the remote server got messed up.
      If we succeed, and it is different from [localStateD], we set
      [localStateD] to [newD], and push an update to the client.  In
      all cases, we set [remoteStateE] to [newE].

    Timed events:

    - When it's time to do a server CAS, we compute an encryption
      [localStateE] of [localStateD].  We then tell the server that if
      it's state is [remoteStateE], it should replace it with
      [localStateE].  The server is expected to respond with
      [ssbServerGotUpdate] with it's updated state on both failure and
      success.

  *)

Module TrustedServerSyncBox (DataTypes : EncryptionDataTypes) (Algorithm : EncryptionAlgorithm DataTypes).
  Import DataTypes.

  Module Import TEB := TrustedEncryptBox DataTypes Algorithm.
  Module Import TDB := TrustedDecryptBox DataTypes Algorithm.

  Section trustedServerSyncBox.
    Variable d_eqb : rawDataT -> rawDataT -> bool.

    Record ServerSyncBoxPreState
      := { localStateD : rawDataT;
           remoteStateE : option encryptedDataT }.

    Record ServerSyncBoxState :=
      {
        ssbState :> ServerSyncBoxPreState;
        ssbGetUpdateState : TickBoxState unit;
        ssbCASState : TickBoxState encryptedDataT;
        ssbEncryptState : EncryptBoxState;
        ssbDecryptState : DecryptBoxState
      }.

(* python:
<<
fields=[(x.strip(), y.strip()) for x, y in [z.split(':') for z in """
        ssbState : ServerSyncBoxPreState;
        ssbGetUpdateState : TickBoxState unit;
        ssbCASState : TickBoxState cas_state;
        ssbEncryptState : EncryptBoxState;
        ssbDecryptState : DecryptBoxState""".split(';')]]
for field0, ty0 in fields:
    body = ';\n          '.join((('%s := st.(%s)' % (field, field)) if field != field0 else ('%s := v' % field))
                                for field, ty in fields)
    print('  Definition set_%s (st : ServerSyncBoxState) (v : %s)' % (field0, ty0))
    print('    := {| ' + body + ' |}.\n')
>> *)

    Definition set_ssbState (st : ServerSyncBoxState) (v : ServerSyncBoxPreState)
      := {| ssbState := v;
            ssbGetUpdateState := st.(ssbGetUpdateState);
            ssbCASState := st.(ssbCASState);
            ssbEncryptState := st.(ssbEncryptState);
            ssbDecryptState := st.(ssbDecryptState) |}.

    Definition set_ssbGetUpdateState (st : ServerSyncBoxState) (v : TickBoxState unit)
      := {| ssbState := st.(ssbState);
            ssbGetUpdateState := v;
            ssbCASState := st.(ssbCASState);
            ssbEncryptState := st.(ssbEncryptState);
            ssbDecryptState := st.(ssbDecryptState) |}.

    Definition set_ssbCASState (st : ServerSyncBoxState) (v : TickBoxState encryptedDataT)
      := {| ssbState := st.(ssbState);
            ssbGetUpdateState := st.(ssbGetUpdateState);
            ssbCASState := v;
            ssbEncryptState := st.(ssbEncryptState);
            ssbDecryptState := st.(ssbDecryptState) |}.

    Definition set_ssbEncryptState (st : ServerSyncBoxState) (v : EncryptBoxState)
      := {| ssbState := st.(ssbState);
            ssbGetUpdateState := st.(ssbGetUpdateState);
            ssbCASState := st.(ssbCASState);
            ssbEncryptState := v;
            ssbDecryptState := st.(ssbDecryptState) |}.

    Definition set_ssbDecryptState (st : ServerSyncBoxState) (v : DecryptBoxState)
      := {| ssbState := st.(ssbState);
            ssbGetUpdateState := st.(ssbGetUpdateState);
            ssbCASState := st.(ssbCASState);
            ssbEncryptState := st.(ssbEncryptState);
            ssbDecryptState := v |}.

    Inductive ssbConfigInput :=
    | ssbGetUpdateConfig (_ : tbConfigInput)
    | ssbCASConfig (_ : tbConfigInput)
    | ssbSetMasterKey (key : masterKeyT).

    Inductive ssbEventInput :=
    | ssbClientGetUpdate
    | ssbClientSet (newD : rawDataT)
    | ssbServerGotUpdate (newE : encryptedDataT)
    | ssbSystemRandomness (randomness : systemRandomnessT) (tag : rawDataT)
    | ssbTick (_ : N).

    Definition ssbInput := (ssbConfigInput + ssbEventInput)%type.

    Inductive ssbWarningOutput :=
    | ssbGetUpdateWarning (_ : tbWarningOutput unit)
    | ssbCASWarning (_ : tbWarningOutput encryptedDataT)
    | ssbEncryptError (_ : ebErrorOutput)
    | ssbDecryptError (_ : dbErrorOutput unit)
    | ssbWarningInvalidTransition (ev : ssbInput) (st : ServerSyncBoxState)
    | ssbWarningPushBeforePull.

    Inductive ssbEventOutput :=
    | ssbClientGotUpdate (data : rawDataT)
    | ssbServerGetUpdate
    | ssbServerCAS (curE newE : encryptedDataT)
    | ssbRequestSystemRandomness (howMuch : systemRandomnessHintT) (tag : rawDataT).

    Definition ssbOutput := (ssbWarningOutput + ssbEventOutput)%type.

    Variable initRawData : rawDataT.
    Context (world : Type)
            (handle : ssbOutput -> action world).

    Definition initState : ServerSyncBoxState :=
      {|
        ssbState := {| localStateD := initRawData;
                       remoteStateE := None |};
        ssbGetUpdateState := TrustedTickBox.initState _;
        ssbCASState := TrustedTickBox.initState _;
        ssbEncryptState := TEB.initState;
        ssbDecryptState := TDB.initState
      |}.

    Local Ltac handle_eq_false' :=
      idtac;
      match goal with
        | _ => progress subst_body
        | _ => intro
        | _ => progress simpl in *
        | _ => progress subst
        | [ H : appcontext[match ?E with _ => _ end] |- _ ] => (atomic E; destruct E)
        | [ H : Some _ = None |- _ ] => solve [ inversion H ]
        | [ H : None = Some _ |- _ ] => solve [ inversion H ]
        | [ H : inl _ = inr _ |- _ ] => solve [ inversion H ]
        | [ H : inr _ = inl _ |- _ ] => solve [ inversion H ]
        | [ H : _::_ = nil |- _ ] => solve [ inversion H ]
        | [ H : appcontext[match ?E with _ => _ end] |- _ ] => (revert H; case_eq E; intros)
        | [ H : (_, _) = (_, _) |- _ ] => inversion H; clear H
        | [ H : inl _ = inl _ |- _ ] => inversion H; clear H
        | [ H : inr _ = inr _ |- _ ] => inversion H; clear H
        | [ H : Some _ = Some _ |- _ ] => inversion H; clear H
        | [ H : _::_ = _::_ |- _ ] => inversion H; clear H
        | [ H : ?a = ?b |- _ ]
          => let a' := (eval hnf in a) in
             let b' := (eval hnf in b) in
             progress change (a' = b') in H
      end.

    Local Ltac handle_eq_false :=
      match goal with
        | [ |- _ -> False ] => idtac
      end;
      subst_body; clear; intro;
      abstract (repeat handle_eq_false').

    Definition handle_ssbGetUpdate'
               (st : ServerSyncBoxState)
    : tbOutput unit * TickBoxState unit -> list ssbOutput * ServerSyncBoxState.
    Proof.
      refine (fun i =>
                (match fst i with
                   | inl warning
                     => inl (ssbGetUpdateWarning warning)::nil
                   | inr tbRequestDataUpdate
                     => let upd := tickBoxLoopPreBody
                                     (st.(ssbGetUpdateState))
                                     (inr (tbValueReady tt)) in
                        match fst upd as u return u = fst upd -> _ with
                          | nil => fun _ => nil
                          | inl warning::nil => fun _ => inl (ssbGetUpdateWarning warning)::nil
                          | inl warning::inl warning'::nil => fun _ => inl (ssbGetUpdateWarning warning)::inl (ssbGetUpdateWarning warning')::nil
                          | _ => fun H => match (_ H) : False with end
                        end eq_refl
                   | inr (tbPublishUpdate val)
                     => inr ssbServerGetUpdate::nil
                 end,
                 set_ssbGetUpdateState st (snd i)));
      handle_eq_false.
    Defined.

    Definition fold_handler {outT stT}
               (get : ServerSyncBoxState -> stT)
               (set : ServerSyncBoxState -> stT -> ServerSyncBoxState)
               (handle : ServerSyncBoxState -> outT * stT -> list ssbOutput * ServerSyncBoxState)
               (st : ServerSyncBoxState)
    : list outT * stT -> list ssbOutput * ServerSyncBoxState
      := fun outs_st =>
           fold_left (fun ls_st out =>
                        let ls'_st' := handle (snd ls_st) (out, get (snd ls_st)) in
                        (fst ls_st ++ fst ls'_st', snd ls'_st'))
                     (fst outs_st)
                     (nil, set st (snd outs_st)).

    Definition handle_ssbGetUpdate
      := fold_handler ssbGetUpdateState set_ssbGetUpdateState handle_ssbGetUpdate'.

    Definition handle_ssbEncrypt
               (st : ServerSyncBoxState)
    : option (ebOutput unit) * EncryptBoxState -> list ssbOutput * ServerSyncBoxState.
    Proof.
      refine (fun i =>
                let st' := set_ssbEncryptState st (snd i) in
                match fst i with

                   | Some (inl warning)
                     => ((inl (ssbEncryptError warning))::nil, st')

                   | Some (inr (ebRequestSystemRandomness howMuch tag))
                     => ((inr (ssbRequestSystemRandomness howMuch (fst tag)))::nil, st')

                   | Some (inr (ebEncrypted newE _))
                     => let upd := tickBoxLoopPreBody
                                     (st'.(ssbCASState))
                                     (inr (tbValueReady newE)) in
                        (match fst upd as u return u = fst upd -> _ with
                           | nil => fun _ => nil
                           | inl warning::nil => fun _ => (inl (ssbCASWarning warning))::nil
                           | inl warning::inl warning'::nil => fun _ => inl (ssbCASWarning warning)::inl (ssbCASWarning warning')::nil
                           | _ => fun H => match (_ H) : False with end
                         end eq_refl,
                         set_ssbCASState st' (snd upd))

                   | None => (nil, st')
                 end);
      handle_eq_false.
    Defined.

    Definition handle_ssbCAS'
               (st : ServerSyncBoxState)
    : tbOutput encryptedDataT * TickBoxState encryptedDataT -> list ssbOutput * ServerSyncBoxState.
    Proof.
      refine (fun i =>
                let st' := set_ssbCASState st (snd i) in
                match fst i with
                  | inl warning
                    => (inl (ssbCASWarning warning)::nil, st')

                  | inr (tbPublishUpdate val)
                    => (match st'.(remoteStateE) with
                          | Some curE
                            => inr (ssbServerCAS curE val)
                          | None => inl ssbWarningPushBeforePull
                        end::nil,
                        st')

                  | inr tbRequestDataUpdate
                    => let encResult := encryptBoxLoopPreBody
                                          (st'.(ssbEncryptState))
                                          (ebEncrypt (st.(localStateD)) tt) in
                       handle_ssbEncrypt st' encResult
                end).
    Defined.

    Definition handle_ssbCAS
      := fold_handler ssbCASState set_ssbCASState handle_ssbCAS'.

    Definition handle_ssbDecrypt
               (st : ServerSyncBoxState)
    : option (dbOutput unit) * DecryptBoxState -> list ssbOutput * ServerSyncBoxState.
    Proof.
      refine (fun i =>
                let st' := set_ssbDecryptState st (snd i) in
                match fst i with

                  | Some (inl warning)
                    => (inl (ssbDecryptError warning)::nil, st)

                  | Some (inr (dbDecrypted dataD _))
                    => ((if d_eqb dataD st.(localStateD)
                         then nil
                         else (inr (ssbClientGotUpdate dataD))::nil),
                        set_ssbState st' {| localStateD := dataD;
                                            remoteStateE := st'.(remoteStateE) |})

                  | None => (nil, st')

                end).
    Defined.

    Definition serverSyncBoxLoopPreBody
               (st : ServerSyncBoxState)
    : ssbInput -> list ssbOutput * ServerSyncBoxState.
    Proof.
      refine (fun i =>
                match i with

                  | inl (ssbGetUpdateConfig i')
                    => handle_ssbGetUpdate
                         st
                         (tickBoxLoopPreBody
                            (st.(ssbGetUpdateState))
                            (inl i'))

                  | inl (ssbCASConfig i')
                    => handle_ssbCAS
                         st
                         (tickBoxLoopPreBody
                            (st.(ssbCASState))
                            (inl i'))

                  | inl (ssbSetMasterKey newKey)
                    => let (ls0, st0) := handle_ssbEncrypt
                                           st
                                           (encryptBoxLoopPreBody
                                              (st.(ssbEncryptState))
                                              (ebSetMasterKey _ newKey)) in
                       let (ls1, st1) := handle_ssbDecrypt
                                           st0
                                           (decryptBoxLoopPreBody
                                              (st.(ssbDecryptState))
                                              (dbSetMasterKey _ newKey)) in
                       (ls0 ++ ls1, st1)

                  | inr (ssbTick n)
                    => let (ls0, st0) := handle_ssbGetUpdate
                                           st
                                           (tickBoxLoopPreBody
                                              (st.(ssbGetUpdateState))
                                              (inr (tbTick _ n))) in
                       let (ls1, st1) := handle_ssbCAS
                                           st0
                                           (tickBoxLoopPreBody
                                              (st0.(ssbCASState))
                                              (inr (tbTick _ n))) in
                       (ls0 ++ ls1, st1)

                  | inr ssbClientGetUpdate
                    => handle_ssbGetUpdate
                         st
                         (tickBoxLoopPreBody
                            (st.(ssbGetUpdateState))
                            (inr (tbNotifyChange _)))

                  | inr (ssbClientSet newD)
                    => let st' := set_ssbState
                                    st
                                    {| localStateD := newD;
                                       remoteStateE := st.(remoteStateE) |} in
                       handle_ssbCAS
                         st'
                         (tickBoxLoopPreBody
                            (st'.(ssbCASState))
                            (inr (tbNotifyChange _)))

                  | inr (ssbServerGotUpdate dataE)
                    => let st' := set_ssbState
                                    st
                                    {| localStateD := st.(localStateD);
                                       remoteStateE := Some dataE |} in
                       handle_ssbDecrypt
                         st'
                         (decryptBoxLoopPreBody
                            (st'.(ssbDecryptState))
                            (dbDecrypt dataE tt))

                  | inr (ssbSystemRandomness randomness tag)
                    => handle_ssbEncrypt
                         st
                         (encryptBoxLoopPreBody
                            (st.(ssbEncryptState))
                            (ebSystemRandomness randomness (tag, tt)))

                end).
    Defined.

    Definition serverSyncBoxLoopBody {T}
               (serverSyncBoxLoop : ServerSyncBoxState -> T)
               (st : ServerSyncBoxState)
    : ssbInput -> action world * T
      := fun i => let outs := fst (serverSyncBoxLoopPreBody st i) in
                  (fold_left compose (map handle outs) id,
                   serverSyncBoxLoop (snd (serverSyncBoxLoopPreBody st i))).

    CoFixpoint serverSyncBoxLoop (st : ServerSyncBoxState) :=
      Step (serverSyncBoxLoopBody serverSyncBoxLoop st).

    Definition serverSyncBox : process _ _ := serverSyncBoxLoop initState.
  End trustedServerSyncBox.
End TrustedServerSyncBox.


(**************************************************
 * Author: Ana Nora Evans (ananevans@virginia.edu)
 **************************************************)
Require Import Coq.PArith.BinPos.

Require Import Common.Definitions.

Require Import Intermediate.Machine.
Require Import TargetSFI.Machine.

Definition label :Set := N*N.

(*Definition register := RiscMachine.Register.t.*)

Inductive ainstr :=
| INop : ainstr
| ILabel : label -> ainstr
(* register operations *)
| IConst : RiscMachine.value -> RiscMachine.Register.t -> ainstr
| IMov : RiscMachine.Register.t -> RiscMachine.Register.t -> ainstr
| IBinOp : RiscMachine.ISA.binop -> RiscMachine.Register.t ->
           RiscMachine.Register.t -> RiscMachine.Register.t -> ainstr
(* memory operations *)
| ILoad : RiscMachine.Register.t -> RiscMachine.Register.t -> ainstr
| IStore : RiscMachine.Register.t -> RiscMachine.Register.t -> ainstr
(* conditional and unconditional jumps *)
| IBnz : RiscMachine.Register.t -> label -> ainstr
| IJump : RiscMachine.Register.t -> ainstr
| IJal : label -> ainstr
(* termination *)
| IHalt : ainstr.

Definition code := list ainstr.

Definition lcode : Set := list ((option (list label)) * ainstr).

Definition map_register (reg : Intermediate.Machine.register) : RiscMachine.Register.t :=
  match reg with
  | Intermediate.Machine.R_ONE => RiscMachine.Register.R_ONE
  | Intermediate.Machine.R_COM => RiscMachine.Register.R_COM
  | Intermediate.Machine.R_AUX1 => RiscMachine.Register.R_AUX1
  | Intermediate.Machine.R_AUX2 => RiscMachine.Register.R_AUX2
  | Intermediate.Machine.R_RA => RiscMachine.Register.R_RA
  | Intermediate.Machine.R_SP => RiscMachine.Register.R_SP
  | Intermediate.Machine.R_ARG => RiscMachine.Register.R_ARG
  end.

Definition map_binop (op : Common.Values.binop) : RiscMachine.ISA.binop :=
  match op with
  | Add => RiscMachine.ISA.Addition
  | Minus => RiscMachine.ISA.Subtraction
  | Mul => RiscMachine.ISA.Multiplication
  | Eq => RiscMachine.ISA.Equality
  | Leq => RiscMachine.ISA.Leq
  end.

Definition label_eqb (l1 l2 : label) :=
  let '(c1,i1) := l1 in
  let '(c2,i2) := l2 in
  (N.eqb c1 c2) && (N.eqb i1 i2).

Definition label_eq_dec:
  forall l1 l2 : label,  {l1 = l2} + {l1 <> l2}.
  Proof.
    repeat decide equality. Defined.


(** a generalization of heterogeneous substitution systems to monoidal categories in place of endofunctor categories

author: Ralph Matthes 2022
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.CategoriesOfMonoids.
Require Import UniMath.CategoryTheory.Actegories.Actegories.
Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories.
Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories.
Require Import UniMath.CategoryTheory.Actegories.CoproductsInActegories.
Require Import UniMath.CategoryTheory.coslicecat.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects.

Local Open Scope cat.

Import BifunctorNotations.
Import MonoidalNotations.
(* Import ActegoryNotations. *)

Section hss.

  Context {V : category} (Mon_V : monoidal V).

  Local Definition PtdV : category := coslice_cat_total V I_{Mon_V}.
  Local Definition Mon_PtdV : monoidal PtdV := monoidal_pointed_objects Mon_V.
  Local Definition Act : actegory Mon_PtdV V := actegory_with_canonical_pointed_action Mon_V.

  Context (H : V ⟶ V).
  Context (θ : pointedtensorialstrength Mon_V H).

  Section TheProperty.

    Context (t : V) (η : I_{Mon_V} --> t) (τ : H t --> t).

  Definition gbracket_property_parts {z : V} (e : I_{Mon_V} --> z) (f : z --> t) (h : z ⊗_{Mon_V} t --> t) : UU :=
    (ru^{Mon_V}_{z} · f = z ⊗^{Mon_V}_{l} η · h) ×
      (θ (z,,e) t · #H h · τ =  z ⊗^{Mon_V}_{l} τ · h).

  Definition gbracket_parts_at {z : V} (e : I_{Mon_V} --> z) (f : z --> t) : UU :=
    ∃! h : z ⊗_{Mon_V} t --> t, gbracket_property_parts e f h.

  Definition gbracket : UU :=
    ∏ (Z : PtdV) (f : pr1 Z --> t), gbracket_parts_at (pr2 Z) f.

  Lemma isaprop_gbracket_property_parts {z : V} (e : I_{Mon_V} --> z) (f : z --> t) (h : z ⊗_{Mon_V} t --> t) :
    isaprop (gbracket_property_parts e f h).
  Proof.
    apply isapropdirprod; apply V.
  Qed.

  Lemma isaprop_gbracket : isaprop gbracket.
  Proof.
    apply impred_isaprop; intro Z.
    apply impred_isaprop; intro f.
    apply isapropiscontr.
  Qed.

  Section PropertyAsOneEquation.

    Context (CP : BinCoproducts V).

  Definition Const_plus_H (v : V) : functor V V := BinCoproduct_of_functors _ _ CP (constant_functor _ _ v) H.

  Definition gbracket_property_single {z : V} (e : I_{Mon_V} --> z) (f : z --> t) (h : z ⊗_{Mon_V} t --> t) : UU :=
    actegory_bincoprod_antidistributor Mon_PtdV CP Act (z,,e) I_{Mon_V} (H t) ·
      (z,,e) ⊗^{Act}_{l} (BinCoproductArrow (CP _ _) η τ) · h =
    BinCoproductOfArrows _ (CP _ _) (CP _ _) (ru_{Mon_V} z) (θ (z,,e) t) ·
      #(Const_plus_H z) h · BinCoproductArrow (CP _ _) f τ.

  Lemma isaprop_gbracket_property_single {z : V} (e : I_{Mon_V} --> z) (f : z --> t) (h : z ⊗_{Mon_V} t --> t) :
    isaprop (gbracket_property_single e f h).
  Proof.
    apply V.
  Qed.

  Lemma gbracket_property_single_equivalent {z : V} (e : I_{Mon_V} --> z) (f : z --> t) (h : z ⊗_{Mon_V} t --> t) :
    gbracket_property_parts e f h <-> gbracket_property_single e f h.
  Proof.
    split.
    - intros [Hη Hτ].
      use BinCoproductArrowsEq.
      + etrans.
        { repeat rewrite assoc.
          do 2 apply cancel_postcomposition.
          apply BinCoproductIn1Commutes. }
        etrans.
        { apply cancel_postcomposition.
          apply pathsinv0, (functor_comp (leftwhiskering_functor Act (z,,e))). }
        rewrite BinCoproductIn1Commutes.
        etrans.
        2: { repeat rewrite assoc.
             do 2 apply cancel_postcomposition.
             apply pathsinv0, BinCoproductOfArrowsIn1. }
        etrans.
        { apply pathsinv0, Hη. }
        repeat rewrite assoc'.
        apply maponpaths.
        rewrite assoc.
        etrans.
        2: { apply cancel_postcomposition.
             apply pathsinv0, BinCoproductOfArrowsIn1. }
        rewrite assoc'.
        rewrite id_left.
        apply pathsinv0, BinCoproductIn1Commutes.
      + etrans.
        { repeat rewrite assoc.
          do 2 apply cancel_postcomposition.
          apply BinCoproductIn2Commutes. }
        etrans.
        { apply cancel_postcomposition.
          apply pathsinv0, (functor_comp (leftwhiskering_functor Act (z,,e))). }
        rewrite BinCoproductIn2Commutes.
        etrans.
        2: { repeat rewrite assoc.
             do 2 apply cancel_postcomposition.
             apply pathsinv0, BinCoproductOfArrowsIn2. }
        etrans.
        { apply pathsinv0, Hτ. }
        repeat rewrite assoc'.
        apply maponpaths.
        rewrite assoc.
        etrans.
        2: { apply cancel_postcomposition.
             apply pathsinv0, BinCoproductOfArrowsIn2. }
        rewrite assoc'.
        apply maponpaths.
        apply pathsinv0, BinCoproductIn2Commutes.
    - intro H1.
      split.
      + apply (maponpaths (fun m => BinCoproductIn1 (CP _ _) · m)) in H1.
        unfold actegory_bincoprod_antidistributor, bifunctor_bincoprod_antidistributor, bincoprod_antidistributor in H1.
        repeat rewrite assoc in H1.
        rewrite BinCoproductIn1Commutes in H1.
        assert (aux := functor_comp (leftwhiskering_functor Act (z,,e))
                         (BinCoproductIn1 (CP I_{ Mon_V} (H t)))
                         (BinCoproductArrow (CP I_{ Mon_V} (H t)) η τ)).
        cbn in aux.
        apply (maponpaths (fun m => m · h)) in aux.
        assert (H1' := aux @ H1).
        clear H1 aux.
        rewrite BinCoproductIn1Commutes in H1'.
        etrans.
        2: { apply pathsinv0, H1'. }
        clear H1'.
        etrans.
        2: { repeat rewrite assoc.
             do 2 apply cancel_postcomposition.
             apply pathsinv0, BinCoproductOfArrowsIn1. }
        repeat rewrite assoc'.
        apply maponpaths.
        rewrite assoc.
        etrans.
        2: { apply cancel_postcomposition.
             apply pathsinv0, BinCoproductOfArrowsIn1. }
        rewrite assoc'.
        rewrite id_left.
        apply pathsinv0, BinCoproductIn1Commutes.
      + apply (maponpaths (fun m => BinCoproductIn2 (CP _ _) · m)) in H1.
        unfold actegory_bincoprod_antidistributor, bifunctor_bincoprod_antidistributor, bincoprod_antidistributor in H1.
        repeat rewrite assoc in H1.
        rewrite BinCoproductIn2Commutes in H1.
        assert (aux := functor_comp (leftwhiskering_functor Act (z,,e))
                         (BinCoproductIn2 (CP I_{ Mon_V} (H t)))
                         (BinCoproductArrow (CP I_{ Mon_V} (H t)) η τ)).
        cbn in aux.
        apply (maponpaths (fun m => m · h)) in aux.
        assert (H1' := aux @ H1).
        clear H1 aux.
        rewrite BinCoproductIn2Commutes in H1'.
        etrans.
        2: { apply pathsinv0, H1'. }
        clear H1'.
        etrans.
        2: { repeat rewrite assoc.
             do 2 apply cancel_postcomposition.
             apply pathsinv0, BinCoproductOfArrowsIn2. }
        repeat rewrite assoc'.
        apply maponpaths.
        rewrite assoc.
        etrans.
        2: { apply cancel_postcomposition.
             apply pathsinv0, BinCoproductOfArrowsIn2. }
        rewrite assoc'.
        apply maponpaths.
        apply pathsinv0, BinCoproductIn2Commutes.
  Qed.

  End PropertyAsOneEquation.

  End TheProperty.

  Definition ghss : UU := ∑ (t : V) (η : I_{Mon_V} --> t) (τ : H t --> t), gbracket t η τ.
  Coercion carrierghss (t : ghss) : V := pr1 t.

  Section FixAGhss.

  Context (gh : ghss).

  Definition eta_from_alg : I_{Mon_V} --> gh := pr12 gh.
  Definition tau_from_alg : H gh --> gh := pr122 gh.

  Definition ptd_from_gh : PtdV := (pr1 gh,,eta_from_alg).

  Local Notation η := eta_from_alg.
  Local Notation τ := tau_from_alg.

  Definition gfbracket (Z : PtdV) (f : pr1 Z --> gh) : pr1 Z ⊗_{Mon_V} gh --> gh :=
    pr1 (pr1 (pr222 gh Z f)).

  Notation "⦃ f ⦄_{ Z }" := (gfbracket Z f)(at level 0).

  Lemma gfbracket_unique {Z : PtdV} (f : pr1 Z --> gh)
    : ∏ α : pr1 Z ⊗_{Mon_V} gh --> gh, gbracket_property_parts gh η τ (pr2 Z) f α
   → α = ⦃f⦄_{Z}.
  Proof.
    intros α Hyp.
    apply path_to_ctr.
    assumption.
  Qed.

  Lemma gfbracket_η {Z : PtdV} (f : pr1 Z --> gh) :
    ru^{Mon_V}_{pr1 Z} · f = pr1 Z ⊗^{Mon_V}_{l} η · ⦃f⦄_{Z}.
  Proof.
    exact (pr1 ((pr2 (pr1 (pr222 gh Z f))))).
  Qed.

  Lemma gfbracket_τ {Z : PtdV} (f : pr1 Z --> gh) :
    θ Z gh · #H ⦃f⦄_{Z} · τ =  pr1 Z ⊗^{Mon_V}_{l} τ · ⦃f⦄_{Z}.
  Proof.
    exact (pr2 ((pr2 (pr1 (pr222 gh Z f))))).
  Qed.

  (** there is a restricted form of naturality in the [f] argument, only for pointed [f] *)
  Lemma gfbracket_natural {Z Z' : PtdV} (f : Z --> Z') (g : pr1 Z' --> gh) :
    pr1 f ⊗^{ Mon_V}_{r} gh · ⦃g⦄_{Z'} = ⦃pr1 f · g⦄_{Z}.
  Proof.
    apply gfbracket_unique.
    split.
    - etrans.
      2: { rewrite assoc.
           apply cancel_postcomposition.
           apply (bifunctor_equalwhiskers Mon_V). }
      unfold functoronmorphisms1.
      etrans.
      2: { rewrite assoc'.
           apply maponpaths.
           apply gfbracket_η. }
      repeat rewrite assoc.
      apply cancel_postcomposition.
      apply pathsinv0, monoidal_rightunitornat.
    - etrans.
      2: { rewrite assoc.
           apply cancel_postcomposition.
           apply (bifunctor_equalwhiskers Mon_V). }
      unfold functoronmorphisms1.
      etrans.
      2: { rewrite assoc'.
           apply maponpaths.
           apply gfbracket_τ. }
      rewrite functor_comp.
      repeat rewrite assoc.
      do 2 apply cancel_postcomposition.
      apply pathsinv0, (lineator_linnatright Mon_PtdV Act Act).
  Qed.

  (** As a consequence of naturality, we can compute [gfbracket f] from [gfbracket identity] for
      pointed morphisms [f] *)
  Lemma compute_gfbracket {Z : PtdV} (f : Z --> ptd_from_gh) :
    ⦃pr1 f⦄_{Z} = pr1 f ⊗^{ Mon_V}_{r} gh · ⦃identity gh⦄_{ptd_from_gh}.
  Proof.
    etrans.
    { rewrite <- (id_right (pr1 f)).
      apply pathsinv0, gfbracket_natural. }
    apply idpath.
  Qed.

  (** we are constructing a monoid in the monoidal base category *)

  Definition Ptd_from_ghss : PtdV := (pr1 gh,,η).

  Definition mu_from_ghss : gh ⊗_{Mon_V} gh --> gh := ⦃identity gh⦄_{Ptd_from_ghss}.

  Local Notation μ := mu_from_ghss.

  Definition μ_0 : I_{Mon_V} --> gh := η.

  Definition μ_0_Ptd : I_{Mon_PtdV} --> Ptd_from_ghss.
  Proof.
    exists μ_0.
    cbn. apply id_left.
  Defined.

  Definition μ_1 : I_{Mon_V} ⊗_{Mon_V} gh --> gh := ⦃μ_0⦄_{I_{Mon_PtdV}}.

  Lemma μ_1_is_instance_of_left_unitor : μ_1 = lu^{Mon_V}_{gh}.
  Proof.
    apply pathsinv0, (gfbracket_unique(Z:=I_{Mon_PtdV})).
    split.
    - cbn. unfold μ_0.
      rewrite monoidal_leftunitornat.
      apply cancel_postcomposition.
      apply pathsinv0, unitors_coincide_on_unit.
    - etrans.
      { apply cancel_postcomposition.
        apply pointedtensorialstrength_preserves_unitor.
        apply lineator_preservesunitor. }
      cbn.
      apply pathsinv0, monoidal_leftunitornat.
  Qed.

  Definition ghss_monoid_data : monoid_data Mon_V gh := μ,,μ_0.

  Lemma ghss_first_monoidlaw : monoid_laws_unit_right Mon_V ghss_monoid_data.
  Proof.
    red. cbn.
    etrans.
    { apply pathsinv0, (gfbracket_η(Z:=Ptd_from_ghss)). }
    apply id_right.
  Qed.

  Lemma ghss_second_monoidlaw_aux :
    ru^{Mon_V}_{I_{Mon_V}} · η = I_{Mon_V} ⊗^{Mon_V}_{l} η · (η ⊗^{Mon_V}_{r} gh · μ).
  Proof.
    rewrite assoc.
    etrans.
    2: { apply cancel_postcomposition.
         apply (bifunctor_equalwhiskers Mon_V). }
    unfold functoronmorphisms1.
    rewrite assoc'.
    etrans.
    2: { apply maponpaths.
         apply pathsinv0, ghss_first_monoidlaw. }
    apply pathsinv0, monoidal_rightunitornat.
  Qed.

  Lemma ghss_second_monoidlaw : monoid_laws_unit_left Mon_V ghss_monoid_data.
  Proof.
    red. cbn.
    etrans.
    2: { apply μ_1_is_instance_of_left_unitor. }
    apply (gfbracket_unique(Z:=I_{Mon_PtdV})).
    split.
    - exact ghss_second_monoidlaw_aux.
    - rewrite functor_comp.
      transitivity (μ_0 ⊗^{ Mon_V}_{r} H (pr1 gh) · θ Ptd_from_ghss (pr1 gh) · # H μ · τ). (* give this term due to efficiency problems *)
      { apply cancel_postcomposition.
        rewrite assoc.
        apply cancel_postcomposition.
        apply pathsinv0.
        set (aux := lineator_linnatright Mon_PtdV
                      (actegory_with_canonical_pointed_action Mon_V)
                      (actegory_with_canonical_pointed_action Mon_V)
                      H θ I_{ Mon_PtdV} Ptd_from_ghss (pr1 gh) μ_0_Ptd).
        cbn in aux.
        etrans.
        { exact aux. }
        apply idpath.
      }
      etrans.
      { do 2 rewrite assoc'.
        apply maponpaths.
        rewrite assoc.
        apply (gfbracket_τ(Z:=Ptd_from_ghss)).
      }
      repeat rewrite assoc.
      apply cancel_postcomposition.
      cbn.
      apply (bifunctor_equalwhiskers Mon_V).
  Qed.

  Definition gh_squared : PtdV := Ptd_from_ghss ⊗_{Mon_PtdV} Ptd_from_ghss.

  Definition μ_2 : gh ⊗_{Mon_V} gh --> gh := μ.

  Lemma μ_2_is_Ptd_mor : luinv^{Mon_V}_{I_{Mon_V}} · η ⊗^{Mon_V} η · μ_2 = η.
  Proof.
    rewrite assoc'.
    apply (z_iso_inv_on_right _ _ _ (nat_z_iso_pointwise_z_iso (leftunitor_nat_z_iso Mon_V) I_{ Mon_V})).
    cbn.
    rewrite unitors_coincide_on_unit.
    etrans.
    2: { apply pathsinv0, ghss_second_monoidlaw_aux. }
    rewrite assoc.
    apply cancel_postcomposition.
    apply (bifunctor_equalwhiskers Mon_V).
  Qed.

  Definition μ_2_Ptd : gh_squared --> Ptd_from_ghss := μ_2,,μ_2_is_Ptd_mor.

  Definition μ_3 : (gh ⊗_{Mon_V} gh) ⊗_{Mon_V} gh --> gh := ⦃μ_2⦄_{gh_squared}.

  Lemma ghss_third_monoidlaw_aux : θ (pr1 gh_squared,, pr2 gh_squared) gh · # H (μ ⊗^{Mon_V}_{r} gh) =
                                     μ_2 ⊗^{Mon_V}_{r} H gh · θ Ptd_from_ghss gh.
  Proof.
    apply pathsinv0.
    assert (aux := lineator_linnatright Mon_PtdV
                     (actegory_with_canonical_pointed_action Mon_V)
                     (actegory_with_canonical_pointed_action Mon_V)
                     H θ gh_squared Ptd_from_ghss gh μ_2_Ptd).
    simpl in aux. (* simpl not cbn for efficiency of Qed *)
    etrans.
    { exact aux. }
    apply idpath.
  Qed.

  Lemma ghss_third_monoidlaw : monoid_laws_assoc Mon_V ghss_monoid_data.
  Proof.
    red. cbn. apply pathsinv0.
    transitivity μ_3.
    - (** this case is the monoidal generalization of the second item on p.168 of Matthes & Uustalu, TCS 2004 *)
      apply (gfbracket_unique(Z:=gh_squared)).
      split.
      + cbn.
        etrans.
        2: { rewrite assoc.
             apply cancel_postcomposition.
             apply (bifunctor_equalwhiskers Mon_V). }
        unfold functoronmorphisms1.
        etrans.
        2: { rewrite assoc'.
             apply maponpaths.
             apply pathsinv0, ghss_first_monoidlaw.
        }
        apply pathsinv0, monoidal_rightunitornat.
      + etrans.
        { apply cancel_postcomposition.
          rewrite functor_comp.
          rewrite assoc.
          apply cancel_postcomposition.
          exact ghss_third_monoidlaw_aux.
        }
        etrans.
        { do 2 rewrite assoc'.
          apply maponpaths.
          rewrite assoc.
          apply (gfbracket_τ(Z:=Ptd_from_ghss)).
        }
        do 2 rewrite assoc.
        apply cancel_postcomposition.
        cbn.
        apply (bifunctor_equalwhiskers Mon_V).
    - (** this case is the monoidal generalization of the first item on p.168 of Matthes & Uustalu, TCS 2004 *)
      apply pathsinv0, (gfbracket_unique(Z:=gh_squared)).
      split.
      + cbn.
        etrans.
        2: { rewrite assoc.
             apply cancel_postcomposition.
             rewrite assoc.
             rewrite <- monoidal_associatornatleft.
             rewrite assoc'.
             apply maponpaths.
             apply (bifunctor_leftcomp Mon_V). }
        etrans.
        2: { apply cancel_postcomposition.
             do 2 apply maponpaths.
             apply pathsinv0, ghss_first_monoidlaw. }
        apply cancel_postcomposition.
        apply pathsinv0, left_whisker_with_runitor.
      + etrans.
        { apply cancel_postcomposition.
          rewrite assoc'.
          rewrite functor_comp.
          rewrite assoc.
          apply cancel_postcomposition.
          apply pointedtensorialstrength_preserves_actor.
          apply lineator_preservesactor. }
        cbn.
        etrans.
        { repeat rewrite assoc'.
          do 2 apply maponpaths.
          etrans.
          { rewrite assoc.
            apply cancel_postcomposition.
            rewrite functor_comp.
            rewrite assoc.
            apply cancel_postcomposition.
            apply pathsinv0, (lineator_linnatleft Mon_PtdV _ _ H θ Ptd_from_ghss _ _ μ).
          }
          repeat rewrite assoc'.
          apply maponpaths.
          rewrite assoc.
          apply (gfbracket_τ(Z:=Ptd_from_ghss)).
        }
        cbn.
        repeat rewrite assoc.
        apply cancel_postcomposition.
        etrans.
        { repeat rewrite assoc'.
          apply maponpaths.
          do 2 rewrite <- (bifunctor_leftcomp Mon_V).
          apply maponpaths.
          rewrite assoc.
          apply (gfbracket_τ(Z:=Ptd_from_ghss)).
        }
        cbn.
        rewrite (bifunctor_leftcomp Mon_V).
        repeat rewrite assoc.
        apply cancel_postcomposition.
        apply monoidal_associatornatleft.
  Qed.

  Definition ghss_monoid : monoid Mon_V gh.
  Proof.
    exists ghss_monoid_data.
    exact (ghss_second_monoidlaw,,ghss_first_monoidlaw,,ghss_third_monoidlaw).
  Defined.

  End FixAGhss.

End hss.


From iris.algebra Require Import proofmode_classes.
From iris.proofmode Require Import classes.
From iris.base_logic Require Export derived.
From iris.prelude Require Import options.

Import base_logic.bi.uPred.

(* Setup of the proof mode *)
Section class_instances.
Context {M : ucmra}.
Implicit Types P Q R : uPred M.

Global Instance into_pure_cmra_valid `{!CmraDiscrete A} (a : A) :
  @IntoPure (uPredI M) (✓ a) (✓ a).
Proof. by rewrite /IntoPure discrete_valid. Qed.

Global Instance from_pure_cmra_valid {A : cmra} (a : A) :
  @FromPure (uPredI M) false (✓ a) (✓ a).
Proof.
  rewrite /FromPure /=. eapply bi.pure_elim=> // ?.
  rewrite -uPred.cmra_valid_intro //.
Qed.

Global Instance from_sep_ownM (a b1 b2 : M) :
  IsOp a b1 b2 →
  FromSep (uPred_ownM a) (uPred_ownM b1) (uPred_ownM b2).
Proof. intros. by rewrite /FromSep -ownM_op -is_op. Qed.
Global Instance from_sep_ownM_core_id (a b1 b2 : M) :
  IsOp a b1 b2 → TCOr (CoreId b1) (CoreId b2) →
  FromAnd (uPred_ownM a) (uPred_ownM b1) (uPred_ownM b2).
Proof.
  intros ? H. rewrite /FromAnd (is_op a) ownM_op.
  destruct H; by rewrite bi.persistent_and_sep.
Qed.

Global Instance into_and_ownM p (a b1 b2 : M) :
  IsOp a b1 b2 → IntoAnd p (uPred_ownM a) (uPred_ownM b1) (uPred_ownM b2).
Proof.
  intros. apply bi.intuitionistically_if_mono. by rewrite (is_op a) ownM_op bi.sep_and.
Qed.

Global Instance into_sep_ownM (a b1 b2 : M) :
  IsOp a b1 b2 → IntoSep (uPred_ownM a) (uPred_ownM b1) (uPred_ownM b2).
Proof. intros. by rewrite /IntoSep (is_op a) ownM_op. Qed.
End class_instances.


(* -*- company-coq-local-symbols: (("|=" . ?⊨) ("=|" . ?⫤) ("->>" . ?↠) ("=~" . ?≈) ("<|" . ?⟨) ("|>" . ?⟩) ); -*- *)
Set Warnings "-notation-overridden".

Require Import Prelude.Prelude.
Require Import Defs.Defs.
Require Import Wf.Wf.

Lemma subst_exvar_Sch_close_Sch_wrt_Ty : forall sch ty__in exA skA,
    skA \notin free_skvars_Ty ty__in
  -> lc_Ty ty__in
  -> subst_exvar_Sch ty__in exA (close_Sch_wrt_Ty skA sch) = close_Sch_wrt_Ty skA (subst_exvar_Sch ty__in exA sch).
Proof.
  introv NIT LC. unfold close_Sch_wrt_Ty. generalize 0. Sch_Ty_ind sch; intros.
  - simpl. ifdec; reflexivity.
  - unfold close_Sch_wrt_Ty. crush. ifdec; crush.
  - crush. if_taut. unfold close_Sch_wrt_Ty. simpl. rewrite close_Ty_wrt_Ty_rec_involuntive; crush. crush.
  - crush.
  - forwards: IHTy1 n. forwards: IHTy2 n.
    unfold close_Sch_wrt_Ty in *. rewr*. crush.
  - unfold close_Sch_wrt_Ty. simpl. rewrite IHsch. reflexivity.
Qed.

(*** Overrides*)
Theorem DSub_app_close_Sch_wrt_Ty : forall (dsub : DSub) (skA : skvar) (sch : Sch),
    skA \notin DSub_codom_dskvars dsub
  -> DSub_lc dsub
  -> DSub_app (close_Sch_wrt_Ty skA sch) dsub = close_Sch_wrt_Ty skA (DSub_app sch dsub).
Proof.
  introv NID LC. DSub_ind dsub. crush. subdist.
  rewrite IHdsub0. rewrite subst_exvar_Sch_close_Sch_wrt_Ty. crush.
  rewrite free_skvars_Ty_DSub_codom_dskvars. eauto. rewr. fsetdec. rewrite emb_Ty_lc. apply LC. rewr. fsetdec.
  rewr in NID. fsetdec. eauto.
Qed.

Lemma Gen_complete__helper : forall dty__exA exA skA sch dsub,
    skA \notin free_skvars_Sch sch
  -> skA \notin DSub_codom_dskvars dsub
  -> DSub_unique ([(exA, dty__exA)] ++ dsub)
  -> subst_skvar_Sch (emb_Ty dty__exA) skA (DSub_app (subst_exvar_Sch (T_SkVar_f skA) exA sch) dsub) = DSub_app sch ([(exA, dty__exA)] ++ dsub).
Proof.
  introv NIT NIS UNI. Sch_Ty_ind sch; rewr.
  - crush.
  - crush. if_taut.
  - destruct (exA0 == exA).
    + subst. simpl. if_taut. rewr. simpl. if_taut.
      do_DSub_exA_decide dsub exA.
      * rewrite INV. rewr. reflexivity.
      * assert (dty = dty__exA). unfold DSub_unique in UNI. applys UNI exA. crush. crush.
        subst. rewrite EMB. rewr. reflexivity.
    + simpl. if_taut. rewr.
      do_DSub_exA_decide dsub exA0.
      * rewrite INV. simpl. if_taut.
      * rewrite EMB. rewr.
        rewrite subst_skvar_Ty_not_in_Ty_idempotent. reflexivity. eauto.
        rewrite free_skvars_Ty_DSub_codom_dskvars. eauto. eauto.
  - crush.
  - crush.
  - simpl. rewrite IHsch. reflexivity. crush.
Qed.

Theorem Gen_complete : forall ty dty dsub dsub__a denv dsch,
    DSub_app_t ty (dsub__a ++ dsub) = emb_Ty dty
  -> DSub_app (generalize_Sch (S_Mono ty) (DSub_to_A dsub__a) empty) dsub = emb_Sch dsch
  -> DSub_WfDTy denv (dsub__a ++ dsub)
  -> DSub_unique (dsub__a ++ dsub)
  -> SubSump denv dsch (DS_Mono dty).
Proof.
  introv EMB1 EMB2 WF UNI. gen dsub dsch denv. induction dsub__a as [|[exA dty__exA] dsub__a]; intros.
  - simpl in EMB2. rewr*. emb_auto''. rewrite EMB in EMB1. apply emb_Ty_inj in EMB1. crush.
  - rewrite (generalize_Sch_l_irrelevance (DSub_codom_dskvars dsub)) in EMB2.
    simpl in EMB2.
    remember (proj1_sig (atom_fresh (union (free_skvars_Sch (generalize_Sch (S_Mono ty) (DSub_to_A dsub__a) (DSub_codom_dskvars dsub))) (DSub_codom_dskvars dsub)))) as skA.
    emb_auto''.
    remember (proj1_sig (atom_fresh (union (free_skvars_Sch (generalize_Sch (S_Mono ty) (DSub_to_A dsub__a) (DSub_codom_dskvars dsub))) (DSub_codom_dskvars dsub)))) as skA.
    eapply (SubSumpInst (free_dskvars_DSch dsch0) _ _ _ dty__exA). apply WF. rewr. fsetdec. intros.
    rewrite <- subst_dskvar_DSch_intro. applys IHdsub__a ([(exA, dty__exA)] ++ dsub).
    rewrite app_assoc. rewrite DSub_app_t_app_distr. rewrite DSub_app_t_app_symm.
    subdist. subdist in EMB1. assumption. norm in UNI. eauto using DSub_unique_app_symm.
    eapply DSub_unique_rewr. eassumption. rewr_dsrel. fsetdec'.
    rewrite (generalize_Sch_l_irrelevance (DSub_codom_dskvars dsub)).
    remember (generalize_Sch (S_Mono ty) (DSub_to_A dsub__a) (DSub_codom_dskvars dsub)) as dsch__gen.
    rewrite embed_Sch_open_comm. rewrite <- EMB. rewrite DSub_app_close_Sch_wrt_Ty. rewrite <- subst_skvar_Sch_spec.
    rewrite Gen_complete__helper. reflexivity.
    1,2,4: subst; fresh_assert; fsetdec. eapply DSub_unique_rewr. eassumption. rewr_dsrel. fsetdec'. eauto.
    eapply DSub_WfDTy_rewr. eassumption. auto. rewr_dsrel. fsetdec'. assumption.
Qed.

Theorem subst_dskvar_DSch_generalize_DSch : forall dskA da dty sch,
     dskA \notin varl da
  -> varl da [><] free_dskvars_DTy dty
  -> lc_DTy dty
  -> subst_dskvar_DSch dty dskA (generalize_DSch sch da)
  = generalize_DSch (subst_dskvar_DSch dty dskA sch) da.
Proof.
  introv NID DISJ LC. da_ind da.
  - crush.
  - simpl. forwards: IHda.
    rewr in NID. fsetdec. rewr in DISJ. eapply disj_subset_proper; rewr. 3:eassumption. fsetdec. crush.
    rewrite <- H.
    rewrite subst_dskvar_DSch_close_DSch_wrt_DTy. reflexivity. assumption.
    destruct (dskA == dskA0). 2:assumption. subst. false. apply NID. rewr. fsetdec.
    eapply in_disjoint_impl_notin2.  eassumption. rewr. fsetdec.
Qed.

Definition subst_dskvar_DSub (dskA dskB : dskvar) : DSub -> DSub := map (fun pair => (fst pair, subst_dskvar_DTy (DT_SkVar_f dskA) dskB (snd pair))).

Theorem subst_dskvar_DSub_to_A : forall dsub dskA dskB,
    DSub_to_A (subst_dskvar_DSub dskB dskA dsub) = DSub_to_A dsub.
Proof. intros. induction dsub; crush. Qed.

Theorem subst_dskvar_DSub_app : forall dskA dskB dsub1 dsub2,
    subst_dskvar_DSub dskA dskB (dsub1 ++ dsub2)
  = subst_dskvar_DSub dskA dskB dsub1 ++ subst_dskvar_DSub dskA dskB dsub2.
Proof. induction dsub1; crush. Qed.
#[local] Hint Rewrite subst_dskvar_DSub_app : core.

Lemma DSub_app_t_exA_subst_dskvar_DSub : forall exA dskA dskB dsub dty,
    DSub_app_t (T_ExVar exA) dsub = emb_Ty dty
  -> DSub_app_t (T_ExVar exA) (subst_dskvar_DSub dskA dskB dsub) = emb_Ty (subst_dskvar_DTy (DT_SkVar_f dskA) dskB dty).
Proof.
  introv EMB. rev_DSub_ind dsub.
  - rewr in EMB. emb_auto''. contradiction.
  - rewr. simpl. rewr. subdist. simpl.
    ifdec.
    + subst. rewr. subdist in EMB. apply emb_Ty_inj in EMB. crush.
    + apply IHdsub0. rewr in EMB. subdist in EMB. simpl in EMB.
      if_taut.
Qed.

Lemma DGen_complete__helper : forall dsub__a ty dsub dty dskB dskA,
    DSub_app_t ty (dsub__a ++ dsub) = emb_Ty dty
  -> dskB \notin DSub_codom_dskvars dsub
  -> dskB \notin free_skvars_Ty ty
  -> DSub_app_t ty ((subst_dskvar_DSub dskA dskB dsub__a) ++ dsub)
  = emb_Ty (subst_dskvar_DTy (DT_SkVar_f dskA) dskB dty).
Proof.
  introv EMB NID NIT. gen dty. induction ty; intros; emb_auto''.
  - subdist. simpl. reflexivity.
  - subdist. simpl. ifdec. false. apply NIT. rewr. fsetdec. crush.
  - do_DSub_exA_decide dsub exA.
    + subdist*. rewrite INV in *.
      do_DSub_exA_decide dsub__a exA.
      * rewrite INV0 in EMB. emb_auto''. contradiction.
      * eauto using DSub_app_t_exA_subst_dskvar_DSub.
    + subdist. rewrite EMB0. rewr. subdist in EMB. rewrite EMB0 in EMB. rewr in EMB. apply emb_Ty_inj in EMB. subst.
      rewrite subst_dskvar_DTy_not_in_DTy_idempotent. reflexivity.
      rewrite <- free_skvars_Ty_embed_Ty.
      rewrite free_skvars_Ty_DSub_codom_dskvars. 2:eauto. eassumption.
  - crush.
  - subdist.
    forwards IH1: IHty1. rewr in NIT. fsetdec. eassumption. subdist in IH1. rewrite IH1.
    forwards IH2: IHty2. rewr in NIT. fsetdec. eassumption. subdist in IH2. rewrite IH2.
    simpl. reflexivity.
Qed.

Theorem subst_dskvar_DSub_lookup : forall exA dty dsub dskA dskB,
    DTyPSI.In (exA, dty) (DSub_bindings (subst_dskvar_DSub dskB dskA dsub))
  -> exists dty', subst_dskvar_DTy (DT_SkVar_f dskB) dskA dty' = dty /\ DTyPSI.In (exA, dty') (DSub_bindings dsub).
Proof.
  intros. DSub_ind dsub.
  - crush.
  - simpl in H. rewr in H. indestr.
    + rewr in H. destr. exists. crush.
    + forwards: IHdsub0. eassumption. destr. exists. crush.
Qed.

Theorem DSub_unique_subst_dskvar_DSub : forall dsub dskA dskB,
    DSub_unique dsub
  -> DSub_unique (subst_dskvar_DSub dskB dskA dsub).
Proof.
  introv UNI. unfold DSub_unique. intros.
  apply subst_dskvar_DSub_lookup in H. apply subst_dskvar_DSub_lookup in H0. destr.
  forwards: UNI. apply H1. apply H2. crush.
Qed.

Theorem DSub_WfDTy_subst : forall denv1 denv2 dsub dskA dskB,
    DSub_WfDTy denv1 dsub
  -> Metatheory.remove dskA (DEnv_dskvars denv1) \u singleton dskB [<=] DEnv_dskvars denv2
  -> DSub_WfDTy denv2 (subst_dskvar_DSub dskB dskA dsub).
Proof.
  introv WF SUB. induction dsub.
  - crush.
  - unfold DSub_WfDTy. intros. rewr in H. indestr.
    + destruct a as [exA dty']. rewr in H. subst.
      assert (denv1 |=dty DS_Mono dty'). apply WF. rewr. fsetdec.
      apply WfDTy_props in H. apply WfDTy_props. split. 2:crush.
      simpl. rewrite free_dskvars_DTy_subst_dskvar_DTy_upper. rewrite <- SUB.
      destr. simpl in H. rewrite H. simpl. fsetdec.
    + apply IHdsub. eauto. assumption.
Qed.

Theorem subst_dskvar_DSub_notincodom_involuntive : forall dskA dskB dsub,
    dskA \notin DSub_codom_dskvars dsub
  -> subst_dskvar_DSub dskB dskA dsub = dsub.
Proof.
  intros. DSub_ind dsub. crush.
  simpl.
  asserts_rewrite (subst_dskvar_DTy (DT_SkVar_f dskB) dskA dty = dty).
    assert (dskA \notin free_dskvars_DTy dty).
    rewrite <- free_skvars_Ty_embed_Ty. rewrite free_skvars_Ty_DSub_codom_dskvars. eassumption.
    rewr. fsetdec'. crush.
  rewrite IHdsub0. reflexivity. rewr in H. fsetdec.
Qed.

Theorem DGen_complete : forall da ty dty dsub dsub__a denv dsch,
    DSub_app_t ty (dsub__a ++ dsub) = emb_Ty dty
  -> DSub_app (generalize_Sch (S_Mono ty) (DSub_to_A dsub__a) empty) dsub = emb_Sch dsch
  -> DSub_WfDTy  denv          dsub
  -> DSub_WfDTy (denv :::a da) dsub__a
  -> DSub_unique (dsub__a ++ dsub)
  -> varl da [><] DSub_codom_dskvars dsub
  -> varl da [><] free_skvars_Ty ty
  -> NoDup' da
  -> SubSump denv dsch (generalize_DSch (DS_Mono dty) da).
Proof.
  introv EMB1 EMB2 WF1 WF2 UNI DISJ1 DISJ2 ND. gen dsub__a dty dsch denv. da_ind da; intros.
  - simpl in WF2.
    assert (DSub_WfDTy denv (dsub__a ++ dsub)). apply DSub_WfDTy_app; assumption.
    eapply Gen_complete; eassumption.
  - intros. simpl. eapply (SubSumpSkol (varl da)). intros dskB NI__dskB. rewrite <- subst_dskvar_DSch_spec.
    rewrite subst_dskvar_DSch_generalize_DSch. simpl. applys IHda (subst_dskvar_DSub dskB dskA dsub__a).
    + eapply disj_subset_proper. 3:apply DISJ1. rewr. crush. crush.
    + eapply disj_subset_proper. 3:apply DISJ2. rewr. crush. crush.
    + inverts ND. eassumption.
    + forwards: subst_dskvar_DSub_notincodom_involuntive dskA dskB dsub.
      eapply in_disjoint_impl_notin2. eassumption. rewr. fsetdec.
      rewrite <- H. rewrite <- subst_dskvar_DSub_app. auto using DSub_unique_subst_dskvar_DSub.
    + apply DGen_complete__helper. eassumption.
      eapply in_disjoint_impl_notin2. eassumption. rewr. crush.
      eapply in_disjoint_impl_notin2. eassumption. rewr. crush.
    + rewrite subst_dskvar_DSub_to_A in *. eassumption.
    + eauto.
    + eapply DSub_WfDTy_subst. eassumption. rewr_derel. fsetdec.
    + inverts ND. eassumption.
    + unfold AtomSetImpl.disjoint. simpl. fsetdec.
    + auto.
Qed.

Theorem free_dskvars_DSch_generalize_DSch : forall dsch da,
    free_dskvars_DSch (generalize_DSch dsch da) [<=] free_dskvars_DSch dsch.
Proof.
  intros. induction da. crush.
  simpl. simpl. rewrite free_dskvars_DSch_close_DSch_wrt_DTy. rewrite IHda. crush.
Qed.

Theorem SubSump_DEnv_sub : forall denv1 denv2 sch1 sch2,
    SubSump denv1 sch1 sch2
  -> denv1 [<=]de denv2
  -> SubSump denv2 sch1 sch2.
Proof.
  introv SS SUB. gen denv2. induction SS; intros.
  - auto.
  - econstructor. intros. apply H. eassumption. crush.
  - econstructor. intros. eapply WfDTy_DEnv_sub. 1,2:eassumption.
    eauto.
Qed.
#[export] Hint Resolve SubSump_DEnv_sub : core.

Theorem DGen_complete' : forall da ty dty dsub dsub__a denv dsch da__disj,
    DSub_app_t ty (dsub__a ++ dsub) = emb_Ty dty
  -> DSub_app (generalize_Sch (S_Mono ty) (DSub_to_A dsub__a) empty) dsub = emb_Sch dsch
  -> DSub_WfDTy denv dsub
  -> DSub_WfDTy (denv :::a da) dsub__a
  -> DSub_unique (dsub__a ++ dsub)
  -> varl da     [><] DSub_codom_dskvars dsub
  -> varl da     [><] free_skvars_Ty ty
  -> varl da__disj [><] free_dskvars_DTy dty
  -> NoDup' da
  -> SubSump denv dsch (generalize_DSch (generalize_DSch (DS_Mono dty) da) da__disj).
Proof.
  intros. induction da__disj.
  - simpl. eapply DGen_complete; eassumption.
  - simpl. apply (SubSumpSkol empty). intros.
    rewrite <- subst_dskvar_DSch_spec. rewrite subst_dskvar_DSch_not_in_DSch_idempotent.
    eapply SubSump_DEnv_sub. apply IHda__disj. eapply disj_subset_proper. 3:eassumption. rewr. crush. crush. crush.
    do 2 rewrite free_dskvars_DSch_generalize_DSch. eapply in_disjoint_impl_notin2. eassumption. rewr. crush.
Qed.

Theorem generalize_DSch_app : forall da1 da2 sch,
    generalize_DSch sch (da2 ++ da1) = generalize_DSch (generalize_DSch sch da1) da2.
Proof. induction da2; crush. Qed.


Require Export Coq.Lists.List.

Polymorphic Fixpoint LIn (A : Type) (a:A) (l:list A) : Type :=
  match l with
    | nil => False
    | b :: m => (b = a) + LIn A a m
  end.

Polymorphic Inductive NTerm : Type :=
| cterm : NTerm
| oterm : list NTerm -> NTerm.

Polymorphic Fixpoint dummy {A B} (x : list (A * B)) : list (A * B) :=
  match x with
    | nil => nil
    | (_, _) :: _ => nil
  end.

Lemma foo :
  forall v t sub vars,
    LIn (nat * NTerm) (v, t) (dummy sub)
    ->
    (
      LIn (nat * NTerm) (v, t) sub
      *
      notT (LIn nat v vars)
    ).
Proof.
  induction sub; simpl; intros.
  destruct H.
  Set Printing Universes.
  try (apply IHsub in X). (* Toplevel input, characters 5-21:
Error: Universe inconsistency (cannot enforce Top.47 = Set). *)