Require Import RelationClasses.
Require Import VST.floyd.proofauto.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.binheap.binary_heap_pro.
Require Import CertiGraph.binheap.binary_heap_malloc_spec.
Require Import CertiGraph.binheap.binary_heap_model.
Require Import CertiGraph.binheap.binary_heap_Zmodel.

(* Relation on heap items. *)
Definition key_type : Type := Z. Definition priority_type : Type := int. Definition payload_type : Type := int.
Definition heap_item : Type := (key_type * priority_type * payload_type)%type.
Definition heap_item_key (hi : heap_item) : key_type := fst (fst hi).
Definition heap_item_priority (hi : heap_item) : priority_type := snd (fst hi).
Definition heap_item_payload (hi : heap_item) : payload_type := snd hi.

Definition cmp (a b : heap_item) : bool :=
  negb (Int.lt (heap_item_priority b) (heap_item_priority a)).
Definition cmp_rel (a b : heap_item) : Prop :=
  cmp a b = true.
Lemma cmp_dec: forall a a', {cmp_rel a a'} + {~cmp_rel a a'}.
Proof.
  intros [[? ?] ?] [[? ?] ?]. unfold cmp_rel, cmp, heap_item_priority. simpl. case (Int.lt p1 p); simpl; auto.
Qed.
#[export] Instance cmp_po: PreOrder cmp_rel.
Proof.
  constructor. intros [[? ?] ?]. red. unfold cmp, heap_item_priority. simpl. case_eq (Int.lt p p); auto; intro. exfalso.
  apply lt_inv in H. lia.
  intros [[? ?] ?] [[? ?] ?] [[? ?] ?]. unfold cmp_rel, cmp, heap_item_priority. simpl.
  case_eq (Int.lt p1 p); simpl; try discriminate.
  case_eq (Int.lt p3 p1); simpl; try discriminate.
  case_eq (Int.lt p3 p); auto.
  intros ? ? ?. exfalso.
  apply lt_inv in H.
  apply lt_false_inv in H0.
  apply lt_false_inv in H1.
  lia.
Qed.
Lemma cmp_linear: forall a b,
  cmp_rel a b \/ cmp_rel b a.
Proof.
  intros [[? ?] ?] [[? ?] ?]. unfold cmp_rel, cmp, heap_item_priority; simpl.
  case_eq (Int.lt p1 p); auto. intro.
  right.
  case_eq (Int.lt p p1); auto. intro. exfalso.
  apply lt_inv in H. apply lt_inv in H0.
  lia.
Qed.

(* Not sure if it's a great idea to expose the capacity inside the abstraction boundary. *)
Definition heap : Type := (nat * list heap_item)%type.
#[export] Instance heap_inhabitant : Inhabitant heap := (O, []).
Definition heap_capacity (h : heap) : Z := Z.of_nat (fst h).
Definition heap_items (h : heap) : list heap_item := snd h.
Definition heap_size (h : heap) : Z := Zlength (heap_items h).

Definition heap_ordered := binary_heap_model.heapOrdered heap_item cmp_rel.
Definition weak_heap_ordered_bottom_up (L : list heap_item) (x : Z) :=
  binary_heap_model.weak_heapOrdered2 heap_item cmp_rel L (Z.to_nat x).
Definition weak_heap_ordered_top_down (L : list heap_item) (x : Z) :=
  binary_heap_model.weak_heapOrdered heap_item cmp_rel L (Z.to_nat x).
Definition swim := binary_heap_model.swim heap_item cmp_rel cmp_dec.
Definition sink L i := binary_heap_model.sink heap_item cmp_rel cmp_dec (L,i).
(* Definition insert := binary_heap_model.insert heap_item cmp_rel cmp_dec. *)
(* Definition remove_min := binary_heap_model.remove_min heap_item cmp_rel cmp_dec. *)

(* This may get bundled elsewhere at some point. *)
#[global] Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition t_item := Tstruct _structItem noattr.
Definition t_pq := Tstruct _structPQ noattr.

Definition heap_item_rep (i : heap_item) : reptype t_item :=
  (Vint (Int.repr (fst (fst i))), (Vint (snd (fst i)), Vint (snd i))).

Definition hitem (i : heap_item) : val -> mpred :=
  data_at Tsh t_item (heap_item_rep i).

Definition lookup_array (lookup : list Z) : val -> mpred :=
  data_at Tsh (tarray tuint (Zlength lookup)) (map (fun z => Vint (Int.repr z)) lookup).

Definition heap_array (contents : list heap_item) : val -> mpred :=
 data_at Tsh (tarray t_item (Zlength contents)) (map heap_item_rep contents).

(* Maybe can move this and associated definitons to Zmodel... *)
Definition linked_correctly' (contents : list heap_item) (lookup : list Z) (offset : Z) : Prop :=
  NoDup lookup /\
  forall i, 0 <= i < Zlength contents ->
    let loc := heap_item_key (Znth i contents) in
    0 <= loc < Zlength lookup /\
    Znth loc lookup = offset + i.

Definition linked_correctly (contents : list heap_item) (lookup : list Z) : Prop :=
  linked_correctly' contents lookup 0.

Lemma linked_correctly_app1: forall contents contents' lookup,
  linked_correctly (contents ++ contents') lookup ->
  linked_correctly contents lookup.
Proof.
  repeat intro. destruct H. split; trivial.
  repeat intro. specialize (H0 i). rewrite Znth_app1 in H0. 2: lia.
  apply H0. rewrite Zlength_app. rep_lia.
Qed.

Lemma linked_correctly_app2: forall contents contents' lookup,
  linked_correctly (contents ++ contents') lookup ->
  linked_correctly' contents' lookup (Zlength contents).
Proof.
  repeat intro. destruct H as [Hz H]. split; trivial. intros.
  specialize (H (Zlength contents + i)). rewrite Znth_app2 in H. 2: lia.
  rewrite Z.add_0_l in H. replace (Zlength contents + i - Zlength contents) with i in H by lia.
  apply H. rewrite Zlength_app. rep_lia.
Qed.

Lemma linked_correctly_app3: forall contents contents' lookup,
  linked_correctly contents lookup ->
  linked_correctly' contents' lookup (Zlength contents) ->
  linked_correctly (contents ++ contents') lookup.
Proof.
  repeat intro. destruct H as [Hz H]. destruct H0 as [Hz' H0]. split. trivial. intros.
  rewrite Z.add_0_l. assert (0 <= i < Zlength contents \/ Zlength contents <= i < Zlength (contents ++ contents')) by rep_lia.
  destruct H2. destruct H2. unfold loc. rewrite Znth_app1; try lia. apply H; trivial. rep_lia.
  unfold loc. rewrite Znth_app2; try lia. rewrite Zlength_app in *.
  specialize (H0 (i - Zlength contents)). destruct H0. lia. rewrite H3. lia.
Qed.

Lemma linked_correctly_app_eq: forall contents contents' lookup,
  (linked_correctly contents lookup /\ linked_correctly' contents' lookup (Zlength contents)) =
  linked_correctly (contents ++ contents') lookup.
Proof.
  intros. apply prop_ext. split; intros. eapply linked_correctly_app3; tauto.
  split. eapply linked_correctly_app1; apply H. apply linked_correctly_app2. trivial.
Qed.

Lemma linked_correctly'_shuffle: forall contents lookup lookup' offset,
  linked_correctly' contents lookup offset ->
  Permutation lookup lookup' ->
  (forall i, 0 <= i < Zlength contents -> Znth (heap_item_key (Znth i contents)) lookup = Znth (heap_item_key (Znth i contents)) lookup') ->
  linked_correctly' contents lookup' offset.
Proof.
  intros. destruct H as [Hz H]. split.
  eapply Permutation_NoDup; eauto.
  repeat intro. unfold loc. rewrite <- H1; trivial.
  apply Permutation_Zlength in H0. rewrite <- H0. apply H; trivial.
Qed.

Definition lookup_oob_eq (contents : list heap_item) (lookup lookup' : list Z) : Prop :=
  Permutation lookup lookup' /\
  forall i, (forall j, 0 <= j < Zlength contents -> heap_item_key (Znth j contents) <> i) ->
  Znth i lookup = Znth i lookup'.

Lemma lookup_oob_eq_refl: forall contents lookup,
  lookup_oob_eq contents lookup lookup.
Proof. split. trivial. repeat intro. trivial. Qed.

Lemma lookup_oob_eq_trans: forall contents lookup lookup' lookup'',
  lookup_oob_eq contents lookup lookup' ->
  lookup_oob_eq contents lookup' lookup'' ->
  lookup_oob_eq contents lookup lookup''.
Proof.
  intros. destruct H, H0. split. transitivity lookup'; auto.
  repeat intro. specialize (H1 i H3). rewrite H1. apply H2; trivial.
Qed.

#[export] Instance lookup_oob_po: forall c, PreOrder (lookup_oob_eq c).
Proof. intro c. split. intro x. apply lookup_oob_eq_refl. intros x y z. apply lookup_oob_eq_trans. Qed.

Lemma lookup_oob_eq_shuffle: forall contents contents' lookup lookup',
  Permutation (map heap_item_key contents) (map heap_item_key contents') ->
  lookup_oob_eq contents lookup lookup' ->
  lookup_oob_eq contents' lookup lookup'.
Proof.
  repeat intro. destruct H0 as [Hz H0]. split; trivial. intros.
  apply H0. repeat intro.
  symmetry in H.
  apply Permutation_Znth in H. 2: exact 0. destruct H as [? [f [? [? ?]]]].
  do 2 rewrite Zlength_map in *. rewrite <- H in *.
  apply (H1 (Z.of_nat (f (Z.to_nat j)))).
  specialize (H4 (Z.to_nat j)). rep_lia.
  specialize (H6 j H2). rewrite Znth_map in H6. 2: lia. rewrite H6 in H3.
  rewrite Znth_map in H3. trivial.
  specialize (H4 (Z.to_nat j)). rep_lia.
Qed.

Lemma lookup_oob_eq_Zexchange: forall L1 L2 j k,
  0 <= j < Zlength L1 ->
  0 <= k < Zlength L1 ->
  linked_correctly L1 L2 ->
  lookup_oob_eq (Zexchange L1 j k) L2 (Zexchange L2 (heap_item_key (Znth j L1)) (heap_item_key (Znth k L1))).
Proof.
  repeat intro. destruct H1 as [Hz H1]. split; repeat rewrite Zlength_Zexchange in *.
  apply Zexchange_Permutation.
  intros. rewrite Znth_Zexchange''; auto.
  destruct (H1 _ H); auto.
  destruct (H1 _ H0); auto.
  intro. subst i. eapply H2. apply H0. rewrite Znth_Zexchange'; auto.
  intro. subst i. eapply H2. apply H. rewrite Znth_Zexchange; auto.
Qed.

Definition linked_heap_array (contents : list heap_item) (v1 : val) (lookup : list Z) (v2 : val) : mpred :=
  (!!(linked_correctly contents lookup) && ((heap_array contents v1) * (lookup_array lookup v2)))%logic.

Lemma harray_emp: forall arr,
  heap_array [] arr |-- emp.
Proof.
  unfold heap_array. intros. rewrite data_at_isptr. entailer. rewrite data_at_zero_array_eq; auto.
Qed.

Lemma fold_heap_array': forall L i arr,
  i = Zlength L ->
  data_at Tsh (tarray t_item i) (map heap_item_rep L) arr = heap_array L arr.
Proof. intros. rewrite H. reflexivity. Qed.

Lemma fold_heap_array: forall L arr,
  data_at Tsh (tarray t_item (Zlength L)) (map heap_item_rep L) arr = heap_array L arr.
Proof. reflexivity. Qed.

Lemma heap_array_split: forall L1 L2 ptr,
  heap_array (L1 ++ L2) ptr =
  ((heap_array L1 ptr) *
   (heap_array L2 (field_address0 (tarray t_item (Zlength (L1 ++ L2))) [ArraySubsc (Zlength L1)] ptr)))%logic.
Proof.
  intros. unfold heap_array.
  rewrite map_app.
  erewrite split2_data_at_Tarray_app.
  2: rewrite Zlength_map; reflexivity. 2: rewrite Zlength_app, Zlength_map; lia.
  rewrite Zlength_app.
  replace (Zlength L1 + Zlength L2 - Zlength L1) with (Zlength L2) by lia.
  trivial.
Qed.

Lemma linked_heap_array_split: forall L1 L2 ptr L3 ptr',
  linked_heap_array (L1 ++ L2) ptr L3 ptr' =
  (linked_heap_array L1 ptr L3 ptr' * (!! linked_correctly' L2 L3 (Zlength L1) && heap_array L2 (field_address0 (tarray t_item (Zlength (L1 ++ L2))) [ArraySubsc (Zlength L1)] ptr)))%logic.
Proof.
  unfold linked_heap_array. intros. rewrite heap_array_split.
  rewrite sepcon_assoc.
  rewrite (sepcon_comm (heap_array L2 _)).
  rewrite <- sepcon_assoc.
  rewrite sepcon_andp_prop'.
  rewrite sepcon_andp_prop.
  rewrite <- andp_assoc.
  rewrite <- prop_and.
  rewrite linked_correctly_app_eq.
  trivial.
Qed.

Definition valid_pq (pq : val) (h: heap): mpred :=
  EX arr : val, EX junk: list heap_item, EX arr2 : val, EX lookup : list Z,
    (!! heap_ordered (heap_items h)) && (!! (Zlength ((heap_items h) ++ junk) = heap_capacity h)) &&
    (!! (2 * (heap_capacity h - 1) <= Int.max_unsigned)) &&
    (!! (Zlength lookup = heap_capacity h)) &&
    (data_at Tsh t_pq (Vint (Int.repr (heap_capacity h)), (Vint (Int.repr (heap_size h)), (arr, arr2))) pq *
       linked_heap_array ((heap_items h) ++ junk) arr lookup arr2 *
(* tokens that allow deallocation *)
       free_tok arr (sizeof (Tstruct _structItem noattr) * (heap_capacity h)) *
       free_tok arr2 (sizeof tuint * (heap_capacity h)) *
       free_tok pq (sizeof (Tstruct _structPQ noattr))).

Definition hitem_ (v : val) : mpred :=
  data_at_ Tsh t_item v.

Lemma hitem_hitem_: forall v hi,
  hitem hi v |-- hitem_ v.
Proof.
  intros.
  unfold hitem, hitem_. cancel.
  (* apply data_at_data_at_. *)
Qed.

Lemma malloc_hitem: forall v,
  malloc_compatible (sizeof (Tstruct _structItem noattr)) v ->
  (data_at_ Tsh (tarray tint (sizeof (Tstruct _structItem noattr) / sizeof tint)) v) |--
  (hitem_ v).
Proof.
  intros v H.
  sep_apply data_at__memory_block_cancel.
  change (sizeof (tarray _ _)) with (sizeof t_item).
  rewrite memory_block_data_at_.
  apply derives_refl.
  apply malloc_compatible_field_compatible in H; auto.
Qed.

Lemma free_hitem: forall v,
  hitem_ v |--
  data_at_ Tsh (tarray tint (sizeof (Tstruct _structItem noattr) / sizeof tint)) v.
Proof.
  unfold hitem_. intro.
  saturate_local.
  sep_apply data_at__memory_block_cancel.
  rewrite <- memory_block_data_at_.
  apply derives_refl.
  destruct H as [? [? [? [? ?]]]].
  split3; auto.
  split3; auto.
  hnf in H2 |- *.
  destruct v; auto.
  unfold t_item in H2.
  change (_ / _) with 3.
  apply align_compatible_rec_Tarray; intros.
  assert (i0 = 0 \/ i0 = 1 \/ i0 = 2) by lia.
  destruct H5 as [? | [? | ?]]; subst i0;
  [ eapply align_compatible_rec_Tstruct_inv with (i0 := _key) in H2 |
    eapply align_compatible_rec_Tstruct_inv with (i0 := _priority) in H2 |
    eapply align_compatible_rec_Tstruct_inv with (i0 := _data) in H2 ] ;
  try reflexivity;
  eapply align_compatible_rec_by_value; try reflexivity;
  eapply align_compatible_rec_by_value_inv in H2; try reflexivity; apply H2.
Qed.

Lemma free_pq: forall v,
  (data_at_ Tsh t_pq v) |--
  (data_at_ Tsh (tarray tint (sizeof (Tstruct _structPQ noattr) / sizeof tint)) v).
Proof.
  intro. saturate_local.
  sep_apply data_at__memory_block_cancel.
  rewrite <- memory_block_data_at_.
  apply derives_refl.
  destruct H as [? [? [? [? ?]]]].
  split3; auto.
  split3; auto.
  hnf in H2 |- *.
  destruct v; auto.
  unfold t_pq in H2.
  apply align_compatible_rec_Tarray; intros.
  apply align_compatible_rec_by_value with (ch := Mint32); auto. simpl.
  apply Z.divide_add_r. 2: apply Z.divide_factor_l.
  eapply align_compatible_rec_Tstruct_inv with (i0 := _capacity) in H2;
    [|reflexivity..]. eapply align_compatible_rec_by_value_inv in H2; [|reflexivity].
  simpl in H2. now rewrite Z.add_0_r in H2.
Qed.

Lemma simpl_size_t_item: forall s,
  12 * s / 4 = 3 * s.
Proof.
  intro. change 12 with (3 * 4).
  rewrite <- Z.mul_assoc. rewrite (Z.mul_comm 4).
  rewrite Z.mul_assoc.
  rewrite Z.div_mul; lia.
Qed.

Lemma malloc_items: forall v size,
  0 <= size ->
  malloc_compatible (sizeof (Tstruct _structItem noattr) * size) v ->
  data_at_ Tsh (tarray tint (sizeof (Tstruct _structItem noattr) * size / sizeof tint)) v |--
  data_at_ Tsh (tarray t_item size) v.
Proof.
  intros.
  sep_apply data_at__memory_block_cancel.
  rewrite <- memory_block_data_at_.
  simpl sizeof.
  apply derives_refl'. f_equal. rewrite (Z.mul_comm 12). change 12 with (3 * 4).
  rewrite Zaux.Zdiv_eucl_unique. rewrite Z.mul_assoc.
  rewrite Z_div_mult. 1,2: lia.
  apply malloc_compatible_field_compatible; try reflexivity.
  simpl in *.
  rewrite Z.max_r by lia. trivial.
Qed.

Lemma free_items: forall v size,
(*  malloc_compatible (sizeof (Tstruct _structItem noattr) * size) v *)
  data_at_ Tsh (tarray t_item size) v |--
  data_at_ Tsh (tarray tint (sizeof (Tstruct _structItem noattr) * size / sizeof tint)) v.
Proof.
  intros. saturate_local.
  sep_apply data_at__memory_block_cancel.
  rewrite <- memory_block_data_at_.
  simpl. rewrite Zaux.Zdiv_eucl_unique. rewrite simpl_size_t_item.
  apply derives_refl'. f_equal. lia.
  destruct H as [? [? [? [? ?]]]].
  split3; auto.
  split3; auto.
  hnf in H1 |- *.
  destruct v; auto. simpl. simpl sizeof.
  rewrite Zaux.Zdiv_eucl_unique. rewrite simpl_size_t_item.
  simpl in H1. lia.
  hnf in H2 |- *.
  destruct v; auto.
  simpl sizeof. rewrite simpl_size_t_item.
  apply align_compatible_rec_Tarray; intros.
  assert (exists k, 0 <= k < size /\ (i0 = 3 * k + 0 \/ i0 = 3 * k + 1 \/ i0 = 3 * k + 2)).
  { exists (i0 / 3).
    generalize (Z_div_mod_eq i0 3); intro. spec H5. lia.
    generalize (Z.mod_pos_bound i0 3); intro. spec H6. lia.
    split. 2: lia.
    destruct H4. split.
    apply Z.div_pos; lia.
    apply Z.div_lt_upper_bound; lia. }
  destruct H5 as [k [? ?]].
  eapply align_compatible_rec_Tarray_inv in H2. 2: apply H5.
  destruct H6 as [? | [? | ?]]; subst i0;
  [ eapply align_compatible_rec_Tstruct_inv with (i0 := _key) in H2 |
    eapply align_compatible_rec_Tstruct_inv with (i0 := _priority) in H2 |
    eapply align_compatible_rec_Tstruct_inv with (i0 := _data) in H2 ] ;
  try reflexivity;
  eapply align_compatible_rec_by_value; try reflexivity;
  eapply align_compatible_rec_by_value_inv in H2; try reflexivity;
  simpl in *; rewrite (Z.mul_add_distr_l 4), Z.mul_assoc, Z.add_assoc; simpl; apply H2.
Qed.

Lemma malloc_lookup: forall v size,
  0 <= size ->
  malloc_compatible (sizeof tint * size) v ->
  data_at_ Tsh (tarray tint (sizeof tint * size / sizeof tint)) v |--
  data_at_ Tsh (tarray tuint size) v.
Proof.
  intros.
  sep_apply data_at__memory_block_cancel.
  rewrite <- memory_block_data_at_.
  simpl sizeof.
  apply derives_refl'. f_equal.
  rewrite (Z.mul_comm _ size). rewrite Zaux.Zdiv_eucl_unique.
  rewrite Z_div_mult; lia.
  apply malloc_compatible_field_compatible; try reflexivity.
  simpl in *.
  rewrite Z.max_r by lia. trivial.
Qed.

Lemma free_lookup: forall v size,
(*  malloc_compatible (sizeof tint * size) v -> *)
  data_at_ Tsh (tarray tuint size) v |--
  data_at_ Tsh (tarray tint (sizeof tint * size / sizeof tint)) v.
Proof.
  intros. saturate_local.
  sep_apply data_at__memory_block_cancel.
  rewrite <- memory_block_data_at_.
  simpl. rewrite Zaux.Zdiv_eucl_unique.
  rewrite (Z.mul_comm _ size), Z_div_mult; trivial. lia.
  destruct H as [? [? [? [? ?]]]].
  split3; auto.
  split3; auto.
  hnf in H1 |- *.
  destruct v; auto. simpl. rewrite Zaux.Zdiv_eucl_unique.
  rewrite (Z.mul_comm _ size), Z_div_mult; trivial. lia.
  hnf in H2 |- *.
  destruct v; auto.
  simpl sizeof. rewrite (Z.mul_comm _ size), Z_div_mult. 2: lia.
  apply align_compatible_rec_Tarray; intros.
  eapply align_compatible_rec_Tarray_inv in H2. 2: apply H4.
  eapply align_compatible_rec_by_value; try reflexivity.
  eapply align_compatible_rec_by_value_inv in H2. apply H2. reflexivity.
Qed.

Definition update_pri_if_key (key: key_type) (newpri: priority_type) (hi : heap_item) :=
  if Z.eq_dec key (heap_item_key hi) then (key, newpri, heap_item_payload hi) else hi.

Definition update_pri_by_key (h: list heap_item) (key: key_type) (newpri: priority_type) :=
  map (update_pri_if_key key newpri) h.

Definition find_item_by_key (h: list heap_item) (key: key_type) :=
  filter (fun item => Z.eq_dec (heap_item_key item) key) h.

Inductive Subsequence {A : Type} : list A -> list A -> Prop :=
 | SubNil: forall L, Subsequence nil L
 | SubIn: forall L1 L2, Subsequence L1 L2 -> forall x, Subsequence (x :: L1) (x :: L2)
 | SubOut: forall L1 L2, Subsequence L1 L2 -> forall x, Subsequence L1 (x :: L2).

Definition sub_permutation {A} (l1 l2 : list A) :=
  exists l2', Permutation l2' l2 /\ Subsequence l1 l2'.

Definition keys_valid (h : list heap_item) :=
  NoDup (map heap_item_key h).

Definition proj_keys h :=
  map heap_item_key (heap_items h).

Definition proj_payloads h :=
  map heap_item_payload (heap_items h).

Lemma proj_keys_Zlength: forall h,
    Zlength (proj_keys h) = heap_size h.
Proof.
  intros. unfold proj_keys, heap_size. now rewrite Zlength_map.
Qed.

Definition keys_dist_linked_correctly i keys dist h :=
  forall k,
    Znth i keys = k ->
    find_item_by_key (heap_items h) k =
    [(k, Znth i dist, Int.repr i)] \/
    ~ In k (proj_keys h).

Lemma Subsequence_In: forall A (l1 l2 : list A),
  Subsequence l1 l2 ->
  forall x, In x l1 -> In x l2.
Proof.
  induction 1; simpl; auto. contradiction.
  destruct 1; auto.
Qed.

Lemma NoDup_Subsequence: forall A (l1 l2 : list A),
  Subsequence l1 l2 ->
  NoDup l2 ->
  NoDup l1.
Proof.
  intros ? ? ? ?. induction H; intros.
  * constructor.
  * constructor. inversion H0. subst x0 l. intro. apply H3. eapply Subsequence_In; eauto.
    apply IHSubsequence. inversion H0. trivial.
  * inversion H0; auto.
Qed.

Lemma NoDup_sub_permutation: forall A (l1 l2 : list A),
  sub_permutation l1 l2 ->
  NoDup l2 ->
  NoDup l1.
Proof.
  intros A l1 l2 [l2' [? ?]] ?.
  eapply NoDup_Subsequence; eauto.
  symmetry in H.
  eapply Permutation_NoDup; eauto.
Qed.

Lemma keys_valid_tl: forall hi h,
  keys_valid (hi :: h) -> keys_valid h.
Proof. intros. eapply List_ext.NoDup_cons_1, H. Qed.

Lemma update_pri_by_key_not_In: forall h key newpri,
  ~In key (map heap_item_key h) ->
  update_pri_by_key h key newpri = h.
Proof.
  induction h. reflexivity. intros.
  simpl. unfold update_pri_if_key. case Z.eq_dec; intro. exfalso. apply H. left. auto.
  rewrite IHh; trivial. intro. apply H. right. trivial.
Qed.

Lemma update_pri_by_key_split: forall h key newpri start xp xd rest,
  keys_valid h ->
  h = start ++ (key, xp, xd) :: rest ->
  update_pri_by_key h key newpri = start ++ (key, newpri, xd) :: rest.
Proof.
  intros h key newpri start xp xd. revert h. induction start; intros; rewrite H0.
  * simpl in *. subst h. rewrite update_pri_by_key_not_In. f_equal.
    unfold update_pri_if_key. case Z.eq_dec. trivial. contradiction.
    intro. red in H. simpl in H. inversion H. contradiction.
  * subst h. simpl in H. generalize (keys_valid_tl _ _ H); intro.
    specialize (IHstart (start ++ (key, xp, xd) :: rest) rest H0 (eq_refl _)).
    simpl. rewrite IHstart. f_equal.
    unfold update_pri_if_key. case Z.eq_dec; auto. intro.
    inversion H. subst key. rewrite map_app in H3. exfalso. apply H3.
    apply in_or_app. right. left. trivial.
Qed.

Lemma can_split: forall (h: heap) (key: key_type),
    (~In key (map heap_item_key (heap_items h))) \/
    exists start xp xd rest,
      (heap_items h) = start ++ (key, xp, xd) :: rest.
Proof.
  destruct h. simpl. induction l. left. intro. inversion H.
  intro key. case (Z.eq_dec key (heap_item_key a)); intro.
  * right. destruct a as [[? ?] ?]. unfold heap_item_key in e. simpl in e. subst k.
    exists nil, p, p0, l. trivial.
  * specialize (IHl key). destruct IHl. left. intro. apply H. simpl in H0. destruct H0; [symmetry in H0|]; contradiction.
    destruct H as [start [xp [xd [rest ?]]]].
    right. exists (a :: start), xp, xd, rest. rewrite H. trivial.
Qed.

Lemma upd_Znth_Zexchange {A} {iA : Inhabitant A}: forall k j (L : list A),
  0 <= k < Zlength L ->
  0 <= j < Zlength L ->
  upd_Znth k (upd_Znth j L (Znth k L)) (Znth j L) = Zexchange L j k.
Proof.
  intros. apply list_eq_Znth; do 2 rewrite Zlength_upd_Znth. rewrite Zlength_Zexchange; trivial.
  intros. case (Z.eq_dec i k); intro.
  * subst k. rewrite Znth_Zexchange'; auto.
    rewrite upd_Znth_same; auto. rewrite Zlength_upd_Znth; auto.
  * rewrite upd_Znth_diff; auto. 2,3: rewrite Zlength_upd_Znth; auto.
    case (Z.eq_dec i j); intro.
    + subst j. rewrite upd_Znth_same; auto. rewrite Znth_Zexchange; auto.
    + rewrite upd_Znth_diff; auto. rewrite Znth_Zexchange''; auto.
Qed.

Lemma linked_correctly_Zexchange: forall L1 L2 j k,
  0 <= j < Zlength L1 ->
  0 <= k < Zlength L1 ->
  linked_correctly L1 L2 ->
  linked_correctly (Zexchange L1 j k) (Zexchange L2 (heap_item_key (Znth j L1)) (heap_item_key (Znth k L1))).
Proof.
  repeat intro. destruct H1 as [Hz ?]. split.
  * eapply Permutation_NoDup. 2: apply Hz.
    apply Zexchange_Permutation.
  * intros. subst loc. rewrite Zlength_Zexchange in H2. rewrite Zlength_Zexchange.
    destruct (H1 _ H). destruct (H1 _ H0). destruct (H1 _ H2). clear H1.
    case (Z.eq_dec i j); intro.
    - subst j. rewrite Znth_Zexchange; auto. rewrite Znth_Zexchange'; auto.
    - case (Z.eq_dec i k); intro.
      + subst i. rewrite Znth_Zexchange'; auto. rewrite Znth_Zexchange; auto.
      + rewrite Znth_Zexchange''; auto. rewrite Znth_Zexchange''; auto.
        intro. rewrite H1 in H8. rewrite H4 in H8. lia.
        intro. rewrite H1 in H8. rewrite H6 in H8. lia.
Qed.

Lemma exists_min_in_list: forall L,
  0 < Zlength L ->
  exists min_item : heap_item,
  In min_item L /\
  Forall (cmp_rel min_item) L.
Proof.
  induction L. discriminate.
  destruct L. exists a. split. left. trivial. constructor. reflexivity. constructor.
  intros _. assert (0 < Zlength (h :: L)) by (rewrite Zlength_cons; rep_lia).
  specialize (IHL H). clear H. destruct IHL as [mi' [? ?]].
  case_eq (cmp mi' a); intro. exists mi'.
  split. right. trivial.
  constructor. apply H1. trivial.
  exists a. split. left. trivial. constructor. reflexivity.
  rewrite Forall_forall in H0. rewrite Forall_forall. intro hi; intros.
  transitivity mi'.
  destruct (cmp_linear a mi'); auto. unfold cmp_rel in H3. rewrite H1 in H3. discriminate.
  apply H0. trivial.
Qed.

Lemma linked_correctly'_app: forall L1 L1' L2 n,
  linked_correctly' (L1 ++ L1') L2 n <->
  (linked_correctly' L1 L2 n /\ linked_correctly' L1' L2 (Zlength L1 + n)).
Proof.
  split; intros. destruct H. split; split; trivial; repeat intro. subst loc.
  assert (0 <= i < Zlength (L1 ++ L1')) by (rewrite Zlength_app; rep_lia).
  specialize (H0 _ H2). destruct H0.
  rewrite app_Znth1 in *; try lia. subst loc.
  assert (0 <= i + Zlength L1 < Zlength (L1 ++ L1')) by (rewrite Zlength_app; rep_lia).
  specialize (H0 _ H2). destruct H0.
  rewrite app_Znth2 in *; try lia.
  replace (i + Zlength L1 - Zlength L1) with i in * by lia.
  replace (Zlength L1 + n + i) with (n + (i + Zlength L1)) by lia. auto.
  destruct H as [[? ?] [? ?]]. split; trivial. intros. subst loc.
  rewrite Zlength_app in H3. assert (0 <= i < Zlength L1 \/ 0 <= i - Zlength L1 < Zlength L1') by rep_lia.
  destruct H4. rewrite app_Znth1; auto; lia.
  rewrite app_Znth2; try lia.
  specialize (H2 _ H4). destruct H2. replace (Zlength L1 + n + (i - Zlength L1)) with (n + i) in H5 by lia.
  auto.
Qed.

Lemma lookup_oob_eq_nil: forall L1 L2,
  lookup_oob_eq nil L1 L2 ->
  L1 = L2.
Proof.
  intros. destruct H.
  apply Znth_eq_ext. apply Permutation_Zlength; trivial. intros.
  apply H0. intros. rewrite Zlength_nil in H2. lia.
Qed.

Lemma fold_linked_heap_array: forall L1 v1 L2 v2,
  linked_correctly L1 L2 ->
  (heap_array L1 v1) * (lookup_array L2 v2) |-- linked_heap_array L1 v1 L2 v2.
Proof.
  intros. unfold linked_heap_array. entailer!.
Qed.

Lemma relink_tail: forall L0 L1 L2 L1' L2',
  linked_correctly (L0 ++ L1) L1' ->
  Permutation L0 L2 ->
  lookup_oob_eq L2 L1' L2' ->
  forall i, 0 <= i < Zlength L1 ->
  Znth (heap_item_key (Znth i L1)) L1' = Znth (heap_item_key (Znth i L1)) L2'.
Proof.
  intros old_live junk live lookup lookup'. intros.
  destruct H, H1.
  apply Permutation_Znth in H0. 2: apply (0,Int.zero,Int.zero).
  assert (0 <= i + Zlength live < Zlength (old_live ++ junk)) by (rewrite Zlength_app; rep_lia).
  destruct (H3 _ H5).
  rewrite <- H4; trivial.
  repeat intro.
  rewrite Znth_app2 in H7. 2: lia.
  replace (i + Zlength live - Zlength old_live) with i in H7 by lia.
  destruct H0 as [H0 [f [? [? ?]]]].
  rewrite H12 in H9. 2: lia.
  specialize (H10 (Z.to_nat j)).
  assert (0 <= (Z.of_nat (f (Z.to_nat j))) < Zlength (old_live ++ junk)) by lia.
  destruct (H3 _ H13).
  rewrite Znth_app1 in H15. 2: lia.
  rewrite H9 in H15. rewrite H7 in H15. lia.
Qed.

Lemma valid_pq_NoDup: forall p h,
  valid_pq p h |-- !! NoDup (heap_items h).
Proof.
  intros. unfold valid_pq, linked_heap_array, linked_correctly, linked_correctly'. Intros arr junk lookup lookup'.
  entailer!. clear H5 H6.
  apply NoDup_nth_error. rewrite NoDup_nth_error in H3. intros.
  rewrite <- (Nat2Z.id i) in H6.
  rewrite Znth_nth_error in H6. 2: rewrite Zlength_correct; rep_lia.
  remember (nth_error (heap_items h) j). destruct o. 2: discriminate.
  assert (j < length (heap_items h))%nat. { eapply nth_error_Some. intro. congruence. }
  assert (0 <= Z.of_nat j < Zlength (heap_items h)) by (rewrite Zlength_correct; lia).
  rewrite <- (Nat2Z.id j) in Heqo. rewrite Znth_nth_error in Heqo; auto.
  inversion Heqo. subst h0. clear Heqo. inversion H6. clear H6.
  generalize (H4 (Z.of_nat i)); generalize (H4 (Z.of_nat j)); intros. clear H4.
  rewrite Zlength_app in *. spec H6. rep_lia. spec H9. rewrite Zlength_correct; rep_lia.
  rewrite Znth_app1 in H6. 2: lia.
  rewrite Znth_app1 in H9. 2: rewrite Zlength_correct; lia.
  destruct H6, H9.
  rewrite H10 in H11. rewrite H11 in H6. lia.
Qed.

Lemma upd_Znth_update {A} {iA : Inhabitant A}: forall t (L: list A) x,
  0 <= t < Zlength L ->
  upd_Znth t L x = update L (Z.to_nat t) x.
Proof.
  intros.
  apply List_ext.list_eq_Znth.
    { rewrite Zlength_upd_Znth. do 2 rewrite Zlength_correct. rewrite update_length. trivial. }
  intros. rewrite Zlength_upd_Znth in H0.
  case (eq_dec i t); intros.
  subst i. rewrite upd_Znth_same; auto.
  assert (nth_error (update L (Z.to_nat t) x) (Z.to_nat t) = Some x).
    { rewrite nth_error_update; auto. rewrite Zlength_correct in H. lia. }
  rewrite Znth_nth_error in H1. inversion H1. do 2 rewrite H3. trivial.
  rewrite Zlength_correct. rewrite update_length. rewrite Zlength_correct in H. lia.
  rewrite Znth_upd_Znth_diff; auto.
  apply nth_error_Znth; auto. rewrite Zlength_correct. rewrite update_length. rewrite Zlength_correct in H0; lia.
  rewrite nth_error_update'. trivial.
  lia.
Qed.

Lemma Perm_Perm_cons_Perm: forall {A} {l1 l2 l3: list A} {a b},
  Permutation l1 (a :: l2) ->
  Permutation l2 (b :: l3) ->
  Permutation l1 (a :: b :: l3).
Proof.
  intros. transitivity (a :: l2). trivial. constructor. trivial.
Qed.

Lemma NoDup_Perm_False: forall {A} {l1 l2: list A} {a},
  NoDup l1 ->
  Permutation l1 (a :: a :: l2) -> False.
Proof.
  intros. assert (NoDup (a :: a :: l2)).
  eapply Permutation_NoDup; eauto.
  inversion H1. apply H4. left. trivial.
Qed.

Lemma malloc_pq: forall v,
  malloc_compatible (sizeof (Tstruct _structPQ noattr)) v ->
  (data_at_ Tsh (tarray tint (sizeof (Tstruct _structPQ noattr) / sizeof tint)) v) |--
  (data_at_ Tsh t_pq v).
Proof.
  intros v H.
  sep_apply data_at__memory_block_cancel.
  change (sizeof (tarray _ _)) with (sizeof t_pq).
  rewrite memory_block_data_at_.
  apply derives_refl.
  apply malloc_compatible_field_compatible in H; auto.
Qed.

Lemma Zlength_default_val_array: forall t size,
  0 <= size ->
  Zlength (default_val (tarray t size)) = size.
Proof.
  unfold default_val. simpl. intros. rewrite Zlength_Zrepeat; lia.
Qed.

Definition initializing_inc_list (size capacity : Z) : list val :=
  (map (fun z => Vint (Int.repr z)) (List_ext.nat_inc_list (Z.to_nat size))) ++
  default_val (tarray tuint (capacity - size)).

Lemma initializing_inc_list_inc: forall size capacity,
  0 <= size < capacity ->
  upd_Znth size (initializing_inc_list size capacity) (Vint (Int.repr size)) =
  initializing_inc_list (size + 1) capacity.
Proof.
  unfold initializing_inc_list. intros.
  rewrite upd_Znth_app2.
  1,2: rewrite Zlength_map, List_ext.nat_inc_list_Zlength.
  2: rewrite (Zlength_default_val_array tuint); lia.
  rewrite Z2Nat.id. 2: lia. rewrite Z.sub_diag.
  apply List_ext.list_eq_Znth.
  rewrite Zlength_app, Zlength_app, Zlength_upd_Znth, Zlength_map, Zlength_map.
  rewrite (Zlength_default_val_array tuint), (Zlength_default_val_array tuint).
  rewrite List_ext.nat_inc_list_Zlength, List_ext.nat_inc_list_Zlength. 1,2,3: lia.
  rewrite Zlength_app, Zlength_upd_Znth, Zlength_map.
  rewrite List_ext.nat_inc_list_Zlength, (Zlength_default_val_array tuint). 2: lia.
  replace (Z.of_nat (Z.to_nat size) + (capacity - size)) with capacity by lia.
  intros. assert (i < size \/ size <= i) by lia. destruct H1.
  rewrite Znth_app1, Znth_app1. rewrite Znth_map, Znth_map.
  rewrite List_ext.nat_inc_list_i, List_ext.nat_inc_list_i. trivial.
  5,6: rewrite Zlength_map. 3,4,5,6: rewrite List_ext.nat_inc_list_Zlength.
  1,2,3,4,5,6: lia.
  rewrite Znth_app2. 1,2 : rewrite Zlength_map, List_ext.nat_inc_list_Zlength. 2: lia.
  assert (i = size \/ size < i) by lia. destruct H2. subst i.
  rewrite Znth_app1. rewrite Znth_map, List_ext.nat_inc_list_i, Z2Nat.id, Z.sub_diag, Znth_upd_Znth_same; trivial.
  5: rewrite Zlength_map. 4,5: rewrite List_ext.nat_inc_list_Zlength.
  rewrite (Zlength_default_val_array tuint).
  1,2,3,4,5,6: lia.
  rewrite Znth_app2. 1,2: rewrite Zlength_map, List_ext.nat_inc_list_Zlength.
  rewrite Znth_upd_Znth_diff.
  unfold default_val. simpl. unfold Zrepeat.
  rewrite Znth_repeat_inrange, Znth_repeat_inrange; trivial.
  all: lia.
Qed.

Lemma initializing_inc_list_done: forall capacity,
  initializing_inc_list capacity capacity =
  map (fun z => Vint (Int.repr z)) (List_ext.nat_inc_list (Z.to_nat capacity)).
Proof.
  unfold initializing_inc_list. intros. rewrite Z.sub_diag.
  apply app_nil_r.
Qed.

Definition initial_item_list (size : Z) : list heap_item :=
  map (fun i => (i, Int.zero, Int.zero)) (List_ext.nat_inc_list (Z.to_nat size)).

Lemma Zlength_initial_item_list: forall size,
  0 <= size ->
  Zlength (initial_item_list size) = size.
Proof. intros. unfold initial_item_list. rewrite Zlength_map, List_ext.nat_inc_list_Zlength. lia. Qed.

Definition initializing_item_list (size capacity : Z) : list (reptype t_item) :=
  map heap_item_rep (initial_item_list size) ++ default_val (tarray t_item (capacity - size)).

Lemma Zlength_initializing_item_list: forall size capacity,
  0 <= size < capacity ->
  Zlength (initializing_item_list size capacity) = capacity.
Proof.
  unfold initializing_item_list. intros.
  rewrite Zlength_app, Zlength_map, Zlength_initial_item_list, (Zlength_default_val_array t_item); lia.
Qed.

Lemma initial_item_list_i: forall i size,
  0 <= i < size ->
  Znth i (initial_item_list size) = (i, Int.zero, Int.zero).
Proof.
  intros. unfold initial_item_list. rewrite Znth_map. rewrite List_ext.nat_inc_list_i. trivial.
  2: rewrite List_ext.nat_inc_list_Zlength. 1,2: lia.
Qed.

(* BUG, we shouldn't need this but it seems like a bad guess is being made for implicit assumptions without it? *)
Definition initializing_item_array (size capacity : Z) (v : val) : mpred :=
  data_at Tsh (tarray t_item capacity) (initializing_item_list size capacity) v.

Lemma initializing_item_list_inc: forall size capacity : Z,
  0 <= size < capacity ->
    upd_Znth size (initializing_item_list size capacity) (Vint (Int.repr size), (Vzero, Vzero)) =
    initializing_item_list (size + 1) capacity.
Proof.
  unfold initializing_item_list. intros.
  rewrite upd_Znth_app2.
  1,2: rewrite Zlength_map, Zlength_initial_item_list.
  3: rewrite (Zlength_default_val_array t_item); lia.
  2,3: lia. rewrite Z.sub_diag.
  apply List_ext.list_eq_Znth.
  rewrite Zlength_app, Zlength_app, Zlength_upd_Znth, Zlength_map, Zlength_map.
  rewrite (Zlength_default_val_array t_item), (Zlength_default_val_array t_item).
  rewrite Zlength_initial_item_list, Zlength_initial_item_list. 1-5: lia.
  rewrite Zlength_app, Zlength_upd_Znth, Zlength_map.
  rewrite Zlength_initial_item_list, (Zlength_default_val_array t_item). 2,3: lia.
  replace (size + (capacity - size)) with capacity by lia.
  intros. assert (i < size \/ size <= i) by lia. destruct H1.
  rewrite Znth_app1, Znth_app1. rewrite Znth_map, Znth_map.
  rewrite initial_item_list_i, initial_item_list_i. trivial.
  5,6: rewrite Zlength_map. 3-6: rewrite Zlength_initial_item_list. 1-10: lia.
  rewrite Znth_app2. 1,2 : rewrite Zlength_map, Zlength_initial_item_list. 2-4: lia.
  assert (i = size \/ size < i) by lia. destruct H2. subst i.
  rewrite Znth_app1. rewrite Znth_map, Z.sub_diag, Znth_upd_Znth_same, initial_item_list_i. trivial.
  2: rewrite (Zlength_default_val_array t_item). 6: rewrite Zlength_map.
  5,6: rewrite Zlength_initial_item_list. 1-8: lia.
  rewrite Znth_app2. 1,2: rewrite Zlength_map, Zlength_initial_item_list.
  rewrite Znth_upd_Znth_diff.
  unfold default_val. simpl. unfold Zrepeat.
  rewrite Znth_repeat_inrange, Znth_repeat_inrange; trivial.
  all: lia.
Qed.

Lemma initializing_item_list_done: forall capacity,
  initializing_item_list capacity capacity = map heap_item_rep (initial_item_list capacity).
Proof.
  unfold initializing_item_list. intros. rewrite Z.sub_diag.
  apply app_nil_r.
Qed.

Lemma initial_link_ok: forall size,
  0 <= size ->
  linked_correctly (initial_item_list size) (List_ext.nat_inc_list (Z.to_nat size)).
Proof.
  split. apply List_ext.nat_inc_list_NoDup.
  intros. rewrite List_ext.nat_inc_list_Zlength. rewrite Zlength_initial_item_list in H0; trivial.
  subst loc. unfold initial_item_list. rewrite Znth_map.
  unfold heap_item_key. simpl.
  rewrite List_ext.nat_inc_list_i.
  rewrite List_ext.nat_inc_list_i.
  4: rewrite List_ext.nat_inc_list_Zlength.
  1,2,3,4: lia.
Qed.

Lemma valid_heap_NoDup_keys: forall p h,
    valid_pq p h |-- !!(NoDup (proj_keys h)).
Proof.
  intros. unfold valid_pq, linked_heap_array, proj_keys.
  Intros arr junk arr2 lookup. entailer!.
  destruct H3. clear H4 H5.
  apply NoDup_nth_error. intros.
  remember (nth_error (map heap_item_key (heap_items h)) i). destruct o.
  2: { symmetry in Heqo. apply nth_error_Some in Heqo. contradiction. lia. }
  assert (j < length (map heap_item_key (heap_items h)))%nat. { apply nth_error_Some. intro. rewrite H7 in H5. discriminate. }
  assert (0 <= Z.of_nat i < Zlength (heap_items h)). { rewrite map_length in H4. rewrite Zlength_correct. lia. } clear H4.
  assert (0 <= Z.of_nat j < Zlength (heap_items h)). { rewrite map_length in H7. rewrite Zlength_correct. lia. } clear H7.
  destruct (H6 (Z.of_nat i)). 2: destruct (H6 (Z.of_nat j)). 1,2: rewrite Zlength_app; rep_lia.
  rewrite Znth_app1 in H7, H9, H10, H11. 2-5: lia.
  rewrite Heqo in H5.
  rewrite <- (Nat2Z.id i) in H5.
  rewrite <- (Nat2Z.id j) in H5.
  rewrite nth_error_Znth in H5.
  2,3: rewrite Zlength_map; lia.
  rewrite <- (Znth_map _ heap_item_key) in H9. 2: lia.
  rewrite H5 in H9. rewrite Znth_map in H9. 2: lia.
  rewrite H9 in H11. lia.
Qed.

Lemma nat_inc_list_plus_1_Permutation: forall (i : Z),
  0 <= i ->
  Permutation (nat_inc_list (Z.to_nat (i + 1))) (i :: nat_inc_list (Z.to_nat i)).
Proof.
  intros.
  replace (Z.to_nat (i + 1)) with (1 + Z.to_nat i)%nat by lia.
  simpl. symmetry.
  rewrite Z2Nat.id; auto.
  apply Permutation_cons_append.
Qed.

Lemma Permutation_filter: forall A (L1 L2 : list A) (f : A -> bool),
  Permutation L1 L2 ->
  Permutation (filter f L1) (filter f L2).
Proof.
  intros. induction H.
  constructor. simpl. case (f x). constructor. trivial. trivial.
  simpl. case (f x); case (f y). constructor. constructor. reflexivity.
  constructor. reflexivity. reflexivity. transitivity (filter f l'); trivial.
Qed.

Lemma filter_map_comm: forall A B (f : A -> bool) (g : B -> bool) (h : A -> B) (L : list A),
  (forall x, f x = g (h x)) ->
  filter g (map h L) = map h (filter f L).
Proof.
  induction L; intros. reflexivity.
  simpl. rewrite <- H. case (f a); auto. simpl. f_equal. auto.
Qed.

Lemma filter_map_comm': forall A f g (L : list A),
  (forall x, f x = f (g x)) ->
  filter f (map g L) = map g (filter f L).
Proof. intros. rewrite filter_map_comm with (f := f); auto. Qed.

Lemma find_item_by_key_update_pri_by_key: forall L k op v np,
  find_item_by_key L k = [(k, op, v)] ->
  find_item_by_key (update_pri_by_key L k np) k = [(k, np, v)].
Proof.
  intros. unfold find_item_by_key, update_pri_by_key in *.
  rewrite filter_map_comm'. 2: { unfold update_pri_if_key. intros.
    destruct x as [[kk ?] ?].
    unfold heap_item_key. simpl.
    case (Z.eq_dec kk); case (Z.eq_dec _ kk); simpl;
    case (Z.eq_dec _ k); simpl; intros; auto; exfalso; auto. }
  change (key_type * priority_type * payload_type)%type with heap_item.
  rewrite H.
  unfold update_pri_if_key, heap_item_key. simpl.
  case Z.eq_dec; trivial. destruct 1; trivial.
Qed.

Lemma Permutation_find_item_by_key: forall L1 L2 k,
  Permutation L1 L2 ->
  Permutation (find_item_by_key L1 k) (find_item_by_key L2 k).
Proof. intros. unfold find_item_by_key. apply Permutation_filter. trivial. Qed.

Lemma not_In_app: forall A x (L1 L2 : list A),
  ~ In x (L1 ++ L2) ->
  ~ In x L1 /\ ~ In x L2.
Proof.
  split; intro; apply H; apply in_or_app; auto.
Qed.

Lemma Permutation_two_eq: forall A (L : list A) x,
  Permutation L [x ; x] ->
  L = [x ; x].
Proof.
  intros. remember [x ; x]. revert Heql. induction H.
  * discriminate.
  * inversion 1. subst. symmetry in H. apply Permutation_length_1_inv in H. subst. trivial.
  * inversion 1. trivial.
  * intros. subst l''. spec IHPermutation2. trivial. specialize (IHPermutation1 IHPermutation2). subst l'. trivial.
Qed.

Lemma filter_empty: forall A f (L : list A),
  (forall x, In x L -> f x = false) ->
  filter f L = [].
Proof.
  induction L; intros. reflexivity.
  simpl. rewrite H. apply IHL. intros. apply H. right. trivial.
  left. trivial.
Qed.

Lemma find_item_by_key_app: forall L1 L2 k,
  find_item_by_key (L1 ++ L2) k = find_item_by_key L1 k ++ find_item_by_key L2 k.
Proof. intros. unfold find_item_by_key. rewrite filter_app. trivial. Qed.

Lemma filter_false_nil:
    forall A (l: list A) f,
      (forall a, In a l -> f a = false) ->
      filter f l = [].
  Proof. intros. apply filter_empty. trivial. Qed.

  Lemma find_item_by_key_finds_item:
    forall h item,
      In item h ->
      NoDup (map heap_item_key h) ->
      find_item_by_key h (heap_item_key item) =
      [item].
  Proof.
    intros.
    unfold find_item_by_key. induction h; [inversion H|].
    destruct H.
    - subst a. simpl.
      destruct (Z.eq_dec (heap_item_key item) (heap_item_key item)).
      2: exfalso; apply n; trivial.
      simpl. simpl in H0.
      apply NoDup_cons_2 in H0.
      replace (filter
                 (fun item0 : heap_item =>
                    Z.eq_dec (heap_item_key item0) (heap_item_key item)) h)
        with (@nil heap_item); trivial.
      rewrite filter_false_nil; trivial.
      intros.
      rewrite <- not_true_iff_false.
      intro.
      apply (in_map heap_item_key) in H.
      replace (heap_item_key a) with (heap_item_key item) in H.
      apply H0; trivial.
      destruct (Z.eq_dec (heap_item_key a) (heap_item_key item)).
      + lia.
      + simpl in H1. inversion H1.
    - simpl.
      destruct (Z.eq_dec (heap_item_key a) (heap_item_key item)).
      + exfalso.
        simpl in H0.
        apply NoDup_cons_2 in H0.
        apply H0. rewrite e. apply in_map; trivial.
      + simpl. apply IHh; trivial.
        simpl in H0.
        apply (NoDup_cons_1 _ (heap_item_key a)); trivial.
  Qed.

Lemma filter_absorb_map: forall A (f : A -> A) (g : A -> bool) L,
  (forall x, (g (f x) = g x) /\ ((g (f x) = false) \/ f x = x)) ->
  filter g (map f L) = filter g L.
Proof.
  induction L; auto; intros.
  simpl.
  case_eq (g (f a)); intro. destruct (H a). rewrite H0 in H2. destruct H2. discriminate.
  rewrite H1 in *. rewrite H0. rewrite H2, IHL; trivial.
  destruct (H a). rewrite H1 in H0. rewrite H0.
  apply IHL; auto.
Qed.

Lemma find_item_by_key_update_pri_by_key': forall L k1 k2 np,
  k1 <> k2 ->
  find_item_by_key (update_pri_by_key L k1 np) k2 = find_item_by_key L k2.
Proof.
  intros. unfold find_item_by_key, update_pri_by_key.
  rewrite filter_absorb_map. trivial. intros.
  unfold update_pri_if_key, heap_item_key. destruct x as [[? ?] ?].
  simpl. case Z.eq_dec; intro; simpl. subst k1. split; trivial.
  case Z.eq_dec; auto; intro; simpl. contradiction.
  case Z.eq_dec; simpl; split; auto.
Qed.

Lemma update_pri_by_key_keys_unaffected:
  forall l key newpri,
    map heap_item_key (update_pri_by_key l key newpri) = map heap_item_key l.
Proof.
  intros. induction l; trivial.
  simpl. rewrite IHl. f_equal.
  unfold update_pri_by_key, update_pri_if_key, heap_item_key.
  destruct (Z.eq_dec key (fst (fst a))); simpl fst; trivial.
Qed.

Lemma update_pri_by_key_payloads_unaffected:
  forall l key newpri,
    map heap_item_payload (update_pri_by_key l key newpri) = map heap_item_payload l.
Proof.
  intros. induction l; trivial.
  simpl. rewrite IHl. f_equal.
  unfold update_pri_by_key, update_pri_if_key, heap_item_payload, heap_item_key.
  destruct (Z.eq_dec key (fst (fst a))); simpl fst; trivial.
Qed.

Lemma In_update_pri_by_key: forall i L k np,
    In i (update_pri_by_key L k np) ->
    (In i L /\ heap_item_key i <> k) \/
    (exists oi, In oi L /\
                heap_item_key i = k /\
                heap_item_payload i = heap_item_payload oi /\
                heap_item_key i = heap_item_key oi /\
                heap_item_priority i = np).
Proof.
  intros.
  unfold update_pri_by_key in H.
  rewrite in_map_iff in H. destruct H as [oi [? ?]].
  revert H. unfold update_pri_if_key. case Z.eq_dec; intros.
  2: left; subst; auto.
  right. exists oi. split; trivial. subst i.
  unfold heap_item_key, heap_item_payload, heap_item_priority in *.
  simpl. tauto.
Qed.

(*
Does not seem to work on arrays.

unfold_data_at (data_at _ (tarray tint 3) _ v).

In environment
v : val
H : field_compatible (Tstruct _structItem noattr) [] v
V := list_repeat (Z.to_nat 3) (default_val tint) : list (reptype tint)
P := v : val
T := tarray tint 3 : type
F := field_at Tsh T [] V P : mpred
id := ?id : ident
Unable to unify "Tunion ?id noattr" with
 "match nested_field_rec (tarray tint 3) [] with
  | Some (_, t0) => t0
  | None => Tvoid
  end".
*)


From Coq Require Import ssreflect ssrfun ssrbool.
From Mon Require Export Base.
From Mon.SRelation Require Import SRelation_Definitions SMorphisms.
From Mon.sprop Require Import SPropBase SPropMonadicStructures Monoid SpecificationMonads MonadExamples.

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

(****************************************************************************)
(* Ordered monad algebras yield morphisms into the monotone continuations   *)
(* monad. This gives a general way of generating many effect observations,  *)
(* as described at the end of Section 4.1                                   *)
(****************************************************************************)
Section Algebra.

  Context (M:Monad) (alg:OrderedAlgebra M).

  Existing Instance oalg_order.
  Definition WPSpecMonad := @MonoCont _ (@oalg_rel _ alg) _.

  Program Definition mor_underlying X (m:M X) : WPSpecMonad X :=
    Sexists _ (fun post => alg (bind m (fun x => ret (post x)))) _.
  Next Obligation.
    move=> ? ? H. apply oalg_mono ; assumption.
  Qed.

  Import FunctionalExtensionality.
  Program Definition mor : MonadMorphism M WPSpecMonad :=
    @mkMorphism _ _ mor_underlying _ _.
  Next Obligation.
    apply Ssig_eq; extensionality post; cbv ; rewrite monad_law1 malg_ret //.
  Qed.
  Next Obligation.
    apply Ssig_eq ; extensionality post; cbv; rewrite monad_law3 malg_bind //.
  Defined.

  Definition D_wp := @Dθ _ _ mor.

  Definition underlying {A spec} : D_wp A spec -> M A := Spr1.

End Algebra.

Section UpdateMonadEffectObservation.
  Context (M:monoid) (X : monoid_action M).
  Let UpdX := Upd X.
  Let WUpdX := UpdSpec X.

  Program Definition UpdEffObs : MonadMorphism UpdX WUpdX :=
    @mkMorphism _ _ (fun A m => Sexists _ (fun p x => let mx := m x in p (nfst mx) (nsnd mx)) _) _ _.
  Next Obligation.
    move=> ? ? H ? ; apply H.
  Qed.

End UpdateMonadEffectObservation.

Section Option.
  Program Definition Opt : Monad :=
    @mkMonad option (@Some) (fun _ _ m f => Option.bind f m) _ _ _.
  (* TODO : report this error of Solve Obligations *)
  (* Solve Obligations with move: c => [?|] //=. *)
  Next Obligation. move: c => [?|] //=. Qed.
  Next Obligation. move: c => [?|] //=. Qed.

  Program Definition TotAlg : OrderedAlgebra Opt :=
    let alg := @mkMonadAlgebra Opt SProp
                               (fun c => match c with
                                      | Some p => p
                                      | None => sEmpty end) _ _ in
    @mkOrderedAlgebra _ alg SProp_op_order _ _.
  Next Obligation. move: m => [?|] //=. Qed.
  Next Obligation. typeclasses eauto. Qed.
  Next Obligation. move=> ? ? ? [?|] //= ; intuition. Qed.

  Definition morWpTot := mor TotAlg.

  Program Definition PartAlg : OrderedAlgebra Opt :=
    let alg := @mkMonadAlgebra Opt SProp
                               (fun c => match c with
                                      | Some p => p
                                      | None => sUnit end) _ _ in
    @mkOrderedAlgebra _ alg SProp_op_order _ _.
  Next Obligation. move: m => [?|] //=. Qed.
  Next Obligation. typeclasses eauto. Qed.
  Next Obligation. move=> ? ? ? [?|] //= ; intuition. Qed.

  Definition morWpPart := mor PartAlg.

  Import StrongestPostcondition.
  Let SP := ForwardPredTransformer.

  Import FunctionalExtensionality.
  Import SPropNotations.

  Section TotalSPNotExactlyMorphism.
    Program Definition θSP A (m : Opt A) : SP A :=
      match m with
      | Some a => ret a
      | None => Sexists _ (fun pre a => @mkOver _ pre _) _
      end.

    Lemma θSP_ret A (a:A) : θSP (ret a) = ret a.
    Proof. reflexivity. Qed.

    Lemma θSP_bind A B (m:Opt A) (f : A -> Opt B) :
      bind (θSP m) (fun b => θSP (f b)) ≤ θSP (bind m f).
    Proof.
      move: m => [a|] //=.
      change SP_bind with (@monad_bind SP).
      change SP_ret with (@monad_ret SP).
      erewrite monad_law1.
      move:(f a) => [?|] //=.

      move=> pre b /= [a H] ; exact (over H).
    Qed.

  End TotalSPNotExactlyMorphism.

  Program Definition morSpPart : MonadMorphism Opt SP :=
    @mkMorphism Opt SP (fun A c => match c with
                             | Some a => ret a
                             | None => Sexists _ (fun pre a => @mkOver _ sEmpty _) _
                             end) _ _.
  Next Obligation. destruct H. Qed.
  Next Obligation.
    move: m => [a|] //=.
    change SP_bind with (@monad_bind SP).
    change SP_ret with (@monad_ret SP).
    erewrite monad_law1.
    move:(f a) => [?|] //=.
    apply Ssig_eq=> //=.
    extensionality pre ; extensionality y.
    apply SPropOver_eq.
    split.
    move=> H ; destruct H.
    move=> [? H] ; move: (over H) => H0 ; destruct H0.
  Qed.

  Lemma part_pairing A m : wpsp_pairing (morWpPart A m) (morSpPart A m).
  Proof.
    cbv ; destruct m as [?|]; split ; try intuition ; subst_sEq ; intuition.
  Qed.

  Program Definition ranTotDiv A B (f : B -> Opt A)  w
    (H : morWpTot A (bind (None : Opt B) f) ≤ w) :
    ran w (morWpTot B None) :=
    Sexists _ (fun _ => Sexists _ (fun _ => sEmpty) _) _.
  Next Obligation. cbv ; intuition. Qed.
  Next Obligation. cbv ; split. cbv in H. assumption. intuition. Qed.

End Option.

Section FreeMonadEffectObservation.

  Context (S : Type) (P: S -> Type).
  Context (W : OrderedMonad).
  Context (OpContSpecs : forall s, W (P s)).

  Let Free := Free P.

  Fixpoint OpSpec_mor A (m : Free A) : W A :=
    match m with
    | retFree _ a => ret a
    | @opr _ _ _ s k => bind (OpContSpecs s) (fun ps => OpSpec_mor (k ps))
    end.

  Import FunctionalExtensionality.
  Program Definition OpSpecEffObs : MonadMorphism Free W :=
    @mkMorphism _ _ OpSpec_mor _ _.
  Next Obligation.
    elim m=> [?|? ? IH] //=.
    rewrite /bind /ret monad_law1 //.
    rewrite /bind monad_law3 ; f_equal. extensionality ps ; apply IH.
  Qed.

  Definition OpSpecWP : Dijkstra W := Dθ OpSpecEffObs.

  Program Definition cont_perform : forall s, OpSpecWP (P s) (@OpContSpecs s) :=
    fun s => Sexists _ (@opr _ _ _ s (@retFree _ _ _)) _.
  Next Obligation.
    cbv ; rewrite monad_law2 ; sreflexivity.
  Qed.

  Inductive ObsFree A : W A -> Type :=
  | OFRet : forall a w, ret a ≤ w -> ObsFree w
  | OFOp : forall s w w',
      bind (OpContSpecs s) w' ≤ w ->
      (forall x : P s, OpSpecWP A (w' x)) ->
      ObsFree w.

  Definition observeθ A w (m:OpSpecWP A w) : ObsFree w.
  Proof.
    destruct m as [[|] H].
    exact (OFRet H).
    apply (OFOp H)=> a. exists (f a). sreflexivity.
  Defined.

  Context (OpPartialRan : forall s C (w : W C) w0,
              bind (OpContSpecs s) w0 ≤ w -> ran w (OpContSpecs s)).
  Definition observeRan A w (m:OpSpecWP A w) : ObsFree w.
  Proof.
    destruct m as [[|] H] ; simpl in H.
    exact (OFRet H).
    pose (OpPartialRan H) as H'.
    destruct H' as [w0 H'].
    simple refine (OFOp _ _).
    exact s. exact w0. destruct H' ; assumption.
    move=> a. exists (f a). destruct H' as [H1 H2].
    apply (H2 (fun a => OpSpecEffObs A (f a))). assumption.
  Defined.

End FreeMonadEffectObservation.

Section FreeDijkstraMonads.
  Context (S : Type) (P: S -> Type).
  Context (W : OrderedMonad).
  Context (OpSpecs : forall s, W (P s)).
  Context (OpPartialRan : forall s C (w : W C) w0,
              bind (OpSpecs s) w0 ≤ w -> ran w (OpSpecs s)).

  Inductive FreeD (A:Type) : W A -> Type :=
  | FDRet : forall (a:A) (w:W A), ret a ≤ w -> FreeD w
  | FDop : forall s w (w':ran w (OpSpecs s)),
      (forall x:P s, FreeD (Spr1 w' x)) -> FreeD w.

  Definition fd_dret A (a:A) : FreeD (ret a) :=
    @FDRet _ a (ret a) ltac:(sreflexivity).

  Definition fd_weaken A {w1 w2} (m : @FreeD A w1) (Hw : w1 ≤ w2)
    : FreeD w2.
  Proof.
    revert w2 Hw ; induction m=> w2 Hw.
    simple refine (@FDRet _ a _ _). estransitivity ; eassumption.
    simple refine (@FDop _ s _ _ (fun x => _)).
    apply (OpPartialRan (w0:=Spr1 w')).
    destruct w' as [? [? ?]] ; estransitivity ; eassumption.
    simpl.
    apply (X x).
    apply ran_mono. assumption. sreflexivity.
  Defined.

  Definition fd_bind A B wm wf (m:@FreeD A wm) (f:forall a, @FreeD B (wf a))
    : FreeD (bind wm wf).
  Proof.
    revert wf f; induction m => wf0 f0.
    apply (fd_weaken (f0 a)). rewrite -monad_law1;
                               apply omon_bind; [assumption| sreflexivity].
    simple refine (@FDop _ s  _ _ (fun x => _)).
    apply (OpPartialRan (w0:=fun x => bind (Spr1 w' x) wf0)).
    rewrite /bind -monad_law3.
    apply omon_bind ; [|sreflexivity].
    destruct w' as [? [? ?]] ; assumption.

    simpl.
    apply (fd_weaken (X x wf0 f0)).
    match goal with
    | [|- _≤ Spr1 ?X _] => destruct X as [w'' [H1 H2]]
    end ; simpl in *.
    apply (H2 (fun x => bind (Spr1 w' x) wf0)).
    rewrite /bind -monad_law3. apply omon_bind ; [|sreflexivity].
    destruct w' as [? [? ?]] ; assumption.
  Defined.

  (* So far, so good, we have a carrier type with return,
     bind and weaken operations defined *)
  (* The problems arise when trying to prove anything by induction
     because right kan extension need not to be equal on the nose *)
  (* Assuming that the preorder on W is actually an order should
     be enough to go forward but that looks quite annoying to prove... *)

  (* Import FunctionalExtensionality. *)
  (* Import SPropNotations. *)
  (* Notation "w1 ≃ w2" := (w1 ≤ w2 s/\ w2 ≤ w1) (at level 65). *)
  (* Context (Wantisym : forall A (w1 w2 : W A), w1 ≃ w2 -> w1 = w2). *)
  (* Lemma kleisli_antisym A B (w1 w2 : A -> W B) : (forall a, w1 a ≃ w2 a) -> w1 = w2.  *)
  (* Proof. *)
  (*   move=> H ; extensionality a ; apply Wantisym ; apply H. *)
  (* Qed. *)

  (* Lemma fd_weaken_refl A w1 (m:@FreeD A w1) (H : w1 ≤ w1) : *)
  (*   fd_weaken m H = m. *)
  (* Proof. *)
  (*   induction m=> //=. *)
  (*   Set Printing Implicit. *)
  (*   match goal with *)
  (*   | [|- FDop ?f1 = FDop ?f2] => enough (f1 = f2) as -> ; [reflexivity|] *)
  (*   end. *)

End FreeDijkstraMonads.

Section SumOfTheories.
  Context (S1 S2 : Type) (P1: S1 -> Type) (P2: S2 -> Type).
  Context (W : OrderedMonad).
  Context (OpSpecs1 : forall s, W (P1 s)) (OpSpecs2 : forall s, W (P2 s)).

  Definition sumS : Type := S1 + S2.
  Definition sumP (s:sumS) : Type :=
    match s with
    | inl s1 => P1 s1
    | inr s2 => P2 s2
    end.
  Definition sumOpSpecs (s:sumS) : W (sumP s) :=
    match s with
    | inl s1 => OpSpecs1 s1
    | inr s2 => OpSpecs2 s2
    end.
End SumOfTheories.

(****************************************************************************)
(* We use the approach of McBride'15, Turing completeness totally free,     *)
(* in order to extend a Dijkstra monad on a free monad with an operation    *)
(* corresponding to a recursive call. Then we provide a fix operation       *)
(* (some kind of handler) to recover a function in the original Dijkstra    *)
(* monad.                                                                   *)
(****************************************************************************)

From Equations Require Import Equations.
From Mon.sprop Require Import WellFounded.

Derive NoConfusion for FreeF.
Derive Subterm for FreeF.

Section GeneralRecursion.
  Context (S : Type) (P: S -> Type).

  Context (W : OrderedMonad).

  Context (OpSpecs : forall s, W (P s))
          (Hran_s : forall s C (w : W C) w0, bind (OpSpecs s) w0 ≤ w ->
                                        ran w (OpSpecs s)).

  Context `{forall A, aa (@omon_rel W A)}.

  Context (DBase : Dijkstra W)
          (perform_s : forall s, DBase (P s) (OpSpecs s))
          (intro_assume:forall A (pre:SProp) (w:W A),
              (pre -> DBase A w) -> DBase A (assume_p pre w)).

  Context (Dom:Type) (prec : Dom -> Dom -> Prop) `{WellFounded _ prec}
          (Hsquash_prec : forall d1 d2, Squash (prec d1 d2) -> prec d1 d2).
  Context (Cod : Dom -> Type) (inv : forall d:Dom, W (Cod d)).

  Definition inv' d0 d := assume_p (Squash (prec d d0)) (inv d).

  Context (Hran_inv : forall d0 d C (w : W C) w0,
              bind (inv' d0 d) w0 ≤ w ->
              ran w (inv' d0 d)).

  Import SPropNotations.

  Definition GenRecExtS : Type := sumS S Dom.
  Definition GenRecExtP (s:GenRecExtS) : Type := sumP P Cod s.
  Definition GenRecExtSpecs (d0:Dom) (s:GenRecExtS) : W (GenRecExtP s) :=
    sumOpSpecs OpSpecs (fun d => assume_p (Squash (prec d d0)) (inv d)) s.

  Definition GenRecExt d0 := OpSpecWP (GenRecExtSpecs d0).

  Section GenRecTelescopes.
    Import Telescopes.
    Definition GenRecTele :=
      ext Dom (fun d => ext Type (fun C => ext (W C) (fun w => tip (GenRecExt d C w)))).

    Let T C := (FreeF GenRecExtP C).
    Definition GenRec_to_FreeF : tele_fn GenRecTele {C : Type & T C}.
    Proof. intros ? C ? [m] ; exists C ; exact m. Defined.
    Definition GenRec_measure :=
      tele_measure GenRecTele {C : Type & T C} GenRec_to_FreeF
                   (lexdepprod Type T (empty_rel Type)
                               (@FreeF_subterm _ GenRecExtP)).
    Definition to_tele C w d c : GenRecTele :=
      sigmaI _ d (sigmaI _ C (sigmaI _ w c)).

  End GenRecTelescopes.

  Import FunctionalExtensionality.

  Context (f : forall (d:Dom), GenRecExt d (Cod d) (inv d)).
  Equations(noind) eval {C w d} (c : GenRecExt d C w) : DBase C w
    by wf (d, to_tele c)
          (Subterm.lexprod Dom _ prec GenRec_measure)
    :=
    eval (Sexists _ (retFree _ z) _) := wkn (dm_ret DBase z) _ ;
    eval (Sexists _ (@opr _ _ _ (inl s) k) w) :=
      wkn (dm_bind (perform_s s)
                    (fun ps => @eval _ (Spr1 (Hran_s w) ps) d (Sexists _ (k ps) _))) _ ;

    eval (Sexists _ (@opr _ _ _ (inr d') k) w) :=
      let m (pre : Squash (prec d' d)) := @eval _ _ d' (f d') in
      wkn (dm_bind (intro_assume m) (fun ps => @eval C (Spr1 (Hran_inv w) ps) d (Sexists _ (k ps) _))) _.
  Next Obligation.
    match goal with
    | [|- context [Spr1 ?T]] =>
      let H0 := fresh "H" in
      move: (Spr2 T) => /= [_ H0] ; apply (H0 _ w ps)
    end.
  Qed.
  Next Obligation.
    do 2 right. do 2 constructor.
  Qed.
  Next Obligation.
    match goal with
    | [|- context [Spr1 ?T]] =>
      let H0 := fresh "H" in
      move: (Spr2 T) => /= [H0 _] ; apply H0
    end.
  Qed.
  Next Obligation.
    match goal with
    | [|- context [Spr1 ?T]] =>
      let H0 := fresh "H" in
      move: (Spr2 T) => /= [_ H0] ; apply (H0 _ w ps)
    end.
  Qed.
  Next Obligation.
    do 2 right. do 2 constructor.
  Qed.
  Next Obligation.
    match goal with
    | [|- context [Spr1 ?T]] =>
      let H0 := fresh "H" in
      move: (Spr2 T) => /= [H0 _] ; apply H0
    end.
  Qed.

  Next Obligation.
    unfold eval.
    rewrite Subterm.FixWf_unfold_ext.
    destruct c as [[?|[?|?]] ?] ; try reflexivity.
  Defined.

  Definition ffix (d:Dom) : DBase (Cod d) (inv d) := eval (f d).

  Definition call {d0} d : GenRecExt d0 (Cod d) (inv' d0 d) :=
    cont_perform (GenRecExtSpecs d0) (inr d).

End GeneralRecursion.

Section NatLtSProp.

  Inductive leS : nat -> nat -> SProp :=
  | leSZ : forall n, leS 0 n
  | leSS : forall n m, leS n m -> leS (S n) (S m).

  Lemma leS_diag : forall n, leS n n.
  Proof. elim=> [|] ; constructor. assumption. Qed.

  Lemma leS_to_le : forall m n, leS n m -> le n m.
  Proof.
    induction m. move=> [|n H] //=.
    assert (HF:sEmpty) by inversion H ; inversion HF.
    move=> [?|n H]. exact (PeanoNat.Nat.le_0_l _).
    apply Le.le_n_S ; apply IHm. inversion H ; assumption.
  Qed.

  Goal forall (p:SProp), Squash (Box p) -> p.
  Proof. move=> p [[H]] ; exact H. Qed.

  Lemma sq_le_to_leS : forall m n, Squash (le n m) -> leS n m.
  Proof.
    elim=> [|m IHm] [|n IHn].
    move=> ? ; constructor.
    destruct IHn as [H] ; inversion H.
    move=> ? ; constructor.
    destruct IHn as [H] ; inversion H.
    apply leS_diag.
    constructor. apply IHm.
    constructor. apply Le.le_Sn_le ; assumption.
  Qed.

End NatLtSProp.

Section EmptySignature.

  Definition EmptyS : Type := False.
  Definition EmptyP : EmptyS -> Type := False_rect Type.
  Definition EmptyOpSpecs (W: OrderedMonad) (s : EmptyS) : W (EmptyP s) :=
    match s with end.
  Definition EmptyRan (W:OrderedMonad) (s:EmptyS) :
    forall (C : Type) (w : W C), ran w (EmptyOpSpecs W s) :=
    match s with end.
  Definition EmptyRan' (W:OrderedMonad) (s:EmptyS) :
    forall (C : Type) (w : W C) w0,
      bind (EmptyOpSpecs W s) w0 ≤ w -> ran w (EmptyOpSpecs W s) :=
    match s with end.

End EmptySignature.

(****************************************************************************)
(* Dijkstra monad for Pure computations                                     *)
(****************************************************************************)

Section Pure.
  Let W := MonoContSProp.
  Import SPropNotations.
  Import FunctionalExtensionality.

  Definition Pure_car A (w:W A) : Type :=
    { f : forall p, Spr1 w p -> { a : A ≫ p a }
    ≫ forall p p' (H : Pred_op_order p' p) Hwp Hwp',
          Squash (Spr1 (f p Hwp) = Spr1 (f p' Hwp')) }.

  Program Definition Pure_ret A (a:A) : Pure_car (ret a) :=
    ⦑fun p Hpre => Sexists _ a Hpre⦒.
  Next Obligation. constructor ; reflexivity. Qed.

  Import EqNotations.
  Lemma sprop_app_irr
    : forall {p:SProp} {Z : Type} (f : p -> Z) (x1 x2 : p), f x1 = f x2.
  Proof. reflexivity. Defined.

  Program Definition Pure_bind A B wm wf (m:@Pure_car A wm)
          (f: forall a, @Pure_car B (wf a)) : @Pure_car B (bind wm wf) :=
    ⦑fun p Hpre =>
      let m0 := Spr1 m _ Hpre in
      Spr1 (f (Spr1 m0)) p (Spr2 m0)⦒.
  Next Obligation.
    unshelve epose (Hm := Spr2 m _ _ _ Hwp Hwp').
    cbv ; intuition.
    destruct Hm as [Hm].
    unshelve epose (Hf := Spr2 (f (Spr1 (Spr1 m (fun a : A => Spr1 (wf a) p) Hwp))) p p' H _ _).
    exact (Spr2 (Spr1 m (fun a : A => Spr1 (wf a) p) Hwp)).
    unshelve eapply (Spr2 (wf _) _ _).
    exact p.
    exact H.
    exact (Spr2 (Spr1 m (fun a : A => Spr1 (wf a) p) Hwp)).
    destruct Hf as [Hf].
    constructor.
    rewrite Hf.
    assert (forall a a' p Hp Hp' (Ha:a = a'), Spr1 (f a) p Hp = Spr1 (f a') p Hp').
    intros.
    refine (match Ha as H0 in _ = a0 return
                  forall (H:a' = a0),
                    Spr1 (f a) p0 Hp = Spr1 (f a0) p0 (eq_sind (fun a => Spr1 (wf a) p0) Hp' H)
            with
            | eq_refl => _
            end eq_refl).
    intros. apply sprop_app_irr.

    erewrite (H0 _ _ p' _ _ Hm).
    reflexivity.
  Qed.

  Program Definition Pure_wkn A w w' (m:@Pure_car A w) (Hww':w ≤ w')
    : @Pure_car A w'
    := ⦑fun p Hpre => Spr1 m p (Hww' p Hpre)⦒.
  Next Obligation. apply (Spr2 m)=> //. Qed.

  Lemma sprop_app_irr'
    : forall {p:SProp} {Z : Type} (f : p -> Z) (x1 x2 : p), f x1 ≡ f x2.
  Proof. reflexivity. Defined.

  Import SPropAxioms.

  Program Definition Pure : Dijkstra W :=
    {| dm_tyop := Pure_car
    ; dm_ret := Pure_ret
    ; dm_bind := Pure_bind
    ; dm_wkn := Pure_wkn
    |}.
  Next Obligation. hnf ; reflexivity. Qed.
  Next Obligation. hnf ; reflexivity. Qed.
  Next Obligation. hnf ; reflexivity. Qed.
  Next Obligation.
    cbv.
    apply Monoid.Ssig_sEq.
    simpl ;  funext p ; funext_s Hpre.
    assert (forall a a' p Hp Hp' (Ha:a ≡ a'), Spr1 (f a) p Hp ≡ Spr1 (f a') p Hp').
    intros.
    refine (match Ha as H0 in _ ≡ a0 return
                  forall (H:a' ≡ a0),
                    Spr1 (f a) p0 Hp ≡ Spr1 (f a0) p0 (sEq_sind _ _ (fun a _ => Spr1 (wf a) p0) Hp' _ H)
            with
            | sEq_refl _ => _
            end (sEq_refl _)).
    intros. apply sprop_app_irr'.
    apply H.
    epose (Spr2 m (fun a : A => Spr1 (wf' a) p) _ _ _ _).
    destruct s as [s].
    rewrite s.
    reflexivity.
    Unshelve.
    cbv in Hf |- *; move=> ? ; apply Hf.
    cbv in Hm |- * ; apply Hm=> //.
  Qed.

  Program Definition pure_intro_assume A (pre:SProp) w (f : pre -> Pure A w)
    : Pure A (assume_p pre w) :=
    ⦑fun p Hpre => Spr1 (f _) p _⦒.
  Next Obligation. destruct Hpre ; assumption. Qed.
  Next Obligation. destruct Hpre ; assumption. Qed.
  Next Obligation. apply (Spr2 (f _))=> //. Qed.
End Pure.

(****************************************************************************)
(* We implement the fibonnacci function on top of Pure using General Recursion *)
(****************************************************************************)

Section Fibonnacci.
  Let W := MonoContSProp.
  Definition fib_trivial_inv : W nat := PrePostSpec sUnit (fun _ => sUnit).
  Let GenRecNatNat :=
    GenRecExt (EmptyOpSpecs W) lt (fun _ => fib_trivial_inv).
  Let call {n0} (n:nat) : GenRecNatNat n0 nat _ := call _ _ _ n.
  Import DijkstraMonadNotations.
  Program Definition fib0 (n:nat) : GenRecNatNat n nat fib_trivial_inv :=
    match n with
    | 0 | 1 => wkn (dret 1) _
    | S (S n) => wkn (r1 <- call (S n) ; r2 <- call n ; dret (r1 + r2)) _
    end.
  Next Obligation. destruct H; cbv; auto. Qed.
  Next Obligation. destruct H; cbv; auto. Qed.
  Next Obligation. cbv ; intuition ; constructor. reflexivity.
                   constructor ; reflexivity. Qed.

  Definition Empty_perform W (D: Dijkstra W) (s:EmptyS) : D (EmptyP s) (EmptyOpSpecs W s) := match s with end.
  Program Definition fib := @ffix _ _ W _ (@EmptyRan' W) _ Pure (Empty_perform  Pure) pure_intro_assume _ _ _ _ _ _ _ fib0.
  Next Obligation.
    apply leS_to_le. apply (sq_le_to_leS H).
  Qed.
  Next Obligation.
    unshelve eapply (ran_iso (@MonoContAlongPrePost_ran _ _ w (Squash (S d <= d0)) (fun _ => sUnit)  _)).
    cbv in H.
    move=> Hw ; destruct (H _ Hw) ; assumption.
    split ; sreflexivity.
    cbv ; intuition.
  Qed.

  Program Definition fib' n := Spr1 (@fib n) (fun _ => sUnit) _.
  Next Obligation. intuition. Qed.

  (* Goal exists x, x = Spr1 (fib' 2). *)
  (* Proof. *)
  (*   eexists. *)
  (*   rewrite /fib' /fib /ffix. *)
  (*   time repeat (simp eval ; simpl). *)
  (*   (* Tactic call ran for 15.526 secs (15.437u,0.026s) (success) *) *)
  (*   reflexivity. *)
  (* Qed. *)

  (* Goal exists x, x = Spr1 (fib' 0). *)
  (* Proof. *)
  (*   eexists. *)
  (*   rewrite /fib' /fib /ffix. *)
  (*   time repeat (simp eval ; simpl). *)
  (*   (* Tactic call ran for 1.12 secs (1.115u,0.003s) (success) *) *)
  (*   reflexivity. *)
  (* Qed. *)

  (* Goal exists x, x = Spr1 (fib' 3). *)
  (* Proof. *)
  (*   eexists. *)
  (*   rewrite /fib' /fib /ffix. *)
  (*   time repeat (simp eval ; simpl). *)
  (*   (* Tactic call ran for 296.109 secs (295.803u,0.029s) (success) *) *)
  (*   reflexivity. *)
  (* Qed. *)

End Fibonnacci.


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

(***
Modulus : 2^416 - 2^208 - 1
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 13%nat;
    base := 32;
    bitwidth := 32;
    s := 2^416;
    c := [(1, 1); (2^208, 1)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

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

    mul_code := None;

    square_code := None;

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

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


From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype seq.
From scilla
Require Import Automata.
From scilla
Require Import options.

(**
An encoding of the Puzzle contract from Luu et al.

contract Puzzle {
  address public owner;
  bool public locked;
  uint public reward;
  bytes32 public diff;
  bytes public solution;

  function Puzzle() { //constructor
    owner = msg.sender;
    reward = msg.value;
    locked = false;
    diff = bytes32(11111); //pre-defined difficulty
 }

  function(){ //main code, runs at every invocation
    if (msg.sender == owner){ //update reward
      if (locked) throw;
      owner.send(reward);
      reward = msg.value;
    } else if (msg.data.length > 0){ //submit a solution
      if (locked) throw;
      if (sha256(msg.data) < diff) {
        msg.sender.send(reward); //send reward solution = msg.data;
        locked = true;
      }
    }
  }
}

*)

Section Puzzle.

Variable bytes32 : nat -> nat.
Variable sha256 : nat -> nat.
(* Variable data_tag : nat. *)

Definition get_solution (pl : payload_type) :=
  if pl is (0, n :: _) :: _ then n
  else 0.

Record PuzzleState :=
  PS {
      owner : nat;
      locked: bool;
      reward : nat;
      diff : nat;
      solution : option nat;
    }.

Variable init_sender : nat.
Variable init_reward : nat.

(* Inital state after the constructor execution *)
Set Warnings "-abstract-large-number".
Definition s0 := PS init_sender false init_reward (bytes32 11111) None.

(* Transition 1 -- changing the reward *)
Definition input_filter1 : input_filter_type PuzzleState :=
  fun m st1 => (sender m == init_sender) && (~~ locked (state st1)).

Definition new_reward s r :=
  let: PS a b _ d e := s in PS a b r d e.

Definition trans_rel1 : trans_rel_type input_filter1 :=
  fun m st1 _ s2 outs =>
    let s1 := state st1 in
    s2 = new_reward s1 (value m) /\
    outs = [:: (init_sender, reward s1, 0, [::])].

Definition update_reward := CTrans 1 trans_rel1.

(* Transition 2 *)
Definition input_filter2 : input_filter_type PuzzleState :=
  fun m st1 =>
    (sender m != init_sender) && (~~ locked (state st1)).

Definition trans_rel2 : trans_rel_type input_filter2 :=
  fun m st1 _ s2 outs =>
    let s1 := state st1 in
    let sol := get_solution (payload m) in
    if sha256 sol < diff s1
    then s2 = PS (owner s1) true (reward s1) (diff s1) (Some sol)
         /\ outs = [:: (sender m, reward s1, 0, [::])]
    else s2 = s1 /\ outs = [::].

Definition try_solution := CTrans 2 trans_rel2.

(* Puzzle protocol *)

Variable puzzle_acc : nat.

Program Definition puzzle_prot : Protocol PuzzleState :=
  @CProt _ puzzle_acc init_reward s0 [:: update_reward; try_solution] _.

(* Let the fun begin now *)
Section PuzzleInvariants.

Notation PState := (cstate PuzzleState).

(*
   First invariant: the real balance at any time is not smaller than the reward,
   so the reward can be always transferred.
*)

Definition I_bal (st : PState) :=
  ~~ locked (state st) ->
  balance st >= reward (state st).

Theorem I_bal_ind : inductive puzzle_prot I_bal.
Proof.
split; rewrite /s0/I_bal/=; first by rewrite leqnn.
move=>ts; case=>/=;[|case; last by []]=>Z [a bal s1];
subst ts=>/= Hi m pf s2 outs; last first.
- rewrite /trans_rel2; case:ifP=>// _; first by case=>->.
  case=>->E/=/Hi=>G; subst outs.
  rewrite /msg_bals/=; rewrite subn0.
  suff X : bal <= bal + value m by apply: (leq_trans G X).
  by apply: leq_addr.
rewrite /trans_rel1/==>[][]->E.
rewrite /input_filter1/= in pf; case/andP:pf=>_ L.
case: (s1) L Hi E=>x b c d e/={s1}Z/(_ Z){Z}Hi->_.
by rewrite /msg_bals/msg_bal/= addn0 leq_addl.
Qed.

(* Since locked the balance doesn't change *)
Definition is_locked st := locked (state st).

Definition holds_same_balance (st st' : PState) :=
  balance st = balance st'.

(* Fact: since we're locked, the balance doesn't change
   (this is how it should be!) *)
Theorem since_locked : since puzzle_prot is_locked holds_same_balance.
Proof.
move=>st1 Hl st2 [n]; elim: n st1 Hl=>/=[st _|n Hi st1 Hl [st][Hs Hr]]; first by move=><-.
suff [Eb Hl']: balance st = balance st1 /\ is_locked st.
- by rewrite /holds_same_balance in Hi *; rewrite -Eb{Eb}; apply: Hi=>//.
clear Hr Hi st2.
case: st1 Hs Hl=>acc b[ow1]lk1 rw1 d1 s1 [ts][m]/=[pf][os][s2][G]_->{st}/= Hl.
rewrite /is_locked/= in Hl. rewrite Hl in pf=>{Hl}.
by case: G=>/=;[|case=>//]=>Z; subst ts; simpl in pf;
   rewrite?/input_filter1 /input_filter2 andbC/= in pf.
Qed.

(* TODO: Think of more interesting temporal properties *)

End PuzzleInvariants.

End Puzzle.

(* TODO: Implement the puzzle contract as an I/O automata *)

(* TODO: Prove a bunch of atomic invariants *)


From stdpp Require Export vector.
From iris.algebra Require Export ofe.
From iris.algebra Require Import list.
From iris Require Import options.

Section ofe.
  Context {A : ofeT}.

  Instance vec_equiv m : Equiv (vec A m) := equiv (A:=list A).
  Instance vec_dist m : Dist (vec A m) := dist (A:=list A).

  Definition vec_ofe_mixin m : OfeMixin (vec A m).
  Proof. by apply (iso_ofe_mixin vec_to_list). Qed.
  Canonical Structure vecO m : ofeT := OfeT (vec A m) (vec_ofe_mixin m).

  Global Instance list_cofe `{Cofe A} m : Cofe (vecO m).
  Proof.
    apply: (iso_cofe_subtype (λ l : list A, length l = m)
      (λ l, eq_rect _ (vec A) (list_to_vec l) m) vec_to_list)=> //.
    - intros v []. by rewrite /= vec_to_list_to_vec.
    - intros c. by rewrite (conv_compl 0 (chain_map _ c)) /= vec_to_list_length.
  Qed.

  Global Instance vnil_discrete : Discrete (@vnil A).
  Proof. intros v _. by inv_vec v. Qed.
  Global Instance vcons_discrete n x (v : vec A n) :
    Discrete x → Discrete v → Discrete (x ::: v).
  Proof.
    intros ?? v' ?. inv_vec v'=>x' v'. inversion_clear 1.
    constructor. by apply discrete. change (v ≡ v'). by apply discrete.
  Qed.
  Global Instance vec_ofe_discrete m : OfeDiscrete A → OfeDiscrete (vecO m).
  Proof. intros ? v. induction v; apply _. Qed.
End ofe.

Arguments vecO : clear implicits.
Typeclasses Opaque vec_dist.

Section proper.
  Context {A : ofeT}.

  Global Instance vcons_ne n :
    Proper (dist n ==> forall_relation (λ x, dist n ==> dist n)) (@vcons A).
  Proof. by constructor. Qed.
  Global Instance vcons_proper :
    Proper (equiv ==> forall_relation (λ x, equiv ==> equiv)) (@vcons A).
  Proof. by constructor. Qed.

  Global Instance vlookup_ne n m :
    Proper (dist n ==> eq ==> dist n) (@Vector.nth A m).
  Proof.
    intros v. induction v as [|x m v IH]; intros v'; inv_vec v'.
    - intros _ x. inv_fin x.
    - intros x' v' EQ i ? <-. inversion_clear EQ. inv_fin i=> // i. by apply IH.
  Qed.
  Global Instance vlookup_proper m :
    Proper (equiv ==> eq ==> equiv) (@Vector.nth A m).
  Proof.
    intros v v' ? x x' ->. apply equiv_dist=> n. f_equiv. by apply equiv_dist.
  Qed.

  Global Instance vec_to_list_ne m : NonExpansive (@vec_to_list A m).
  Proof. by intros v v'. Qed.
  Global Instance vec_to_list_proper m : Proper ((≡) ==> (≡)) (@vec_to_list A m).
  Proof. by intros v v'. Qed.
End proper.

(** Functor *)
Definition vec_map {A B : ofeT} m (f : A → B) : vecO A m → vecO B m :=
  @vmap A B f m.
Lemma vec_map_ext_ne {A B : ofeT} m (f g : A → B) (v : vec A m) n :
  (∀ x, f x ≡{n}≡ g x) → vec_map m f v ≡{n}≡ vec_map m g v.
Proof.
  intros Hf. eapply (list_fmap_ext_ne f g v) in Hf.
  by rewrite -!vec_to_list_map in Hf.
Qed.
Instance vec_map_ne {A B : ofeT} m f n :
  Proper (dist n ==> dist n) f →
  Proper (dist n ==> dist n) (@vec_map A B m f).
Proof.
  intros ? v v' H. eapply list_fmap_ne in H; last done.
  by rewrite -!vec_to_list_map in H.
Qed.
Definition vecO_map {A B : ofeT} m (f : A -n> B) : vecO A m -n> vecO B m :=
  OfeMor (vec_map m f).
Instance vecO_map_ne {A A'} m :
  NonExpansive (@vecO_map A A' m).
Proof. intros n f g ? v. by apply vec_map_ext_ne. Qed.

Program Definition vecOF (F : oFunctor) m : oFunctor := {|
  oFunctor_car A _ B _ := vecO (oFunctor_car F A B) m;
  oFunctor_map A1 _ A2 _ B1 _ B2 _ fg := vecO_map m (oFunctor_map F fg)
|}.
Next Obligation.
  intros F A1 ? A2 ? B1 ? B2 ? n m f g Hfg. by apply vecO_map_ne, oFunctor_map_ne.
Qed.
Next Obligation.
  intros F m A ? B ? l.
  change (vec_to_list (vec_map m (oFunctor_map F (cid, cid)) l) ≡ l).
  rewrite vec_to_list_map. apply listOF.
Qed.
Next Obligation.
  intros F m A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' l.
  change (vec_to_list (vec_map m (oFunctor_map F (f ◎ g, g' ◎ f')) l)
    ≡ vec_map m (oFunctor_map F (g, g')) (vec_map m (oFunctor_map F (f, f')) l)).
  rewrite !vec_to_list_map. by apply: (oFunctor_map_compose (listOF F) f g f' g').
Qed.

Instance vecOF_contractive F m :
  oFunctorContractive F → oFunctorContractive (vecOF F m).
Proof.
  by intros ?? A1 ? A2 ? B1 ? B2 ? n ???; apply vecO_map_ne; first apply oFunctor_map_contractive.
Qed.


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

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	   A sufficient condition for a Comma to be Complete        	     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export Pres_Limits.
Require Export Comma_proj.

Set Implicit Arguments.
Unset Strict Implicit.

Section comma_complete.

Variables (X A : Category) (G : Functor A X) (J : Category).

Hypothesis A_comp_for_J : forall F : Functor J A, Limit F.
Hypothesis G_pres_JA : forall F : Functor J A, Preserves_limits F G.

Variables (x : X) (F : Functor J (Comma G x)).

Let F' := F o_F Comma_proj G x.

Let l_F' := A_comp_for_J F'.

Let l_GF' := G_pres_JA l_F'.

(* construction d'un cone Delta(x)->F' o G *)

Definition Tc_tau (i : J) := Mor_com_ob (F i).

Lemma Tc_tau_cone_law : Cone_law (F:=F' o_F G) Tc_tau.
Proof.
unfold Cone_law in |- *; intros i j g.
apply (Prf_com_law (FMor F g)).
Qed.

Definition Tc_cone := Build_Cone Tc_tau_cone_law.

(* limite objet pour F *)

Canonical Structure Tc_limF := Build_Com_ob (Lim_diese l_GF' Tc_cone).

(* limiting cone pour F *)

Lemma Tc_limconeF_tau_com_law :
 forall i : J, Com_law (axf:=Tc_limF) (bxg:=F i) (Limiting_cone l_F' i).
Proof.
unfold Com_law in |- *; intro i.
apply Sym; exact (Prf_limit1 l_GF' Tc_cone i).
Qed.

Canonical Structure Tc_limconeF_tau (i : J) :=
  Build_Com_arrow (Tc_limconeF_tau_com_law i).

Lemma Tc_limconeF_cone_law : Cone_law Tc_limconeF_tau.
Proof.
unfold Cone_law in |- *; simpl in |- *.
intros i j g.
unfold Equal_com_arrow in |- *; simpl in |- *.
unfold Comp_com_mor in |- *; simpl in |- *.
apply (Eq_cone (Limiting_cone l_F') g).
Qed.

Definition Tc_limconeF := Build_Cone Tc_limconeF_cone_law.

(* operation # *)

 Section ctdiese.

 Variables (axf : Comma G x) (t : Cone axf F).

 Definition Tc_t_tau (i : J) := Mor_com_arrow (t i).

 Lemma Tc_t_tau_cone_law : Cone_law (c:=Ob_com_ob axf) (F:=F') Tc_t_tau.
 Proof.
 unfold Cone_law in |- *; intros i j g.
 generalize (Eq_cone t g).
 intro H.
 apply Trans with (FMor (Comma_proj G x) (t i o FMor F g)).
 exact (Pres (FMap (Comma_proj G x) axf (F j)) H).
 exact (Prf_Fcomp_law (Comma_proj G x) (t i) (FMor F g)).
 Qed.

 Definition Tc_t_cone := Build_Cone Tc_t_tau_cone_law.

 Lemma Tc_t_cone_com_law :
  Com_law (axf:=axf) (bxg:=Tc_limF) (Lim_diese l_F' Tc_t_cone).
 Proof.
 unfold Com_law in |- *; unfold Mor_com_ob at 1 in |- *; simpl in |- *.
 apply Sym; apply (Prf_limit2 l_GF').
 unfold Limit_eq in |- *; simpl in |- *; intro i.
 apply
  Trans
   with
     (Mor_com_ob axf
      o FMor G (Lim_diese l_F' Tc_t_cone) o FMor G (Limiting_cone l_F' i)).
 apply Ass1.
 apply Trans with (Mor_com_ob axf o FMor G (Tc_t_tau i)).
 apply Comp_l.
 apply Trans with (FMor G (Lim_diese l_F' Tc_t_cone o Limiting_cone l_F' i)).
 apply FComp1.
 unfold FMor in |- *; apply (Pres (FMap G (Ob_com_ob axf) (Ob_com_ob (F i)))).
 apply (Prf_limit1 l_F' Tc_t_cone i).
 apply Sym; apply (Prf_com_law (t i)).
 Qed.

 Canonical Structure Tc_diese := Build_Com_arrow Tc_t_cone_com_law.

 End ctdiese.

Lemma Tc_UA_law1 : Limit_law1 Tc_limconeF Tc_diese.
Proof.
unfold Limit_law1, Limit_eq in |- *; intros axf t.
intro i; apply (Prf_limit1 l_F' (Tc_t_cone t) i).
Qed.

Lemma Tc_UA_law2 : Limit_law2 Tc_limconeF Tc_diese.
Proof.
unfold Limit_law2, Limit_eq in |- *; intros axf t g.
intro H; unfold Tc_diese in |- *; simpl in |- *;
 unfold Equal_com_arrow in |- *; simpl in |- *.
apply (Prf_limit2 l_F').
exact H.
Qed.

Definition Comma_l_F := Build_IsLimit Tc_UA_law1 Tc_UA_law2.

Definition Comma_l_F1 := Build_Limit Comma_l_F.

End comma_complete.

Lemma Comma_complete :
 forall (X A : Category) (G : Functor A X),
 Complete A -> Continuous G -> forall x : X, Complete (Comma G x).
Proof.
intros X A G cA cG x.
unfold Complete in |- *; intros J F.
exact (Comma_l_F1 (cA J) (cG J) F).
Defined.


Require Export lemma_25.

Section auxLemmas.
  Lemma n_neq_np1: forall n, (n + 1 =? n)%nat = false.
  Proof. intros.
         induction n.
         reflexivity.
         auto.
  Qed.

  Lemma n_neq_npc: forall n c, (c =? 0)%nat = false -> (n + c =? n)%nat = false.
  Proof. intros.
         induction n.
         simpl.
         destruct c.
         repeat (try inversion H; try auto).
         reflexivity.
         simpl. auto.
  Qed.

  Lemma one_plus_not_zero: forall n, (1 + n =? 0)%nat = false.
  Proof. induction n; auto. Qed.

  Axiom eqmSym: forall x y, (x #? y) ## (y #? x).
End auxLemmas.
Import ListNotations.
Axiom compHid: forall (n1 n2: nat) (t t1 t2: message) {n} (z: mylist n),
    closMylist [msg t, msg t1, msg t2] = true /\ closMylist z = true /\
    Fresh [n1; n2] ([msg t, msg t1, msg t2]++z) = true ->
    (z ++ [msg (If |t1|#?|t2| then ((comm t1 (k n1)), (comm t2 (k n2))) else t)]) ~ (z ++ [msg (If |t1|#?|t2| then ((comm t2 (k n1)), (comm t1 (k n2))) else t)]).
Proposition commKeysDist: forall n1 n2, (n1 =? n2 = false)%nat -> let k1:= kc (nonce n1) in
                                                    let k2:= kc (nonce n2) in
                                                    k1 #? k2 ## FAlse.
Proof. intros.
       pose proof(let c1:= (n1+n2+1) in
                  let c2:= 2*c1 in
                  let nonce:= nonce c2 in
                  compHid n1 c1 |_ nonce (compl nonce) [msg nonce, msg k2]).
       pose proof(complEql (nonce (2*(n1+n2+1)))).
       simpl in H0. rewrite H1 in H0; repeat try rewrite IFTRUE_M in H0.
       funappf2m comm 1 2 H0.
       (* funapptrmhypbl (let c1:= (n1+n2+1) in *)
       (*                 let c2:= 2*c1 in *)
       (*                 msg (comm (nonce c2) k2)) (let c1:= (n1+n2+1) in *)
       (*                                            let c2:= 2*c1 in *)
       (*                                            msg (comm (nonce c2) k2)) H0. *)
       do 2 restr_proj_in 2 H0.
       funappf1 pi1 2 H0.
       repeat rewrite proj1 in H0.
       restr_proj_in 3 H0.
       funappf2mb eqm 1 2 H0.
       restr_proj_in 3 H0.
       restr_proj_in 2 H0.
       (* rewrite <- IFSAME_B with (b:= k1 #? k2) in H0. *)
       (* rewrite <- IFSAME_B with (b:= k1 #? k2) (b1:= (comm (compl (nonce (n1 + n2 + 1 + (n1 + n2 + 1 + 0)))) (k n1)) #? *)
       (*    (comm (nonce (n1 + n2 + 1 + (n1 + n2 + 1 + 0))) k2)) in H0. *)
       (* assert((|nonce (n1 + n2 + 1 + (n1 + n2 + 1 + 0))| #? |nonce (n1 + n2 + 1 + (n1 + n2 + 1 + 0))|) ## TRue). *)
       unfold k in H0.
       fold k1 in H0.
       rewrite <- compBind with (t1:= (compl (nonce (n1 + n2 + 1 + (n1 + n2 + 1 + 0))))) (t2:= nonce (n1 + n2 + 1 + (n1 + n2 + 1 + 0))) in H0.
       pose proof(Msgneql (nonce (n1 + n2 + 1 + (n1 + n2 + 1 + 0)))).
       pose proof (FRESHNEQ (n1 + n2 + 1 + (n1 + n2 + 1 + 0)) O).
       apply Example10_B with (x:= (nonce (n1 + n2 + 1 + (n1 + n2 + 1 + 0))) #? O) (F:= FAlse) (z:= FAlse) in H3; try auto.
       unfold const in H3.
       rewrite H3 in H2. try red_in H2.
       rewrite eqmSym in H2.
       rewrite H2 in H0.
       red_in H0.
       apply consteql in H0; try auto.
       rewrite <-IFTFb.
       assert((comm (nonce (n1 + n2 + 1 + (n1 + n2 + 1 + 0))) k2) #?
       (comm (nonce (n1 + n2 + 1 + (n1 + n2 + 1 + 0))) k2) ## TRue).
       rewrite eqmeql; try reflexivity.
       rewrite <- H4.
       Search "eqbr".
       pose proof(eqbrmsg_msg'' (Mvar 20) k1 k2 (comm (nonce (n1 + n2 + 1 + (n1 + n2 + 1 + 0))) (Mvar 20)) #?
           (comm (nonce (n1 + n2 + 1 + (n1 + n2 + 1 + 0))) k2) FAlse).
       simpl in H5. fold k2.
       fold k2 in H5.
       rewrite <- H5.
       rewrite H0; redg.
       repeat try reflexivity.
       reflexivity.
       split; try auto.
       unfold Fresh; try reflexivity.
       simpl.
       unfold noDupNlist.
       simpl.
       Search "eqb_refl".
       rewrite Nat.eqb_refl.
       reflexivity.
       repeat (split; try auto).
       simpl.
       unfold Fresh.
       simpl.
       rewrite <- plus_assoc.
       repeat rewrite n_neq_npc.
       rewrite <- plus_assoc.
       repeat rewrite n_neq_npc.
       simpl.
       rewrite Nat.eqb_sym.
       rewrite H.
       simpl.
       rewrite Nat.eqb_sym.
       rewrite plus_assoc.
       rewrite plus_comm with (m:= n2).
       rewrite <- plus_assoc.
       rewrite n_neq_npc.
       simpl.
       unfold noDupNlist.
       simpl.
       rewrite Nat.eqb_refl.
       rewrite plus_comm.
       rewrite <- plus_assoc.
       repeat rewrite n_neq_npc.
       rewrite Nat.eqb_refl.
       reflexivity.
       rewrite one_plus_not_zero; try auto.
       rewrite plus_comm; try rewrite one_plus_not_zero; try auto.
       rewrite plus_comm with (m:=1).
       rewrite <- plus_assoc.
       try rewrite one_plus_not_zero; try auto.
       rewrite plus_assoc.
       rewrite plus_comm with (m:=1).
       try rewrite one_plus_not_zero; try auto.
Qed.


Require Import oeuf.Common.

Require Import oeuf.Utopia.
Require Import oeuf.Monads.
Require Import oeuf.ListLemmas.
Require Import oeuf.Metadata.
Require Import oeuf.HigherValue.
Require Import oeuf.AllValues.
Require Import oeuf.OpaqueOps.
Require oeuf.StepLib.

Definition function_name := nat.

Inductive expr :=
| Value (v : value)
| Arg
| UpVar (idx : nat)
| Deref (e : expr) (n : nat)
| Call (f : expr) (a : expr)
| MkConstr (tag : nat) (args : list expr)
| Elim (loop : expr) (cases : list expr) (target : expr)
| MkClose (f : function_name) (free : list expr)
| OpaqueOp (op : opaque_oper_name) (args : list expr)
.

Inductive is_value : expr -> Prop :=
| IsValue : forall v, is_value (Value v).

Definition env := list expr.

Inductive state :=
| Run (e : expr) (l : list value) (k : value -> state)
| Stop (v : value).

Inductive sstep (E : env) : state -> state -> Prop :=
| SArg : forall l k v,
        nth_error l 0 = Some v ->
        sstep E (Run Arg l k) (k v)
| SUpVar : forall n l k v,
        nth_error l (S n) = Some v ->
        sstep E (Run (UpVar n) l k) (k v)

| SDerefStep : forall e n l k,
        ~ is_value e ->
        sstep E (Run (Deref e n) l k)
                (Run e l (fun v => Run (Deref (Value v) n) l k))
| SDerefinate : forall tag args n l k v,
        nth_error args n = Some v ->
        sstep E (Run (Deref (Value (Constr tag args)) n) l k)
                (k v)

| SCloseStep : forall tag vs e es l k,
        Forall is_value vs ->
        ~ is_value e ->
        sstep E (Run (MkClose tag (vs ++ [e] ++ es)) l k)
                (Run e l (fun v => Run (MkClose tag (vs ++ [Value v] ++ es)) l k))
| SCloseDone : forall tag vs l k,
        let es := map Value vs in
        sstep E (Run (MkClose tag es) l k) (k (Close tag vs))

| SConstrStep : forall fname vs e es l k,
        Forall is_value vs ->
        ~ is_value e ->
        sstep E (Run (MkConstr fname (vs ++ [e] ++ es)) l k)
                (Run e l (fun v => Run (MkConstr fname (vs ++ [Value v] ++ es)) l k))
| SConstrDone : forall fname vs l k,
        let es := map Value vs in
        sstep E (Run (MkConstr fname es) l k) (k (Constr fname vs))

| SOpaqueOpStep : forall op vs e es l k,
        Forall is_value vs ->
        ~ is_value e ->
        sstep E (Run (OpaqueOp op (vs ++ [e] ++ es)) l k)
                (Run e l (fun v => Run (OpaqueOp op (vs ++ [Value v] ++ es)) l k))
| SOpaqueOpDone : forall op vs l k v,
        let es := map Value vs in
        opaque_oper_denote_higher op vs = Some v ->
        sstep E (Run (OpaqueOp op es) l k) (k v)

| SCallL : forall e1 e2 l k,
        ~ is_value e1 ->
        sstep E (Run (Call e1 e2) l k)
                (Run e1 l (fun v => Run (Call (Value v) e2) l k))
| SCallR : forall e1 e2 l k,
        is_value e1 ->
        ~ is_value e2 ->
        sstep E (Run (Call e1 e2) l k)
                (Run e2 l (fun v => Run (Call e1 (Value v)) l k))
| SMakeCall : forall fname free arg l k body,
        nth_error E fname = Some body ->
        sstep E (Run (Call (Value (Close fname free)) (Value arg)) l k)
                (Run body (arg :: free) k)

| SElimStepLoop : forall loop cases target l k,
        ~ is_value loop ->
        sstep E (Run (Elim loop cases target) l k)
                (Run loop l (fun v => Run (Elim (Value v) cases target) l k))
| SElimStep : forall loop cases target l k,
        is_value loop ->
        ~ is_value target ->
        sstep E (Run (Elim loop cases target) l k)
                (Run target l (fun v => Run (Elim loop cases (Value v)) l k))
| SEliminate : forall loop cases tag args l k case,
        is_value loop ->
        nth_error cases tag = Some case ->
        sstep E (Run (Elim loop cases (Value (Constr tag args))) l k)
                (Run (Call (Call case loop) (Value (Constr tag args))) l k)
.

Definition sstar BE := StepLib.sstar (sstep BE).
Definition SStarNil := @StepLib.SStarNil state.
Definition SStarCons := @StepLib.SStarCons state.

Definition splus BE := StepLib.splus (sstep BE).
Definition SPlusOne := @StepLib.SPlusOne state.
Definition SPlusCons := @StepLib.SPlusCons state.

(* Proofs *)

(*
 * Mutual recursion/induction schemes for expr
 *)

Definition expr_rect_mut
        (P : expr -> Type)
        (Pl : list expr -> Type)
    (HValue :   forall v, P (Value v))
    (HArg :     P Arg)
    (HUpVar :   forall n, P (UpVar n))
    (HDeref :   forall e n, P e -> P (Deref e n))
    (HCall :    forall f a, P f -> P a -> P (Call f a))
    (HConstr :  forall tag args, Pl args -> P (MkConstr tag args))
    (HElim :    forall loop cases target,
        P loop -> Pl cases -> P target -> P (Elim loop cases target))
    (HClose :   forall f free, Pl free -> P (MkClose f free))
    (HOpaqueOp : forall o args, Pl args -> P (OpaqueOp o args))
    (Hnil :     Pl [])
    (Hcons :    forall e es, P e -> Pl es -> Pl (e :: es))
    (e : expr) : P e :=
    let fix go e :=
        let fix go_list es :=
            match es as es_ return Pl es_ with
            | [] => Hnil
            | e :: es => Hcons e es (go e) (go_list es)
            end in
        match e as e_ return P e_ with
        | Value v => HValue v
        | Arg => HArg
        | UpVar n => HUpVar n
        | Deref e n => HDeref e n (go e)
        | Call f a => HCall f a (go f) (go a)
        | MkConstr tag args => HConstr tag args (go_list args)
        | Elim loop cases target =>
                HElim loop cases target (go loop) (go_list cases) (go target)
        | MkClose f free => HClose f free (go_list free)
        | OpaqueOp o args => HOpaqueOp o args (go_list args)
        end in go e.

Definition expr_rect_mut'
        (P : expr -> Type)
        (Pl : list expr -> Type)
    HValue HArg HUpVar HDeref HCall HConstr HElim HClose HOpaqueOp Hnil Hcons
    : (forall e, P e) * (forall es, Pl es) :=
    let go := expr_rect_mut P Pl
        HValue HArg HUpVar HDeref HCall HConstr HElim HClose HOpaqueOp Hnil Hcons
    in
    let fix go_list es :=
        match es as es_ return Pl es_ with
        | [] => Hnil
        | e :: es => Hcons e es (go e) (go_list es)
        end in
    (go, go_list).

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition expr_ind' (P : expr -> Prop)
    (HValue :   forall v, P (Value v))
    (HArg :     P Arg)
    (HUpVar :   forall n, P (UpVar n))
    (HDeref :   forall e n, P e -> P (Deref e n))
    (HCall :    forall f a, P f -> P a -> P (Call f a))
    (HConstr :  forall c args, Forall P args -> P (MkConstr c args))
    (HElim :    forall loop cases target,
        P loop -> Forall P cases -> P target -> P (Elim loop cases target))
    (HClose :   forall f free, Forall P free -> P (MkClose f free))
    (HOpaqueOp : forall o args, Forall P args -> P (OpaqueOp o args))
    (e : expr) : P e :=
    ltac:(refine (@expr_rect_mut P (Forall P)
        HValue HArg HUpVar HDeref HCall HConstr HElim HClose HOpaqueOp _ _ e); eauto).

Require oeuf.Semantics.

Definition prog_type : Type := list expr * list metadata.
Definition val_level := VlHigher.
Definition valtype := value_type val_level.

Definition initial_env (prog : prog_type) : env := fst prog.

Inductive is_callstate (prog : prog_type) : valtype -> valtype -> state -> Prop :=
| IsCallstate : forall fname free av body,
        nth_error (fst prog) fname = Some body ->
        let fv := Close fname free in
        HigherValue.public_value (snd prog) fv ->
        HigherValue.public_value (snd prog) av ->
        is_callstate prog fv av
            (Run body (av :: free) Stop).

Inductive final_state (prog : prog_type) : state -> valtype -> Prop :=
| FinalState : forall v,
        HigherValue.public_value (snd prog) v ->
        final_state prog (Stop v) v.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env val_level
                 (is_callstate prog)
                 (sstep)
                 (final_state prog)
                 (initial_env prog).


(*

  Copyright 2014 Cornell University

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

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

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

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

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

*)

Require Export computation2.

Lemma cl_sub_csub2sub {o} :
  forall (s : @CSub o), cl_sub (csub2sub s).
Proof.
  induction s; simpl; eauto with slow.
Qed.
Hint Resolve cl_sub_csub2sub : slow.

Lemma cover_vars_iff_closed_lsubst_aux {o} :
  forall (t : @NTerm o) s,
    cover_vars t s <=> closed (lsubst_aux t (csub2sub s)).
Proof.
  introv; rw @cover_vars_iff_closed_lsubstc.
  unfold csubst.
  pose proof (unfold_lsubst (csub2sub s) t) as h; exrepnd.
  rw h0.
  unfold closed.
  repeat (rw @free_vars_lsubst_aux_cl; eauto with slow).
  apply alphaeq_preserves_free_vars in h1.
  rw h1; tcsp.
Qed.