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.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj34eqsynthconj6 : forall  (lv0 : natural), (@eq natural (Succ lv0) (Succ lv0)).
Admitted.
QuickChick conj34eqsynthconj6.


(** 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.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import TableAux.Specs.find_next_level_idx.
Require Import TableAux.LowSpecs.find_next_level_idx.
Require Import TableAux.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       granule_map_spec
       pgte_read_spec
       buffer_unmap_spec
       entry_is_table_spec
       null_ptr_spec
       find_granule_spec
       entry_to_phys_spec
    .

  Lemma find_next_level_idx_spec_exists:
    forall habd habd'  labd g_tbl idx res
           (Hspec: find_next_level_idx_spec g_tbl idx habd = Some (habd', res))
            (Hrel: relate_RData habd labd),
    exists labd', find_next_level_idx_spec0 g_tbl idx labd = Some (labd', res) /\ relate_RData habd' labd'.
  Proof.
    intros. destruct Hrel. inv id_rdata. destruct g_tbl.
    unfold find_next_level_idx_spec0, find_next_level_idx_spec in *.
    repeat autounfold in *.
    hsimpl_hyp Hspec; inv Hspec; simpl in *.
    - extract_prop_dec; repeat destruct_con; bool_rel; simpl in *. solve_peq; simpl.
      simpl_htarget; grewrite; simpl. solve_bool_range; grewrite.
      eexists. split. reflexivity. constructor. repeat simpl_field. reflexivity.
    - extract_prop_dec; repeat destruct_con; bool_rel; simpl in *. solve_peq; simpl.
      simpl_htarget; grewrite; simpl.
      repeat destruct_if; try discriminate; repeat simpl_field; try (eexists; split; [reflexivity|constructor;reflexivity]).
  Qed.

End Refine.


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 Import Coq.Arith.Compare_dec Coq.Strings.String.
Require Import Fiat.Common.Equality Fiat.Parsers.ParserFromParserADT Fiat.Parsers.SplitterFromParserADT Fiat.Parsers.ParserInterface.
Require Import Coq.Arith.Wf_nat.
Require Import Fiat.Common.Wf.
Require Import Fiat.Common.NatFacts.
Require Import Coq.ZArith.BinInt.
Require Import Fiat.Parsers.ContextFreeGrammar.Notations.
Require Export Fiat.Parsers.Refinement.Tactics.
Require Export Fiat.Common.BoolFacts.
Require Export Fiat.ADTNotation.BuildComputationalADT.
Require Export Fiat.Common.NatFacts.
Require Export Fiat.Parsers.StringLike.FirstCharSuchThat.
Require Export Coq.Strings.Ascii.
Require Export Coq.extraction.ExtrOcamlBasic.
Require Export Coq.extraction.ExtrOcamlNatInt.
Require Export Coq.extraction.ExtrOcamlString.
Require Export Coq.extraction.ExtrOcamlIntConv.
Require Export Fiat.Parsers.ExtrOcamlPrimitives.

Import ExtrOcamlPrimitives.Ocaml.

Extract Inlined Constant Compare_dec.lt_dec => "(<)".
Extract Inlined Constant Sumbool.sumbool_of_bool => "(fun x -> x)".
Extract Inlined Constant Equality.ascii_beq => "(=)".
Extract Inlined Constant ascii_eq_dec => "(=)".
Extract Inlined Constant orbr => "(||)".
Extract Inlined Constant andbr => "(&&)".
Extract Constant minusr => "fun (n : int) (m : int) -> let v = n - m in if v < 0 then 0 else v".
Extract Constant minus => "fun (n : int) (m : int) -> let v = n - m in if v < 0 then 0 else v".
Extract Constant pred => "fun (n : int) -> if n < 1 then 0 else n - 1".
Extract Constant max => "fun (n : int) (m : int) -> if n >= m then n else m".
Extract Constant min => "fun (n : int) (m : int) -> if n <= m then n else m".
Extract Inlined Constant Ascii.nat_of_ascii => "Char.code".
Extract Inlined Constant ContextFreeGrammar.Reflective.opt.nat_of_ascii => "Char.code".

Global Arguments string_dec : simpl never.
Global Arguments Equality.string_beq : simpl never.
Global Arguments SplitterFromParserADT.msplits / .
Global Arguments splits_for / .
Global Arguments Equality.ascii_beq !_ !_ / .
Global Arguments SplitterFromParserADT.mlength / .
Global Arguments SplitterFromParserADT.mis_char / .
Global Arguments SplitterFromParserADT.mtake / .
Global Arguments SplitterFromParserADT.mdrop / .
Global Arguments SplitterFromParserADT.mto_string / .
Global Arguments new_string_of_string / .
Global Arguments ComputationalADT.cRep / .
Global Arguments new_string_of_base_string / .
Global Arguments ComputationalADT.cConstructors / .
Global Arguments Wf.prod_relation / .
Global Arguments Wf_nat.ltof / .
Global Arguments find_first_char_such_that / .
Global Arguments find_first_char_such_that' / .

Module HideProofs.
  Notation hex := (ex _).
  Notation exist' x := (exist _ x _).
  Notation horr := (or_intror _).
  Notation horl := (or_introl _).
End HideProofs.

Definition chan : Pervasives.in_channel
  := match z_of_int (Array.length Sys.argv) with
       | 0%Z | 1%Z => Pervasives.stdin
       | 2%Z => let chan := Pervasives.open_in (Array.get Sys.argv 1) in
                let v := Pervasives.at_exit (fun _ => Pervasives.close_in chan) in
                Ocaml.sequence
                  v
                  chan
       | argc => Pervasives.exit (int_of_z argc)
     end.

Definition profile : forall {T}, (unit -> T) -> Ocaml.float * T
  := fun _ f
     => let startt := Sys.time tt in
        let ret := f tt in
        let endt := Sys.time tt in
        ((endt - startt)%ocaml_float, ret).

Fixpoint sum_of_float (ls : list Ocaml.float) : Ocaml.float
  := match ls with
       | nil => Pervasives.float_of_nat 0
       | x::xs => x + sum_of_float xs
     end%ocaml_float.

Local Notation Σ ls := (sum_of_float ls).

Definition mean (ls : list Ocaml.float) : Ocaml.float
  := (Σ ls / List.length ls)%ocaml_float.

Definition sample_variance (ls : list Ocaml.float) : Ocaml.float
  := let avg := mean ls in
     (Σ (List.map (fun x => (x - avg) * (x - avg)) ls)
        / (List.length ls - 1))%ocaml_float.

Definition median (ls : list Ocaml.float) : Ocaml.float
  := let ls' := Ocaml.List.sort Pervasives.compare ls in
     let len := List.length ls in
     ((List.nth (Div2.div2 (len - 1)) ls' 0 + List.nth (Div2.div2 len) ls' 0)
        / 2)%ocaml_float.

Parameter display_info : forall (sum median mean sample_variance : Ocaml.float)
                                (iterations : nat) (duplicates_per_iteration : nat),
                           unit.
Extract Constant display_info
=> "fun sum median mean sample_variance iterations duplicates_per_iteration
-> Printf.printf ""total: %f, median: %f, mean: %f, sample variance: %f, iterations: %d (%d on each)\n"" sum median mean sample_variance iterations duplicates_per_iteration".

Definition display_info_for_times (duplicates_per_iteration : nat) (ls : list Ocaml.float) : unit
  := let iter := List.length ls in
     let sum := Σ ls in
     let med := median ls in
     let avg := mean ls in
     let var := sample_variance ls in
     display_info sum med avg var iter duplicates_per_iteration.

Fixpoint copy {A} (n : nat) (x : A) : list A
  := match n with
       | 0 => nil
       | S n' => x::copy n' x
     end.

Definition profile_parser
           {T stringT}
           (line : stringT)
           (parse : stringT -> bool)
           (num_times : nat)
           (duplicates_per_iteration : nat)
           (all_say_yes : T)
           (all_say_no : T)
           (mixed_answers : forall (yes no : nat), T)
: T * list Ocaml.float
  := let parse_once := (fun x : unit => let () := x in parse line) in
     let starters := copy duplicates_per_iteration tt in
     let parse_many := (fun x : unit => let () := x in List.map parse_once starters) in
     let time_results := List.map
                           (fun x : unit => let () := x in @profile (list bool) parse_many)
                           (copy num_times tt) in
     let times := List.map fst time_results in
     let results := List.map snd time_results in
     ((if List.fold_right andb true (flatten1 results)
       then all_say_yes
       else if List.fold_right andb true (List.map negb (flatten1 results))
            then all_say_no
            else mixed_answers
                   (List.length (List.filter (fun x => x) (flatten1 results)))
                   (List.length (List.filter negb (flatten1 results)))),
      times).

Definition display_profile_parser_results
           {T stringT}
           (line : stringT)
           (parse : stringT -> bool)
           (num_times : nat)
           (duplicates_per_iteration : nat)
           (all_say_yes : T)
           (all_say_no : T)
           (mixed_answers : forall (yes no : nat), T)
: unit * T
  := let '(res, times) := profile_parser line parse num_times duplicates_per_iteration all_say_yes all_say_no mixed_answers in
     let tt_val := display_info_for_times duplicates_per_iteration times in
     (tt_val, res).

Definition premain'
           {stringT}
           (line : stringT)
           (num_times : nat)
           (duplicates_per_iteration : nat)
           (parse : stringT -> bool)
: unit
  := let '((), exit_code)
         := @display_profile_parser_results
              nat
              stringT
              line
              parse
              num_times
              duplicates_per_iteration
              0
              1
              (fun _ _ => 2)
     in Pervasives.exit (int_of_nat exit_code).

Definition line_ocaml : Ocaml.string := Pervasives.input_line chan.

Definition line : string := Ocaml.explode line_ocaml.

Definition premain_ocaml (parse : Ocaml.string -> bool) : unit
  := premain' line_ocaml 10 10 parse.

Definition premain (parse : Coq.Strings.String.string -> bool) : unit
  := premain' line 10 10 parse.


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). *)