Require Import RelationClasses.
Require Import Sorting.
Require Import VST.floyd.proofauto.
Require Import CertiGraph.binheap.binary_heap_model.
Require Import CertiGraph.binheap.binary_heap_Zmodel.
Require Import CertiGraph.binheap.binary_heap.
Require Import CertiGraph.binheap.env_binary_heap.

Set Nested Proofs Allowed.

Definition exch_spec :=
  DECLARE _exch WITH i : Z, j : Z, arr: val, arr_contents: list heap_item
  PRE [tuint, tuint, tptr t_item]
    PROP (0 <= i < Zlength arr_contents; 0 <= j < Zlength arr_contents)
    PARAMS (Vint (Int.repr i); Vint (Int.repr j); arr)
    GLOBALS ()
    SEP (harray arr_contents arr)
  POST [tvoid]
    PROP ()
    LOCAL ()
    SEP (harray (Zexchange arr_contents i j) arr).

Definition less_spec :=
  DECLARE _less WITH i : Z, j : Z, arr: val, arr_contents: list heap_item
  PRE [tuint, tuint, tptr t_item]
    PROP (0 <= i < Zlength arr_contents; 0 <= j < Zlength arr_contents)
    PARAMS (Vint (Int.repr i); Vint (Int.repr j); arr)
    GLOBALS ()
    SEP (harray arr_contents arr)
  POST [tint]
    PROP ()
    LOCAL (temp ret_temp (Val.of_bool (cmp (Znth i arr_contents) (Znth j arr_contents))))
    SEP (harray arr_contents arr).

Definition swim_spec :=
  DECLARE _swim WITH i : Z, arr: val, arr_contents: list heap_item
  PRE [tuint, tptr t_item]
    PROP (0 <= i < Zlength arr_contents;
          weak_heap_ordered_bottom_up arr_contents i)
    PARAMS (Vint (Int.repr i); arr)
    GLOBALS ()
    SEP (harray arr_contents arr)
  POST [tvoid]
    EX arr_contents' : list (int * int),
      PROP (heap_ordered arr_contents'; Permutation arr_contents arr_contents')
      LOCAL ()
      SEP (harray arr_contents' arr).

Definition sink_spec :=
  DECLARE _sink WITH i : Z, arr: val, arr_contents: list heap_item, first_available : Z, b : Z
  PRE [tuint, tptr t_item, tuint]
    PROP (0 <= i <= Zlength arr_contents;
          first_available = Zlength arr_contents;
          (i = Zlength arr_contents -> (2 * i) <= Int.max_unsigned);
          (i < Zlength arr_contents -> (2 * (first_available - 1) <= Int.max_unsigned)); (* i = fa - 1 -> (2 * i + 1) = 2 * fa - 1, must be representable *)
          weak_heap_ordered_top_down_bounded arr_contents b i)
    PARAMS (Vint (Int.repr i); arr; Vint (Int.repr first_available))
    GLOBALS ()
    SEP (harray arr_contents arr)
  POST [tvoid]
    EX arr_contents' : list heap_item,
      PROP (heap_ordered_bounded arr_contents' b;
            Permutation arr_contents arr_contents')
      LOCAL ()
      SEP (harray arr_contents' arr).

Definition size_spec :=
  DECLARE _size WITH pq : val, h : heap
  PRE [tptr t_pq]
    PROP ()
    PARAMS (pq)
    GLOBALS ()
    SEP (valid_pq pq h)
  POST [tuint]
    PROP ()
    LOCAL (temp ret_temp (Vint (Int.repr (heap_size h))))
    SEP (valid_pq pq h).

Definition capacity_spec :=
  DECLARE _capacity WITH pq : val, h : heap
  PRE [tptr t_pq]
    PROP ()
    PARAMS (pq)
    GLOBALS ()
    SEP (valid_pq pq h)
  POST [tuint]
    PROP ()
    LOCAL (temp ret_temp (Vint (Int.repr (heap_capacity h))))
    SEP (valid_pq pq h).

Definition remove_min_nc_spec :=
  DECLARE _remove_min_nc WITH pq : val, h : heap, i : val, iv : heap_item
  PRE [tptr t_pq, tptr t_item]
    PROP (heap_size h > 0)
    PARAMS (pq; i)
    GLOBALS ()
    SEP (valid_pq pq h; hitem iv i)
  POST [tvoid]
  EX h', EX iv' : heap_item,
    PROP (heap_capacity h = heap_capacity h';
          Permutation (heap_items h) (iv' :: heap_items h');
          Forall (cmp_rel iv') (heap_items h'))
    LOCAL ()
    SEP (valid_pq pq h'; hitem iv' i).

Definition insert_nc_spec :=
  DECLARE _insert_nc WITH pq : val, h : heap, i : val, iv : heap_item
  PRE [tptr t_pq, tptr t_item]
    PROP (heap_size h < heap_capacity h)
    PARAMS (pq; i)
    GLOBALS ()
    SEP (valid_pq pq h; hitem iv i)
  POST [tvoid]
  EX h',
    PROP (heap_capacity h = heap_capacity h';
          Permutation (iv :: heap_items h) (heap_items h'))
    LOCAL ()
    SEP (valid_pq pq h'; hitem iv i).

Definition build_heap_spec :=
  DECLARE _build_heap WITH arr: val, arr_contents: list heap_item, size : Z
  PRE [tptr t_item, tuint]
    PROP (size > 0 ; (* Required because PARENT subtracts 1u *)
          Zlength arr_contents = size)
    PARAMS (arr; Vint (Int.repr size))
    GLOBALS ()
    SEP (harray arr_contents arr)
  POST [tvoid]
  EX arr_contents' : list heap_item,
    PROP (heap_ordered arr_contents';
          Permutation arr_contents arr_contents')
    LOCAL ()
    SEP (harray arr_contents' arr).

Definition heapsort_rev_spec :=
  DECLARE _heapsort_rev WITH arr : val, arr_contents : list heap_item, size : Z
  PRE [tptr t_item, tuint]
    PROP (size > 0 ;
          Zlength arr_contents = size)
    PARAMS (arr; Vint (Int.repr size))
    GLOBALS ()
    SEP (harray arr_contents arr)
  POST [tvoid]
  EX arr_contents' : list heap_item,
    PROP (Sorted (Basics.flip cmp_rel) arr_contents';
          Permutation arr_contents arr_contents')
    LOCAL ()
    SEP (harray arr_contents' arr).

Definition Gprog : funspecs :=
         ltac:(with_library prog [ exch_spec ; less_spec ; swim_spec ; sink_spec ;
                                   remove_min_nc_spec ; insert_nc_spec ;
                                   size_spec ; capacity_spec ;
                                   build_heap_spec ; heapsort_rev_spec ]).

Lemma body_heapsort: semax_body Vprog Gprog f_heapsort_rev heapsort_rev_spec.
Proof.
  start_function.
  assert_PROP (2 * (size - 2) <= Int.max_unsigned). {
    go_lower. unfold harray. saturate_local. apply prop_right.
    destruct H1 as [? [? [? [? ?]]]].
    destruct arr; try contradiction. simpl in H5. rep_lia. }
  forward_call (arr, arr_contents, size).
  Intros arr_contents'.
  forward.
  forward_loop (EX s : Z, EX arr_contents1 : list heap_item, EX arr_contents2 : list heap_item,
                 PROP (s > 0 ;
                       s = Zlength arr_contents1;
                       heap_ordered arr_contents1;
                       Sorted (Basics.flip cmp_rel) arr_contents2;
                       Forall (fun x => HdRel (Basics.flip cmp_rel) x arr_contents2) arr_contents1;
                       Permutation arr_contents (arr_contents1 ++ arr_contents2))
                 LOCAL (temp _arr arr; temp _active (Vint (Int.repr s)))
                 SEP (harray (arr_contents1 ++ arr_contents2) arr)).
  { Exists size arr_contents' (@nil heap_item).
    rewrite app_nil_r. entailer!. split. apply Permutation_Zlength. trivial.
    apply Forall_forall. constructor. }
  Intros s arrc1 arrc2.
  generalize (Permutation_Zlength _ _ _ H9); intro.
  rewrite Zlength_app in H10.
  forward_if.
  2: { assert (s = 1) by rep_lia. subst s.
       destruct arrc1. rewrite Zlength_nil in H12; lia.
       destruct arrc1. 2: do 2 rewrite Zlength_cons in H12; rep_lia.
       rewrite H12.
       forward. Exists (h :: arrc2). entailer!. 2: apply derives_refl.
       constructor. trivial. rewrite Forall_forall in H8.
       apply H8. left. trivial. }
  forward.
  rewrite harray_split. Intros.
  forward_call (0, s-1, arr, arrc1). rep_lia.
  destruct arrc1. rewrite Zlength_nil in H5. lia.
  generalize (foot_split_spec _ (h :: arrc1)). case foot_split. destruct o. 2: intros [? ?]; subst; discriminate.
  intros. destruct l. destruct arrc1. 2: discriminate. inversion H12. subst h0. clear H12.
  { (* Degenerate case: only one item, which simplies nicely after chaning the bound! *)
    rewrite Zlength_one in H5. lia. }

(*  subst s. simpl.
    rewrite Zexchange_eq.
    rewrite Int.sub_idem.
    change [h] with (nil ++ [h]) at 1.
    rewrite harray_split. Intros.
    assert (weak_heap_ordered_top_down_bounded [] 0 0). {
      apply weak_heapOrdered_bounded_root_weak_heapOrdered.
      apply hOwhO.
      apply cmp_po.
      apply heapOrdered_empty. }
    forward_call (0, arr, @nil heap_item, 0, 0).
    rewrite Zlength_nil. simpl. intuition. rep_lia.
    Intros arrcx.
    apply Permutation_nil in H12. subst arrcx.
    Exists 0 (@nil heap_item) (h :: arrc2). entailer!.
    split. apply heapOrdered_empty. constructor. trivial. inversion H7. trivial.
    rewrite <- harray_split. simpl. change (h :: arrc2) with ([h] ++ arrc2).
    rewrite <- harray_split. apply derives_refl. } *)

  (* Main line *)
  assert (h1 = h) by (inversion H12; auto). subst h1.
  rewrite H12 in *. clear H12 arrc1.
  replace (s - 1) with (Zlength (h :: l)).
  2: autorewrite with sublist in *; rep_lia.
  rewrite Zexchange_head_foot.
  rewrite harray_split. Intros.
  forward_call (0, arr, (h0 :: l), s-1, 0).
  { split. rep_lia. split. autorewrite with sublist in *. rep_lia.
    split. rep_lia. split. intros _. rep_lia.
    apply weak_heapOrdered_bounded_root_weak_heapOrdered.
    eapply weak_heapOrdered_root.
    apply heapOrdered_cutfoot in H6. apply H6. }
  Intros arrc1. Exists (s-1) arrc1 (h :: arrc2). entailer!.
  { split. apply Permutation_Zlength in H13. autorewrite with sublist in *. trivial.
    split. apply heapOrdered_bounded_root_heapOrdered. apply H12.
    split. constructor. trivial. inversion H8. trivial.
    split.
    * apply Forall_forall. intros. constructor.
      symmetry in H13.
      generalize (Permutation_in x H13 H0); intro.
      generalize (root_minimal _ cmp_rel cmp_po _ H6 h eq_refl); intro.
      rewrite Forall_forall in H14. apply H14.
      rewrite <- app_comm_cons. right.
      apply in_or_app.
      destruct H5. subst x. right. left. trivial. auto.
    * apply Permutation_trans with (((h :: l) ++ [h0]) ++ arrc2). trivial.
      change (h :: arrc2) with ([h] ++ arrc2). rewrite app_assoc.
      apply Permutation_app. 2: apply Permutation_refl.
      apply Permutation_trans with (h :: arrc1).
      2: apply Permutation_cons_append.
      simpl. constructor.
      apply Permutation_app_comm_trans. apply H13. }
  { apply Permutation_Zlength in H13.
    rewrite Zlength_app. rewrite H13. rewrite <- Zlength_app.
    rewrite <- harray_split.
    rewrite Zlength_app.
    replace (Zlength ((h :: l) ++ [h0])) with (Zlength (arrc1 ++ [h])).
    rewrite <- Zlength_app.
    rewrite <- harray_split. rewrite <- app_assoc. apply derives_refl.
    autorewrite with sublist in *. lia. }
Qed.

Lemma body_build_heap: semax_body Vprog Gprog f_build_heap build_heap_spec.
Proof.
  start_function.
  assert_PROP (2 * (size - 1) <= Int.max_unsigned). {
    go_lower. unfold harray. saturate_local. apply prop_right.
    destruct H1 as [? [? [? [? ?]]]].
    destruct arr; try contradiction. simpl in H5. rep_lia. }
  assert (Zlength arr_contents <= Int.max_unsigned) by rep_lia.
  forward.
  rewrite sub_repr. rewrite <- Zparent_repr. 2: lia.
  forward_loop (EX s : Z, EX arr_contents' : list heap_item,
                 PROP (0 <= s < Zlength arr_contents;
                       weak_heap_ordered_top_down_bounded arr_contents' s s;
                       Permutation arr_contents arr_contents')
                 LOCAL (temp _arr arr; temp _size__1 (Vint (Int.repr size)); temp _start (Vint (Int.repr s)))
                 SEP (harray arr_contents' arr)).
  { Exists (Zparent size) arr_contents. entailer!.
    split. rewrite Zparent_unfold. 2: lia.
    split. apply Z_div_pos; lia.
    eapply Z.le_lt_trans.
    2: apply Z.div_lt.
    apply Z.div_le_mono. 1,2,3,4: lia.
    red. generalize (weak_heapOrdered_bounded_half _ cmp_rel arr_contents); intro.
    unfold Zparent. rewrite ZtoNat_Zlength, Nat2Z.id. trivial. }
  Intros s arr_contents'.
  generalize (Permutation_Zlength _ _ _ H5); intro.
  forward_call (s, arr, arr_contents', size, s).
  { split. lia. split. congruence. split. lia. split; auto. }
  Intros arr_contents''.
  forward_if (s > 0).
  { forward. subst s. Exists arr_contents''. entailer!.
    split. 2: eapply Permutation_trans; eauto.
    apply heapOrdered_bounded_root_heapOrdered. apply H7. }
  { forward. entailer!. }
  forward.
  Exists (s - 1) arr_contents''. entailer!.
  split. 2: eapply Permutation_trans; eauto.
  red in H7. apply hObU_whObU_pred.
  replace (1 + Z.to_nat (s-1))%nat with (Z.to_nat s) by rep_lia. trivial.
Qed.

Lemma body_sink: semax_body Vprog Gprog f_sink sink_spec.
Proof.
  start_function.
  assert (Hc : i = Zlength arr_contents \/ 0 <= i < Zlength arr_contents) by lia. destruct Hc as [Hc | Hc].
* (* Special case: oob sink, used when removing the last element of the heap. *)
  forward_loop ( PROP () LOCAL (temp _k (Vint (Int.repr i)); temp _first_available (Vint (Int.repr first_available))) SEP (harray arr_contents arr) ).
  entailer!.
  forward_if False. exfalso. lia. (* This is where the bound is needed.  For some reason I need a slightly different bound than I expect. *)
  forward.
  Exists arr_contents. entailer!.
  eapply weak_heapOrdered_bounded_oob. 2: apply H3.
  rewrite Zlength_correct, Nat2Z.id. apply le_refl.
* (* Main line *)
  assert (Hx : i < Zlength arr_contents) by lia. specialize (H2 Hx). clear H1 Hx. rename H2 into H1. rename H3 into H2.
  forward_loop (EX i' : Z, EX arr_contents' : list heap_item,
                 PROP (0 <= i' < Zlength arr_contents;
                       sink arr_contents (Z.to_nat i) = sink arr_contents' (Z.to_nat i'))
                 LOCAL (temp _k (Vint (Int.repr i')); temp _arr arr; temp _first_available (Vint (Int.repr first_available)))
                 SEP (harray arr_contents' arr)).
  Exists i arr_contents. entailer!.
  Intros i' arr_contents'.
  assert (Zlength arr_contents = Zlength arr_contents'). { unfold sink in H4.
    generalize (sink_permutation _ cmp_rel cmp_dec arr_contents (Z.to_nat i)); intro.
    generalize (sink_permutation _ cmp_rel cmp_dec arr_contents' (Z.to_nat i')); intro.
    apply Permutation_Zlength in H5. apply Permutation_Zlength in H6. congruence. }
  forward_if (Zleft_child i' < first_available).
    { forward. entailer!. rewrite Zleft_child_unfold; lia. }
    { forward. (* Prove postcondition *)
      Exists arr_contents'. entailer!. unfold sink at 2 in H4.
      rewrite <- Zleft_child_unfold in H6; try lia.
      unfold Zleft_child in H6. rewrite H5 in H6. rewrite Zlength_correct in H6.
      erewrite sink_done in H4. 2: apply Znth_nth_error; lia.
      rewrite <- H4. { split.
      * apply sink_hO_bounded. apply cmp_po. apply cmp_linear. apply H2.
      * apply sink_permutation. }
      intros. assert (left_child (Z.to_nat i') < length arr_contents')%nat by (apply nth_error_Some; congruence).
      lia.
      intros. assert (right_child (Z.to_nat i') < length arr_contents')%nat by (apply nth_error_Some; congruence).
      unfold right_child in H7. lia. }
  forward.
  rewrite mul_repr, add_repr. rewrite <- Zleft_child_unfold. 2: lia.
  forward_if (EX b : bool, PROP (if b then Zright_child i' <  first_available /\  cmp_rel (Znth (Zright_child i') arr_contents') (Znth (Zleft_child i') arr_contents')
                                      else Zright_child i' >= first_available \/ ~cmp_rel (Znth (Zright_child i') arr_contents') (Znth (Zleft_child i') arr_contents') )
                           LOCAL (temp _t'1 (Val.of_bool b); temp _k (Vint (Int.repr i')); temp _j (Vint (Int.repr (Zleft_child i'))); temp _arr arr; temp _first_available (Vint (Int.repr first_available)))
                           SEP (harray arr_contents' arr)).
    { forward_call (Zright_child i', Zleft_child i', arr, arr_contents').
        { entailer!. simpl. repeat f_equal. rewrite Zright_child_unfold, Zleft_child_unfold; lia. }
        { rewrite Int.unsigned_repr in H7. rewrite Zright_child_unfold, Zleft_child_unfold in *; lia.
          (* Here is where we seem to need the precise bound on first_available? *)
          rewrite Zleft_child_unfold in *; rep_lia. }
      forward. Exists (cmp (Znth (Zright_child i') arr_contents') (Znth (Zleft_child i') arr_contents')).
      unfold cmp_rel. rewrite Zright_child_unfold, Zleft_child_unfold in *.
      rewrite Int.unsigned_repr in H7. 2,3,4,5: rep_lia.
      case cmp; entailer!. }
    { forward. Exists false.
      rewrite Zright_child_unfold, Zleft_child_unfold in *. rewrite Int.unsigned_repr in H7.
      entailer!. all: rep_lia. }
  Intro bo.
  set (j' := if bo then Zright_child i' else Zleft_child i').
  forward_if (PROP (if bo then Zright_child i' <  first_available /\  cmp_rel (Znth (Zright_child i') arr_contents') (Znth (Zleft_child i') arr_contents')
                          else Zright_child i' >= first_available \/ ~cmp_rel (Znth (Zright_child i') arr_contents') (Znth (Zleft_child i') arr_contents') )
              LOCAL (temp _t'1 (Val.of_bool bo); temp _k (Vint (Int.repr i')); temp _j (Vint (Int.repr j')); temp _arr arr; temp _first_available (Vint (Int.repr first_available)))
              SEP (harray arr_contents' arr)).
    { forward. subst j'. rewrite Zright_child_unfold, Zleft_child_unfold in *; try lia. entailer!. tauto. }
    { forward. entailer!. }
    Intros. (* Need to get the PROP above the bar... why doesn't forward_call do this for me? *)
    forward_call (i', j', arr, arr_contents'). { subst j'. rewrite Zright_child_unfold, Zleft_child_unfold in *; try lia. destruct bo; lia. }
    forward_if (~cmp_rel (Znth i' arr_contents') (Znth j' arr_contents')).
      { forward. (* Prove function postcondition *)
        Exists arr_contents'. entailer!. unfold sink at 2 in H4. erewrite sink_done in H4; intros.
        rewrite <- H4. split. apply sink_hO_bounded. apply cmp_po. apply cmp_linear. apply H2.
        apply sink_permutation.
        apply Znth_nth_error. lia.
        * rewrite <- (Nat2Z.id (left_child _)) in H0. change (Z.of_nat _) with (Zleft_child i') in H0.
          rewrite Znth_nth_error in H0. 2: rewrite Zright_child_unfold, Zleft_child_unfold in *; lia.
          inversion H0. subst b0. clear H0.
          destruct bo; subst j'; auto.
          transitivity (Znth (Zright_child i') arr_contents'); tauto.
        * assert (0 <= Zright_child i' < Zlength arr_contents'). {
            split. unfold Zright_child. lia.
            apply Z2Nat.inj_lt. unfold Zright_child. lia. lia.
            rewrite ZtoNat_Zlength.
            eapply nth_error_Some.
            unfold Zright_child.
            rewrite Nat2Z.id. congruence. }
          rewrite <- (Nat2Z.id (right_child _)) in H0. change (Z.of_nat _) with (Zright_child i') in H0.
          rewrite Znth_nth_error in H0; try lia.
          inversion H0. subst b0. clear H0.
          destruct bo; subst j'. tauto. destruct H7. lia.
          transitivity (Znth (Zleft_child i') arr_contents'). trivial.
          destruct (cmp_linear (Znth (Zleft_child i') arr_contents') (Znth (Zright_child i') arr_contents')); auto.
          contradiction. }
      { forward.  entailer!. unfold cmp_rel, j' in H0. congruence. }
    forward_call (i', j', arr, arr_contents').
      { subst j'. rewrite Zright_child_unfold, Zleft_child_unfold in *; try lia. destruct bo; lia. }
    forward.
    (* Prove loop invariant at loop bottom *)
    Exists j' (Zexchange arr_contents' i' j').
    entailer!. split. subst j'. rewrite Zright_child_unfold, Zleft_child_unfold in *; try lia. destruct bo; lia.
    unfold sink at 2. unfold Zexchange. erewrite sink_step. apply H4.
    apply Znth_nth_error; lia.
    unfold left_child. replace (1 + Z.to_nat i' + Z.to_nat i')%nat with (Z.to_nat (2 * i' + 1)) by lia.
    apply Znth_nth_error.
    split. lia. rewrite <- Zleft_child_unfold; try lia.
    rewrite <- Zleft_child_unfold; try lia.
    case_eq (nth_error arr_contents' (right_child (Z.to_nat i'))); intros.
    + (* From H0... feels like it should be a lemma. *)
      assert (h = Znth (Zright_child i') arr_contents'). {
        rewrite <- (nat_of_Z_eq (right_child _)) in H0.
        rewrite Znth_nth_error in H0. inversion H0. trivial.
        assert ((Z.to_nat (Z.of_nat (right_child (Z.to_nat i')))) < length arr_contents')%nat by (apply nth_error_Some; congruence).
        rewrite Zlength_correct. lia. } subst h.
      (* Probably another lemma... *)
      assert (Zright_child i' < Zlength arr_contents'). {
        assert (right_child (Z.to_nat i') < length arr_contents')%nat by (apply nth_error_Some; congruence).
        unfold Zright_child. rewrite Zlength_correct. lia. }
      clear H0. subst j'.
      destruct bo.
      - right. split. unfold Zright_child. lia. tauto.
      - left. split. unfold Zleft_child. lia. destruct H7. lia. tauto.
    + subst j'. destruct bo.
      - rewrite H5 in H7. apply nth_error_None in H0. destruct H7. unfold Zright_child in H7. rewrite Zlength_correct in H7. lia.
      - split. unfold Zleft_child. lia. tauto.
Time Qed.

Lemma body_swim: semax_body Vprog Gprog f_swim swim_spec.
Proof.
  start_function.
  assert_PROP (Zlength arr_contents <= Int.max_unsigned) as Hz.
    { go_lower. unfold harray. saturate_local. apply prop_right.
      destruct H1 as [? [? [? [? ?]]]].
      destruct arr; try contradiction. simpl in H5. rep_lia. }
  forward_loop (EX i' : Z, EX arr_contents' : list heap_item,
                PROP (0 <= i' < Zlength arr_contents;
                      swim arr_contents (Z.to_nat i) = swim arr_contents' (Z.to_nat i'))
                LOCAL (temp _k (Vint (Int.repr i')); temp _arr arr)
                SEP (harray arr_contents' arr)).
  Exists i arr_contents. entailer!.
  Intros i' arr_contents'.
  assert (Zlength arr_contents = Zlength arr_contents'). {
    unfold swim in H2.
    generalize (swim_permutation _ cmp_rel cmp_dec arr_contents (Z.to_nat i)); intro.
    generalize (swim_permutation _ cmp_rel cmp_dec arr_contents' (Z.to_nat i')); intro.
    apply Permutation_Zlength in H3. apply Permutation_Zlength in H4. congruence. }
  generalize (parent_le (Z.to_nat i')); intro Hq.
  assert (Hx: i' = 0 \/ i' > 0) by lia.
  forward_if (EX b : bool, PROP (if b then i' > 0 /\  cmp_rel (Znth i' arr_contents') (Znth (Zparent i') arr_contents')
                                      else i' = 0 \/ ~cmp_rel (Znth i' arr_contents') (Znth (Zparent i') arr_contents') )
                           LOCAL (temp _t'1 (Val.of_bool b); temp _k (Vint (Int.repr i')); temp _arr arr)
                           SEP (harray arr_contents' arr)).
    { (* if-branch *)
      destruct Hx as [Hx | Hx]. subst i'. inversion H4.
      forward_call (i', Zparent i', arr, arr_contents').
      { entailer!. simpl. rewrite Zparent_repr. trivial. lia. }
      { assert (parent (Z.to_nat i') <= (Z.to_nat i'))%nat by apply parent_le. unfold Zparent. lia. }
      forward. unfold cmp_rel. case (cmp (Znth i' arr_contents') (Znth (Zparent i') arr_contents')).
      Exists true. entailer!.
      Exists false. entailer!. }
    { (* else-branch *)
      forward. Exists false. entailer!. }
  Intro b.
  forward_if (PROP (i' > 0 /\ cmp_rel (Znth i' arr_contents') (Znth (Zparent i') arr_contents'))
              LOCAL (temp _k (Vint (Int.repr i')); temp _arr arr)
              SEP (harray arr_contents' arr)).
    { subst b. forward. entailer!. tauto. }
    { subst b. forward. (* Prove postcondition *)
      Exists arr_contents'. entailer!. split.
      { assert (heap_ordered (swim arr_contents (Z.to_nat i))). { apply swim_hO; auto. apply cmp_po. apply cmp_linear. }
        unfold swim at 2 in H2. destruct H5.
        * subst i'. simpl in H2. rewrite swim_0 in H2. rewrite <- H2. trivial.
        * erewrite swim_done in H2; eauto. rewrite <- H2. trivial.
          apply Znth_nth_error; lia.
          unfold Zparent. rewrite <- Znth_nth_error; try lia.
          rewrite Nat2Z.id. trivial. }
      { unfold swim in H2.
        generalize (swim_permutation _ cmp_rel cmp_dec arr_contents (Z.to_nat i)); intro.
        generalize (swim_permutation _ cmp_rel cmp_dec arr_contents' (Z.to_nat i')); intro.
        rewrite H2 in H4. etransitivity. apply H4. symmetry. trivial. } }
  forward_call (i', Zparent i', arr, arr_contents').
    { entailer!. simpl. rewrite Zparent_repr. trivial. lia. }
    { unfold Zparent. lia. }
  forward.
  Exists (Zparent i') (Zexchange arr_contents' i' (Zparent i')).
  entailer!. split. unfold Zparent. lia.
  split.
  * destruct H4.
    unfold swim, Zparent, Zexchange in *. rewrite Nat2Z.id. erewrite swim_step. congruence.
    rewrite H3, Zlength_correct in H1.
    4: apply H5. 2: apply Znth_nth_error.
    3: rewrite <- Znth_nth_error. 3: rewrite Nat2Z.id; trivial.
    1,2,3: lia.
  * rewrite Zparent_repr. trivial. lia.
Time Qed.

Lemma body_insert_nc: semax_body Vprog Gprog f_insert_nc insert_nc_spec.
Proof.
  start_function.
  unfold valid_pq.
  Intros arr junk.
  destruct junk. { exfalso. unfold heap_size, heap_capacity in *. rewrite Zlength_app, Zlength_nil in H2. lia. }
  change (h0 :: junk) with ([h0] ++ junk) in *. rewrite app_assoc in *.
  rewrite harray_split. Intros.
  assert (0 <= heap_size h) by apply Zlength_nonneg.
  forward. unfold harray. entailer!.
  forward. unfold hitem.
  forward.
  unfold harray at 1.
  forward. entailer!. rewrite Zlength_app, Zlength_one. unfold heap_size in *. lia.
  forward.
  forward.
  forward. { (* C typing issue? *) entailer!. apply H10. discriminate. }
  forward. entailer!. rewrite Zlength_app, Zlength_one. unfold heap_size in *. lia.
  forward.
  forward.
  (* Just before the call, let's do some cleanup *)
  deadvars!.
  rewrite upd_Znth_overwrite, upd_Znth_same, map_app, upd_Znth_app2, Zlength_map.
  unfold heap_size at 3. rewrite Z.sub_diag.
  simpl fst. change (Vint (fst iv), Vint (snd iv)) with (heap_item_rep iv). rewrite upd_Znth_map.
  rewrite <- map_app. rewrite upd_Znth0.
  2,3,4: autorewrite with sublist; unfold heap_size in *; lia.
  replace (Zlength (heap_items h ++ [h0])) with (Zlength (heap_items h ++ [iv])).
  2: do 2 rewrite Zlength_app, Zlength_one; lia.
  forward_call (heap_size h, arr, heap_items h ++ [iv]).
    { rewrite Zlength_app, Zlength_one. unfold heap_size in *. split. lia.
      red. rewrite Zlength_correct, Nat2Z.id.
      apply weak_heapOrdered2_postpend. apply cmp_po. trivial. }
  Intro vret.
  forward.
  forward.
  (* Prove postcondition *)
  Exists ((Z.to_nat (heap_capacity h))%nat, vret).
  unfold heap_capacity. rewrite Nat2Z.id. simpl fst.
  unfold valid_pq. entailer!.
  * transitivity (snd h ++ [iv]); trivial. change (iv :: heap_items h) with ([iv] ++ heap_items h).
    apply Permutation_app_comm.
  * Exists arr junk. entailer!.
    + rewrite Zlength_app. apply Permutation_Zlength in H5.
      unfold heap_items. simpl. rewrite <- H5. unfold heap_capacity in *. simpl. rewrite <- H2.
      autorewrite with sublist. lia.
    + unfold heap_size, heap_capacity, heap_items. simpl fst. simpl snd.
      generalize (Permutation_Zlength _ _ _ H5); intro. rewrite <- H10.
      replace (Zlength (heap_items h ++ [iv])) with (Zlength (snd h) + 1). 2: rewrite Zlength_app; trivial.
      cancel.
      rewrite harray_split. cancel.
      repeat rewrite Zlength_app. rewrite <- H10. rewrite Zlength_app. apply derives_refl.
Time Qed.

Lemma body_remove_min_nc: semax_body Vprog Gprog f_remove_min_nc remove_min_nc_spec.
Proof.
  start_function.
  unfold valid_pq.
  Intros arr junk.
  rewrite harray_split.
  Intros.
  destruct h. destruct l. inversion H.
  unfold heap_items, heap_capacity, heap_size in *. simpl in H, H0, H1 |-*. clear H.
  generalize (foot_split_spec _ (h :: l)).
  case foot_split. destruct o; intro. 2: destruct H; subst l0; discriminate.
  rename h into root. rename h0 into foot.
  assert (Hx: Zlength l = Zlength (root :: l) - 1) by (rewrite Zlength_cons; lia).
  assert (Hy : 0 <= Zlength l) by apply Zlength_nonneg.
  forward.
  forward.
  forward.
  forward.
  unfold harray. entailer!.
  forward_call (0, Zlength l, arr, root :: l).
  entailer!. simpl. congruence. lia.
  forward.
  forward.
  unfold harray at 1. (* Not delighted with this unfold... *)
  forward.
    { entailer!. rewrite Zlength_Zexchange. lia. }
    { entailer!. rewrite Znth_map. rewrite <- Hx. rewrite Znth_Zexchange'; try lia. rewrite Znth_0_cons.
      unfold heap_item_rep. trivial. rewrite Zlength_Zexchange. lia. }
  unfold hitem.
  forward.
  forward.
  forward.
  forward.
    { entailer!. rewrite Zlength_Zexchange. lia. }
    { entailer!. rewrite Znth_map. 2: rewrite Zlength_Zexchange; lia.
      rewrite <- Hx. rewrite Znth_Zexchange'; try lia. rewrite Znth_0_cons.
      apply Forall_map in H6.
      rewrite Forall_Znth in H6. specialize (H6 (Zlength l)). do 2 rewrite Zlength_map in H6. rewrite Zlength_Zexchange in H6.
      assert (Hq: 0 <= (Zlength l) < Zlength (root :: l)) by lia.
      specialize (H6 Hq). rewrite Znth_map in H6. 2: rewrite Zlength_map, Zlength_Zexchange; lia.
      rewrite Znth_map in H6. 2: rewrite Zlength_Zexchange; lia.
      rewrite Znth_Zexchange' in H6; try lia.
      (* Flailing around solves the goal... *)
      apply H6. discriminate. }
  (* this change refolds the harray back up *)
  change (data_at _ _ _ arr) with (harray (Zexchange (root :: l) 0 (Zlength l)) arr).
  forward.
  forward.
  forward.
  (* Just before the final call, let's do some cleanup *)
  rewrite <- Hx.
  rewrite Znth_map. 2: rewrite Zlength_Zexchange; lia.
  rewrite Znth_Zexchange'; try lia. rewrite Znth_0_cons.
  autorewrite with norm. rewrite <- Hx.
  unfold heap_item_rep. rewrite H.
  destruct l.
  * (* corner case: heap is now empty *)
    destruct l0. 2: destruct l0; discriminate.
    inversion H. subst foot. clear H Hx.
    simpl.
    forward_call (0, arr, @nil heap_item, 0, 0); rewrite Zlength_nil.
      { rewrite Zexchange_eq. unfold harray. rewrite data_at_isptr. entailer. (* Surely there's a less heavy hammer way to do this? *)
        rewrite data_at_zero_array_eq; auto. entailer!. }
      { split; auto. split; auto. split. rep_lia. split. rep_lia.
        apply weak_heapOrdered_bounded_root_weak_heapOrdered.
        apply hOwhO. apply cmp_po. apply heapOrdered_empty. }
    (* Prove postcondition *)
    Intro vret. Exists (n, vret) root. entailer. (* Surely there's a less heavy hammer way to do this? *)
    apply Permutation_nil in H3. subst vret. clear H Hy.
    sep_apply harray_emp. rewrite emp_sepcon.
    do 2 rewrite fold_harray. unfold valid_pq, hitem.
    apply andp_right. apply prop_right. auto.
    Exists arr (root :: junk). simpl. entailer!.
    apply heapOrdered_empty.
    rewrite <- harray_split. apply derives_refl.
  * (* main line: heap still has items in it *)
    destruct l0; inversion H. subst h0.
    deadvars!.
    assert (Zlength (h :: l) = Zlength (root :: l0)). { rewrite H5, Zlength_app, Zlength_one, Zlength_cons. lia. }
    rewrite H3, Zexchange_head_foot. rewrite harray_split.
    forward_call (0, arr, (foot :: l0), Zlength (foot :: l0), 0). entailer!.
      { split. rewrite Zlength_cons. generalize (Zlength_nonneg l0). lia.
        split; trivial. split. rep_lia.
        (* Here is where we use the bound. *)
        split. intros _. generalize (Zlength_nonneg junk); intro.
        simpl in H2. repeat rewrite Zlength_cons in *. rewrite Zlength_app in H2. lia.
        apply weak_heapOrdered_bounded_root_weak_heapOrdered.
        apply weak_heapOrdered_root with root.
        rewrite H5, app_comm_cons in H1.
        apply heapOrdered_cutfoot in H1. trivial. }
    (* Prove postcondition *)
    Intro vret. Exists (n, vret) root. simpl fst. unfold hitem, heap_item_rep, heap_size, heap_capacity. simpl fst. simpl snd. entailer!.
      { (* Pure part *)
        split. constructor. rewrite H5. transitivity ([foot] ++ l0). apply Permutation_app_comm. auto.
        generalize (root_minimal _ _ _ _ H1 root eq_refl); intro.
        rewrite H5 in H11. apply Forall_inv_tail in H11.
        eapply forall_permutation. apply H11. transitivity ([foot] ++ l0). apply Permutation_app_comm. simpl. tauto. }
    unfold valid_pq. Exists arr (root :: junk). unfold heap_size, heap_capacity. simpl.
    replace (Zlength vret) with (Zlength (root :: l0)). 2: { apply Permutation_Zlength in H6. trivial. }
    apply heapOrdered_bounded_root_heapOrdered in H4.
    entailer!. { (* Pure part inside spatial part *)
      simpl fst in H2. rewrite <- H2. apply Permutation_Zlength in H6. autorewrite with sublist. rewrite <- H6.
      simpl snd. autorewrite with sublist in *. lia. }
    (* Spatial part, this seems a bit uglier than necessary? *)
    change (root :: junk) with ([root] ++ junk). rewrite app_assoc. do 2 rewrite harray_split.
    apply Permutation_Zlength in H6.
    rewrite app_comm_cons. rewrite Zlength_app. rewrite H6. rewrite Zlength_app.
    assert (Zlength (root :: l0) = Zlength vret). { rewrite <- H6. do 2 rewrite Zlength_cons. trivial. }
    do 3 rewrite app_comm_cons.
    do 4 rewrite Zlength_app. rewrite H11.
    do 2 rewrite Zlength_one.
    rewrite Zlength_cons.
    rewrite H3, H11. cancel.
Time Qed.

Lemma body_less: semax_body Vprog Gprog f_less less_spec.
Proof.
  start_function.
  unfold harray.
  forward.
  rewrite Znth_map; trivial.
  entailer!.
  forward.
  do 2 (rewrite Znth_map; trivial).
  entailer!.
  forward.
  repeat rewrite Znth_map in *; trivial.
  entailer!.
Time Qed.

Lemma body_size: semax_body Vprog Gprog f_size size_spec.
Proof.
  start_function.
  unfold valid_pq.
  Intros arr junk.
  forward.
  forward.
  unfold valid_pq.
  Exists arr. Exists junk.
  entailer!.
Time Qed.

Lemma body_capacity: semax_body Vprog Gprog f_capacity capacity_spec.
Proof.
  start_function.
  unfold valid_pq.
  Intros arr junk.
  forward.
  forward.
  unfold valid_pq.
  Exists arr. Exists junk.
  entailer!.
Time Qed.

(* I need this to make a replace work... ugly... *)
Lemma heap_item_rep_morph: forall x y,
  (fst (heap_item_rep x), snd (heap_item_rep y)) = heap_item_rep (fst x, snd y).
Proof. unfold heap_item_rep. destruct x,y; reflexivity. Qed.

Lemma body_exch: semax_body Vprog Gprog f_exch exch_spec.
Proof.
  start_function.
  unfold harray.
  forward. { rewrite Znth_map; trivial. entailer!. }
  forward. { rewrite Znth_map; trivial. entailer!.
    (* C-typing issue? *)
    apply Forall_map in H3.
    rewrite Forall_Znth in H3. specialize (H3 i). do 2 rewrite Zlength_map in H3.
    specialize (H3 H). rewrite Znth_map in H3. 2: rewrite Zlength_map; trivial.
    (* Flailing around solves the goal... *)
    simplify_value_fits in H3. destruct H3.
    rewrite Znth_map in H4; trivial.
    apply H4. discriminate. }
  forward. { repeat rewrite Znth_map; trivial. entailer!. }
  forward.
  forward. { repeat rewrite Znth_map; trivial. entailer!.
    clear H3.
    (* We may be in another C-typing issue... *)
    case (eq_dec i j); intro.
    + subst j. rewrite upd_Znth_same. trivial. rewrite Zlength_map; auto.
    + rewrite upd_Znth_diff; auto. 2,3: rewrite Zlength_map; auto.
      (* So ugly... is there no easier way? *)
      replace (let (x, _) := heap_item_rep _ in x) with (fst (heap_item_rep (Znth j arr_contents))) in H4 by trivial.
      rewrite heap_item_rep_morph, upd_Znth_map in H4.
      apply Forall_map in H4.
      rewrite Forall_Znth in H4. specialize (H4 j).
      do 2 rewrite Zlength_map in H4. rewrite Zlength_upd_Znth in H4. specialize (H4 H0).
      do 2 rewrite Znth_map in H4. 2,3,4: autorewrite with sublist; trivial.
      rewrite upd_Znth_diff in H4; auto. rewrite Znth_map; trivial.
      (* Flailing around solves the goal... *)
      simplify_value_fits in H4. destruct H4.
      apply H4. discriminate. }
  forward.
  forward.
  forward.
  (* Prove postcondition *)
  repeat rewrite upd_Znth_overwrite.
  2,3,4: autorewrite with sublist; auto.
  repeat rewrite upd_Znth_same.
  2,3: autorewrite with sublist; auto.
  case (eq_dec i j); intro.
  + subst j. rewrite upd_Znth_overwrite, upd_Znth_same. 2,3: autorewrite with sublist; auto. simpl fst.
    simpl fst; simpl snd.
    replace (let (x, _) := Znth i (map heap_item_rep arr_contents) in x,
             let (_, y) := Znth i (map heap_item_rep arr_contents) in y)
            with (heap_item_rep (Znth i arr_contents)) by (rewrite Znth_map; auto).
    rewrite upd_Znth_map, upd_Znth_same_Znth; trivial.
    rewrite Zexchange_eq. Intros. unfold harray. go_lower. cancel.
  + rewrite upd_Znth_diff; auto. 2,3: rewrite Zlength_map; auto. simpl fst.
    simpl fst; simpl snd.
    replace (let (x, _) := Znth j (map heap_item_rep arr_contents) in x,
             let (_, y) := Znth j (map heap_item_rep arr_contents) in y)
            with (heap_item_rep (Znth j arr_contents)) by (rewrite Znth_map; auto).
    replace (let (x, _) := Znth i (map heap_item_rep arr_contents) in x,
             let (_, y) := Znth i (map heap_item_rep arr_contents) in y)
            with (heap_item_rep (Znth i arr_contents)) by (rewrite Znth_map; auto).
    do 2 rewrite upd_Znth_map.
    rewrite fold_harray'. 2: autorewrite with sublist; trivial.
    replace (upd_Znth j (upd_Znth i arr_contents (Znth j arr_contents)) (Znth i arr_contents)) with (Zexchange arr_contents i j).
    go_lower. cancel.
    apply Znth_eq_ext. { rewrite Zlength_Zexchange. autorewrite with sublist. trivial. }
    intros. rewrite Zlength_Zexchange in H1. case (eq_dec i0 j); intro.
    * subst i0. rewrite upd_Znth_same. 2: autorewrite with sublist; trivial.
      rewrite Znth_Zexchange'; trivial.
    * case (eq_dec i0 i); intro. subst i0.
      rewrite upd_Znth_diff. rewrite upd_Znth_same. rewrite Znth_Zexchange; trivial. 1,2,3,4: autorewrite with sublist; trivial.
      rewrite Znth_Zexchange''; auto.
      repeat rewrite upd_Znth_diff; autorewrite with sublist; trivial.
Time Qed.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Construction.Product.
Require Import Category.Structure.Monoidal.

Generalizable All Variables.

(* ProductFunctor is a mapping between product categories. *)

#[export]
Program Instance ProductFunctor
        {C : Category} {D : Category} {F : C ⟶ D}
        {J : Category} {K : Category} {G : J ⟶ K} :
  (C ∏ J) ⟶ (D ∏ K) := {
  fobj := fun x => (F (fst x), G (snd x));
  fmap := fun _ _ f => (fmap[F] (fst f), fmap[G] (snd f));
  fmap_respects := fun x y f g eqv =>
    (fmap_respects (fst x) (fst y) (fst f) (fst g) (fst eqv),
     fmap_respects (snd x) (snd y) (snd f) (snd g) (snd eqv));
  fmap_id := fun x =>
    (@fmap_id C D F (fst x), @fmap_id J K G (snd x));
  fmap_comp := fun x y z f g =>
    (@fmap_comp C D F (fst x) (fst y) (fst z) (fst f) (fst g),
     @fmap_comp J K G (snd x) (snd y) (snd z) (snd f) (snd g))
}.

Notation "F ∏⟶ G" := (@ProductFunctor _ _ F _ _ G) (at level 9).

Program Definition ProductFunctor_swap
        {C : Category} {D : Category}
        {J : Category} {K : Category}
        (F : (C ∏ J) ⟶ (D ∏ K)) : (J ∏ C) ⟶ (K ∏ D) := {|
  fobj := fun x => Swap (F (Swap x));
  fmap := fun _ _ f => _
|}.
Next Obligation.
  simpl in *.
  split; apply F; split; assumption.
Defined.
Next Obligation.
  proper; simpl; simplify; simpl in *.
  - rewrite !let_snd.
    rewrites; reflexivity.
  - rewrite !let_fst.
    rewrites; reflexivity.
Qed.
Next Obligation.
  rewrite !let_fst, !let_snd; cat.
Qed.
Next Obligation.
  simpl in *.
  rewrite !let_fst, !let_snd; simplify;
  rewrite ?fst_comp, ?snd_comp;
  rewrite <- fmap_comp; reflexivity.
Qed.

(* If we have a monoidal structural for one of the categories, we can project
   out one or the other side of the [ProductFunctor]. *)

Program Definition ProductFunctor_fst
        {C : Category} {D : Category}
        {J : Category} `{@Monoidal J} `{K : Category}
        (F : (C ∏ J) ⟶ (D ∏ K)) : C ⟶ D := {|
  fobj := fun x => fst (F (x, I));
  fmap := fun x y f => fst (@fmap _ _ F (x, I) (y, I) (f, id));
  fmap_respects := fun x y f g eqv =>
    fst (@fmap_respects _ _ F (x, I) (y, I) (f, id) (g, id)
                        (eqv, reflexivity _));
  fmap_id := fun x => fst (@fmap_id _ _ F (x, I));
  fmap_comp := fun x y z f g =>
    _ (fst (@fmap_comp _ _ F (x, I) (y, I) (z, I) (f, id) (g, id)))
|}.
Next Obligation.
  intros.
  rewrite fst_comp.
  rewrite <- fmap_comp; simpl.
  rewrite id_left; reflexivity.
Qed.

Program Definition ProductFunctor_snd
        {C : Category} `{@Monoidal C} `{D : Category}
        {J : Category} {K : Category}
        (F : (C ∏ J) ⟶ (D ∏ K)) : J ⟶ K := {|
  fobj := fun x => snd (F (I, x));
  fmap := fun x y f => snd (@fmap _ _ F (I, x) (I, y) (id, f));
  fmap_respects := fun x y f g eqv =>
    snd (@fmap_respects _ _ F (I, x) (I, y) (id, f) (id, g)
                        (reflexivity _, eqv));
  fmap_id := fun x => snd (@fmap_id _ _ F (I, x));
  fmap_comp := fun x y z f g =>
    _ (snd (@fmap_comp _ _ F (I, x) (I, y) (I, z) (id, f) (id, g)))
|}.
Next Obligation.
  intros.
  rewrite snd_comp.
  rewrite <- fmap_comp; simpl.
  rewrite id_left; reflexivity.
Qed.


Require Import LF.
Require Import Map.

Inductive type0 : Type :=
| tunit : type0
| tbool : type0
| tpair : type0 -> type0 -> type0
| tsum  : type0 * nat -> type0 * nat -> type0
| tlist : type0 -> nat -> type0.

Inductive type1 : Type :=
| tfun : nat -> nat -> list type0 -> type0 -> type1.

Module VarEq <: EQ_TYPE.

  Definition t := nat.

  Definition eq := Nat.eqb.

  Theorem eq_refl : forall x,
    true = eq x x.
  Proof.
    intros. unfold eq. Search (Nat.eqb _ _).
    apply beq_nat_refl.
  Qed.

End NatEq.

Module NatMap := Make(NatEq).

(* Definition context := var -> option type0. *)
Definition context := NatMap.t type0.

Print context.
Definition context_empty : context := fun _ => None.
Definition context_add (Gamma : context) (p : var * type0) : context :=
  fun x => let (y, t) := p in if Nat.eqb x y then Some t else Gamma x.
Definition context_union (Gamma1 Gamma2 : context) : context :=
  fun x => match Gamma1 x with
  | Some t => Some t
  | None => Gamma2 x
  end.

(* Definition 5.1 *)
Fixpoint erase0 (t : type0) : LF.type0 :=
  match t with
  | tunit => LF.tunit
  | tbool => LF.tbool
  | tpair t1 t2 => LF.tpair (erase0 t1) (erase0 t2)
  | tsum (t1, _) (t2, _) => LF.tsum (erase0 t1) (erase0 t2)
  | tlist t1 _ => LF.tlist (erase0 t1)
  end.

Fixpoint erase1 (t : type1) : LF.type1 :=
  let (_, _, t1s, t2) := t in
  LF.tfun (Vector.of_list (List.map erase0 t1s)) (erase0 t2).


Set Implicit Arguments.
Require Import Morphisms Lia.
From Undecidability.HOU Require Import std.std.
From Undecidability.HOU.calculus Require Import
  prelim terms syntax semantics confluence typing order.

Set Default Proof Using "Type".

(* * Weak Normalisation *)

Section SemanticTyping.

  Variable (X: Const).

  Definition SemType := exp X -> Prop.

  (* ** Logical Relations *)
  Definition active (s: exp X) :=
    match s with lambda s => True | _ => False end.

  Definition C (T: SemType) (s: exp X) :=
    exists t, s ▷ t /\ (active t -> T t).

  Fixpoint V (A: type) (s: exp X) :=
    match A with
    | typevar beta => False
    | A → B => match s with
              | lambda s => normal s /\
                      forall t delta, C (V A) t -> C (V B) ((ren delta (lambda s)) t)
              | _ => False
              end
    end.

  Definition E A := C (V A).
  Definition G Gamma gamma := forall i A, nth Gamma i = Some A -> E A (gamma i).

  Lemma E_evaluates s A:
    E A s -> exists t, s ▷ t.
  Proof. intros (t & H1 & H2); exists t; intuition. Qed.

  Lemma closure_under_expansion s t A:
    s >* t -> E A s -> E A t.
  Proof.
    intros H [v [[H1 H2] H3]]. exists v. intuition. split; eauto.
    eapply confluence_normal_left; eauto.
  Qed.

  Lemma closure_under_reduction s t A:
    s >* t -> E A t -> E A s.
  Proof.
    intros H [v [[H1 H2] H3]]. exists v; intuition. split; eauto.
  Qed.

  Definition ren_closed (S: SemType) :=
    forall delta s, S s -> S (ren delta s).

  Lemma ren_closed_C S: ren_closed S -> ren_closed (C S).
  Proof.
    intros H delta s; unfold C in *; intros (t & [H1 H2] & H3).
    exists (ren delta t); split.
    split; eauto using ren_steps, normal_ren.
    intros H4. eapply H, H3. destruct t; cbn in *; intuition.
  Qed.

  Lemma ren_closed_V A: ren_closed (V A).
  Proof.
    induction A as [beta | A IHA B IHB].
    - intros ? ? [].
    - intros delta []; cbn in *; eauto; intros [H1 H2].
      split; eauto using normal_ren.
      intros t delta' H'. asimpl.
      replace (_ • e) with (ren (upRen_exp_exp (delta >> delta')) e)by now asimpl.
      now eapply H2.
  Qed.

  Lemma ren_closed_E A: ren_closed (E A).
  Proof.
    eapply ren_closed_C, ren_closed_V.
  Qed.

  Lemma ren_closed_G Gamma gamma delta: G Gamma gamma -> G Gamma (gamma >> ren delta).
  Proof.
    intros H x A E. eapply ren_closed_E, H, E.
  Qed.

  Lemma E_var x A: E A (var x).
  Proof.
    exists (var x). unfold evaluates; cbn; intuition.
  Qed.

  Lemma G_id Gamma: G Gamma var.
  Proof.
    intros ???. eapply E_var.
  Qed.

  Lemma G_cons Gamma A s gamma:
    G Gamma gamma -> E A s -> G (A :: Gamma) (s .: gamma).
  Proof.
    intros. intros [|] B H'; cbn in *.
    now injection H' as ->. now eapply H.
  Qed.

  Lemma G_up Gamma A gamma:
    G Gamma gamma -> G (A :: Gamma) (up gamma).
  Proof.
    eauto using G_cons, ren_closed_G, E_var.
  Qed.

  Lemma compat_var Gamma i A gamma:
    nth Gamma i = Some A -> G Gamma gamma -> E A (gamma i).
  Proof. intuition. Qed.

  Lemma compat_const c:
    E (ctype X c) (const c).
  Proof.
    exists (const c); split; [split|]; cbn; intuition.
  Qed.

  Lemma compat_lambda A B s:
    E B s -> (forall t delta, E A t -> E B (ren delta (lambda s) t)) ->  E (A → B) (lambda s).
  Proof.
    intros [t [[H1 H2] _]] ?; cbn; exists (lambda t); intuition; split; rewrite ?H1; eauto.
    intros; eapply closure_under_expansion; [|eauto]; now rewrite H1.
  Qed.

  Lemma compat_app A B s t:
    E (A → B) s -> E A t -> E B (s t).
  Proof.
    intros (v1 & [H1 H2] & H3). intros (v2 & [H4 H5] & H6).
    eapply closure_under_reduction. rewrite H1, H4; eauto.
    destruct v1.
    1, 2, 4: eexists; split; [split|]; eauto; cbn; intuition.
    cbn in H3; mp H3; cbn; intuition.
    specialize (H0 v2 id); asimpl in H0; unfold id in H0.
    eapply H0; exists v2; split; [split|]; eauto.
  Qed.

End SemanticTyping.

(* ** Semantic Soundness *)
Section Soundness.

  Context {X: Const}.

  Implicit Type (s: exp X).

  Definition semtyping Gamma s A := forall gamma, G Gamma gamma -> E A (gamma • s).

  Notation "Gamma ⊨ s : A" := (semtyping Gamma s A) (at level 80, s at level 99).

  Lemma semantic_soundness Gamma s A:
    Gamma ⊢ s : A -> Gamma ⊨ s : A.
  Proof.
    induction 1.
    - intros ??; cbn; eapply compat_var; eauto.
    - intros ??; cbn; eapply compat_const.
    - intros ??; cbn; eapply compat_lambda; eauto using G_up.
      intros; eapply closure_under_reduction. cbn; dostep; now asimpl.
      eapply IHtyping, G_cons; eauto.
      replace (gamma >> _) with (gamma >> ren delta) by now asimpl.
      eapply ren_closed_G; eauto.
    - intros ??; cbn; eapply compat_app; eauto.
  Qed.

  (* ** Termination *)
  Lemma termination_steps Gamma s A:
    Gamma ⊢ s : A -> exists t, s ▷ t.
  Proof.
    intros H % semantic_soundness.
    specialize (H var (@G_id X Gamma)).
    asimpl in H; unfold id in H.
    eapply E_evaluates, H.
  Qed.

  Lemma ordertyping_termination_steps Gamma n s A:
    Gamma ⊢(n) s : A -> exists t, s ▷ t.
  Proof.
    now intros ? % ordertyping_soundness % termination_steps.
  Qed.

End Soundness.


Require Export desargues2Dlemmas3.
Require Export desargues3Dspecial.

Module Desargues2Dfinal  (DecPoints: FSetInterface.WS) (M: RankProjectiveSpace DecPoints).

Module Export Desargues_2D_lem3 := Desargues2Dlemmas3 DecPoints M.
Module Export Desargues_3D := Desargues3Dspecial DecPoints M.

Section desargues_theorem.
Variables A' B' C' : Point.
Variables A B C : Point.

Variables O : Point.

Variable rABC : rk(triple A B C)=3.
Variable rA'B'C' : rk(triple A' B' C')=3.
Variable rABCA'B'C'O : rk(union (triple A B C) (union (triple A' B' C') (singleton O)))=3.

Variable rABO : rk(triple A B O)=3.
Variable rACO :rk(triple A C O)=3.
Variable rBCO : rk (triple B C O)=3.

Variable rAA'O : rk(triple A A' O)=2.
Variable rBB'O : rk(triple B B' O)=2.
Variable rCC'O : rk(triple C C' O)=2.

Variable rA'O : rk(couple A' O)=2.
Variable rB'O : rk(couple B' O)=2.
Variable rC'O : rk(couple C' O)=2.

Lemma rA'B'O' : rk(triple A' B' O)=3.
Proof.
eapply (l1_scheme A' B' A B O); try assumption.
Qed.

Lemma rA'C'O' :rk(triple A' C' O)=3.
Proof.
eapply (l1_scheme A' C' A C O); try assumption.
Qed.

Lemma rB'C'O' : rk (triple B' C' O)=3.
Proof.
eapply (l1_scheme B' C' B C O); try assumption.
Qed.

Hint Resolve rA'B'O' rA'C'O' rB'C'O' : rk.

(* all points are distinct, especially ABC A'B'C and O *)
(* If needed, for any 2 points, rk(X,Y)=2 *)
(* triangles are truely perspective in the plane *)

Variable rAA' : rk(couple A A')=2.
Variable rBB' : rk(couple B B')=2.
Variable rCC' : rk(couple C C')=2.

Variables alpha beta gamma : Point.

Variable rABgamma : rk(triple A B gamma)=2.
Variable rA'B'gamma : rk(triple A' B' gamma)=2.

Variable rACbeta : rk(triple A C beta)=2.
Variable rA'C'beta : rk(triple A' C' beta)=2.

Variable rBCalpha : rk(triple B C alpha)=2.
Variable rB'C'alpha : rk(triple B' C' alpha) =2.

Lemma Desargues_plane : rk (triple alpha beta gamma) <= 2.
Proof.
generalize rA'B'O';intro rA'B'O'.
generalize rA'C'O';intro rA'C'O'.
generalize rB'C'O';intro rB'C'O'.
elim (l2rABOP A' B' C' A B C O); try assumption.
intros P (rABOP, rOP).
elim (ex_o O P).
intros o (rOPo,(rOo, rPo)).
setoid_replace (triple O P o) with (triple o O P) in rOPo by fsetdecide.
assert (T:exists a : Point, rk (triple o A a) = 2 /\ rk (triple P A' a) = 2)
 by (eapply (ra A' B' C' A B C O);solve [eauto with rk]).
elim T;intros a (Ha2,Ha2');clear T.
assert (Tb:exists b : Point, rk (triple o B b) = 2 /\ rk (triple P B' b) = 2)
 by (eapply (rb A' B' C' A B C O);solve [eauto with rk]).
elim Tb;intros b (Hb2,Hb2');clear Tb.
assert (Tc:exists c : Point, rk (triple o C c) = 2 /\ rk (triple P C' c) = 2)
 by (eapply rc;solve [eauto with rk]).
elim Tc;intros c (Hc2,Hc2');clear Tc.
(* we prove r(a,b,c)=3 in advance, so we can reuse it in subsequent sections of the proof *)
assert (rabc3:rk(triple a b c)=3).
apply le_antisym.
apply rk_triple_le.
assert (rk (union (triple a b c) (couple o A))>=4).
generalize (matroid3 (union (triple a b c) (couple o A)) (triple o B b)).
setoid_replace (union (union (triple a b c) (couple o A)) (triple o B b)) with
(union (triple a b c) (triple o A B)) by (unfold Equal; split; fsetdecide_no_hyps).
assert (rk(union (triple a b c) (triple o A B))>=4).
generalize (matroid3 (union (triple a b c) (triple o A B)) (triple o C c)).
assert (rk (union (union (triple a b c) (triple o A B)) (triple o C c)) >=4).
assert (rk (add c (triple A B C)) >=4).
generalize (rABOc A' B' C' A B C O rABC rA'B'C' rABCA'B'C'O rABO rACO rBCO rA'B'O' rA'C'O'
            rB'C'O' rAA'O rBB'O rCC'O rAA' rBB' rCC' P rABOP rOP o); intro Hr.
assert (rk (add c (triple A B C)) >= 4).
setoid_replace (triple A B C) with (triple C B A) by fsetdecide_no_hyps.
apply (rk3_4 O B A C c).
apply le_antisym.
assert (rk (union (triple A B C) (union (triple A' B' C') (singleton O))) >= rk (add C (triple O B A))).
apply matroid2; fsetdecide_no_hyps.
omega.
assert (rk(triple A B C)<=rk(add C (triple O B A))).
apply matroid2; fsetdecide_no_hyps.
omega.
setoid_replace (triple B A C) with (triple A B C) by fsetdecide_no_hyps.
assumption.
setoid_replace (triple O B A) with (triple A B O) by fsetdecide_no_hyps.
eapply Hr; try eassumption.
omega.
assert (rk (union (union (triple a b c) (triple o A B)) (triple o C c)) >=rk (add c (triple A B C))).
apply matroid2; fsetdecide_no_hyps.
omega.
assert (rk (inter (union (triple a b c) (triple o A B)) (triple o C c)) >=
rk (couple o c)).
apply matroid2; fsetdecide_no_hyps.
assert (rk (couple o c)>=2).
setoid_replace (couple o c) with (couple c o) by fsetdecide_no_hyps.
generalize (rco A' B' C' A B C O rABC rA'B'C' rABCA'B'C'O rABO rACO rBCO rA'B'O'
            rA'C'O' rB'C'O' rAA'O rBB'O rCC'O rAA' rBB' rCC' P rABOP rOP o rOPo rOo rPo c Hc2 Hc2'); omega.
omega.
assert (rk(inter (union (triple a b c) (couple o A)) (triple o B b))>=rk(couple o b)).
apply matroid2; fsetdecide_no_hyps.
assert (rk(couple o b)>=2).
setoid_replace (couple o b) with (couple b o) by fsetdecide_no_hyps.
generalize (rbo A' B' C' A B C O rABC rA'B'C' rABCA'B'C'O rABO rACO rBCO rA'B'O' rA'C'O' rB'C'O'
            rAA'O rBB'O rCC'O rAA' rBB' rCC' P rABOP rOP o rOPo rOo rPo b Hb2 Hb2') ; omega.
omega.
generalize (matroid3 (triple a b c) (triple o A a)).
setoid_replace (union (triple a b c) (triple o A a))
with (union (triple a b c) (couple o A)) by (unfold Equal; split; fsetdecide_no_hyps).
assert (rk(inter (triple a b c) (triple o A a))>=rk(singleton a)).
apply matroid2; fsetdecide_no_hyps.
rewrite rk_singleton in H0.
omega.

(* end of the proof of r(a,b,c)=3 *)

eapply (Desargues A B C a b c alpha beta gamma o).
setoid_replace (triple A a o) with (triple o A a) by fsetdecide_no_hyps;assumption.
setoid_replace (triple B b o) with (triple o B b) by fsetdecide_no_hyps;assumption.
setoid_replace (triple C c o) with (triple o C c) by fsetdecide_no_hyps;assumption.
assumption.
assumption.

(* r(a,b,c,A,B,C)>=4 *)
assert (rk(add b (triple A B C))<= rk (union (triple a b c) (triple A B C))).
apply matroid2; fsetdecide_no_hyps.
assert (rk(add b (triple A B C)) >= 4).
generalize (rABOb A' B' C' A B C O rABC rA'B'C' rABCA'B'C'O rABO rACO rBCO
            rA'B'O' rA'C'O' rB'C'O' rAA'O rBB'O rCC'O rAA' rBB' rCC' P rABOP
            rOP o rOPo rOo  rPo b Hb2 Hb2'); intros HrABOb.
generalize (matroid3 (add b (triple A B C)) (add O (triple A B C))).
setoid_replace (union (add b (triple A B C)) (add O (triple A B C)))
with (union (triple A B C) (couple O b)) by (unfold Equal; split; fsetdecide_no_hyps).
assert (rk(inter (add b (triple A B C)) (add O (triple A B C)))>=rk(triple A B C)).
apply matroid2; fsetdecide_no_hyps.
assert (rk(add b (triple A B C))<=rk(union (triple A B C) (couple O b))).
apply matroid2; fsetdecide_no_hyps.
assert (rk (add b (triple A B C))>=4).
setoid_replace (triple A B C) with (triple C A B) by fsetdecide_no_hyps.
apply (rk3_4 O A B C b).
apply le_antisym.
assert (rk(add C (triple O A B))<=rk
                (union (triple A B C) (union (triple A' B' C') (singleton O))) ).
apply matroid2; fsetdecide_no_hyps.
omega.
assert (rk(add C (triple O A B)) >=rk(triple A B C)).
apply matroid2; fsetdecide_no_hyps.
omega.
assumption.
setoid_replace (triple O A B) with (triple A B O) by fsetdecide_no_hyps.
assumption.
omega.
assert (rk(add C (triple O A B))<=rk
                (union (triple A B C) (union (triple A' B' C') (singleton O)))).
apply matroid2; fsetdecide_no_hyps.
omega.

(* gamma *)
apply (beta_ok' A' C' B' A C B O) with (P:=P) (o:=o) (alpha:=alpha) (gamma:=beta) (b:=c); try eassumption.
setoid_replace (triple A C B) with (triple A B C) by fsetdecide_no_hyps; assumption.
setoid_replace (triple A' C' B') with (triple A' B' C') by fsetdecide_no_hyps; assumption.
setoid_replace (triple A C B) with (triple A B C) by fsetdecide_no_hyps.
setoid_replace (triple A' C' B') with (triple A' B' C') by fsetdecide_no_hyps; assumption.
setoid_replace (triple C B O) with (triple B C O) by fsetdecide_no_hyps;assumption.
setoid_replace (triple C' B' O) with (triple B' C' O) by fsetdecide_no_hyps; eauto with rk.
apply (rACOP A' B' C' A B C); try assumption.
setoid_replace (triple C B alpha) with (triple B C alpha) by fsetdecide_no_hyps; assumption.
setoid_replace (triple C' B' alpha) with (triple B' C' alpha) by fsetdecide_no_hyps; assumption.
setoid_replace (triple a c b) with (triple a b c) by fsetdecide_no_hyps; assumption.

assumption.
(* beta *)
apply (beta_ok' A' B' C' A B C O) with (P:=P) (o:=o) (alpha:=alpha) (gamma:=gamma) (b:=b); try eassumption.
eauto with rk.

(* alpha *)
apply (beta_ok' B' A' C' B A C O) with (P:=P) (o:=o) (alpha:=beta) (gamma:=gamma) (b:=a); try eauto with rk.
setoid_replace (triple B A C) with (triple A B C) by fsetdecide_no_hyps ; assumption.
setoid_replace (triple B' A' C') with (triple A' B' C') by fsetdecide_no_hyps ; assumption.
setoid_replace (triple B A C) with (triple A B C) by fsetdecide_no_hyps.
setoid_replace (triple B' A' C') with (triple A' B' C') by fsetdecide_no_hyps.
assumption.
setoid_replace (triple B A O) with (triple A B O) by fsetdecide_no_hyps; assumption.
setoid_replace (triple B' A' O) with (triple A' B' O) by fsetdecide_no_hyps; eauto with rk.
eauto with rk.
eauto with rk.
setoid_replace (triple B A O) with (triple A B O) by fsetdecide_no_hyps; assumption.
setoid_replace (triple B A gamma) with (triple A B gamma) by fsetdecide_no_hyps; assumption.
setoid_replace (triple B' A' gamma) with (triple A' B' gamma) by fsetdecide_no_hyps; assumption.
setoid_replace (triple b a c) with (triple a b c) by fsetdecide_no_hyps; assumption.

assumption.
Qed.

End desargues_theorem.

End Desargues2Dfinal.


From mathcomp Require Import ssreflect ssrfun.
From rlzrs Require Import all_rlzrs.
Require Import all_baire cs prod sum func classical_func facts.
Require Import Morphisms.

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

Local Open Scope cs_scope.
Section isomorphisms.
Definition isomorphism (X Y: cs) (f: X c-> Y) :=
	exists (g: Y c-> X), cancel (projT1 f) (projT1 g) /\ cancel (projT1 g) (projT1 f).

Definition isomorphic (X Y: cs):= exists f, @isomorphism X Y f.
Arguments isomorphic {X Y}.

Notation "X ~=~ Y" := (@isomorphic X Y) (at level 2).

Lemma iso_ref: Reflexive (@isomorphic).
Proof. by move => X; exists (exist_c (id_cont X)); exists (exist_c (id_cont X)). Qed.

Lemma iso_sym: Symmetric (@isomorphic).
Proof. by move => X Y [f [g [cncl cncl']]]; exists g; exists f. Qed.

Lemma iso_trans: Transitive (@isomorphic).
Proof.
move => X Y Z [f [g [cncl1 cncl2]]] [f' [g' [cncl1' cncl2']]].
exists (f' \o_cs f); exists (g \o_cs g').
by rewrite /=; split; apply can_comp.
Qed.

Global Instance iso_equiv: Equivalence (@isomorphic).
Proof. split; [exact/iso_ref | exact/iso_sym | exact/iso_trans]. Qed.
End isomorphisms.
Notation "X ~=~ Y" := (@isomorphic X Y) (at level 2).

Global Instance prod_prpr:
  Proper (isomorphic ==> isomorphic ==> isomorphic) cs_prod.
Proof.
  move => X X' [f [f' [cnclf cnclf']]] Y Y' [g [g' [cnclg cnclg']]].
  have fcont: (projT1 f) \is_continuous by apply/ass_cont/(projT2 f).
  have gcont: (projT1 g) \is_continuous by apply/ass_cont/(projT2 g).
  have f'cont: (projT1 f') \is_continuous by apply/ass_cont/(projT2 f').
  have g'cont: (projT1 g') \is_continuous by apply/ass_cont/(projT2 g').
  exists (exist_c (fprd_cont fcont gcont)).
  exists (exist_c (fprd_cont f'cont g'cont)).
  split; case => [x y /=]; rewrite /fprd /=.
  - by have /= ->:= cnclf x; have /= ->:= cnclg y.
  by have /= ->:= cnclf' x; have /= ->:= cnclg' y.
Qed.

Global Instance sum_prpr:
  Proper (isomorphic ==> isomorphic ==> isomorphic) cs_sum.
Proof.
  move => X X' [f [f' [cnclf cnclf']]] Y Y' [g [g' [cnclg cnclg']]].
  have fcont: (projT1 f) \is_continuous by apply/ass_cont/(projT2 f).
  have gcont: (projT1 g) \is_continuous by apply/ass_cont/(projT2 g).
  have f'cont: (projT1 f') \is_continuous by apply/ass_cont/(projT2 f').
  have g'cont: (projT1 g') \is_continuous by apply/ass_cont/(projT2 g').
  exists (exist_c (fsum_cont fcont gcont)).
  exists (exist_c (fsum_cont f'cont g'cont)).
  split; case => [x | y]; rewrite /fsum /=.
  - + * by have /= ->:= cnclf x.
  - + by have /= ->:= cnclg y.
  - by have /= ->:= cnclf' x.
  by have /= ->:= cnclg' y.
Qed.


Definition tautology : forall P : Prop, P -> P
  := fun (P : Prop) => fun P => P.

Definition Modus_tollens : forall P Q : Prop, ~Q /\ (P -> Q) -> ~P
  := fun (P Q : Prop) (H : ~ Q /\ (P -> Q)) =>
  match H with
  | conj HnQ HPQ => fun (HP : P) => HnQ (HPQ HP)
  end.

Definition Disjunctive_syllogism : forall P Q : Prop, (P \/ Q) -> ~P -> Q
 := fun (P Q : Prop) (HdPQ : P \/ Q) (HnP : ~ P) =>
  match HdPQ with
  | or_introl HP =>
    match HnP HP return Q with
    end
  | or_intror HQ => HQ
  end.

Definition tautology_on_Set : forall A : Set, A -> A
  := fun (A : Set) => fun A => A.

Definition Modus_tollens_on_Set : forall A B : Set, (B -> Empty_set) * (A -> B) -> (A -> Empty_set)
  := fun (A B : Set) (H : (B -> Empty_set) * (A -> B)) (HA : A) => fst H ((snd H) HA).

Definition Disjunctive_syllogism_on_Set : forall A B : Set, (A + B) -> (A -> Empty_set) -> B
 := fun (A B : Set) (HsAB : A + B) (HnA : (A -> Empty_set)) =>
  match HsAB with
  | inl HA =>
    match HnA HA return B with
    end
  | inr HB => HB
  end.


Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div fintype.
Require Import tuple finfun bigop.

Lemma big_cat_example f :
  \sum_(1 <= n < 11) f(n) = \sum_(1 <= n < 6) f(n) + \sum_(6 <= n < 11) f(n).
Proof.
 by rewrite -big_cat.
Qed.

(* hint: use big_nat_recr and big_nil *)
Lemma exo19 : forall n : nat, 2 * (\sum_(0 <= x < n.+1) x) = n * n.+1.
Proof.
Abort.

Parameter n : nat.
Parameters a b : 'I_n.

(* use bigA_distr_big to prove the following *)

Lemma bigA_distr_big_test : (a + b)^2 = a^2 + 2 * a * b + b^2.
Proof.
case: (boolP (a == b)) => [/eqP -> | ab].
  ring.
transitivity (\prod_(j : 'I_2) (\sum_(i in [predU (pred1 a) & (pred1 b)]) i)).
  rewrite big_ord_recr /=.
  rewrite big_ord_recr /=.
  rewrite big_ord0.
  rewrite mul1n.
  rewrite expnS.
  rewrite expn1.
  rewrite bigU /=; last first.
    by rewrite disjoint1.
  rewrite (big_pred1 a) //.
  by rewrite (big_pred1 b).
rewrite bigA_distr_big /=.
pose f1 := [ffun x : 'I_2 => match x with Ordinal O _ => a | Ordinal 1 _ => a | _ => a end].
pose f2 := [ffun x : 'I_2 => match x with Ordinal O _ => a | Ordinal 1 _ => b | _ => a end].
pose f3 := [ffun x : 'I_2 => match x with Ordinal O _ => b | Ordinal 1 _ => a | _ => a end].
pose f4 := [ffun x : 'I_2 => match x with Ordinal O _ => b | Ordinal 1 _ => b | _ => a end].
have f1f2 : f1 != f2.
  apply/eqP/ffunP.
  move/(_ (@Ordinal _ 1 _)).
  move/(_ erefl).
  rewrite !ffunE.
  by apply/eqP.
have f1f3 : f1 != f3.
  apply/eqP/ffunP.
  move/(_ (@Ordinal _ 0 _)).
  move/(_ erefl).
  rewrite !ffunE.
  by apply/eqP.
have f1f4 : f1 != f4.
  apply/eqP/ffunP.
  move/(_ (@Ordinal _ 0 _)).
  move/(_ erefl).
  rewrite !ffunE.
  by apply/eqP.
have f2f3 : f2 != f3.
  apply/eqP/ffunP.
  move/(_ (@Ordinal _ 0 _)).
  move/(_ erefl).
  rewrite !ffunE.
  by apply/eqP.
have f2f4 : f2 != f4.
  apply/eqP/ffunP.
  move/(_ (@Ordinal _ 0 _)).
  move/(_ erefl).
  rewrite !ffunE.
  by apply/eqP.
have f3f4 : f3 != f4.
  apply/eqP/ffunP.
  move/(_ (@Ordinal _ 1 _)).
  move/(_ erefl).
  rewrite !ffunE.
  by apply/eqP.
set tmp := ffun_on _.
transitivity (\sum_(f in [predU (pred1 f1) & [predU (pred1 f2) & [predU (pred1 f3) & (pred1 f4)]]]) \prod_(i < 2) f i).
  apply eq_bigl => /= f.
  move H : (f \in tmp) => [|].
    apply/esym.
    rewrite !inE /=.
    move/familyP : (H).
    move/(_ (@Ordinal _ O _)).
    move/(_ erefl).
    rewrite /= !inE.
    case/orP => /eqP H1.
    - move/familyP : (H).
      move/(_ (@Ordinal _ 1 _)).
      move/(_ erefl).
      rewrite /= !inE.
      case/orP => /eqP H2.
      + rewrite (_ : f == f1) //.
        apply/eqP/ffunP.
        case.
        case => [i|].
          rewrite ffunE /= -H1.
          congr (f (Ordinal _)).
          by apply eq_irrelevance.
        case=> i //.
        rewrite ffunE /= -H2.
        congr (f (Ordinal _)).
        by apply eq_irrelevance.
      + rewrite (_ : f == f2).
          by rewrite orbC.
        apply/eqP/ffunP.
        case.
        case => [i|].
          rewrite ffunE /= -H1.
          congr (f (Ordinal _)).
          by apply eq_irrelevance.
        case=> i //.
        rewrite ffunE /= -H2.
        congr (f (Ordinal _)).
        by apply eq_irrelevance.
    - move/familyP : (H).
      move/(_ (@Ordinal _ 1 _)).
      move/(_ erefl).
      rewrite /= !inE.
      case/orP => /eqP H2.
      + rewrite (_ : f == f3).
          by rewrite orbA /= orbC.
        apply/eqP/ffunP.
        case.
        case => [i|].
          rewrite ffunE /= -H1.
          congr (f (Ordinal _)).
          by apply eq_irrelevance.
        case=> i //.
        rewrite ffunE /= -H2.
        congr (f (Ordinal _)).
        by apply eq_irrelevance.
      + rewrite (_ : f == f4).
          by rewrite 2!orbA orbC.
        apply/eqP/ffunP.
        case.
        case => [i|].
          rewrite ffunE /= -H1.
          congr (f (Ordinal _)).
          by apply eq_irrelevance.
        case=> i //.
        rewrite ffunE /= -H2.
        congr (f (Ordinal _)).
        by apply eq_irrelevance.
  apply/esym/negbTE.
  rewrite !inE /=.
  move/negbT: H; apply contra => H.
  apply/familyP.
  case/orP : H.
    move/eqP => ->.
    case.
    case => [i|].
      by rewrite !inE ffunE eqxx.
    case=> // i.
    by rewrite !inE ffunE eqxx.
  case/orP.
    move/eqP => ->.
    case.
    case=> [i|].
      by rewrite !inE ffunE eqxx.
    case=> // i.
    by rewrite !inE ffunE eqxx orbC.
  case/orP.
    move/eqP => ->.
    case.
    case=> [i|].
      by rewrite !inE ffunE eqxx orbC.
    case=> // i.
    by rewrite !inE ffunE eqxx.
  move/eqP => ->.
  case.
  case=> [i|].
    by rewrite !inE ffunE eqxx orbC.
  case=> // i.
  by rewrite !inE ffunE eqxx orbC.
rewrite bigU /=; last first.
  by rewrite disjoint1 !inE /= negb_or f1f2 /= negb_or f1f3 f1f4.
rewrite bigU /=; last first.
  by rewrite disjoint1 !inE /= negb_or /= f2f3 f2f4.
rewrite bigU /=; last first.
  by rewrite disjoint1 !inE /=.
rewrite (big_pred1 f1) // (big_pred1 f2) // (big_pred1 f3) // (big_pred1 f4) //.
rewrite !big_ord_recr /= !big_ord0 !mul1n !ffunE /=.
ring.
Qed.


(*
 * Module: ThreadProofs
 *
 * Description:
 *  Prove useful theorems about threads and the semantics of SVA-OS.
 *)

(* Load Coq Standard Library modules *)
Require Import Arith.
Require Import List.
Require Import Coq.Logic.Classical_Prop.

(* Load SVAOS specific modules *)
Require Export Semantics.
Require Export InvProofs.
Require Export ICProofs.

(*
 * Theorem: addThreadInText
 *
 * Description:
 *  Show that adding a thread that is in the text segment yields a thread list
 *  that is also in the text segment.
 *)
Theorem addThreadInText : forall (t     : SVAThread)
                                 (tl    : ThreadList)
                                 (cfg   : list nat)
                                 (mmu   : MMU)
                                 (cs ce : nat),
(threadInText t cfg mmu cs ce) /\
(threadListInText tl cfg mmu cs ce) -> threadListInText (t :: tl) cfg mmu cs ce.
Proof.
intros.
destruct H as [H1 H2].
unfold threadListInText.
split.

(* Case 1 *)
auto.

(* Case 2 *)
auto.
Qed.

(*
 * Theorem: replaceThreadInText
 *
 * Description:
 *  Show that replacing a thread in a thread list with another thread
 *  in the text segment keeps the entire thread list in the text segment.
 *)
Theorem replaceThreadInText : forall (t : SVAThread)
                                     (tl  : ThreadList)
                                     (cfg : list nat)
                                     (mmu : MMU)
                                     (cs ce n   : nat),
(threadInText t cfg mmu cs ce) /\ (threadListInText tl cfg mmu cs ce)
->
threadListInText (updateThread n t tl) cfg mmu cs ce.
Proof.
intros t tl cfg mmu cs ce.
induction tl.

(* Cases 1 and 2 *)
intros.
destruct H as [H1 H2].
induction n.
auto.
auto.

(* Case 3 *)
intros.
destruct H as [H1 H2].
destruct H2 as [H2 H3].
fold threadListInText in H3.

assert (threadListInText (a :: tl) cfg mmu cs ce).
apply addThreadInText.
auto.

destruct n.
simpl.
auto.

unfold updateThread.
simpl.
fold updateThread.
auto.
Qed.

(*
 * Theorem: textInThreadMMU
 *
 * Description:
 *  This theorem shows that modifying the mapping for an address that is not
 *  the PC in an SVAThread does not move the thread outside the text segment.
 *)
Theorem textInThreadMMU : forall (t : SVAThread)
                                 (cfg : list nat)
                                 (tlb : TLBTy)
                                 (mmu : MMU)
                                 (v cs ce : nat),
(threadInText t cfg mmu cs ce) /\
(((canThreadSwap t) = true) ->
  (v <> (getThreadPC t)) /\
  (not (In (getThreadPC t) cfg) -> v <> ((getThreadPC t) - 1)))
->
(threadInText t cfg (updateTLB v tlb mmu) cs ce).
Proof.
intros.
destruct H as [H1 H2].
destruct t.
destruct b.

(* Case 1: The thread holds valid processor state *)
unfold canThreadSwap in H2.
destruct H2.
auto.
simpl in H0.
unfold threadInText.
rewrite <- sameMMULookup.
split.
apply H1.
unfold threadInText in H1.
destruct H1 as [H1 H2].
apply imply_to_or in H0.
destruct H2 as [H2 | H2].
left.
auto.
destruct H0 as [H0 | H0].
apply NNPP in H0.
left.
auto.
right.
rewrite <- sameMMULookup.
auto.
rewrite <- pred_of_minus in H0.
apply not_eq_sym.
apply H0.
unfold getThreadPC in H.
apply not_eq_sym.
auto.

(* Case 2: The thread holds no valid state *)
auto.
Qed.

(*
 * Theorem: TLAlwaysInText
 *
 * Description:
 *  Show that the thread list stays within the text segment.
 *)
Theorem TLAlwaysInText: forall (c1 c2 : config),
(c1 ==> c2) /\
(threadListInText
  (getThreadList c1) (getCFG c1) (getCMMU c1) (getTextStart c1) (getTextEnd c1)) /\
(validCFG c1 (getCFG c1)) /\
(textMappedLinear c1) /\
(pcInText c1)
->
(threadListInText
  (getThreadList c2) (getCFG c2) (getCMMU c2) (getTextStart c2) (getTextEnd c2)).
Proof.
intros.
destruct H as [H1 H2].
destruct H2 as [H2 cfg].
destruct cfg as [cfg line].
destruct line as [line pct].
destruct H1.
destruct c.

(* Cases 1 - 6 *)
auto.
auto.
auto.
auto.
auto.
auto.

(* Case 7 *)
simpl.
simpl in H2.
destruct H as [H10 H].
destruct H as [H11 H].
destruct H as [H12 H].
destruct H as [H13 H].
destruct H as [H14 H].
destruct H as [H15 H].
destruct H as [H16 H].
induction tl.

(* Case 7a: Base case: empty thread list *)
auto.

(* Case 7b: Induction case: non-empty thread list *)
simpl in cfg.
simpl in IHtl.
unfold threadListInText.
split.

(* Case 7b1: Show that the first thread is in the text segment *)
unfold threadListInText in H2.
destruct H2 as [H2 H3].
fold threadListInText in H3.
apply textInThreadMMU.
split.

(* Case 7b1a: Show that the thread was valid before the MMU change. *)
auto.

(* Case 7b1b: Show that if the thread is valid, the map is not changing the PC value *)
destruct a.
destruct b.
simpl.
intros.
destruct H0.
unfold threadInText in H2.
destruct H2 as [H4 H5].
rewrite -> H12 in H14.
split.

(* Case 7b1b: Show that the map argument isn't the PC in the thread *)
contradict H14.
rewrite -> H14.
apply and_not_or.
split.
apply le_not_lt.
apply H4.
apply le_not_lt.
apply H4.

(* Case 7b1b: Show that if the thread was swapped, v isn't the previous address *)
rewrite <- pred_of_minus.
apply or_to_imply.
destruct H5.
left.
contradict H0.
auto.
right.
contradict H0.
rewrite <- H0.
contradict H0.
destruct H14 as [H14a | H14b].
destruct H0.
apply le_not_lt in H0.
contradiction.
destruct H0.
apply le_not_lt in H1.
contradiction.

(* Case 7b1c: The thread has not valid PC *)
simpl.
intros.
contradict H0.
auto.

fold threadListInText.
apply IHtl.
destruct H2 as [H2 H20].
auto.
auto.
auto.
auto.

(* Case 8 - 13 *)
auto.
auto.
auto.
auto.
auto.
auto.

(* Case 14 *)
simpl.
simpl in H2.
apply replaceThreadInText.
split.
simpl.
split.
simpl in cfg.
unfold validCFG in cfg.
simpl in cfg.
assert (validCFG3 CFG MMU cs ce).
apply cfg23.
auto.
unfold validCFG3 in H0.
apply H0.
apply H.
left.
apply H.
auto.

(* Case 15 *)
simpl.
simpl in H2.
apply replaceThreadInText.
split.

(* Case 15a: threadOnCPU is in Text *)
unfold textMappedLinear in line.
simpl in line.
unfold pcInText in pct.
simpl in pct.
assert ((cs <= getPhysical (getTLB (S PC) MMU) <= ce) \/
vlookup PC
         (C MMU DS (val vr) PC SP CFG cs ce st asid tid ntid tl gvs gve gl th) =
       jmp).
apply line.
auto.
destruct H0.
destruct getThread.
destruct getThread.
simpl.
split.
auto.
right.
auto.
destruct H as [exec swap].
destruct swap as [swap canswap].
unfold vlookup in H0.
simpl in H0.
unfold vaLookup in swap.
unfold vLookup in H0.
contradict H0.
rewrite -> swap.
discriminate.

(* Case 15b: threadOffCPU is in Text *)
apply replaceThreadInText.
split.
destruct getThread.
unfold threadOffCPU.
simpl.
auto.
auto.

(* Case 17 *)
simpl.
apply replaceThreadInText.
split.
simpl.
auto.
auto.

(* Case 18 *)
simpl.
apply replaceThreadInText.
split.
simpl.
auto.
auto.

(* Case 19 *)
auto.

(* Case 20 *)
simpl.
unfold pushSIC.
apply replaceThreadInText.
split.

(* Case 20a *)
simpl.
auto.

(* Case 20b *)
auto.

(* Case 21 *)
simpl.
unfold popSIC.
apply replaceThreadInText.
split.

(* Case 21a *)
simpl.
auto.

(* Case 21b *)
auto.

(* Case 22 *)
simpl.
unfold pushIC.
apply replaceThreadInText.
split.

(* Case 22a *)
simpl.
auto.

(* Case 22b *)
auto.
Qed.

(*
 * Theorem: stayLinear
 *
 * Description:
 *  Prove that if the text segment is mapped linearly, then it stays that way.
 *)
Theorem stayLinear: forall (c1 c2 : config),
(c1 ==> c2) /\
(textMappedLinear c1) /\
(pcInText c1) /\
(validConfig c1) /\
(textNotWriteable c1) /\
(textMappedOnce c1) /\
(validCFG c1 (getCFG c1))
->
(textMappedLinear c2).
Proof.
intros.
destruct H as [H1 H2].
destruct H2 as [H2 H3].
destruct H3 as [H3 H4].
destruct H4 as [H4 H5].
destruct H5 as [H5 H6].
destruct H6 as [H6 H7].
destruct H1.
destruct c.

(* Case 1 - *)
auto.
auto.

(* Case 3: sta *)
unfold textMappedLinear.
simpl.
intros.
destruct H as [HA H].
destruct H as [HB H].
destruct H as [HC H].
unfold textMappedLinear in H2.
simpl in H2.
assert (cs <= getPhysical (getTLB (S v) MMU) <= ce \/
     vlookup v
       (C MMU DS Reg PC SP CFG cs ce st asid tid ntid tl gvs gve gl th) = jmp).
apply H2.
auto.
destruct H1 as [H1 | H1].

(* Case 3a: Left-hand side *)
left.
auto.

(* Case 3b: Right-hand side *)
right.
assert (n <> v).
unfold textNotWriteable in H5.
assert (not (canWrite v MMU)).
apply H5.
auto.
contradict HC.
rewrite -> HC.
auto.
unfold vlookup.
unfold vLookup.
simpl.
rewrite <- sameRead.
unfold vlookup in H1.
unfold vLookup in H1.
auto.

(* Case 3: Prove remaining odds and ends *)
auto.

(* Case 4 - 6*)
auto.
auto.
auto.

(* Case 7: map *)
unfold textMappedLinear.
simpl.
intros.
destruct H as [HA H].
destruct H as [HB H].
destruct H as [HC H].
destruct H as [HD H].
destruct H as [HE H].
rewrite -> HC in HE.
unfold textNotWriteable in H5.
unfold textMappedOnce in H6.
unfold textMappedLinear in H2.
simpl in H2.

(* Assert that we're not modifying anything within the code segment *)
assert (v0 <> v).
contradict H0.
rewrite -> H0.
rewrite -> tlbSet.
contradict HD.
apply and_not_or.
split.
apply le_not_lt.
apply HD.
apply le_not_lt.
apply HD.
apply H.

(* Remove the changes made by the MMU *)
rewrite <- sameMMULookup in H0.

(* Assert the useful information from the linear mapping *)
assert (cs <= getPhysical (getTLB (S v0) MMU) <= ce \/
     vlookup v0
       (C MMU DS Reg PC SP CFG cs ce st asid tid ntid tl gvs gve gl th) = jmp).
apply H2.
auto.

(* Prove the left half of the theorem *)
destruct H8 as [H8 | H8].
left.
rewrite <- sameMMULookup.
auto.

(* Aside: show that S v0 <> v *)
contradict HE.
rewrite <- HE.
apply and_not_or.
split.
apply le_not_lt.
apply H8.
apply le_not_lt.
apply H8.

(* Prove the right half of the theorem *)
right.
unfold vlookup.
unfold vLookup.
simpl.
unfold vlookup in H8.
unfold vLookup in H8.
simpl in H8.
rewrite <- sameMMULookup.
apply H8.
auto.
auto.

(* Case 8 - 21 *)
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
auto.
Qed.

Theorem TLInTextToT: forall (tl : ThreadList) (cfg : list nat) (mmu : MMU) (cs ce : nat) (id : nat) ,
threadListInText tl cfg mmu cs ce -> threadInText (getThread id tl) cfg mmu cs ce.
Proof.
intros tl cfg mmu cs ce.
induction tl.

(* Case 1: Base case: empty list *)
intros.
destruct id.
auto.
auto.

(* Case 2: Induction case: non-empty thread list *)
intros.
induction id.
unfold getThread.
simpl.
unfold threadListInText in H.
destruct H as [H1 H2].
fold threadListInText in H2.
auto.

(* Case 2a: Do the induction *)
unfold threadListInText in H.
destruct H as [H1 H2].
fold threadListInText in H2.
apply IHtl.
auto.
Qed.

(*
 * Theorem: stayPCInText
 *
 * Description:
 *  Prove that if the PC is in the text segment, then it stays there.
 *
 * Notes:
 *  This is invariant PCT in the Oakland 2014 paper text.
 *)
Theorem stayPCInText: forall (c1 c2 : config),
(c1 ==> c2) /\
(textMappedLinear c1) /\
(pcInText c1) /\
(validConfig c1) /\
(textNotWriteable c1) /\
(textMappedOnce c1) /\
(validCFG c1 (getCFG c1)) /\
(In (getTH c1) (getCFG c1)) /\
(threadListInText (getThreadList c1)
  (getCFG c1)(getCMMU c1) (getTextStart c1) (getTextEnd c1)) /\
(AreAllThreadICsInText (getThreadList c1) c1) /\
(In (getThread (getCurrThread c1) (getThreadList c1)) (getThreadList c1))
->
(pcInText c2).
Proof.
intros.

(* Split the preconditions into separate hypotheses *)
destruct H as [H1 H2].
destruct H2 as [H2 H3].
destruct H3 as [H3 H4].
destruct H4 as [H4 H5].
destruct H5 as [H5 H6].
destruct H6 as [H6 H7].
destruct H7 as [H7 TH].
destruct TH as [TH TLT].
destruct TLT as [TLT ICText].
destruct ICText as [ICText goodThreadID].

(* Continue on with the proof *)
destruct H1.
destruct c.

(* Case 1: ldi *)
unfold pcInText.
simpl.
unfold textMappedLinear in H2.
simpl in H2.
assert (n2 <= getPhysical (getTLB (S n0) m) <= n3 \/
     vlookup n0 (C m s t n0 n1 l n2 n3 l0 n4 n5 n6 t0 n7 n8 l1 n9) = jmp).
apply H2.
apply H3.
destruct H0.
auto.
contradict H0.
destruct H.
unfold getInsn in H0.
unfold vlookup in H0.
unfold vlookup.
simpl.
unfold vLookup in H0.
unfold vLookup.
simpl in H0.
rewrite -> H0.
discriminate.

(* Case 2: lda *)
unfold pcInText.
simpl.
unfold textMappedLinear in H2.
simpl in H2.
assert ( cs <= getPhysical (getTLB (S PC) MMU) <= ce \/
     vlookup PC
       (C MMU DS Reg PC SP CFG cs ce st asid tid ntid tl gvs gve gl th) = jmp).
apply H2.
apply H3.
destruct H0.
auto.
contradict H0.
destruct H.
destruct H0.
unfold vlookup.
simpl.
unfold vaLookup in H0.
unfold vLookup.
rewrite -> H0.
discriminate.

(* Case 3: sta *)
unfold pcInText.
simpl.
unfold textMappedLinear in H2.
simpl in H2.
assert ( cs <= getPhysical (getTLB (S PC) MMU) <= ce \/
     vlookup PC
       (C MMU DS Reg PC SP CFG cs ce st asid tid ntid tl gvs gve gl th) = jmp).
apply H2.
apply H3.
destruct H0.
auto.
contradict H0.
destruct H.
destruct H0.
unfold vlookup.
simpl.
unfold vaLookup in H0.
unfold vLookup.
rewrite -> H0.
discriminate.

(* Case 4: add *)
unfold pcInText.
simpl.
unfold textMappedLinear in H2.
simpl in H2.
assert ( cs <= getPhysical (getTLB (S PC) MMU) <= ce \/
     vlookup PC
       (C MMU DS (val v) PC SP CFG cs ce st asid tid ntid tl gvs gve gl th) = jmp).
apply H2.
apply H3.
destruct H0.
auto.
contradict H0.
destruct H.
unfold vlookup.
simpl.
unfold vLookup.
unfold vaLookup in H0.
rewrite -> H0.
discriminate.

(* Case 5: sub *)
unfold pcInText.
simpl.
unfold textMappedLinear in H2.
simpl in H2.
assert ( cs <= getPhysical (getTLB (S PC) MMU) <= ce \/
     vlookup PC
       (C MMU DS (val v) PC SP CFG cs ce st asid tid ntid tl gvs gve gl th) = jmp).
apply H2.
apply H3.
destruct H0.
auto.
contradict H0.
destruct H.
unfold vlookup.
simpl.
unfold vLookup.
unfold vaLookup in H0.
rewrite -> H0.
discriminate.

(* Case 6: jmp *)
unfold pcInText.
simpl.
unfold validCFG in H7.
apply cfg23 in H7.
simpl in H7.
unfold validCFG3 in H7.
apply H7.
apply H.

(* Case 7: map *)
unfold pcInText.
simpl.
simpl in TH.
simpl in TLT.
unfold textMappedLinear in H2.
simpl in H2.
assert ( cs <= getPhysical (getTLB (S PC) MMU) <= ce \/
     vlookup PC
       (C MMU DS Reg PC SP CFG cs ce st asid tid ntid tl gvs gve gl th) = jmp).
apply H2.
apply H3.
destruct H0.
rewrite <- sameMMULookup.
auto.
destruct H as [HA H].
destruct H as [HB H].
destruct H as [HC H].
destruct H as [HD H].
destruct H as [HE H].
destruct H as [HF H].
rewrite -> HC in HE.
contradict HE.
rewrite <- HE.
apply and_not_or.
split.
apply le_not_lt.
apply H0.
apply le_not_lt.
apply H0.
contradict H0.
destruct H.
unfold vlookup.
simpl.
unfold vLookup.
unfold vaLookup in H0.
destruct H0 as [H0 H10].
rewrite -> H0.
discriminate.

(* Case 8: svaDeclareStack *)
unfold pcInText.
simpl.
unfold textMappedLinear in H2.
simpl in H2.
assert ( cs <= getPhysical (getTLB (S PC) MMU) <= ce \/
     vlookup PC
       (C MMU DS Reg PC SP CFG cs ce st asid tid ntid tl gvs gve gl th) = jmp).
apply H2.
apply H3.
destruct H0.
auto.
contradict H0.
destruct H.
unfold vlookup.
simpl.
unfold vLookup.
unfold vaLookup in H0.
destruct H0 as [H0 H10].
rewrite -> H0.
discriminate.

(* Case 9: jeq *)
unfold pcInText.
simpl.
unfold validCFG in H7.
apply cfg23 in H7.
simpl in H7.
unfold validCFG3 in H7.
apply H7.
apply H.

(* Case 10: jeq *)
unfold pcInText.
simpl.
unfold textMappedLinear in H2.
simpl in H2.
assert ( cs <= getPhysical (getTLB (S PC) MMU) <= ce \/
     vlookup PC
       (C MMU DS Reg PC SP CFG cs ce st asid tid ntid tl gvs gve gl th) = jmp).
apply H2.
apply H3.
destruct H0.
auto.
contradict H0.
destruct H.
unfold vlookup.
simpl.
unfold vLookup.
unfold vaLookup in H0.
destruct H0 as [H0 H10].
rewrite -> H0.
discriminate.

(* Case 11: jne *)
unfold pcInText.
simpl.
unfold validCFG in H7.
apply cfg23 in H7.
simpl in H7.
unfold validCFG3 in H7.
apply H7.
apply H.

(* Case 12: jne *)
unfold pcInText.
simpl.
unfold textMappedLinear in H2.
simpl in H2.
assert ( cs <= getPhysical (getTLB (S PC) MMU) <= ce \/
     vlookup PC
       (C MMU DS (val vr) PC SP CFG cs ce st asid tid ntid tl gvs gve gl th) = jmp).
apply H2.
apply H3.
destruct H0.
auto.
contradict H0.
destruct H.
unfold vlookup.
simpl.
unfold vLookup.
unfold vaLookup in H0.
destruct H0 as [H0 H10].
rewrite -> H0.
discriminate.

(* Case 13: svaLoadPGTable *)
unfold pcInText.
simpl.
unfold textMappedLinear in H2.
simpl in H2.
assert ( cs <= getPhysical (getTLB (S PC) MMU) <= ce \/
     vlookup PC
       (C MMU DS (val vr) PC SP CFG cs ce st asid tid ntid tl gvs gve gl th) = jmp).
apply H2.
apply H3.
destruct H0.
auto.
contradict H0.
destruct H.
unfold vlookup.
simpl.
unfold vLookup.
unfold vaLookup in H0.
rewrite -> H0.
discriminate.

(* Case 14: svaInitStack *)
unfold pcInText.
simpl.
unfold textMappedLinear in H2.
simpl in H2.
assert ( cs <= getPhysical (getTLB (S PC) MMU) <= ce \/
     vlookup PC
       (C MMU DS Reg PC SP CFG cs ce st asid tid ntid tl gvs gve gl th) = jmp).
apply H2.
apply H3.
destruct H0.
auto.
contradict H0.
destruct H.
destruct H0 as [H0 HA].
unfold vlookup.
simpl.
unfold vLookup.
unfold vaLookup in H0.
rewrite -> H0.
discriminate.

(* Case 15: svaSwap *)
unfold pcInText.
simpl.
simpl in TLT.
simpl in TH.
assert (threadInText (getThread vr tl) CFG MMU cs ce).
apply TLInTextToT.
auto.
destruct getThread.
destruct b.

(* Case in which the thread is swappable *)
unfold threadInText in H0.
destruct H0 as [H0 H1].
unfold getThreadPC.
auto.

(* Case in which the thread is not swappable *)
unfold canThreadSwap in H.
destruct H.
destruct H1.
destruct H8 as [H8 H100].
contradict H8.
auto.

(* Case 16: trap *)
unfold pcInText.
simpl.
unfold validCFG in H7.
apply cfg23 in H7.
simpl in H7.
unfold validCFG3 in H7.
apply H7.
apply TH.

(* Case 17: iret *)
unfold pcInText.
simpl.
destruct H as [H8 H].
destruct H as [H9 H].
destruct H as [H len].
rewrite -> H.
unfold textMappedLinear in H2.
simpl in H2.
simpl in goodThreadID.
unfold AreAllThreadICsInText in ICText.
simpl in ICText.

assert (ICListInText (getThreadICList tid tl) cs ce MMU).
apply ICText.
auto.
unfold itop.
destruct (getThreadICList tid tl).
simpl in len.
contradict len.
apply le_not_lt.
auto.
simpl.
unfold ICListInText in H0.
destruct H0 as [H0 H00].
fold ICListInText in H00.
apply H0.

(* Case 18: svaRegisterTrap *)
unfold pcInText.
simpl.
unfold textMappedLinear in H2.
simpl in H2.
assert ( cs <= getPhysical (getTLB (S PC) MMU) <= ce \/
     vlookup PC
       (C MMU DS (val vr) PC SP CFG cs ce st asid tid ntid tl gvs gve gl th) = jmp).
apply H2.
apply H3.
destruct H0.
auto.
contradict H0.
destruct H.
unfold vlookup.
simpl.
unfold vLookup.
unfold vaLookup in H0.
destruct H0 as [H0 H10].
rewrite -> H0.
discriminate.

(* Case 19: svaSaveIContext *)
unfold pcInText.
simpl.
unfold textMappedLinear in H2.
simpl in H2.
assert ( cs <= getPhysical (getTLB (S PC) MMU) <= ce \/
     vlookup PC
       (C MMU DS Reg PC SP CFG cs ce st asid tid ntid tl gvs gve gl th) = jmp).
apply H2.
apply H3.
destruct H0.
auto.
contradict H0.
destruct H.
unfold vlookup.
simpl.
unfold vLookup.
unfold vaLookup in H0.
destruct H0 as [H0 NE].
rewrite -> H0.
discriminate.

(* Case 20: svaLoadIContext *)
unfold pcInText.
simpl.
unfold textMappedLinear in H2.
simpl in H2.
assert ( cs <= getPhysical (getTLB (S PC) MMU) <= ce \/
     vlookup PC
       (C MMU DS Reg PC SP CFG cs ce st asid tid ntid tl gvs gve gl th) = jmp).
apply H2.
apply H3.
destruct H0.
auto.
contradict H0.
destruct H.
unfold vlookup.
simpl.
unfold vLookup.
unfold vaLookup in H0.
destruct H0 as [H0 sic].
rewrite -> H0.
discriminate.

(* Case 21: svaPushFunction *)
unfold pcInText.
simpl.
unfold textMappedLinear in H2.
simpl in H2.
assert ( cs <= getPhysical (getTLB (S PC) MMU) <= ce \/
     vlookup PC
       (C MMU DS (val f) PC SP CFG cs ce st asid tid ntid tl gvs gve gl th) = jmp).
apply H2.
apply H3.
destruct H0.
auto.
contradict H0.
destruct H.
unfold vlookup.
simpl.
unfold vLookup.
unfold vaLookup in H0.
destruct H0 as [H0 H10].
rewrite -> H0.
discriminate.
Qed.


From Undecidability.FOL.Incompleteness Require Import utils formal_systems epf.

From Undecidability.Synthetic Require Import Definitions.

Section abstract.
  Variable (theta : nat -> nat -\ bool).
  Hypothesis theta_universal : is_universal theta.

  Context {S : Type} {neg : S -> S} (fs : FS S neg).

  (** ** Folklore proof using soundness *)

  (* Any weakly representable predicate is in a decidable formal system is decidable *)
  Lemma weakly_representable_decidable' (fs' : FS S neg) (p : nat -> Prop) :
    extension fs fs' ->
    decidable (fs'.(fprv)) ->
    (exists r, weakly_represents fs p r /\ sound fs' p r) ->
    decidable p.
  Proof.
    intros Hext [dec Hdec] [r [Hr1 Hr2]].
    exists (fun n => dec (r n)).
    intros x. unfold reflects.
    split.
    - intros H. apply Hdec, Hext, Hr1, H.
    - intros H. apply Hr2, Hdec, H.
  Qed.
  (* Any weakly representable predicate in a complete formal system is decidable *)
  Lemma weakly_representable_decidable (fs' : FS S neg) (p : nat -> Prop) :
    extension fs fs' ->
    complete fs' ->
    (exists r, weakly_represents fs p r /\ sound fs' p r) ->
    decidable p.
  Proof.
    intros H1 H2%complete_decidable H3.
    eapply weakly_representable_decidable'; eassumption.
  Qed.

  (* Any formal system weakly representing the halting problem is undecidable and therefore incomplete *)
  Section halt.
    Variable (r : nat -> S).
    Hypothesis Hrepr : weakly_represents fs (self_halting theta) r.

    Lemma halt_undecidability : ~decidable fs.(fprv).
    Proof.
      intros Hdec. eapply self_halting_undec; first eassumption.
      apply weakly_representable_decidable' with (fs' := fs); firstorder.
    Qed.

    Lemma halt_incompleteness' : ~complete fs.
    Proof.
      intros Hdec%complete_decidable.
      now apply halt_undecidability.
    Qed.

  End halt.
  (* Any formal system weakly representing the halting problem has an independent sentence *)
  Section halt.
    Variable (r : nat -> S).
    Hypothesis Hrepr : weakly_represents fs (self_halting theta) r.
    Variable (fs' : FS S neg).
    Hypothesis (Hext : extension fs fs').
    Hypothesis (snd : sound fs' (self_halting theta) r).

    Lemma halt_incompleteness : exists n, independent fs' (r n).
    Proof.
      destruct (is_provable fs') as (f & Hf1 & Hf2).
      assert (exists c, forall b, ~f (r c) ▷ b) as [d Hd].
      { eapply self_halting_diverge; try eassumption.
        intros c. rewrite <-Hf1. firstorder. }
      exists d. split; firstorder.
    Qed.

  End halt.

  (** ** Strengthened proof using consistency *)

  (* Any formal system strongly separating two recursively inseparable sets is undecidable *)
  Section insep.
    Variable r : nat -> S.
    Hypothesis Hrepr :
      strongly_separates fs (theta_self_return theta true) (theta_self_return theta false) r.

    Lemma insep_undecidability : ~decidable fs.(fprv).
    Proof.
      intros [f Hf].
      unshelve eapply (@no_recursively_separating theta theta_universal).
      { exact (fun c => f (r c)). } cbn.
      intros [] c H.
      - apply Hf, Hrepr, H.
      - enough (f (r c) <> true) by now destruct f.
        intros Hc. eapply (@fs.(consistent) (r c)); firstorder.
    Qed.

    (* We could deduce incompleteness here already, similar to halt_incompleteness' *)

  End insep.

  (* Any formal system strongly separating two recursively inseparable sets has an independent sentence *)
  Section insep.
    Variable r : nat -> S.
    Hypothesis Hrepr :
      strongly_separates fs (theta_self_return theta true) (theta_self_return theta false) r.

    Lemma insep_incompleteness : exists n, independent fs (r n).
      destruct (is_provable fs) as (f & Hf1 & Hf2).
      assert (exists c, forall b, ~f (r c) ▷ b) as [c Hc].
      { eapply recursively_separating_diverge; try eassumption.
        intros [] c Hc; firstorder. }
      exists c. firstorder.
    Qed.

  End insep.
  Section insep.
    Variable (fs' : FS S neg).
    Hypothesis fs'_extension : extension fs' fs.

    Variable r : nat -> S.
    Hypothesis Hrepr :
      strongly_separates fs' (theta_self_return theta true) (theta_self_return theta false) r.

    (* If a formal system strongly separates two predicates, its extensions do, too *)
    Lemma strong_separability_extension :
      strongly_separates fs (theta_self_return theta true) (theta_self_return theta false) r.
    Proof.
      firstorder.
    Qed.

    (* Essential incompleteness and undecidability *)
    Theorem insep_essential_incompleteness : exists n, independent fs (r n).
    Proof.
      apply (@insep_incompleteness r).
      apply strong_separability_extension.
    Qed.

    Theorem insep_essential_undecidability : ~decidable (fun s => fs ⊢F s).
    Proof.
      intros H.
      eapply insep_undecidability; eauto using strong_separability_extension.
    Qed.

  End insep.

End abstract.


Require Export CatSem.CAT.category.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Section Directed_Graph.

Variable ob arr: Type.
Variable arr_oid: Setoid arr.

Class Graph_struct := {
   dom: arr -> ob;
   cod: arr -> ob
}.

End Directed_Graph.

Class Graph := {
  O : Type;
  A : Type;
  A_oid:> Setoid A;
  graph_struct:> Graph_struct O A
}.

Definition Graph_ob (G: Graph) := @O G.
Coercion Graph_ob: Graph >-> Sortclass.

Definition Graph_arr (G: Graph) := @A G.
Coercion Graph_arr: Graph >-> Sortclass.

Section Graph_Morphisms.

Variables G1 G2: Graph.

Class Graph_Morphism := {
  D_O: G1 -> G2;
  D_A: @A G1 -> @A G2;
  D_A_oid:> Proper (equiv ==> equiv) D_A;
  dom_compat: forall f, dom (D_A f) = D_O (dom f);
  cod_compat: forall f, cod (D_A f) = D_O (cod f)
}.

Definition D_OG (G:Graph_Morphism) := @D_O G.
Coercion D_OG : Graph_Morphism >-> Funclass.

Definition D_AG (G:Graph_Morphism) := @D_A G.
Coercion D_AG : Graph_Morphism >-> Funclass.

Lemma dom_com:forall G:Graph_Morphism, forall f,
             dom (D_A f) = D_O (dom f).
Proof. intros G f. apply dom_compat. Qed.

Lemma cod_com:forall G:Graph_Morphism, forall f,
             cod (D_A f) = D_O (cod f).
Proof. intros G f. apply cod_compat. Qed.

End Graph_Morphisms.

Implicit Arguments D_A [G1 G2].
Implicit Arguments D_O [G1 G2].

Section Graph_Morphism_equiv.

Variables G1 G2 : Graph.

Definition eq_Graph_Morphism1 : relation (Graph_Morphism G1 G2) :=
      fun F G => (forall x, F x = G x) /\
                 (forall f, D_A F f == D_A G f).

Lemma eq_Graph_Morphism_equiv: Equivalence eq_Graph_Morphism1.
Proof. unfold eq_Graph_Morphism1.
  split.
    unfold Reflexive.
    intro x; split; intro f; auto;
    apply A_oid.

    unfold Symmetric.
    intros x y H; split; intro f.
      apply sym_eq; apply H.
      apply A_oid; apply H.

    unfold Transitive.
    intros x y z H H'; split; intro f.
    transitivity (y f); [apply H | apply H'].
    apply Equivalence_Transitive with (D_A y f);
         [apply H | apply H'].
Qed.

Definition eq_Graph_Morphism := Build_Setoid eq_Graph_Morphism_equiv.

End Graph_Morphism_equiv.

Section Morphism_Comp_Id.
Variables G1 G2 G3: Graph.
Variable F1: Graph_Morphism G1 G2.
Variable F2: Graph_Morphism G2 G3.

Program Instance CompGM : Graph_Morphism G1 G3 := {
  D_O := fun x => F2 (F1 x);
  D_A := fun f => @D_A _ _ F2 (@D_A _ _ F1 f)
}.
Next Obligation.
 Proof. unfold Proper; red.
        intros x y H.
        rewrite H.
        apply A_oid.
 Qed.
Next Obligation.
 Proof. repeat rewrite dom_com. auto. Qed.
Next Obligation.
 Proof. repeat rewrite cod_com. auto. Qed.

End Morphism_Comp_Id.

(** forgetful functor cat -> graph *)

Section Cat_Graph.
Variable C: Cat.

Definition HOM := {a:C & {b:C & mor a b}}.

Definition src (a:HOM) := projT1 a.
Definition tgt (a:HOM) := projT1 (projT2 a).
Definition arrow (a:HOM) := projT2 (projT2 a).

Definition HOM_relation : relation HOM :=
     fun a b => arrow a === arrow b.

Lemma HOM_relation_oid : Equivalence HOM_relation.
Proof. unfold HOM_relation. split.
 unfold Reflexive.
 intro x.
 apply Equal_hom_refl.

 unfold Symmetric.
 intros x y. apply Equal_hom_sym.

 unfold Transitive.
 intros x y z.
 apply Equal_hom_trans.
Qed.

Definition HOM_oid := Build_Setoid HOM_relation_oid.

Program Instance CatGraph: Graph := {
  O := obj C;
  A := HOM
}.
Next Obligation.
 Proof. apply HOM_oid. Qed.
Next Obligation.
 apply (*Build_Graph_struct*)
      {| dom := src; cod := tgt |}. Defined.

End Cat_Graph.

(** small graph *)

Class SmallGraph := {
  sO: Set;
  sA: Set;
  sA_oid:> Setoid sA;
  smallgraph_struct:> Graph_struct sO sA
}.

Instance Graph_from_SmallGraph (G:SmallGraph): Graph := {
  O := @sO G;
  A := @sA G;
  A_oid := sA_oid;
  graph_struct := @smallgraph_struct G
}.

Coercion Graph_from_SmallGraph: SmallGraph >-> Graph.

Program Instance SMALLGRAPH : @Cat_struct SmallGraph Graph_Morphism := {
  mor_oid a b := eq_Graph_Morphism a b;
  id a := {|D_O := (fun x => x); D_A := (fun f => f) |};
  comp a b c f g := CompGM f g
}.

Next Obligation.
 Proof. unfold Proper. red. auto. Qed.

Next Obligation.
  Proof. unfold Proper. red. red.
         unfold eq_Graph_Morphism1. simpl.
         intros x y H x0 y0 H0.
         destruct H0 as [H0 h0].
         destruct H as [H h].
         split; intro f.
          rewrite H0. rewrite H. auto.
          rewrite h0. rewrite h. apply sA_oid.
  Qed.

Next Obligation.
  Proof. unfold eq_Graph_Morphism1. simpl.
         split; intros; [auto | apply sA_oid].
  Qed.

Next Obligation.
  Proof. unfold eq_Graph_Morphism1. simpl.
         split; intros; [auto | apply sA_oid].
  Qed.

Next Obligation.
  Proof. unfold eq_Graph_Morphism1. simpl.
         split; intros; [auto | apply sA_oid].
  Qed.