From Perennial.program_proof Require Import grove_prelude std_proof.
From Goose.github_com.mit_pdos.gokv Require Import memkv.
From Perennial.program_proof Require Export marshal_proof memkv.common_proof.

(*
  Defines Coq request and reply types for shard server InstallShard RPC. Also defines
  has_encoding for InstallShard Request/Reply and provides WPs for {de|en}codeInstallShardRe{ply|quest}()
 *)

Section memkv_marshal_install_shard_proof.

Record InstallShardRequestC := mkInstallShardC {
  IR_Sid : u64;
  IR_Kvs : gmap u64 (list u8)
}.

(* A marshalled map requires:
   - 8 bytes to record the number of keys
   - 8 bytes per key to record the key (8 * size m)
   - 8 bytes per key to record the length of the slice for that key's value
   - 1 byte * length of each value to record the values *)
Definition marshalledMapSize_data (m : gmap u64 (list u8)) : nat :=
  map_fold (λ k v tot, 8 + 8 + length v + tot)%nat O m.

Definition marshalledMapSize (m: gmap u64 (list u8)) : nat :=
  8 + marshalledMapSize_data m.

Lemma marshalledMapSize_data_delete m k l :
  m !! k = Some l →
  marshalledMapSize_data m = (16 + length l + marshalledMapSize_data (delete k m))%nat.
Proof.
  intros Hlookup.
  rewrite /marshalledMapSize_data.
  assert (m = <[k := l]> (delete k m)) as Heq.
  { rewrite insert_delete_insert. rewrite insert_id //. }
  rewrite Heq.
  rewrite map_fold_insert_L //; last by apply lookup_delete.
  { rewrite insert_delete_insert.
    rewrite delete_insert_delete. lia. }
  intros.
  lia.
Qed.

Lemma marshalledMapSize_data_insert m k l :
  m !! k = None →
  marshalledMapSize_data (<[k := l]>m) = (16 + length l + marshalledMapSize_data m)%nat.
Proof.
  intros Hlookup.
  rewrite /marshalledMapSize_data.
  rewrite map_fold_insert_L //.
  intros.
  lia.
Qed.

(*
Definition marshalledMapSize (m:gmap u64 (list u8)) : nat :=
  8 + 2 * (size m)
*)

Definition has_byte_map_encoding (m:gmap u64 (list u8)) (r:Rec) :=
  ∃ l,
  (int.Z (size m) = size m) ∧
  NoDup l.*1 ∧
  (list_to_map l) = m ∧
  r = [EncUInt64 (size m)] ++
      ((flat_map (λ u, [EncUInt64 u.1 ; EncUInt64 (int.Z (length (u.2))); EncBytes u.2]) l)).

Definition has_encoding_InstallShardRequest (data:list u8) (args:InstallShardRequestC) : Prop :=
  ∃ r, (* (∀ k, k ∈ dom (gset _ ) args.(IR_Kvs) → shardOfC k = args.(IR_CID)) ∧ *)
       has_byte_map_encoding (args.(IR_Kvs)) r ∧
       has_encoding data ([EncUInt64 args.(IR_Sid)] ++ r).

Context `{!heapGS Σ}.

Definition is_slicemap_rep (mv : gmap u64 val) (m : gmap u64 (list u8)) : iProp Σ :=
  "%Hmdoms" ∷ ⌜ dom mv = dom m ⌝ ∗
  "Hmvals" ∷ ([∗ map] k ↦ v ∈ mv, (∃ (q : Qp) vsl, ⌜ v = slice_val vsl ⌝ ∗
              typed_slice.is_slice_small vsl byteT q (default [] (m !! k))))%I.

Lemma is_slicemap_rep_dom  mv m :
  is_slicemap_rep mv m -∗ ⌜ dom mv = dom m ⌝.
Proof. iIntros "($&_)". Qed.

Lemma is_slicemap_rep_empty_inv m :
  is_slicemap_rep ∅ m -∗ ⌜ m = ∅ ⌝.
Proof.
  iIntros "(%Hdom&_)".
  iPureIntro. rewrite dom_empty_L in Hdom.
  apply dom_empty_inv_L. eauto.
Qed.

Lemma is_slicemap_rep_dup mv m :
  is_slicemap_rep mv m -∗ is_slicemap_rep mv m ∗ is_slicemap_rep mv m.
Proof.
  iIntros "Hrep".
  rewrite /is_slicemap_rep.
  iNamed "Hrep". iFrame "%".
  rewrite -big_sepM_sep.
  iApply (big_sepM_mono with "Hmvals").
  iIntros (k x Hlookup) "H".
  iDestruct "H" as (q vsl Heq) "Hslice".
  rewrite -(Qp.div_2 q).
  iDestruct (fractional.fractional_split_1 with "Hslice") as "[Hl1 Hl2]".
  iSplitL "Hl1".
  { iExists _, _. iFrame. eauto. }
  { iExists _, _. iFrame. eauto. }
Qed.

Lemma is_slicemap_rep_move1 m1 m1' m2 m2' k l l':
  m2 !! k = None →
  m1 !! k = Some l →
  m1' !! k = Some l' →
  is_slicemap_rep m1 m1' -∗
  is_slicemap_rep m2 m2' -∗
  (is_slicemap_rep (delete k m1) (delete k m1') ∗
   is_slicemap_rep (<[k := l]> m2) (<[k := l']> m2')).
Proof.
  iIntros (Hnone Hl Hl') "Hs1 Hs2".
  iNamed "Hs1".
  iRename "Hmvals" into "Hmvals1".
  iNamed "Hs2".
  iRename "Hmvals" into "Hmvals2".
  iDestruct (big_sepM_delete with "Hmvals1") as "(Hl&Hmvals1)"; eauto.
  iSplitL "Hmvals1".
  { iSplit; first iPureIntro.
    { rewrite ?dom_delete_L Hmdoms. eauto. }
    iApply (big_sepM_mono with "Hmvals1").
    { iIntros (?? Hldel) "H". iDestruct "H" as (?? Heq) "H". iExists _, _. iFrame "%".
      rewrite lookup_delete_ne //.
      intros Heq'. rewrite Heq' lookup_delete in Hldel. congruence. }
  }
  iSplit; first iPureIntro.
  { rewrite ?dom_insert_L; congruence. }
  iApply (big_sepM_insert_2 with "[Hl]"); auto.
  { simpl. iDestruct "Hl" as (?? Heql) "H". iExists _, _. iFrame "%".
    rewrite lookup_insert. rewrite Hl'. eauto. }
  iApply (big_sepM_mono with "Hmvals2").
  { iIntros (k' ? Hldel) "H". iDestruct "H" as (?? Heq) "H". iExists _, _. iFrame "%".
    destruct (decide (k = k')).
    { subst. congruence. }
    rewrite lookup_insert_ne //.
  }
Qed.

Lemma is_slicemap_lookup_l mv m k v :
  mv !! k = Some v →
  is_slicemap_rep mv m -∗
  is_slicemap_rep mv m ∗
  ∃ q vsl l, ⌜ v = slice_val vsl ⌝ ∗ ⌜ m !! k = Some l ⌝ ∗
   typed_slice.is_slice_small vsl byteT q l.
Proof.
  iIntros (Hlookup) "Hrep".
  iDestruct (is_slicemap_rep_dup with "Hrep") as "(Hrep&$)".
  iNamed "Hrep".
  iDestruct (big_sepM_lookup with "Hmvals") as (q vsl Heq) "H"; eauto.
  assert (is_Some (m !! k)) as (l&Heq').
  { apply elem_of_dom_2 in Hlookup. rewrite Hmdoms in Hlookup. apply elem_of_dom in Hlookup. eauto. }
  iExists q, vsl, l. iFrame "%". rewrite Heq' //.
Qed.

Definition EncSliceMap_invariant m0 enc_v (r:Rec) sz map_sz
           (original_remaining:Z) (mtodo' mdone':gmap u64 val) : iProp Σ :=
  ∃ mtodo mdone (l:list (u64 * (list u8))) (remaining:Z),
    is_slicemap_rep mtodo' mtodo ∗
    is_slicemap_rep mdone' mdone ∗
    ⌜ mtodo ∪ mdone = m0 ⌝ ∗
    ⌜ NoDup l.*1 ⌝ ∗
    ⌜(list_to_map l) = mdone⌝ ∗
    ⌜marshalledMapSize_data mtodo ≤ remaining⌝ ∗
    ⌜remaining = (original_remaining - marshalledMapSize_data mdone)%Z⌝ ∗
    ⌜mtodo ##ₘ mdone ⌝ ∗
    is_enc enc_v sz (r ++ [EncUInt64 map_sz] ++
 (flat_map (λ u, [EncUInt64 u.1 ; EncUInt64 (int.Z (length (u.2))); EncBytes u.2]) l )) remaining
.

Definition own_InstallShardRequest args_ptr args : iProp Σ :=
  ∃ (kvs_ptr:loc) (mv:gmap u64 goose_lang.val),
  "HKey" ∷ args_ptr ↦[InstallShardRequest :: "Sid"] #args.(IR_Sid) ∗
  "HKvs" ∷ args_ptr ↦[InstallShardRequest :: "Kvs"] #kvs_ptr ∗
  "HKvsMap" ∷ map.is_map kvs_ptr 1 (mv, (slice_val Slice.nil)) ∗
  "%Hdom_install" ∷ ⌜dom args.(IR_Kvs) = dom mv ⌝ ∗
  "Hvals" ∷ ([∗ set] k ∈ (fin_to_set u64),
        ⌜shardOfC k ≠ args.(IR_Sid) ∧ mv !! k = None ∧ args.(IR_Kvs) !! k = None⌝ ∨ (∃ q vsl, ⌜default (slice_val Slice.nil) (mv !! k) = (slice_val vsl)⌝ ∗ typed_slice.is_slice_small vsl byteT q (default [] (args.(IR_Kvs) !! k))) )
.

Lemma wp_EncSliceMap e mref mv m sz r remaining :
  marshalledMapSize m <= remaining →
  {{{
      "HKvsMap" ∷ map.is_map mref 1 (mv, slice_val Slice.nil) ∗
      "Henc" ∷ is_enc e sz r remaining ∗
      "Hvals" ∷ is_slicemap_rep mv m
  }}}
    EncSliceMap e #mref
  {{{
       rmap, RET #();
       ⌜has_byte_map_encoding m rmap⌝ ∗
       map.is_map mref 1 (mv, slice_val Slice.nil) ∗
       is_slicemap_rep mv m ∗
       is_enc e sz (r ++ rmap) (remaining - marshalledMapSize m)
  }}}.
Proof using Type*.
  intros Hrem.
  iIntros (Φ) "Hpre HΦ".
  iNamed "Hpre".
  wp_lam. wp_pures.
    iDestruct (is_slicemap_rep_dom with "[$]") as %Hdom_init.

  wp_apply (map.wp_MapLen with "HKvsMap").
  iIntros "[%Hsize Hmap]".
  unfold marshalledMapSize in Hrem.
  wp_apply (wp_Enc__PutInt with "Henc").
  { lia. }
  iIntros "Henc".
  wp_pures.
  wp_apply (map.wp_MapIter_2 _ _ _ _ _ (EncSliceMap_invariant m e r sz (size m) (remaining - 8))
              with "Hmap [Henc Hvals] [] [HΦ]").
  {
    iExists m, ∅.
    iExists []. iExists (remaining-8). simpl. iFrame.
    iSplitL "".
    { rewrite /is_slicemap_rep. rewrite ?dom_empty_L big_sepM_empty //=. }
    iSplit.
    { iPureIntro. rewrite right_id_L //. }
    iSplit.
    { iPureIntro. apply NoDup_nil_2. }
    iSplit; first done.
    rewrite ?Map.map_size_dom Hdom_init //.
    rewrite ?Map.map_size_dom // in Hrem.
    iFrame.
    iPureIntro.
    split; first by lia.
    rewrite /marshalledMapSize_data. rewrite map_fold_empty.
    split; first by lia. apply map_disjoint_empty_r.
  }
  {
    clear Φ.
    iIntros (?? mtodo' mdone' Φ) "!# [Hpre %Htodo] HΦ".
    wp_pures.
    iDestruct "Hpre" as (mtodo mdone l rem') "Hpre".
    iDestruct "Hpre" as "(Hrep_todo&Hrep_done&Hpre)".
    iDestruct "Hpre" as (Hunion Hnodup Hl Hrem' Hremeq Hmdisjoint) "Henc".
    iDestruct (is_slicemap_rep_dom with "Hrep_todo") as %Hdom_todo.
    iDestruct (is_slicemap_rep_dom with "Hrep_done") as %Hdom_done.
    assert (16 <= marshalledMapSize_data mtodo).
    {
      assert (is_Some (mtodo !! k)) as (vl&Heq_vl).
      { apply elem_of_dom_2 in Htodo. rewrite Hdom_todo in Htodo. apply elem_of_dom. eauto. }
      erewrite marshalledMapSize_data_delete; last eauto.
      lia.
    }
    wp_apply (wp_Enc__PutInt with "Henc").
    {
      lia.
    }
    iIntros "Henc".
    wp_pures.

    iDestruct (is_slicemap_lookup_l with "Hrep_todo") as "(Hrep_todo&Hval)"; eauto.
    iDestruct "Hval" as (q vsl l' Heq1 Heq2) "Hslice".

    subst. wp_apply (wp_slice_len).
    wp_apply (wp_Enc__PutInt with "Henc").
    {
      lia.
    }
    iIntros "Henc".
    wp_pures.
    wp_apply (wp_Enc__PutBytes with "[$Henc $Hslice]").
    {
      erewrite (marshalledMapSize_data_delete mtodo) in Hrem' ; last eassumption.
      lia.
    }
    iIntros "(Henc&Hslice)".
    iApply "HΦ".
    iExists (delete k mtodo), (<[k := l']> (list_to_map l)).
    iExists (l ++ [(k, l')]), ((remaining - 8 - marshalledMapSize_data (list_to_map l) - 8 - 8 - length l')).
    assert (k ∉ dom (list_to_map l : gmap u64 (list u8))).
    { intros Hin. apply map_disjoint_dom_1 in Hmdisjoint.
      apply elem_of_dom_2 in Heq2. eauto. }
    iDestruct (is_slicemap_rep_move1 with "Hrep_todo Hrep_done") as "($&$)".
    { apply not_elem_of_dom. rewrite Hdom_done. set_solver. }
    { eauto. }
    { eauto. }
    assert (NoDup (l ++ [(k, l')]).*1).
    { rewrite fmap_app; simpl.
      apply NoDup_app; split_and!; eauto.
      { intros x Hinl. intros. intros Hin. apply elem_of_list_singleton in Hin; subst.
        apply map_disjoint_dom_1 in Hmdisjoint.
        rewrite dom_list_to_map_L in Hmdisjoint.
        assert (k ∈ (list_to_set l.*1 : gset u64)).
        { apply elem_of_list_to_set. eauto. }
        apply elem_of_dom_2 in Heq2. set_solver.
      }
      apply NoDup_singleton.
    }
    iSplit.
    { iPureIntro. rewrite union_delete_insert //. }
    iSplit; first done.
    iSplit.
    { iPureIntro. rewrite -list_to_map_cons. eapply list_to_map_proper; eauto.
      rewrite Permutation_app_comm //. }
    iSplit.
    {
      iPureIntro.
      erewrite marshalledMapSize_data_delete in Hrem'; eauto.
      lia.
    }
    iSplit.
    {
      iPureIntro.
      rewrite marshalledMapSize_data_insert; last first.
      { apply not_elem_of_dom. eauto. }
      lia.
    }
    iSplit.
    {
      iPureIntro.
      apply map_disjoint_dom_2.
      apply map_disjoint_dom_1 in Hmdisjoint.
      rewrite dom_delete_L dom_insert_L. set_solver.
    }
    iDestruct (typed_slice.is_slice_small_sz with "Hslice") as %Hsz'.
    iExactEq "Henc".
    f_equal.
    simpl.
    rewrite -?app_assoc; f_equal.
    simpl. f_equal.
    rewrite flat_map_app //=. repeat f_equal.
    word.
  }
  iIntros "(Hmap&Hinv)".
  iNamed "Hinv".
  wp_pures. iModIntro.
  iApply ("HΦ" $! ([EncUInt64 (size m)] ++
                 flat_map (λ u : u64 * list u8, [EncUInt64 u.1; EncUInt64 (int.Z (length u.2)); EncBytes u.2]) l)).
  iDestruct "Hinv" as "(?&?&%Hunion&%&%&%&->&%&Henc)".
  iFrame.
  rewrite /marshalledMapSize.
  iDestruct (is_slicemap_rep_empty_inv with "[$]") as %Hemp.
  assert (m = mdone) as Hdone.
  { rewrite Hemp left_id_L in Hunion. auto. }
  rewrite Hdone.
  iSplit.
  { iPureIntro.
    rewrite /has_byte_map_encoding. eexists.
    split_and!; eauto.
    assert (size mdone = size mv) as ->; last first.
    { simpl in Hsize. word. }
    rewrite ?Map.map_size_dom. congruence.
  }
  iSplitR "Henc"; last first.
  { iExactEq "Henc". f_equal. lia. }
  iFrame.
Qed.

Definition SizeOfMarshalledMap_invariant m0 (s : loc) (mtodo' mdone':gmap u64 val) : iProp Σ :=
  (∃ (z : u64) mtodo mdone,
    is_slicemap_rep mtodo' mtodo ∗
    is_slicemap_rep mdone' mdone ∗
    ⌜ mtodo ∪ mdone = m0 ⌝ ∗
    ⌜mtodo ##ₘ mdone ⌝ ∗
    s ↦[uint64T] #z ∗
    ⌜ (8 + marshalledMapSize_data mdone)%nat = int.nat z ⌝).

Lemma wp_SizeOfMarshalledMap mref mv m :
  {{{
      "HKvsMap" ∷ map.is_map mref 1 (mv, slice_val Slice.nil) ∗
      "Hvals" ∷ is_slicemap_rep mv m
  }}}
    SizeOfMarshalledMap #mref
  {{{
       (z : u64), RET #z; ⌜ int.nat z = marshalledMapSize m ⌝ ∗
       map.is_map mref 1 (mv, slice_val Slice.nil) ∗
       is_slicemap_rep mv m
  }}}.
Proof.
  iIntros (Φ) "H HΦ". iNamed "H".
  wp_pures.
  rewrite /SizeOfMarshalledMap.
  wp_pure _.
  wp_apply (wp_ref_of_zero _ _ (uint64T)); first done.
  iIntros (s) "Hs".
  wp_pures.
  wp_apply (wp_StoreAt with "[$]"); first eauto.
  iIntros "Hs".
  wp_pures.
  wp_apply (map.wp_MapIter_2 _ _ _ _ _ (SizeOfMarshalledMap_invariant m s)
              with "HKvsMap [Hs Hvals] [] [HΦ]").
  {
    iExists (U64 8), m, ∅.
    simpl. iFrame.
    iSplitL "".
    { rewrite /is_slicemap_rep. rewrite ?dom_empty_L big_sepM_empty //=. }
    iSplit.
    { iPureIntro. rewrite right_id_L //. }
    iPureIntro; split.
    * apply map_disjoint_empty_r.
    * rewrite /marshalledMapSize_data map_fold_empty. word.
  }
  {
    clear Φ.
    iIntros (?? mtodo' mdone' Φ) "!# [Hpre %Htodo] HΦ".
    wp_pures.
    iDestruct "Hpre" as (z mtodo mdone) "Hpre".
    iDestruct "Hpre" as "(Hrep_todo&Hrep_done&%Hunion&%Hdisj&Hs&%Hsum)".
    iDestruct (is_slicemap_rep_dom with "Hrep_todo") as %Hdom_todo.
    iDestruct (is_slicemap_rep_dom with "Hrep_done") as %Hdom_done.
    iDestruct (is_slicemap_lookup_l with "Hrep_todo") as "(Hrep_todo&Hval)"; eauto.
    iDestruct "Hval" as (q vsl l' Heq1 Heq2) "Hslice".
    iDestruct (typed_slice.is_slice_small_sz with "Hslice") as %Hsz'.
    subst. wp_apply (wp_slice_len).
    wp_apply (wp_SumAssumeNoOverflow).
    iIntros (Hnooverflow1).
    wp_apply (wp_LoadAt with "[$]").
    iIntros "Hs".
    wp_apply (wp_SumAssumeNoOverflow).
    iIntros (Hnooverflow2).
    wp_pures.
    wp_apply (wp_StoreAt with "[$]").
    { eauto. }
    iIntros "Hs".
    iApply "HΦ".
    iExists _, (delete k mtodo), (<[k := l']> mdone).
    iFrame.
    iDestruct (is_slicemap_rep_move1 with "Hrep_todo Hrep_done") as "($&$)".
    { apply not_elem_of_dom. rewrite Hdom_done.
      apply map_disjoint_dom_1 in Hdisj.
      apply elem_of_dom_2 in Heq2.
      set_solver. }
    { eauto. }
    { eauto. }
    iSplit.
    { iPureIntro. rewrite union_delete_insert //. }
    iSplit.
    {
      iPureIntro.
      apply map_disjoint_dom_2.
      apply map_disjoint_dom_1 in Hdisj.
      rewrite dom_delete_L dom_insert_L. set_solver.
    }
    iPureIntro.
    rewrite marshalledMapSize_data_insert; last first.
    { apply not_elem_of_dom.
      apply map_disjoint_dom_1 in Hdisj.
      apply elem_of_dom_2 in Heq2.
      eauto. }
    rewrite Hsz'.
    transitivity (16 + int.nat vsl.(Slice.sz) + int.nat z)%nat.
    { lia. }
    rewrite Hnooverflow2. rewrite Hnooverflow1. word.
  }
  iIntros "(Hmap&Hinv)".
  iNamed "Hinv".
  iDestruct "Hinv" as "(?&?&%Hunion&%&?&%)".
  wp_pures.
  wp_apply (wp_LoadAt with "[$]").
  iIntros "Hs".
  iDestruct (is_slicemap_rep_empty_inv with "[$]") as %Hemp.
  assert (m = mdone) as Hdone.
  { rewrite Hemp left_id_L in Hunion. auto. }
  rewrite Hdone.
  iApply "HΦ".
  iFrame.
  iPureIntro.
  rewrite /marshalledMapSize. word.
Qed.

Definition shard_own (mv : gmap u64 val) (m : gmap u64 (list u8)) id : iProp Σ :=
  ([∗ set] k ∈ fin_to_set u64, ⌜shardOfC k ≠ id ∧ mv !! k = None ∧ m !! k = None⌝
                               ∨ (∃ (q : Qp) (vsl : Slice.t),
                                     ⌜default (slice_val Slice.nil) (mv !! k) = slice_val vsl⌝ ∗
                                             typed_slice.is_slice_small vsl byteT q
                                             (default [] (m !! k)))).
(*
Lemma shard_own_shardOfC mv m id :
  shard_own mv m id -∗
  ⌜ (∀ k, k ∈ dom (gset _ ) m → shardOfC k = id) ⌝.
Proof.
  iIntros "H" (k Hin).
  rewrite /shard_own.
  iDestruct (big_sepS_elem_of _ _ k with "H") as "H".
  { apply elem_of_fin_to_set. }
  destruct (decide (shardOfC k = id)); auto.
  iDestruct "H" as "[H|H]".
  {
*)

Lemma shard_own_dup mv m id:
  shard_own mv m id -∗ shard_own mv m id ∗ shard_own mv m id.
Proof.
  iIntros "H".
  rewrite /shard_own. iApply big_sepS_sep.
  iApply (big_sepS_mono with "H").
  iIntros (x Hin) "H". iDestruct "H" as "[%Hl|Hr]".
  { iFrame "%". }
  iDestruct "Hr" as (q vsl Heq) "Hslice".
  rewrite -(Qp.div_2 q).
  iDestruct (fractional.fractional_split_1 with "Hslice") as "[Hl1 Hl2]".
  iSplitL "Hl1".
  { iRight. iExists _, _. iFrame. eauto. }
  { iRight. iExists _, _. iFrame. eauto. }
Qed.

Lemma shard_to_is_slicemap_rep (mv : gmap u64 val) m id:
  dom mv = dom m →
  ([∗ set] k ∈ fin_to_set u64, ⌜shardOfC k ≠ id ∧ mv !! k = None ∧ m !! k = None⌝
                               ∨ (∃ (q : Qp) (vsl : Slice.t),
                                     ⌜default (slice_val Slice.nil) (mv !! k) = slice_val vsl⌝ ∗
                                             typed_slice.is_slice_small vsl byteT q
                                             (default [] (m !! k)))) -∗
  is_slicemap_rep mv m.
Proof.
  iIntros (Hdom) "H".
  assert (dom mv ⊆ fin_to_set u64) as Hdomsub.
  { set_unfold. trivial. }
  remember (fin_to_set u64) as U eqn:Heq. clear Heq.
  iSplit; first done.
  iInduction mv as [| k v mv Hlookup] "IH" using map_ind forall (m U Hdom Hdomsub).
  { iApply big_sepM_empty. eauto. }
  iApply big_sepM_insert; eauto.
  iDestruct (big_sepS_delete _ _ k with "H") as "(Hk&H)".
  { rewrite dom_insert_L in Hdomsub. set_solver. }
  iDestruct ("IH" $! (delete k m) (U ∖ {[k]}) with "[] [] [H]") as "H".
  { iPureIntro.
    rewrite dom_insert_L in Hdom.
    rewrite dom_delete_L.
    rewrite -Hdom.
    apply not_elem_of_dom in Hlookup.
    set_solver. }
  { iPureIntro.
    rewrite dom_insert_L in Hdomsub.
    apply not_elem_of_dom in Hlookup.
    set_solver. }
  { iApply (big_sepS_mono with "H").
    iIntros (??) "H".
    rewrite lookup_insert_ne; last set_solver.
    rewrite lookup_delete_ne; last set_solver. eauto. }
  iSplitR "H".
  { iDestruct "Hk" as "[%Hbad|H]".
    { exfalso. rewrite lookup_insert in Hbad. intuition congruence. }
    rewrite lookup_insert. iDestruct "H" as (?? Heq) "H".
    iExists _, _. iSplit; first eauto. iFrame.
  }
  iApply (big_sepM_mono with "H").
  { iIntros (k' v' Hlookup').
    simpl. rewrite lookup_delete_ne; last set_solver. eauto. }
Qed.

Lemma wp_encodeInstallShardRequest args_ptr args :
  {{{
       own_InstallShardRequest args_ptr args
  }}}
    encodeInstallShardRequest #args_ptr
  {{{
       (reqData:list u8) req_sl, RET (slice_val req_sl); ⌜has_encoding_InstallShardRequest reqData args⌝ ∗
                                               typed_slice.is_slice req_sl byteT 1%Qp reqData ∗
                                               own_InstallShardRequest args_ptr args
  }}}.
Proof.
  iIntros (Φ) "Hpre HΦ".
  iNamed "Hpre".
  wp_lam.
  iDestruct (shard_own_dup with "Hvals") as "(Hvals&Hex)".
  iDestruct (shard_to_is_slicemap_rep with "Hex") as "Hslicemap".
  { eauto. }
  wp_loadField.
  wp_apply (wp_SizeOfMarshalledMap with "[$Hslicemap $HKvsMap]").
  iIntros (z) "(%Hsize&HKvsMap&Hslicemap)".
  wp_apply (wp_SumAssumeNoOverflow).
  iIntros (Hoverflow).
  wp_pures.
  wp_apply (wp_new_enc).
  iIntros (e) "Henc".
  wp_pures.
  wp_loadField.
  wp_apply (wp_Enc__PutInt with "Henc").
  { rewrite Hoverflow. word. }
  iIntros "Henc".
  wp_pures.
  wp_loadField.
  wp_apply (wp_EncSliceMap with "[$Hslicemap $Henc $HKvsMap]").
  { rewrite Hoverflow. word. }
  iIntros (rmap) "(%Hhas&Hismap&Hslicemap&Henc)".
  wp_pures.
  wp_apply (wp_Enc__Finish with "Henc").
  iIntros (??) "(%&%&?)".
  iApply "HΦ".
  iFrame.
  iSplit; last first.
  { iExists _, _. iFrame. eauto. }
  iPureIntro. rewrite /has_encoding_InstallShardRequest. eexists; split; eauto.
Qed.

Definition DecSliceMap_invariant dec_v i_ptr m (r:Rec) mref s data : iProp Σ :=
  ∃ q (l:list (u64 * (list u8))) mdone' (mdone:gmap u64 (list u8)),
    ⌜NoDup l.*1⌝ ∗
    ⌜(list_to_map l) ##ₘ mdone⌝ ∗
    ⌜(list_to_map l) ∪ mdone = m⌝ ∗
    i_ptr ↦[uint64T] #(size mdone) ∗
    map.is_map mref 1 (mdone', (slice_val Slice.nil)) ∗
    is_slicemap_rep mdone' mdone ∗
    is_dec dec_v
          ((flat_map (λ u : u64 * list u8, [EncUInt64 u.1; EncUInt64 (int.Z (length u.2)); EncBytes u.2]) l) ++ r)
          s q data
.

Lemma is_dec_EncBytes_length d v r s q l :
  is_dec d (EncBytes v :: r) s q l  -∗
  ⌜int.Z (length v) = length v⌝.
Proof.
  iNamed 1.
  apply has_encoding_length in Henc.
  rewrite ?encoded_length_cons encode1_bytes_len in Henc.
  iDestruct (typed_slice.is_slice_small_sz with "Hs") as %Hlen.
  iPureIntro.
  assert (length (drop (int.nat off) l) <= length l).
  { rewrite drop_length. lia. }
  word.
Qed.

Lemma wp_DecSliceMap d l m args_sl argsData :
  NoDup l.*1 →
  int.Z (size m) = size m →
  list_to_map l = m →
  {{{
      "Hdec" ∷ is_dec d
             ([EncUInt64 (size m)] ++
              flat_map (λ u : u64 * list u8, [EncUInt64 u.1; EncUInt64 (int.Z (length u.2)); EncBytes u.2]) l)
             args_sl 1 argsData
  }}}
    DecSliceMap d
  {{{
       rmap mv, RET #rmap;
       map.is_map rmap 1 (mv, slice_val Slice.nil) ∗
       is_slicemap_rep mv m
  }}}.
Proof.
  iIntros (Hnodup Hsize Hlist).
  iIntros (Φ) "Hdec HΦ".
  wp_lam.
  wp_apply (wp_Dec__GetInt with "Hdec").
  iIntros "Hdec".
  wp_pures.
  wp_apply map.wp_NewMap.
  iIntros (mref) "Hmref".
  wp_pures.
  wp_apply (wp_ref_to); first eauto.
  iIntros (i_ptr) "Hi".
  wp_pures.
  iAssert (DecSliceMap_invariant d i_ptr m [] mref args_sl argsData) with "[Hi Hmref Hdec]" as "HloopInv".
  {
    iExists 1%Qp, l, ∅, ∅.
    iFrame.
    iSplit; first done.
    iSplitL "".
    { iPureIntro. eapply (map_disjoint_empty_r (M:=gmap _)). }
    rewrite right_id.
    iSplit; first done.
    rewrite app_nil_r. iFrame.
    rewrite /is_slicemap_rep. rewrite ?dom_empty_L. rewrite big_sepM_empty //.
  }

  wp_forBreak_cond.
  clear Hlist Hnodup l.
  iDestruct "HloopInv" as (q l' mdone mdone' Hnodup Hdisj Hunion) "(Hi & Hmref & Hslicemap & Hdec)".
  wp_load.
  wp_pures.
  wp_if_destruct.
  { (* Start of loop iteration *)
    wp_pures.
    destruct l'.
    { simpl in Heqb. exfalso.
      simpl in *. rewrite left_id in Hunion.
      rewrite Hunion in Heqb. lia. }
    destruct p as [k v].
    simpl.
    wp_apply (wp_Dec__GetInt with "Hdec").
    iIntros "Hdec".
    wp_apply (wp_Dec__GetInt with "Hdec").
    iIntros "Hdec".
    iDestruct (is_dec_EncBytes_length with "Hdec") as %Hlen_dec.
    wp_apply (wp_Dec__GetBytes with "Hdec").
    { word. }
    iIntros (q' s') "(Hsl&Hdec)".
    wp_pures.
    wp_apply (map.wp_MapInsert with "Hmref").
    iIntros "Hmref".
    wp_pures.
    wp_load.
    wp_store.
    iLeft.
    iSplitL ""; first done.
    iSplitL "HΦ"; first done.
    iExists q', l', _,  (<[k:=v]> mdone').
    iFrame "Hmref".
    iModIntro.
    iSplitL "".
    { by apply NoDup_cons in Hnodup as [??]. }
    assert ((list_to_map l' (M:=gmap _ _)) !! k = None) as Hnok.
    { apply NoDup_cons in Hnodup as [HkNotInL Hnodup].
        by apply not_elem_of_list_to_map_1. }
    iFrame.
    iSplitL "".
    { iPureIntro. simpl in Hdisj.
      rewrite map_disjoint_insert_r.
      split; first done.
      eapply map_disjoint_weaken; eauto.
      simpl.
      apply insert_subseteq.
      done.
    }
    iSplitL "".
    { iPureIntro. simpl in Hunion.
      rewrite -insert_union_r; last done.
      rewrite insert_union_l.
      done.
    }
    rewrite (map_size_insert_None); last first.
    { eapply map_disjoint_Some_l; eauto.
      simpl. apply lookup_insert. }
    replace (word.add (size mdone') 1) with (int.Z (size mdone') + 1:u64) by word.
    rewrite Z_u64; last first.
    { split; first lia.
      word_cleanup.
      rewrite Hsize in Heqb.
      assert (size mdone' ≤ size m)%nat.
      { rewrite -Hunion.
        rewrite ?Map.map_size_dom.
        apply subseteq_size. set_solver. }
      lia.
    }
    replace (Z.of_nat (S (size mdone'))) with (size mdone' + 1)%Z by lia.
    iFrame.
    rewrite /is_slicemap_rep.
    iNamed "Hslicemap".
    iSplit.
    { rewrite ?dom_insert_L; iPureIntro; congruence. }
    assert (mdone !! k = None).
    { apply not_elem_of_dom. rewrite Hmdoms.
      rewrite list_to_map_cons in Hdisj.
      apply map_disjoint_dom_1 in Hdisj.
      rewrite dom_insert_L in Hdisj. set_solver.
    }
    iApply big_sepM_insert; first auto.
    iSplitL "Hsl".
    { iExists _, _. iSplit; first eauto.
      rewrite lookup_insert //=. }
    iApply (big_sepM_mono with "Hmvals").
    iIntros (k' x' Hlookup).
    simpl. rewrite lookup_insert_ne //.
    intros Heq. subst. congruence.
  }
  assert (size mdone' ≤ size m)%nat.
  { rewrite -Hunion.
    rewrite ?Map.map_size_dom.
    apply subseteq_size. set_solver. }
  iRight. iSplitL ""; first done.
  iModIntro.
  wp_pures.
  iModIntro.
  iApply "HΦ".
  iFrame.
  destruct l'; last first.
  {
    exfalso.
    set (mtodo:=(list_to_map (p :: l'))) in *.
    assert (size m <= size mdone').
    { rewrite ?Z_u64 in Heqb; try word. }
    rewrite -Hunion in Heqb.
    rewrite map_size_disj_union in Heqb; eauto.
    assert (size mtodo > 0).
    { destruct (decide (size mtodo = O)) as [Hz|Hnz]; try lia.
      rewrite ?Map.map_size_dom in Hz.
      apply size_empty_inv in Hz.
      apply dom_empty_inv in Hz.
      rewrite /mtodo in Hz.
      destruct p. rewrite list_to_map_cons in Hz.
      apply insert_non_empty in Hz. exfalso; eauto.
    }
    assert (size m = size mtodo + size mdone')%nat.
    { rewrite -Hunion map_size_disj_union; eauto. }
    word.
  }
  rewrite list_to_map_nil left_id_L in Hunion. subst. iFrame.
Qed.

Lemma is_slicemap_rep_to_shard (mv : gmap u64 val) m id:
  is_slicemap_rep mv m -∗
  ([∗ set] k ∈ fin_to_set u64, ⌜shardOfC k ≠ id ∧ mv !! k = None ∧ m !! k = None⌝
                               ∨ (∃ (q : Qp) (vsl : Slice.t),
                                     ⌜default (slice_val Slice.nil) (mv !! k) = slice_val vsl⌝ ∗
                                             typed_slice.is_slice_small vsl byteT q
                                             (default [] (m !! k)))).
Proof.
  iInduction mv as [| k v mv Hlookup] "IH" using map_ind forall (m).
  { iNamed 1. iApply big_sepS_intro.
    iIntros "!>" (?) "?". iRight.
    assert (m = ∅) as ->.
    { apply dom_empty_inv_L. rewrite dom_empty_L in Hmdoms. congruence. }
    rewrite ?lookup_empty /=.
    iExists 1%Qp, _. iSplit; first eauto.
    iApply (@typed_slice.is_slice_to_small with "[]").
    iApply typed_slice.is_slice_zero.
  }
  iNamed 1. iDestruct (big_sepM_insert with "Hmvals") as "(Hk&Hmvals)"; auto.
  iDestruct ("IH" $! (delete k m) with "[Hmvals]") as "Hrest".
  { iSplit; first iPureIntro.
    { rewrite dom_insert_L in Hmdoms.
      rewrite dom_delete_L.
      apply not_elem_of_dom in Hlookup.
      set_solver. }
    iApply (big_sepM_mono with "Hmvals").
    { iIntros (k' x' Hlookup') "H".
      rewrite lookup_delete_ne; eauto. congruence. }
  }
  iApply (big_sepS_delete _ _ k); first apply elem_of_fin_to_set.
  iDestruct (big_sepS_delete _ _ k with "Hrest") as "(_&Hrest)"; first apply elem_of_fin_to_set.
  iSplitL "Hk".
  { iRight. rewrite lookup_insert. iDestruct "Hk" as (?? Heq) "H". iExists _, _. iSplit; eauto. }
  iApply (big_sepS_mono with "Hrest").
  { iIntros (??) "H".
    rewrite lookup_insert_ne; last by set_solver.
    rewrite lookup_delete_ne; last by set_solver.
    eauto.
  }
Qed.

Lemma wp_decodeInstallShardRequest args args_sl argsData :
  {{{
       typed_slice.is_slice_small args_sl byteT 1%Qp argsData ∗
       ⌜has_encoding_InstallShardRequest argsData args ⌝
  }}}
    decodeInstallShardRequest (slice_val args_sl)
  {{{
       (args_ptr:loc), RET #args_ptr;
       own_InstallShardRequest args_ptr args
  }}}.
Proof.
  iIntros (Φ) "(Hslice&%Henc) HΦ".
  wp_lam.
  destruct Henc as (r&(l&Hsize&Hnodup&HlistMap&Hmapencoded)&Hdata).
  rewrite Hmapencoded in Hdata.
  wp_apply (wp_new_dec with "Hslice"); eauto.
  iIntros (d) "Hdec".
  wp_pures.
  wp_apply (wp_allocStruct); first val_ty.
  iIntros (req) "Hreq".
  wp_pures.
  iDestruct (struct_fields_split with "Hreq") as "H".
  iNamed "H".
  wp_apply (wp_Dec__GetInt with "Hdec").
  iIntros "Hdec".
  wp_storeField.
  wp_apply (wp_DecSliceMap with "[$]"); try eauto.
  iIntros (rmap mv) "(Hmref&Hslicemap)".
  wp_storeField.
  iModIntro.
  iApply "HΦ".
  iExists _, _. iFrame.
  iDestruct (is_slicemap_rep_dom with "[$]") as "%Hdom".
  iSplit; auto.
  iApply is_slicemap_rep_to_shard. eauto.
Qed.

End memkv_marshal_install_shard_proof.


(************************************************************************)
(* Copyright 2007 Milad Niqui                                           *)
(* This file is distributed under the terms of the                      *)
(* GNU Lesser General Public License Version 2.1                        *)
(* A copy of the license can be found at                                *)
(*                  <http://www.gnu.org/licenses/lgpl.txt>              *)
(************************************************************************)

Require Import Arith Omega.

Require Coq.Structures.OrderedTypeEx.
Require Coq.FSets.FSetList.
Require Extraction.
Module NatSet := FSetList.Make(OrderedTypeEx.Nat_as_OT).
Import NatSet.

Notation " A ⇒ B " := (A -> B) (at level 90, right associativity) : type_scope.
Notation " ∀ x , B  " := (forall x:_, B ) (at level 200, x at level 0, no associativity) : type_scope.
Notation " ∀ x y , B  " := (forall (x:_) (y:_), B ) (at level 200, x at level 0, y at level 0, no associativity) : type_scope.
Notation " ∀ x y z , B  " := (forall (x:_) (y:_) (z:_), B ) (at level 200, x at level 0, y at level 0, z at level 0, no associativity) : type_scope.
Notation " ¬ x " := (not  x) (at level 75, right associativity) : type_scope.
Notation " A ∧ B " := (A /\ B) (at level 80, right associativity) : type_scope.
Notation " A ∨ B " := (sumor A B) (at level 85, right associativity) : type_scope.
Notation " A \/ B " := (sumbool A B) (at level 85, right associativity) : type_scope.
Notation " ∃ x , B  " := (sig (fun x:_=>B) ) (at level 0, x at level 99, no associativity) : type_scope.
Notation " A × B " := (A * B) (at level 40, left associativity) : type_scope.
Notation " 'ℕ' " := nat : type_scope.
Infix " ≤ " := le (at level 70, right associativity): nat_scope.
Notation "s ≐ t" := (Equal s t) (at level 70, no associativity).
Infix "∈" := In (at level 30, no associativity).
Infix "⊆" := Subset (at level 70, right associativity).
Infix "\" := diff (at level 40, left associativity).
Notation "| A |" := (cardinal A) (at level 10, no associativity).
Infix "≡" := E.eq (at level 70, no associativity).
Infix "∩" := inter (at level 40, left associativity).
Infix "∪" := union (at level 50, left associativity).
Notation " { x } ∪ X " := (add x X) (at level 50, left associativity).
Notation " X \ { x } " := (remove x X) (at level 40, left associativity).
Notation "∅" := empty.

Require FSetFacts FSetProperties.

Module GeneralProperties := FSetProperties.Properties NatSet.
Import GeneralProperties.

Section problem_knows_not_refl.

Variable town: t.
Variable n:ℕ.
Variable cardinality: | town | = 2×n+1.

Variable knows: elt ⇒ elt ⇒ Prop.
Infix "ℛ" := knows (at level 70, no associativity).

Variable knows_sym: ∀m n, m ℛ n ⇒ n ℛ m.
Variable knows_extensional:∀m n p, n≡p ⇒ m ℛ n⇒ m ℛ p.

Variable property: ∀B, B ⊆ town ⇒ |B| = n ⇒
           ∃d, d∈(town\B) /\ (∀b, b∈B ⇒ d ℛ b).

Lemma extendible_by_one:∀ B', |B'| ≤ |town| -1 ⇒ ∃d, d∈town ∧ ¬(d∈B').
Proof.
 clear knows knows_sym knows_extensional property.
 intros B' H_cardinal_town.
 assert (H_town:1≤ |town|); [omega|].
 rewrite <- (diff_inter_cardinal town B') in H_cardinal_town.
 rewrite <- (diff_inter_cardinal town B') in H_town.
 assert (H_inter:|town∩B'| ≤ |B'|);
  [apply (subset_cardinal);apply (inter_subset_2)|].
 generalize (le_trans _ _ _ H_inter H_cardinal_town); intro H1.
 assert (H2:1≤|town\B'|); [omega|].
 assert (H3:=(S_pred _ _ H2)).
 destruct (cardinal_inv_2 H3) as [d Hd].
 exists d; split.
  apply diff_1 with B'; assumption.
  apply diff_2 with town; assumption.
Qed.

Lemma extendible_to_n:∀ B', B'⊆town ⇒ |B'| ≤ n ⇒ ∃B, |B| = n ∧  B'⊆B ∧ B⊆town.
Proof.
 intros B' H_sub H_B'_cardinal.
 assert (H_cardinal_aux_3:2×n≤ |town| -1);[apply le_trans with (2×n); omega|].
 clear property.
 induction n in H_B'_cardinal, H_cardinal_aux_3 |- *.
 (* n = 0 *)
 generalize (sym_eq (le_n_O_eq _ H_B'_cardinal)); intro H_eq.
 generalize (empty_is_empty_1 (cardinal_inv_1 H_eq)).
 intro H_B'.
 exists ∅; repeat split.
  rewrite H_B'; apply subset_empty.
  apply subset_empty.
 (* n = S n0 *)
 destruct (le_lt_eq_dec _ _ H_B'_cardinal) as [H_lt|H_le].
  generalize (lt_n_Sm_le _ _ H_lt); clear H_lt; intro H_le.
  assert (H_cardinal_town_2:2 * n0 ≤ |town| - 1);[omega|].
  destruct (IHn0 H_le H_cardinal_town_2) as [C [HC1 [HC2 HC3]]].
  assert (HC5:|C| ≤ |town| - 1).
   rewrite HC1; apply le_trans with (2×(S n0));[omega| assumption].
  destruct (extendible_by_one C HC5) as [d [Hd1 Hd2]].
  exists ({d} ∪ C).
  repeat split.
   rewrite (add_cardinal_2 Hd2); rewrite HC1; reflexivity.
   apply subset_add_2; assumption.
   apply subset_add_3; assumption.

  exists B'.
  repeat split; trivial; apply subset_refl.
Qed.

(** The following property, proven by induction, is the heart of the
solution, and is due to Tonny Hurkens. *)
Lemma inductive_invariant:∀ m, m≤ n ⇒
                ∃B', B'⊆town ∧ |B'| = m ∧ ∀ b'₀ b'₁, b'₀∈B' ⇒ b'₁∈B' ⇒ ¬(b'₀≡b'₁) ⇒ b'₀ ℛ b'₁.
Proof.
 intros m.
 induction m; intros H_le.
  (* 0 *)
  exists ∅.
  repeat split.
   apply subset_empty.
   intros b'₀ b'₁ H0 H1; apply False_ind.
   elim (FM.empty_iff b'₀); intros H2 _; apply H2; assumption.
  (* S n *)
  assert (H_le0:=le_Sn_le _ _ H_le).
  destruct (IHm H_le0) as [B' [H3' [H1 H2]]].
  rewrite <- H1 in H_le0.
  destruct (extendible_to_n B' H3' H_le0) as [B [HB1 [HB2 HB3]]].
  destruct (property B HB3 HB1) as [d [Hd1 Hd2]].
  exists ({d}∪ B'); repeat split.
   (* subset of town *)
   apply subset_add_3.
   apply diff_1 with B; assumption.
   apply subset_trans with B; assumption.
   (* cardinality *)
   rewrite <- H1.
   apply add_cardinal_2.
   intro Hd4.
   generalize (in_subset Hd4 HB2).
   apply diff_2 with town; assumption.
(* second big goal *)
   intros b'₀ b'₁ H_b'₀ H_b'₁ H_neq.
   destruct ((proj1 (FM.add_iff B' d b'₀)) H_b'₀) as [H3|H3].
    apply knows_sym; apply knows_extensional with d; trivial.
    destruct ((proj1 (FM.add_iff B' d b'₁)) H_b'₁) as [H4|H4].
     apply False_ind; apply H_neq; rewrite <- H3; assumption.
     apply knows_sym.
     apply Hd2; apply in_subset with B'; trivial.
    destruct ((proj1 (FM.add_iff B' d b'₁)) H_b'₁) as [H4|H4].
     apply knows_extensional with d; trivial.
     apply knows_sym.
     apply Hd2; apply in_subset with B'; trivial.
     apply H2; assumption.
Qed.

Theorem AMM11262: ∃e,e∈town ∧ ∀ u, u∈town ∧ ¬(u≡e)⇒ e ℛ u.
Proof.
 destruct (inductive_invariant n (le_refl n)) as [B [HB1 [HB2 HB3]]].
 destruct (property B HB1 HB2) as [d [Hd1 Hd2]].
 set (C:=(town\({d}∪B))).
 (* C subset town *)
 assert (H_susbset_C:C⊆town);
 [ subst C; apply subset_diff; apply subset_refl
 | ].
 (* inter town *)
 assert (H_inter_town: (town∩ ({d}∪B)) ≐ {d} ∪ B).
  rewrite inter_sym; apply inter_subset_equal;
  apply subset_add_3; trivial; apply diff_1 with B; assumption.
 (* ¬ d∈B *)
 assert (H_d_nin_B:¬d∈B); [apply diff_2 with town; assumption|].
 (* |C| = n *)
 assert (H_cardinal_C:|C| =n).
  assert (H_aux:|town∩({d}∪B)|=S n).
   rewrite (@Equal_cardinal (town∩({d}∪B)) ({d}∪B) H_inter_town);
   rewrite (add_cardinal_2 H_d_nin_B); rewrite HB2; reflexivity.
  generalize (diff_inter_cardinal town ({d}∪B));
  fold C; rewrite H_aux; rewrite cardinality; omega.

 destruct (property C H_susbset_C H_cardinal_C) as [e [He1 He2]].
 exists e.
 (* ({d}∪B)⊆town *)
 assert (H_dB_town:({d}∪B)⊆town).
  intros a Ha0; destruct ((proj1 (FM.add_iff B d a)) Ha0) as [Had|HaB].
   rewrite <- Had; apply diff_1 with B; assumption.
   apply HB1; assumption.
 (* town\C = {d}∪B *)
 assert (H_diff: town\C ≐ {d}∪B ).
  unfold C; split; intro H_mem.
   (* ≥ *)
   assert (H_a0:=diff_1 H_mem);
   assert (H_a1:=diff_2 H_mem);
   destruct (In_dec a ({d}∪B)) as [H_a2|H_a2]; trivial;
   apply False_ind; apply H_a1; exact (diff_3 H_a0 H_a2).
   (* ≤ *)
   destruct (In_dec a (town\({d}∪B))) as [H_a2|H_a2].
    apply False_ind; exact (diff_2 H_a2 H_mem).
    apply diff_3; trivial; apply H_dB_town; assumption.
 (* e∈({d}∪B) *)
 assert (H_e_dB:e∈({d}∪B)); [rewrite <- H_diff; assumption|].

 split.
  apply diff_1 with C; assumption...
  intros u [Hu Hu'].
  assert (H_town_part:town ≐ (C∪({d}∪B))).
   rewrite <- (diff_inter_all town ({d}∪B)); rewrite H_inter_town; apply equal_refl.
   rewrite H_town_part in Hu.
   destruct (union_1 Hu) as [HuC|HudB].
    (* u∈C *)
    apply He2; assumption.
    (* u∈({d}∪B) *)
    destruct ((proj1 (FM.add_iff B d u)) HudB) as [Hud|HuB].
     (* d=u *)
     apply knows_extensional with d; trivial.
     apply knows_sym.
     destruct ((proj1 (FM.add_iff B d e)) H_e_dB) as [Hed|HeB].
      (* d=e *)
      apply False_ind; apply Hu'; rewrite <- Hud; assumption.
      (* e∈B *)
      apply Hd2; assumption.
     (* u∈B *)
     destruct ((proj1 (FM.add_iff B d e)) H_e_dB) as [Hed|HeB].
      (* d=e *)
      apply knows_sym; apply knows_extensional with d; trivial;
      apply knows_sym; apply Hd2; assumption.
      (* e∈B *)
      apply HB3; assumption || contradict Hu'; auto with *.
Qed.

End problem_knows_not_refl.

Extraction "amm11262" AMM11262.


From mathcomp
Require Import all_ssreflect.

From chip
Require Import connect acyclic tarjan.

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

(* TODO: prove everything for foldl version *)

Section SeqSet.

Variable V : finType.

Definition enums (s : seq {set V}) :=
 foldr (fun (s0 : {set V}) => cons (enum s0)) [::] s.

Definition enums' (s : seq {set V}) :=
 foldl (fun l (s0 : {set V}) => enum s0 :: l) [::] s.

Lemma enumsP (s : seq {set V}) l :
  reflect
    (exists2 scc, scc \in s & enum scc = l)
    (l \in enums s).
Proof.
apply/(iffP idP).
- rewrite /enums.
  move => Hsc.
  suff Hsuff: exists2 scc, scc \in enum s & enum scc = l.
    move: Hsuff => [scc Hsc'] He.
    move: Hsc'.
    rewrite mem_enum => Hsc'.
    by exists scc.
  move: Hsc.
  elim: s => //=.
  move => s0 l0 IH.
  rewrite in_cons.
  move/orP.
  case.
  * move/eqP =>->.
    exists s0 => //=.
    rewrite mem_enum.
    rewrite in_cons.
    apply/orP.
    by left.
  * move/IH => [scc Hs] He.
    exists scc => //=.
    rewrite mem_enum in_cons.
    apply/orP.
    right.
    by rewrite -mem_enum.
- move => [scc Hscc] He.
  move: He Hscc =><-.
  rewrite /enums /= => Hsc.
  have Hsc': scc \in enum s by rewrite mem_enum.
  move: Hsc'.
  elim: s {Hsc}; first by rewrite mem_enum.
  move => s0 l0 IH.
  rewrite mem_enum in_cons.
  move/orP.
  case.
  * move/eqP =>->.
    rewrite inE.
    by apply/orP; left.
  * rewrite -mem_enum.
    move/IH => Hl.
    by apply/orP; right.
Qed.

Lemma enums_enums'_in s :
  enums s =i enums' s.
Proof.
rewrite /enums /enums'.
have {2}->: s = rev (rev s) by rewrite revK.
rewrite foldl_rev => s0.
apply/enumsP.
case: ifP.
- move/enumsP => [scc Hsc] He.
  exists scc => //.
  move: Hsc.
  by rewrite mem_rev.
- move/enumsP.
  move => He.
  case => x Hx Hex.
  case: He.
  exists x => //.
  by rewrite mem_rev.
Qed.

Lemma enums'P (s : seq {set V}) l :
  reflect
    (exists2 scc, scc \in s & enum scc = l)
    (l \in enums' s).
Proof.
apply/(iffP idP).
- rewrite -enums_enums'_in.
  by move/enumsP.
- move/enumsP.
  by rewrite -enums_enums'_in.
Qed.

Lemma uniq_enums l :
  uniq l ->
  uniq (enums l).
Proof.
elim: l => //=.
move => s l IH.
move/andP => [Hs Hl].
apply/andP.
split; last by apply: IH.
apply/negP => Hen.
move/negP: Hs.
case.
move: Hen.
elim: l {IH Hl} => //=.
move => s0 l IH.
rewrite in_cons.
move/orP.
case.
- move/eqP => Hs.
  suff Hsuff: s = s0.
    rewrite in_cons.
    apply/orP; left.
    by apply/eqP.
  apply/setP.
  move => x.
  by rewrite -mem_enum Hs mem_enum.
- move => He.
  rewrite in_cons.
  apply/orP.
  right.
  exact: IH.
Qed.

Lemma in_uniq_enums l :
  uniq l ->
  forall l0, l0 \in (enums l) -> uniq l0.
Proof.
elim: l => //=.
move => a l IH.
move/andP => [Ha Hl] l0.
rewrite in_cons.
move/orP.
case => //.
- move/eqP =>->.
  exact: enum_uniq.
- move => Hla.
  exact: IH.
Qed.

Lemma uniq_flatten : forall l,
 (forall a, a \in l -> uniq a) ->
 uniq l ->
 {in l &, forall A B : seq V, A != B -> [disjoint A & B]} ->
 uniq (flatten l).
Proof.
elim => //=.
move => a l IH Ha.
move/andP => [Hal Hul] Hd.
rewrite cat_uniq.
apply/and3P.
split.
- apply: Ha.
  by rewrite in_cons; apply/orP; left.
- apply/negP => Hm.
  move/hasP: Hm => [x Hx] /= Ha'.
  move/flattenP: Hx.
  move => [y Hy] Hxy.
  have Hla: a \in a :: l by rewrite in_cons; apply/orP; left.
  have Hly: y \in a :: l by rewrite in_cons; apply/orP; right.
  have Hn: a != y.
    apply/negP => Hn.
    move/eqP: Hn => Hn.
    move: Hn Hal =>->.
    move/negP.
    by case.
  have Hd' := Hd a y Hla Hly Hn.
  move: Hd'.
  rewrite disjoint_subset.
  move/subsetP => Hd'.
  move/negP: (Hd' _ Ha').
  by case.
- apply: IH => //.
  move => a0 Hl.
  apply: Ha.
  by rewrite in_cons; apply/orP; right.
- move => a' a0 Ha' Ha0 Hneq.
  apply: Hd => //.
  * by rewrite in_cons; apply/orP; right.
  * by rewrite in_cons; apply/orP; right.
Qed.

Variable sc : {set {set V}}.

Hypothesis all_in_cover : forall v : V, v \in cover sc.

Lemma cover_all_in :
  forall v : V, v \in flatten (enums (enum sc)).
Proof.
move => v.
apply/flattenP.
move/bigcupP: (all_in_cover v).
move => [s' Hv] Hs.
exists (enum s'); last by rewrite mem_enum.
apply/enumsP.
exists s' => //.
by rewrite mem_enum.
Qed.

Hypothesis trivIset_sc : trivIset sc.

Lemma in_enums_disjoint :
  forall l l', l \in enums (enum sc) -> l' \in enums (enum sc) ->
    l != l' -> [disjoint l & l'].
Proof.
move/trivIsetP: trivIset_sc => Ht.
move => l l'.
move/enumsP => [s Hs] He.
move/enumsP => [s' Hs'] He' Hl.
move: Hs.
rewrite mem_enum.
move/(Ht s s') => Hts.
move: Hs'.
rewrite mem_enum.
move/Hts.
have Hs: s != s'.
  apply/negP => Hs.
  move/eqP: Hs => Hs.
  move/negP: Hl.
  case.
  rewrite -He -He'.
  by rewrite Hs.
move => Hd.
move/Hd: Hs.
rewrite -He -He' /=.
rewrite 2!disjoint_subset.
move/subsetP => Hs.
apply/subsetP.
move => x.
rewrite mem_enum.
move/Hs.
rewrite /predC /=.
rewrite 2!inE.
by rewrite mem_enum.
Qed.

End SeqSet.

Section TarjanSeq.

Variable V : finType.

Variable successors : V -> seq V.

Definition tarjans := enums (enum (tarjan successors)).

Definition tarjans' := enums' (enum (tarjan successors)).

Lemma tarjansP sccl :
  reflect
    (exists2 scc, scc \in tarjan successors & enum scc = sccl)
    (sccl \in tarjans).
Proof.
apply/(iffP idP).
- move/enumsP => [scc Hsc] He.
  exists scc => //.
  by rewrite -mem_enum.
- move => [scc Hsc] He.
  apply/enumsP.
  exists scc => //.
  by rewrite mem_enum.
Qed.

End TarjanSeq.

Section TarjanAcyclic.

Variable V : finType.
Variable g : rel V.

Lemma trivIset_tarjan :
  trivIset (tarjan (rgraph g)).
Proof.
rewrite tarjan_correct.
exact: trivIset_gsccs.
Qed.

Lemma class_diconnected_tarjan :
  forall c, c \in tarjan (rgraph g) ->
  exists x, forall y, (y \in c) = diconnect g x y.
Proof.
move => c.
rewrite tarjan_correct.
rewrite /gsccs /=.
rewrite /equivalence_partition /=.
move/imsetP => [x Hx] Hc.
exists x.
move => y.
rewrite Hc inE.
rewrite andb_idl //.
set g' : rel V := grel (rgraph g).
rewrite -(@eq_diconnect _ g') //.
move => v1 v2.
rewrite /g' /=.
by rewrite mem_enum.
Qed.

Lemma class_diconnected_tarjans :
  forall c, c \in tarjans (rgraph g) ->
  exists x, forall y, (y \in c) = diconnect g x y.
Proof.
move => c.
move/tarjansP => [scc Hsc].
move =><-.
move/class_diconnected_tarjan: Hsc.
move => [x Hy].
exists x.
move => y.
by rewrite mem_enum.
Qed.

Lemma cover_tarjan : cover (tarjan (rgraph g)) = [set: V].
Proof.
rewrite tarjan_correct.
by rewrite cover_gsccs.
Qed.

Lemma all_in_cover_tarjan : forall v : V, v \in cover (tarjan (rgraph g)).
Proof.
by move => v; rewrite tarjan_correct cover_gsccs.
Qed.

Lemma all_in_flatten_tarjans : forall v : V, v \in flatten (tarjans (rgraph g)).
Proof.
apply: cover_all_in.
exact: all_in_cover_tarjan.
Qed.

Lemma enum_tarjan_non_empty : set0 \notin enum (tarjan (rgraph g)).
Proof.
have Hp := gsccs_partition (rgraph g).
rewrite tarjan_correct.
rewrite /partition in Hp.
move/and3P: Hp.
case => Hc Ht Hs.
by rewrite mem_enum.
Qed.

Lemma uniq_in_tarjans :
forall a, a \in tarjans (rgraph g) -> uniq a.
Proof.
apply: in_uniq_enums.
exact: enum_uniq.
Qed.

Lemma uniq_flatten_tarjans : uniq (flatten (tarjans (rgraph g))).
Proof.
apply: uniq_flatten.
- move => a Ht.
  exact: uniq_in_tarjans.
- apply: uniq_enums.
  exact: enum_uniq.
- apply: in_enums_disjoint.
  exact: trivIset_tarjan.
Qed.

Definition tarjans_acyclic :=
 sccs_acyclic (fun g => tarjans (rgraph g)) g.

Lemma tarjans_acyclicP :
  reflect (acyclic g) tarjans_acyclic.
Proof.
apply/sccs_acyclicP.
- exact: uniq_flatten_tarjans.
- exact: all_in_flatten_tarjans.
- exact: class_diconnected_tarjans.
Qed.

End TarjanAcyclic.


Require Import floyd.proofauto.
Require Import progs.bst.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition t_struct_tree := Tstruct _tree noattr.

Section TREES.
Variable V : Type.
Variable default: V.

Definition key := Z.

Inductive tree : Type :=
 | E : tree
 | T: tree -> key -> V -> tree -> tree.

Definition empty_tree : tree := E.

Fixpoint lookup (x: key) (t : tree) : V :=
  match t with
  | E => default
  | T tl k v tr => if x <? k then lookup x tl
                         else if k <? x then lookup x tr
                         else v
  end.

Fixpoint insert (x: key) (v: V) (s: tree) : tree :=
 match s with
 | E => T E x v E
 | T a y v' b => if  x <? y then T (insert x v a) y v' b
                        else if y <? x then T a y v' (insert x v b)
                        else T a x v b
 end.

Fixpoint pushdown_left (a: tree) (bc: tree) : tree :=
 match bc with
 | E => a
 | T b y vy c => T (pushdown_left a b) y vy c
 end.

Fixpoint delete (x: key) (s: tree) : tree :=
 match s with
 | E => E
 | T a y v' b => if  x <? y then T (delete x a) y v' b
                        else if y <? x then T a y v' (delete x b)
                        else pushdown_left a b
 end.

End TREES.
Arguments E {V}.
Arguments T {V} _ _ _ _.
Arguments insert {V} x v s.
Arguments lookup {V} default x t.
Arguments pushdown_left {V} a bc.
Arguments delete {V} x s.

Fixpoint tree_rep (t: tree val) (p: val) : mpred :=
 match t with
 | E => !!(p=nullval) && emp
 | T a x v b => !! (Int.min_signed <= x <= Int.max_signed /\ tc_val (tptr Tvoid) v) &&
    EX pa:val, EX pb:val,
    data_at Tsh t_struct_tree (Vint (Int.repr x),(v,(pa,pb))) p *
    tree_rep a pa * tree_rep b pb
 end.

Definition treebox_rep (t: tree val) (b: val) :=
 EX p: val, data_at Tsh (tptr t_struct_tree) p b * tree_rep t p.

(* TODO: seems not useful *)
Lemma treebox_rep_spec: forall (t: tree val) (b: val),
  treebox_rep t b =
  EX p: val,
  match t with
  | E => !!(p=nullval) && data_at Tsh (tptr t_struct_tree) p b
  | T l x v r => !! (Int.min_signed <= x <= Int.max_signed /\ tc_val (tptr Tvoid) v) &&
      data_at Tsh (tptr t_struct_tree) p b *
      field_at Tsh t_struct_tree [StructField _key] (Vint (Int.repr x)) p *
      field_at Tsh t_struct_tree [StructField _value] v p *
      treebox_rep l (field_address t_struct_tree [StructField _left] p) *
      treebox_rep r (field_address t_struct_tree [StructField _right] p)
  end.
Proof.
  intros.
  unfold treebox_rep at 1.
  f_equal.
  extensionality p.
  destruct t; simpl.
  + apply pred_ext; entailer!.
  + unfold treebox_rep.
    apply pred_ext; entailer!.
    - Intros pa pb.
      Exists pb pa.
      unfold_data_at 1%nat.
      rewrite (field_at_data_at _ t_struct_tree [StructField _left]).
      rewrite (field_at_data_at _ t_struct_tree [StructField _right]).
      cancel.
    - Intros pa pb.
      Exists pb pa.
      unfold_data_at 3%nat.
      rewrite (field_at_data_at _ t_struct_tree [StructField _left]).
      rewrite (field_at_data_at _ t_struct_tree [StructField _right]).
      cancel.
Qed.

Definition mallocN_spec :=
 DECLARE _mallocN
  WITH n: Z
  PRE [ 1%positive OF tint]
     PROP (4 <= n <= Int.max_unsigned)
     LOCAL (temp 1%positive (Vint (Int.repr n)))
     SEP ()
  POST [ tptr tvoid ]
     EX v: val,
     PROP (malloc_compatible n v)
     LOCAL (temp ret_temp v)
     SEP (memory_block Tsh n v).

Definition freeN_spec :=
 DECLARE _freeN
  WITH p : val , n : Z
  PRE [ 1%positive OF tptr tvoid , 2%positive OF tint]
     (* we should also require natural_align_compatible (eval_id 1) *)
      PROP() LOCAL (temp 1%positive p; temp 2%positive (Vint (Int.repr n)))
      SEP (memory_block Tsh n p)
  POST [ tvoid ]
    PROP () LOCAL () SEP ().

Definition treebox_new_spec :=
 DECLARE _treebox_new
  WITH u : unit
  PRE  [  ]
       PROP() LOCAL() SEP ()
  POST [ (tptr t_struct_tree) ]
    EX v:val,
    PROP()
    LOCAL(temp ret_temp v)
    SEP (data_at Tsh (tptr t_struct_tree) nullval v).

Definition insert_spec :=
 DECLARE _insert
  WITH b: val, x: Z, v: val, t: tree val
  PRE  [ _t OF (tptr (tptr t_struct_tree)), _x OF tint,
        _value OF (tptr Tvoid)   ]
    PROP( Int.min_signed <= x <= Int.max_signed; is_pointer_or_null v)
    LOCAL(temp _t b; temp _x (Vint (Int.repr x)); temp _value v)
    SEP (treebox_rep t b)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (treebox_rep (insert x v t) b).

Definition lookup_spec :=
 DECLARE _lookup
  WITH b: val, x: Z, v: val, t: tree val
  PRE  [ _t OF (tptr (tptr t_struct_tree)), _x OF tint  ]
    PROP( Int.min_signed <= x <= Int.max_signed)
    LOCAL(temp _t b; temp _x (Vint (Int.repr x)))
    SEP (treebox_rep t b)
  POST [ tptr Tvoid ]
    PROP()
    LOCAL(temp ret_temp (lookup nullval x t))
    SEP (treebox_rep t b).

Definition turn_left_spec :=
 DECLARE _turn_left
  WITH ta: tree val, x: Z, vx: val, tb: tree val, y: Z, vy: val, tc: tree val, b: val, l: val, pa: val, r: val
  PRE  [ __l OF (tptr (tptr (Tstruct _tree noattr))),
        _l OF (tptr (Tstruct _tree noattr)),
        _r OF (tptr (Tstruct _tree noattr))]
    PROP(Int.min_signed <= x <= Int.max_signed; is_pointer_or_null vx)
    LOCAL(temp __l b; temp _l l; temp _r r)
    SEP (data_at Tsh (tptr t_struct_tree) l b;
         data_at Tsh t_struct_tree (Vint (Int.repr x), (vx, (pa, r))) l;
         tree_rep ta pa;
         tree_rep (T tb y vy tc) r)
  POST [ Tvoid ]
    EX pc: val,
    PROP(Int.min_signed <= y <= Int.max_signed; is_pointer_or_null vy)
    LOCAL()
    SEP (data_at Tsh (tptr t_struct_tree) r b;
         data_at Tsh t_struct_tree (Vint (Int.repr y), (vy, (l, pc))) r;
         tree_rep (T ta x vx tb) l;
         tree_rep tc pc).

Definition pushdown_left_spec :=
 DECLARE _pushdown_left
  WITH ta: tree val, x: Z, v: val, tb: tree val, b: val, p: val
  PRE  [ _t OF (tptr (tptr (Tstruct _tree noattr)))]
    PROP(Int.min_signed <= x <= Int.max_signed; tc_val (tptr Tvoid) v)
    LOCAL(temp _t b)
    SEP (data_at Tsh (tptr t_struct_tree) p b;
         field_at Tsh t_struct_tree [StructField _key] (Vint (Int.repr x)) p;
         field_at Tsh t_struct_tree [StructField _value] v p;
         treebox_rep ta (field_address t_struct_tree [StructField _left] p);
         treebox_rep tb (field_address t_struct_tree [StructField _right] p))
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (treebox_rep (pushdown_left ta tb) b).

Definition delete_spec :=
 DECLARE _delete
  WITH b: val, x: Z, t: tree val
  PRE  [ _t OF (tptr (tptr t_struct_tree)), _x OF tint]
    PROP( Int.min_signed <= x <= Int.max_signed)
    LOCAL(temp _t b; temp _x (Vint (Int.repr x)))
    SEP (treebox_rep t b)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (treebox_rep (delete x t) b).

Definition tree_free_spec :=
 DECLARE _tree_free
  WITH t: tree val, p: val
  PRE  [ _p OF (tptr t_struct_tree) ]
       PROP() LOCAL(temp _p p) SEP (tree_rep t p)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (emp).

Definition treebox_free_spec :=
 DECLARE _treebox_free
  WITH t: tree val, b: val
  PRE  [ _b OF (tptr (tptr t_struct_tree)) ]
       PROP() LOCAL(temp _b b) SEP (treebox_rep t b)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (emp).

Definition Gprog : funspecs :=
    ltac:(with_library prog [
    mallocN_spec; freeN_spec; treebox_new_spec;
    tree_free_spec; treebox_free_spec;
    insert_spec; lookup_spec;
    turn_left_spec; pushdown_left_spec; delete_spec
  ]).

Lemma tree_rep_saturate_local:
   forall t p, tree_rep t p |-- !! is_pointer_or_null p.
Proof.
destruct t; simpl; intros.
entailer!.
Intros pa pb. entailer!.
Qed.

Hint Resolve tree_rep_saturate_local: saturate_local.

Lemma tree_rep_valid_pointer:
  forall t p, tree_rep t p |-- valid_pointer p.
Proof.
intros.
destruct t; simpl; normalize; auto with valid_pointer.
Qed.
Hint Resolve tree_rep_valid_pointer: valid_pointer.

Lemma treebox_rep_saturate_local:
   forall t b, treebox_rep t b |-- !! field_compatible (tptr t_struct_tree) [] b.
Proof.
intros.
unfold treebox_rep.
Intros p.
entailer!.
Qed.

Hint Resolve treebox_rep_saturate_local: saturate_local.

Definition insert_inv (b0: val) (t0: tree val) (x: Z) (v: val): environ -> mpred :=
  EX b: val, EX t: tree val,
  PROP()
  LOCAL(temp _t b; temp _x (Vint (Int.repr x));   temp _value v)
  SEP(treebox_rep t b;  (treebox_rep (insert x v t) b -* treebox_rep (insert x v t0) b0)).

Lemma ramify_PPQQ {A: Type} {NA: NatDed A} {SA: SepLog A} {CA: ClassicalSep A}: forall P Q,
  P |-- P * (Q -* Q).
Proof.
  intros.
  apply RAMIF_PLAIN.solve with emp.
  + rewrite sepcon_emp; auto.
  + rewrite emp_sepcon; auto.
Qed.

Lemma tree_rep_nullval: forall t,
  tree_rep t nullval |-- !! (t = E).
Proof.
  intros.
  destruct t; [entailer! |].
  simpl tree_rep.
  Intros pa pb. entailer!.
  destruct H1; contradiction.
Qed.

Hint Resolve tree_rep_nullval: saturate_local.

Lemma is_pointer_or_null_force_val_sem_cast_neutral: forall p,
  is_pointer_or_null p -> force_val (sem_cast_neutral p) = p.
Proof.
  intros.
  destruct p; try contradiction; reflexivity.
Qed.

Lemma treebox_rep_leaf: forall x p b (v: val),
  is_pointer_or_null v ->
  Int.min_signed <= x <= Int.max_signed ->
  data_at Tsh t_struct_tree (Vint (Int.repr x), (v, (nullval, nullval))) p * data_at Tsh (tptr t_struct_tree) p b |-- treebox_rep (T E x v E) b.
Proof.
  intros.
  unfold treebox_rep, tree_rep. Exists p nullval nullval. entailer!.
Qed.

Lemma bst_left_entail: forall (t1 t1' t2: tree val) k (v p1 p2 p b: val),
  Int.min_signed <= k <= Int.max_signed ->
  is_pointer_or_null v ->
  data_at Tsh (tptr t_struct_tree) p b *
  data_at Tsh t_struct_tree (Vint (Int.repr k), (v, (p1, p2))) p *
  tree_rep t1 p1 * tree_rep t2 p2
  |-- treebox_rep t1 (field_address t_struct_tree [StructField _left] p) *
       (treebox_rep t1'
         (field_address t_struct_tree [StructField _left] p) -*
        treebox_rep (T t1' k v t2) b).
Proof.
  intros.
  unfold_data_at 2%nat.
  rewrite (field_at_data_at _ t_struct_tree [StructField _left]).
  unfold treebox_rep at 1. Exists p1. cancel.

  rewrite <- wand_sepcon_adjoint.
  clear p1.
  unfold treebox_rep.
  Exists p.
  simpl.
  Intros p1.
  Exists p1 p2.
  entailer!.
  unfold_data_at 2%nat.
  rewrite (field_at_data_at _ t_struct_tree [StructField _left]).
  cancel.
Qed.

Lemma bst_right_entail: forall (t1 t2 t2': tree val) k (v p1 p2 p b: val),
  Int.min_signed <= k <= Int.max_signed ->
  is_pointer_or_null v ->
  data_at Tsh (tptr t_struct_tree) p b *
  data_at Tsh t_struct_tree (Vint (Int.repr k), (v, (p1, p2))) p *
  tree_rep t1 p1 * tree_rep t2 p2
  |-- treebox_rep t2 (field_address t_struct_tree [StructField _right] p) *
       (treebox_rep t2'
         (field_address t_struct_tree [StructField _right] p) -*
        treebox_rep (T t1 k v t2') b).
Proof.
  intros.
  unfold_data_at 2%nat.
  rewrite (field_at_data_at _ t_struct_tree [StructField _right]).
  unfold treebox_rep at 1. Exists p2. cancel.

  rewrite <- wand_sepcon_adjoint.
  clear p2.
  unfold treebox_rep.
  Exists p.
  simpl.
  Intros p2.
  Exists p1 p2.
  entailer!.
  unfold_data_at 2%nat.
  rewrite (field_at_data_at _ t_struct_tree [StructField _right]).
  cancel.
Qed.

Lemma modus_ponens_wand' {A}{ND: NatDed A}{SL: SepLog A}:
  forall P Q R: A, P |-- Q -> P * (Q -* R) |-- R.
Proof.
  intros.
  eapply derives_trans; [| apply modus_ponens_wand].
  apply sepcon_derives; [| apply derives_refl].
  auto.
Qed.

Lemma if_trueb: forall {A: Type} b (a1 a2: A), b = true -> (if b then a1 else a2) = a1.
Proof. intros; subst; auto. Qed.

Lemma if_falseb: forall {A: Type} b (a1 a2: A), b = false -> (if b then a1 else a2) = a2.
Proof. intros; subst; auto. Qed.

Ltac simpl_compb := first [ rewrite if_trueb by (apply Z.ltb_lt; omega)
                          | rewrite if_falseb by (apply Z.ltb_ge; omega)].

Lemma body_insert: semax_body Vprog Gprog f_insert insert_spec.
Proof.
  start_function.
  eapply semax_pre; [
    | apply (semax_loop _ (insert_inv b t x v) (insert_inv b t x v) )].
  * (* Precondition *)
    unfold insert_inv.
    Exists b t. entailer.
    apply ramify_PPQQ.
  * (* Loop body *)
    forward. (* Sskip *)
    unfold insert_inv.
    Intros b1 t1.
    unfold treebox_rep at 1. Intros p1.
    forward. (* p = *t; *)
    forward_if.
    + (* then clause *)
      subst p1.
      forward_call (sizeof t_struct_tree).
        1: simpl; repable_signed.
      Intros p'.
      rewrite memory_block_data_at_ by auto.
      forward. (* p->key=x; *)
      simpl.
      forward. (* p->value=value; *)
      forward. (* p->left=NULL; *)
      forward. (* p->right=NULL; *)
      assert_PROP (t1= (@E _)).
        1: entailer!.
      subst t1. simpl tree_rep. rewrite !prop_true_andp by auto.
      rewrite is_pointer_or_null_force_val_sem_cast_neutral by auto.
      forward. (* *t = p; *)
      forward. (* return; *)
      apply modus_ponens_wand'.
      apply treebox_rep_leaf; auto.
    + (* else clause *)
      destruct t1.
        { simpl tree_rep. normalize. }
      simpl tree_rep.
      Intros pa pb. clear H1.
      forward. (* y=p->key; *)
      forward_if; [ | forward_if ].
      - (* Inner if, then clause: x<k *)
        forward. (* t=&p->left *)
        unfold insert_inv.
        Exists (offset_val 8 p1) t1_1.
        entailer!.
        simpl_compb.
        (* TODO: SIMPLY THIS LINE *)
        replace (offset_val 8 p1)
          with (field_address t_struct_tree [StructField _left] p1)
          by (unfold field_address; simpl;
              rewrite if_true by auto with field_compatible; auto).
        apply RAMIF_PLAIN.trans'.
        apply bst_left_entail; auto.
      - (* Inner if, second branch:  k<x *)
        forward. (* t=&p->right *)
        unfold insert_inv.
        Exists (offset_val 12 p1) t1_2.
        entailer!.
        simpl_compb; simpl_compb.
        (* TODO: SIMPLY THIS LINE *)
        replace (offset_val 12 p1)
          with (field_address t_struct_tree [StructField _right] p1)
          by (unfold field_address; simpl;
              rewrite if_true by auto with field_compatible; auto).
        apply RAMIF_PLAIN.trans'.
        apply bst_right_entail; auto.
      - (* Inner if, third branch: x=k *)
        assert (x=k) by omega.
        subst x. clear H H1 H4.
        forward. (* p->value=value *)
        forward. (* return *)
        (* TODO: SIMPLY THIS LINE *)
        simpl_compb.
        simpl_compb.
        apply modus_ponens_wand'.
        unfold treebox_rep. Exists p1.
        simpl tree_rep. Exists pa pb. entailer!.
  * (* After the loop *)
    forward.
    unfold loop2_ret_assert. apply andp_left2. normalize.
Qed.

Definition lookup_inv (b0 p0: val) (t0: tree val) (x: Z): environ -> mpred :=
  EX p: val, EX t: tree val,
  PROP(lookup nullval x t = lookup nullval x t0)
  LOCAL(temp _p p; temp _x (Vint (Int.repr x)))
  SEP(tree_rep t p;  (tree_rep t p -* tree_rep t0 p0)).

Lemma body_lookup: semax_body Vprog Gprog f_lookup lookup_spec.
Proof.
  start_function.
  unfold treebox_rep. Intros p.
  forward. (* p=*t; *)
  apply (semax_post_ret1 nil
          (data_at Tsh (tptr t_struct_tree) p b :: tree_rep t p :: nil)).
  1: intro HH; inversion HH.
  1: unfold treebox_rep; Exists p; entailer!.
  apply semax_frame''.
  forward_while (lookup_inv b p t x).
  * (* precondition implies loop invariant *)
    Exists p t. entailer!.
    apply -> wand_sepcon_adjoint. cancel.
  * (* type-check loop condition *)
    entailer!.
  * (* loop body preserves invariant *)
    destruct t0; unfold tree_rep at 1; fold tree_rep. normalize.
    Intros pa pb.
    forward.
    forward_if; [ | forward_if ].
    + (* then clause: x<y *)
      forward. (* p=p<-left *)
      Exists (pa,t0_1). unfold fst,snd.
      entailer!.
      - rewrite <- H0; simpl.
        simpl_compb; auto.
      - (* TODO: merge the following 2 lines *)
        apply RAMIF_PLAIN.trans''.
        apply -> wand_sepcon_adjoint.
        Exists pa pb; entailer!.
    + (* else-then clause: y<x *)
      forward. (* p=p<-right *)
      Exists (pb,t0_2). unfold fst,snd.
      entailer!.
      - rewrite <- H0; simpl.
        simpl_compb; simpl_compb; auto.
      - (* TODO: merge the following 2 lines *)
        apply RAMIF_PLAIN.trans''.
        apply -> wand_sepcon_adjoint.
        Exists pa pb; entailer!.
    + (* else-else clause: x=y *)
      assert (x=k) by omega. subst x. clear H H4 H5.
      forward. (* v=p->value *)
      forward. (* return v; *)
      unfold treebox_rep. unfold normal_ret_assert.
      entailer!.
      - rewrite <- H0. simpl.
        simpl_compb; simpl_compb; auto.
      - (* TODO: merge the following 2 lines *)
        apply modus_ponens_wand'.
        Exists pa pb; entailer!.
  * (* after the loop *)
    forward. (* return NULL; *)
    entailer!.
    apply modus_ponens_wand.
Qed.

Lemma body_turn_left: semax_body Vprog Gprog f_turn_left turn_left_spec.
Proof.
  start_function.
  simpl.
  Intros pb pc.
  forward. (* mid=r->left *)
  forward. (* l->right=mid *)
  assert_PROP (is_pointer_or_null pb) by entailer!.
  rewrite is_pointer_or_null_force_val_sem_cast_neutral by auto.
  forward. (* r->left=l *)
  assert_PROP (is_pointer_or_null l) by entailer!.
  rewrite is_pointer_or_null_force_val_sem_cast_neutral by auto.
  forward. (* _l = r *)
  assert_PROP (is_pointer_or_null r) by entailer!.
  rewrite is_pointer_or_null_force_val_sem_cast_neutral by auto.
  Opaque tree_rep. forward. Transparent tree_rep. (* return *)
  (* TODO: simplify the following proof *)
  Exists pc.
  entailer!.
  simpl.
  Exists pa pb.
  entailer!.
Qed.

Definition pushdown_left_inv (b_res: val) (t_res: tree val): environ -> mpred :=
  EX b: val, EX ta: tree val, EX x: Z, EX v: val, EX tb: tree val,
  PROP  ()
  LOCAL (temp _t b)
  SEP   (treebox_rep (T ta x v tb) b;
         (treebox_rep (pushdown_left ta tb) b -* treebox_rep t_res b_res)).

Lemma body_pushdown_left: semax_body Vprog Gprog f_pushdown_left pushdown_left_spec.
Proof.
  start_function.
  eapply semax_pre; [
    | apply (semax_loop _ (pushdown_left_inv b (pushdown_left ta tb))
                         (pushdown_left_inv b (pushdown_left ta tb)))].
  + (* Precondition *)
    unfold pushdown_left_inv.
    Exists b ta x v tb.
    entailer!.
    eapply derives_trans; [| apply ramify_PPQQ].
    rewrite (treebox_rep_spec (T ta x v tb)).
    Exists p.
    entailer!.
  + (* Loop body *)
    unfold pushdown_left_inv.
    clear x v H H0.
    Intros b0 ta0 x vx tbc0.
    unfold treebox_rep at 1.
    Intros p0.
    forward. (* skip *)
    forward. (* p = *t; *)
      (* TODO entailer: The following should be solve automatically. satuate local does not work *)
      1: rewrite (add_andp _ _ (tree_rep_saturate_local _ _)); entailer!.
    simpl tree_rep.
    Intros pa pbc.
    forward. (* q = p->right *)
    forward_if.
    - subst.
      assert_PROP (tbc0 = (@E _)).
        1: entailer!.
      subst.
      forward. (* q=p->left *)
      forward. (* *t=q *)
      forward_call (p0, sizeof t_struct_tree). (* freeN(p, sizeof ( *p )); *)
      Focus 1. {
        entailer!.
        rewrite memory_block_data_at_ by auto.
        cancel.
      } Unfocus.
      forward. (* return *)
      apply modus_ponens_wand'.
      Exists pa.
      cancel.
    - destruct tbc0 as [| tb0 y vy tc0].
        { simpl tree_rep. normalize. }
      forward_call (ta0, x, vx, tb0, y, vy, tc0, b0, p0, pa, pbc). (* turn_left(t, p, q); *)
      Intros pc.
      forward. (* t = &q->left; *)
      Exists (field_address t_struct_tree [StructField _left] pbc) ta0 x vx tb0.
      (* TODO entailer: not to simply too much in entailer? *)
      Opaque tree_rep. entailer!. Transparent tree_rep.
        (* TODO: simplify this line *)
      apply RAMIF_PLAIN.trans'.
      apply bst_left_entail; auto.
  + forward. (* Sskip *)
    apply andp_left2.
    unfold loop2_ret_assert. rewrite prop_true_andp by auto.
    auto.
Qed.

Lemma body_treebox_new: semax_body Vprog Gprog f_treebox_new treebox_new_spec.
Proof.
  start_function.
  forward_call (sizeof (tptr t_struct_tree)).
  simpl sizeof; computable.
  Intros p.
  rewrite memory_block_data_at_ by auto.
  forward.
  forward.
  Exists p. entailer!.
Qed.

Lemma body_tree_free: semax_body Vprog Gprog f_tree_free tree_free_spec.
Proof.
  start_function.
  forward_if (PROP()LOCAL()SEP()).
  + destruct t; simpl tree_rep.
      1: Intros. contradiction.
    Intros pa pb.
    forward.
    forward.
    forward_call (p, sizeof t_struct_tree).
    Focus 1. {
      entailer!.
      rewrite memory_block_data_at_ by auto.
      cancel.
    } Unfocus.
    forward_call (t1,pa).
    forward_call (t2,pb).
    entailer!.
  + forward.
    subst.
    entailer!.
    simpl; normalize.
  + forward.
Qed.

Lemma body_treebox_free: semax_body Vprog Gprog f_treebox_free treebox_free_spec.
Proof.
  start_function.
  unfold treebox_rep.
  Intros p.
  forward.
  forward_call (t,p).
  forward_call (b, sizeof (tptr t_struct_tree)).
  entailer!.
  rewrite memory_block_data_at_ by auto.
  cancel.
  forward.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* $Id: Bool_nat.v 14641 2011-11-06 11:59:10Z herbelin $ *)

Require Export Compare_dec.
Require Export Peano_dec.
Require Import Sumbool.

Open Local Scope nat_scope.

Implicit Types m n x y : nat.

(** The decidability of equality and order relations over
    type [nat] give some boolean functions with the adequate specification. *)

Definition notzerop n := sumbool_not _ _ (zerop n).
Definition lt_ge_dec : forall x y, {x < y} + {x >= y} :=
  fun n m => sumbool_not _ _ (le_lt_dec m n).

Definition nat_lt_ge_bool x y := bool_of_sumbool (lt_ge_dec x y).
Definition nat_ge_lt_bool x y :=
  bool_of_sumbool (sumbool_not _ _ (lt_ge_dec x y)).

Definition nat_le_gt_bool x y := bool_of_sumbool (le_gt_dec x y).
Definition nat_gt_le_bool x y :=
  bool_of_sumbool (sumbool_not _ _ (le_gt_dec x y)).

Definition nat_eq_bool x y := bool_of_sumbool (eq_nat_dec x y).
Definition nat_noteq_bool x y :=
  bool_of_sumbool (sumbool_not _ _ (eq_nat_dec x y)).

Definition zerop_bool x := bool_of_sumbool (zerop x).
Definition notzerop_bool x := bool_of_sumbool (notzerop x).


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

Theorem append_assoc:
   forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
   induction l1; induction l2; induction l3; try (simpl; reflexivity).
   { simpl. rewrite <- IHl1. f_equal. }
   { simpl. rewrite 2 append_nil. reflexivity. }
   { simpl. rewrite append_nil.  reflexivity. }
   { simpl. rewrite 2 append_nil. reflexivity. }
Qed.

Theorem qreva_append : forall (x y : lst), (qreva x y) = (append (rev x) y).
Proof.
   induction x; induction y; simpl; try reflexivity.
   { rewrite IHx.
   rewrite <- append_assoc.
   f_equal. }
   { rewrite IHx.
lfind.
Admitted.

Theorem theorem0 : forall (x : lst), eq (rev x) (qreva x Nil).
Proof.
   intros.
   rewrite qreva_append.
   rewrite append_nil.
   reflexivity.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool ssrint eqtype ssrnat seq choice fintype rat finfun.
From mathcomp Require Import bigop ssralg div ssrnum ssrint.
From mathcomp Require Import fingroup finset.
Require Import Permutation Lib.Perm.

(* Various lemmas and tactics around sequences.
  n-ary composition in IPDL is done using sequences, so
  we need random access and swapping combinators. *)

Fixpoint rot_rcons {A} (n : nat) (xs : list A) :=
  match n, xs with
    | 0, _ => xs
    | S n, (x :: xs) => rot_rcons n (rcons xs x)
    | _, _ => xs
                end.

(* split the sequence in two; the nth element will be the head of the second list *)
Fixpoint seq_split {A} (n : nat) (xs : seq A) : seq A * seq A :=
  match n, xs with
    | 0, xs => (nil, xs)
    | (S n), (x :: xs) => let p := seq_split n xs in (x :: p.1, p.2)
    | (S n), nil => (nil, nil)
                      end.

Lemma seq_splitE  {A} n (xs : seq A) : (seq_split n xs).1 ++ (seq_split n xs).2 = xs.
  move: xs; induction n.
  done.
  induction xs.
  done.
  simpl.
  rewrite -{3}(IHn xs) //=.
Defined.

Lemma Perm_rcons {A} a (xs : seq A) :
  Permutation (a :: xs) (rcons xs a).
  induction xs.
  rewrite //=.
  rewrite //=.
  eapply perm_trans.
  apply perm_swap.
  apply perm_skip.
  done.
Qed.

Lemma Perm_rot {A} n (xs : list A) : Permutation xs (rot_rcons n xs).
  move: xs; induction n.
  simpl.
  done.
  simpl.
  induction xs.
  done.
  eapply perm_trans.
  apply Perm_rcons.
  apply IHn.
Qed.

(* inserts into list. if n >= size xs, appends to end *)
Fixpoint insert {A} (xs : seq A) (n : nat) (x : A) : seq A :=
    match n with
    | 0 => x :: xs
    | S n =>
    match xs with
        | y :: ys => y :: insert ys n x
        | nil => x :: nil
    end
        end.

Lemma size_insert {A} (xs : seq A) n x :
    size (insert xs n x) = S (size xs).
    move: xs; induction n.
    by destruct xs.
    induction xs.
    done.
    simpl.
    rewrite IHn //=.
Qed.

Lemma nth_error_insert_same {A} (xs : seq A) n x :
    n < (S (size xs)) ->
    List.nth_error (insert xs n x) n = Some x.
    move: n; induction xs.
    simpl.
    destruct n.
    done.
    induction n.
    done.
    done.
    induction n.
    simpl.
    done.
    simpl.
    intro; rewrite IHxs //=.
Qed.

Lemma nth_error_insert_lt {A} (xs : seq A) n m x :
  n < size xs ->
  m < n ->
  List.nth_error (insert xs n x) m = List.nth_error xs m.
  move: n m.
  induction xs.
  done.
  induction n.
  done.
  simpl.
  intros.
  induction m.
  done.
  rewrite //=.
  rewrite IHxs //=.
Qed.

Lemma nth_error_insert_gt {A} (xs : seq A) n m x :
  n < size xs ->
  m > n ->
  List.nth_error (insert xs n x) (S m) = List.nth_error xs (m).
  move: n m.
  induction xs.
  done.
  induction n.
  simpl.
  done.
  simpl.
  intros.
  destruct m.
  done.
  rewrite IHxs.
  done.
  done.
  done.
Qed.

Lemma insert_0 {A} (xs : seq A) (x : A) :
insert xs 0 x = x :: xs.
induction xs; done.
Qed.

Fixpoint insert_seq {A} (xs : seq A) (n : nat) (xs' : seq A) :=
match xs' with
| nil => xs
| x :: xs'' =>
    insert_seq (insert xs n x) n xs''
                end.

(* if x < len xs, remove nth element from xs *)
Fixpoint remove {A} (xs : seq A) (n : nat) : seq A :=
  match n, xs with
  | _, nil => nil
  | 0, (x :: xs) => xs
  | S n, (x :: xs) => x :: remove xs n
                        end.

Lemma remove_oob {A} (xs : seq A) n :
  n >= size xs ->
  remove xs n = xs.
  move: xs; induction n.
  induction xs.
  done.
  done.
  induction xs.
  done.
  simpl.
  intro.
  rewrite IHn //=.
Qed.

Lemma size_remove {A} (xs : seq A) n :
  n < size xs ->
  size (remove xs n) = predn (size xs).
  move: xs; induction n.
  induction xs; done.
  induction xs; rewrite //=.
  move => h; rewrite IHn.
  destruct (size xs); done.
  done.
Qed.

Fixpoint remove_range {A} (xs : seq A) from len :=
  match len with
    | 0 => xs
    | S l => remove_range (remove xs from) from l
                           end.

Lemma remove_insert {A} (xs : seq A) n x :
  n < size xs ->
  remove (insert xs n x) n = xs.
  move: n; induction xs.
  induction n; rewrite //=.
  destruct n.
  done.
  simpl.
  move => h.
  rewrite IHxs //=.
Qed.

Lemma insert_remove_eq {A} (xs : seq A) n x :
  n < size xs ->
  List.nth_error xs n = Some x ->
  insert (remove xs n) n x = xs.
  move: n; induction xs.
  done.
  simpl.
  induction n.
  simpl.
  move => _ h; injection h => ->; destruct xs; done.
  simpl.
  move => h h'.
  rewrite IHxs //=.
Qed.

Lemma insert_removeC {A} (xs : seq A) n x :
  n < size xs ->
  List.nth_error xs n = Some x ->
  insert (remove xs n) n x =
  remove (insert xs n x) n.
  intros.
  rewrite insert_remove_eq.
  rewrite remove_insert.
  done.
  done.
  done.
  done.
Qed.

Lemma insert2_remove2 {A} (xs : seq A) pos x y :
  List.nth_error xs pos = Some x ->
  List.nth_error xs (S pos) = Some y ->
  insert (insert (remove (remove xs pos) pos) pos y) pos x = xs.
  move : xs.
  induction pos.
  destruct xs.
  done.
  destruct xs.
  done.
  simpl.
  rewrite !insert_0.
  move => h1 h2; injection h1; injection h2 => -> ->; done.
  destruct xs.
  done.
  simpl.
  destruct xs.
  done.
  intros.
  rewrite (IHpos (a0 :: xs)).
  done.
  done.
  done.
Qed.

Definition lset {A} (xs : seq A) (n : nat) (x : A) :=
  if n < size xs then
  insert (remove xs n) n x else xs.

Lemma lset_0_cons {A} (xs : seq A) x y :
  lset (x :: xs) 0 y = y :: xs.
  rewrite /lset.
  rewrite ltn0Sn.
  rewrite insert_0 //=.
Qed.

Lemma lset_Sn_cons {A} (xs : seq A) x y n :
  lset (x :: xs) (S n) y = x :: lset xs n y.
rewrite /lset.
simpl.
have -> : (n.+1 < (size xs).+1) = (n < size xs) by done.
destruct (n < size xs); done.
Qed.

(* if n < len xs, equal to xs[0..n] ++ xs' ++ xs[n+1 ..] *)
Definition  lset_seq {A} (xs : seq A) (n : nat) (xs' : seq A) : seq A :=
  insert_seq (remove xs n) n xs'.

Lemma insert_seq_Sn_cons {A} (xs : seq A) x n ys :
  insert_seq (x :: xs) n.+1 ys =
  x :: insert_seq xs n ys.
  move: n xs; induction ys.
  done.
  simpl.
  intros.
  rewrite IHys.
  done.
Qed.

Lemma lset_seq_Sn_cons {A} (xs : seq A) x ys n :
  lset_seq (x :: xs) (S n) ys =
  x :: lset_seq xs n ys.
  rewrite /lset_seq.
  simpl.
  rewrite insert_seq_Sn_cons //=.
Qed.

Lemma lset_lset {A} (xs : seq A) n (x x' : A) :
  n < size xs ->
  lset (lset xs n x') n x = lset xs n x.
  move: xs; induction n.
  induction xs.
  simpl.
  rewrite /lset //=.
  simpl.
  intro.
  rewrite !lset_0_cons //=.
  induction xs.
  done.
  move => h.
  rewrite !lset_Sn_cons //=.
  rewrite IHn //=.
Qed.

Lemma lset_nth_error {A} (xs : seq A) (n : nat) x :
  n < size xs ->
  List.nth_error xs n = Some x ->
  xs = lset xs n x.
  move: n.
  induction xs.
  done.
  induction n.
  simpl.
  intro.
  intro H'; injection H'; intro; subst.
  rewrite lset_0_cons //=.
  simpl.
  move => h.
  move/IHxs => ->.
  rewrite lset_Sn_cons lset_lset //=.
  done.
Qed.

Lemma nth_error_lset {A} (xs : seq A) (n m : nat) x :
  n < size xs ->
  List.nth_error (lset xs n x) m = if n == m then Some x else List.nth_error xs m.
  move: m n.
  induction xs.
  simpl.
  done.
  induction m.
  induction n.
  simpl.
  rewrite /lset /= insert_0; done.
  simpl.
  rewrite lset_Sn_cons.
  done.
  induction n.
  simpl.
  rewrite /lset /=.
  rewrite insert_0.
  done.
  simpl.
  move => h.
  rewrite lset_Sn_cons.
  rewrite IHxs.
  rewrite /eq_op //=.
  done.
Qed.

Lemma size_lset {A} (xs : seq A) n x :
  n < size xs ->
  size (lset xs n x) = size xs.
  intro.
  rewrite /lset H.
  rewrite size_insert size_remove.
  destruct (size xs); done.
  done.
Qed.

Lemma nth_error_remove {A} (xs : seq A) n m :
  n < size xs ->
  List.nth_error (remove xs n) m = if m < n then List.nth_error xs m else List.nth_error xs m.+1.
  move: m n.
  induction xs.
  done.
  induction n.
  simpl.
  done.
  simpl.
  move => h.
  destruct m.
  done.
  simpl.
  rewrite IHxs.
  have -> : (m.+1 < n.+1) = (m < n) by done.
  destruct (m < n).
  done.
  destruct xs; done.
  done.
Qed.

Lemma nth_error_eqP {A} (xs xs' : seq A) :
  (forall n, List.nth_error xs n = List.nth_error xs' n) -> xs = xs'.
  move: xs'; induction xs.
  induction xs'.
  done.
  move/(_ 0).
  done.
  intros.
  destruct xs'.
  move: (H 0); done.
  move: (H 0) => h; injection h => ->.
  erewrite IHxs.
  apply: erefl.
  intros.
  move: (H (S n)).
  done.
Qed.

Definition swap {A} n m (xs : seq A) :=
  match List.nth_error xs n, List.nth_error xs m with
    | Some x, Some y =>
      lset (lset xs n y) m x
    | _, _ => xs end.

Lemma size_length {A} (xs : seq A) :
  size xs = length xs.
  induction xs; rewrite //=.
Qed.

Lemma nth_error_size_lt {A} (xs : seq A) n :
  isSome (List.nth_error xs n) =
  (n < size xs).
  rewrite size_length.
  apply Bool.eq_true_iff_eq; split.
  intro.
  apply/ltP.
  apply List.nth_error_Some.
  destruct (List.nth_error xs n); done.
  move/ltP.
  move/List.nth_error_Some.
  destruct (List.nth_error xs n); done.
Qed.

Lemma Perm_swap {A} n m (xs : seq A) :
  Permutation xs (swap n m xs).
rewrite /swap.
remember (List.nth_error xs n) as o1; destruct o1; rewrite //=; symmetry in Heqo1.
remember (List.nth_error xs m) as o2; destruct o2; rewrite //=; symmetry in Heqo2.
apply Permutation_nth_error.
split.
rewrite -!size_length.
rewrite size_lset.
rewrite size_lset.
done.
rewrite -nth_error_size_lt Heqo1 //=.
rewrite size_lset.
rewrite -nth_error_size_lt Heqo2 //=.
rewrite -nth_error_size_lt Heqo1 //=.

exists (fun x =>
     if x == n then m else
       if x == m then n else
         x).
split.
move => x y.
destruct (eqVneq x n); subst.
destruct (eqVneq y n); subst.
done.
destruct (eqVneq y m); subst.
done.
intro; subst.
rewrite eq_refl //= in i0.
destruct (eqVneq x m); subst.
destruct (eqVneq y n); subst.
done.
destruct (eqVneq y m); subst.
done.
intro; subst.
rewrite eq_refl //= in i0.
destruct (eqVneq y n); subst.
intro; subst.
rewrite eq_refl //= in i0.
destruct (eqVneq y m); subst.
intro; subst.
rewrite eq_refl //= in i.
done.

intros.
rewrite !nth_error_lset.
destruct (eqVneq m n0); subst.
destruct (eqVneq n0 n); subst.
congruence.
congruence.
destruct (eqVneq n n0); subst.
congruence.
done.

rewrite -nth_error_size_lt Heqo1 //=.
rewrite size_lset.
rewrite -nth_error_size_lt Heqo2 //=.
rewrite -nth_error_size_lt Heqo1 //=.
Qed.

Definition remove2 {A} (xs : seq A) (n1 n2 : nat) :=
  if n1 < n2 then remove (remove xs n1) (predn n2) else remove (remove xs n2) (predn n1).

Lemma insert0 {A} (xs : seq A) x :
  insert xs 0 x = x :: xs.
  destruct xs; done.
Qed.

Lemma nth_error_cons {A} (xs : seq A) x i :
  List.nth_error (x :: xs) i =
  if i is 0 then Some x else List.nth_error xs (i.-1).
  destruct i; rewrite //=.
Qed.

Lemma nth_error_swap {A} (xs : seq A) n m i :
  List.nth_error (swap n m xs) i =
  if [&& n < size xs & m < size xs] then
    if i == n then List.nth_error xs m else
      if i == m then List.nth_error xs n else
        List.nth_error xs i
  else List.nth_error xs i.
  rewrite /swap.
  rewrite -nth_error_size_lt.
  rewrite -nth_error_size_lt.
  remember (List.nth_error xs n) as o; destruct o; rewrite //=.
  remember (List.nth_error xs m) as o'; destruct o'; rewrite //=.
  rewrite !nth_error_lset.
  destruct (eqVneq m i); subst.
  destruct (eqVneq n i); subst.
  rewrite Heqo Heqo'; done.
  done.
  rewrite eq_sym //=.
  rewrite -nth_error_size_lt -Heqo //=.
  rewrite size_lset.
  rewrite -nth_error_size_lt -Heqo' //=.
  rewrite -nth_error_size_lt -Heqo //=.
Qed.

Lemma nth_error_behead {A} (xs : seq A) i :
  List.nth_error (behead xs) i =
  List.nth_error xs i.+1.
  destruct xs; simpl.
  destruct i; done.
  done.
Qed.

Lemma swap0E {A} (xs : seq A) n b a :
  n != 0 ->
  List.nth_error xs 0 = Some a ->
  List.nth_error xs n = Some b ->
  swap 0 n xs = b :: (lset (behead xs) (n.-1) a).
  intros.
  apply nth_error_eqP => i.
  rewrite nth_error_swap.
  rewrite nth_error_cons.
  rewrite nth_error_lset.
  rewrite nth_error_behead.
  rewrite -!nth_error_size_lt.
  rewrite H0 H1 //=.
  destruct i; rewrite //=.
  have -> : (i.+1 == n) = (n.-1 == i).
  apply Bool.eq_true_iff_eq; split.
  move/eqP => <-.
  rewrite //= eq_refl //=.
  move/eqP => <-.
  destruct n.
  rewrite //=.
  rewrite //= eq_refl //=.
  done.
  rewrite size_behead.
  destruct n; destruct xs; simpl in *.
  done.
  done.
  done.
  rewrite -nth_error_size_lt H1 //=.
Qed.

Lemma swapSS {A} (xs : seq A) x n m :
  swap n.+1 m.+1 (x :: xs) = x :: swap n m xs.
  rewrite /swap //=.
  destruct (List.nth_error xs n); rewrite //=.
  destruct (List.nth_error xs m); rewrite //=.
  rewrite !lset_Sn_cons //=.
Qed.

Lemma ltn_pred_pred x y :
  y > 1 ->
  x < y ->
  x.-1 < y.-1.
  destruct x; destruct y; rewrite //=.
Qed.

Lemma size_swap {A} a b (rs : seq A) :
  size (swap a b rs) = size rs.
  rewrite /swap.
  case h0 : (List.nth_error rs a).
  case h1 : (List.nth_error rs b).
  rewrite size_lset.
  rewrite size_lset //=.
  rewrite -nth_error_size_lt h0 //=.
  rewrite size_lset.
  rewrite -nth_error_size_lt h1 //=.
  rewrite -nth_error_size_lt h0 //=.
  done.
  done.
Qed.

Lemma nth_to_head {A} (x : A) n rs:
  List.nth_error rs n = Some x ->
  Permutation rs (x :: remove rs n).
  move: n; induction rs.
  intros.
  destruct n; done.
  intros.
  destruct n.
  simpl in *.
  inversion H; subst.
  done.
  simpl in *.
  symmetry.
  rewrite perm_swap.
  apply perm_skip.
  symmetry; apply IHrs.
  done.
Qed.

Lemma nth_to_head2 {A} (x y : A) n1 n2 rs :
  n1 != n2 ->
  List.nth_error rs n1 = Some x ->
  List.nth_error (remove rs n1) n2.-1 = Some y ->
  Permutation rs (x :: y :: remove (remove rs n1) n2.-1).
  intros.
  etransitivity.
  apply (nth_to_head x n1 rs).
  done.
  apply perm_skip.
  etransitivity.
  apply (nth_to_head y n2.-1).
  done.
  apply perm_skip.
  done.
Qed.

Require Import Setoid Relation_Definitions Morphisms.
Close Scope bool_scope.

#[export]
Instance cat_Proper t : Proper (@Permutation t ==> @Permutation t ==> @Permutation t) cat.
  move => x y z a b c.
  rewrite z c //=.
Qed.

Lemma cons_catE {t} (x : t) xs :
  x :: xs = [:: x] ++ xs.
  by done.
Qed.

Ltac find_in_rec x xs n :=
  match xs with
  | nil => n
  | (?x' :: ?xs') =>
    let a := eval simpl in x' in
    let b := eval simpl in x in
    match a with
      | b => n
      | _ => find_in_rec x xs' (S n) end end.
Ltac find_in x xs := find_in_rec x xs 0.

Ltac perm_match_step :=
  match goal with
    | |- Permutation ?xs (?y :: ?ys) =>
        let n := find_in y xs in
        setoid_rewrite (Perm_swap 0 n) at 1; rewrite /swap /lset //=;
        apply perm_skip end.

Ltac perm_match :=
  match goal with
  | |- Permutation nil nil => done
  | |- Permutation ?xs (?y :: ?ys) =>
    let n := find_in y xs in
    setoid_rewrite (Perm_swap 0 n) at 1; rewrite /swap /lset //=;
    apply perm_skip; perm_match end.

Ltac perm_tac := cat_perm_tac; perm_match.

Ltac perm_tac' xs :=
  match xs with
    | nil => perm_tac
    | ?x :: ?xs' => setoid_rewrite (cons_catE x) at 1; setoid_rewrite (cons_catE x) at 3; perm_tac' xs' end.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Bool.
Require Import Sumbool.
Require Import Arith.
Require Import BinPos.
Require Import BinNat.
Require Import Pnat.
Require Import Nnat.
Require Import Ndigits.

(** A boolean equality over [N] *)

Notation Peqb := Peqb (only parsing). (* Now in [BinPos] *)
Notation Neqb := Neqb (only parsing). (* Now in [BinNat] *)

Notation Peqb_correct := Peqb_refl (only parsing).

Lemma Peqb_complete : forall p p', Peqb p p' = true -> p = p'.
Proof.
  intros. now apply (Peqb_eq p p').
Qed.

Lemma Peqb_Pcompare : forall p p', Peqb p p' = true -> Pcompare p p' Eq = Eq.
Proof.
  intros. now rewrite Pcompare_eq_iff, <- Peqb_eq.
Qed.

Lemma Pcompare_Peqb : forall p p', Pcompare p p' Eq = Eq -> Peqb p p' = true.
Proof.
  intros; now rewrite Peqb_eq, <- Pcompare_eq_iff.
Qed.

Lemma Neqb_correct : forall n, Neqb n n = true.
Proof.
  intros; now rewrite Neqb_eq.
Qed.

Lemma Neqb_Ncompare : forall n n', Neqb n n' = true -> Ncompare n n' = Eq.
Proof.
  intros; now rewrite Ncompare_eq_correct, <- Neqb_eq.
Qed.

Lemma Ncompare_Neqb : forall n n', Ncompare n n' = Eq -> Neqb n n' = true.
Proof.
  intros; now rewrite Neqb_eq, <- Ncompare_eq_correct.
Qed.

Lemma Neqb_complete : forall a a', Neqb a a' = true -> a = a'.
Proof.
  intros; now rewrite <- Neqb_eq.
Qed.

Lemma Neqb_comm : forall a a', Neqb a a' = Neqb a' a.
Proof.
  intros; apply eq_true_iff_eq. rewrite 2 Neqb_eq; auto with *.
Qed.

Lemma Nxor_eq_true :
 forall a a', Nxor a a' = N0 -> Neqb a a' = true.
Proof.
  intros. rewrite (Nxor_eq a a' H). apply Neqb_correct.
Qed.

Lemma Nxor_eq_false :
 forall a a' p, Nxor a a' = Npos p -> Neqb a a' = false.
Proof.
  intros. elim (sumbool_of_bool (Neqb a a')). intro H0.
  rewrite (Neqb_complete a a' H0) in H.
  rewrite (Nxor_nilpotent a') in H. discriminate H.
  trivial.
Qed.

Lemma Nodd_not_double :
 forall a,
   Nodd a -> forall a0, Neqb (Ndouble a0) a = false.
Proof.
  intros. elim (sumbool_of_bool (Neqb (Ndouble a0) a)). intro H0.
  rewrite <- (Neqb_complete _ _ H0) in H.
  unfold Nodd in H.
  rewrite (Ndouble_bit0 a0) in H. discriminate H.
  trivial.
Qed.

Lemma Nnot_div2_not_double :
 forall a a0,
   Neqb (Ndiv2 a) a0 = false -> Neqb a (Ndouble a0) = false.
Proof.
  intros. elim (sumbool_of_bool (Neqb (Ndouble a0) a)). intro H0.
  rewrite <- (Neqb_complete _ _ H0) in H. rewrite (Ndouble_div2 a0) in H.
  rewrite (Neqb_correct a0) in H. discriminate H.
  intro. rewrite Neqb_comm. assumption.
Qed.

Lemma Neven_not_double_plus_one :
 forall a,
   Neven a -> forall a0, Neqb (Ndouble_plus_one a0) a = false.
Proof.
  intros. elim (sumbool_of_bool (Neqb (Ndouble_plus_one a0) a)). intro H0.
  rewrite <- (Neqb_complete _ _ H0) in H.
  unfold Neven in H.
  rewrite (Ndouble_plus_one_bit0 a0) in H.
  discriminate H.
  trivial.
Qed.

Lemma Nnot_div2_not_double_plus_one :
 forall a a0,
   Neqb (Ndiv2 a) a0 = false -> Neqb (Ndouble_plus_one a0) a = false.
Proof.
  intros. elim (sumbool_of_bool (Neqb a (Ndouble_plus_one a0))). intro H0.
  rewrite (Neqb_complete _ _ H0) in H. rewrite (Ndouble_plus_one_div2 a0) in H.
  rewrite (Neqb_correct a0) in H. discriminate H.
  intro H0. rewrite Neqb_comm. assumption.
Qed.

Lemma Nbit0_neq :
 forall a a',
   Nbit0 a = false -> Nbit0 a' = true -> Neqb a a' = false.
Proof.
  intros. elim (sumbool_of_bool (Neqb a a')). intro H1.
  rewrite (Neqb_complete _ _ H1) in H.
  rewrite H in H0. discriminate H0.
  trivial.
Qed.

Lemma Ndiv2_eq :
 forall a a', Neqb a a' = true -> Neqb (Ndiv2 a) (Ndiv2 a') = true.
Proof.
  intros. cut (a = a'). intros. rewrite H0. apply Neqb_correct.
  apply Neqb_complete. exact H.
Qed.

Lemma Ndiv2_neq :
 forall a a',
   Neqb (Ndiv2 a) (Ndiv2 a') = false -> Neqb a a' = false.
Proof.
  intros. elim (sumbool_of_bool (Neqb a a')). intro H0.
  rewrite (Neqb_complete _ _ H0) in H.
  rewrite (Neqb_correct (Ndiv2 a')) in H. discriminate H.
  trivial.
Qed.

Lemma Ndiv2_bit_eq :
 forall a a',
   Nbit0 a = Nbit0 a' -> Ndiv2 a = Ndiv2 a' -> a = a'.
Proof.
  intros. apply Nbit_faithful. unfold eqf in |- *. destruct n.
  rewrite Nbit0_correct. rewrite Nbit0_correct. assumption.
  rewrite <- Ndiv2_correct. rewrite <- Ndiv2_correct.
  rewrite H0. reflexivity.
Qed.

Lemma Ndiv2_bit_neq :
 forall a a',
   Neqb a a' = false ->
   Nbit0 a = Nbit0 a' -> Neqb (Ndiv2 a) (Ndiv2 a') = false.
Proof.
  intros. elim (sumbool_of_bool (Neqb (Ndiv2 a) (Ndiv2 a'))). intro H1.
  rewrite (Ndiv2_bit_eq _ _ H0 (Neqb_complete _ _ H1)) in H.
  rewrite (Neqb_correct a') in H. discriminate H.
  trivial.
Qed.

Lemma Nneq_elim :
 forall a a',
   Neqb a a' = false ->
   Nbit0 a = negb (Nbit0 a') \/
   Neqb (Ndiv2 a) (Ndiv2 a') = false.
Proof.
  intros. cut (Nbit0 a = Nbit0 a' \/ Nbit0 a = negb (Nbit0 a')).
  intros. elim H0. intro. right. apply Ndiv2_bit_neq. assumption.
  assumption.
  intro. left. assumption.
  case (Nbit0 a); case (Nbit0 a'); auto.
Qed.

Lemma Ndouble_or_double_plus_un :
 forall a,
   {a0 : N | a = Ndouble a0} + {a1 : N | a = Ndouble_plus_one a1}.
Proof.
  intro. elim (sumbool_of_bool (Nbit0 a)). intro H. right. split with (Ndiv2 a).
  rewrite (Ndiv2_double_plus_one a H). reflexivity.
  intro H. left. split with (Ndiv2 a). rewrite (Ndiv2_double a H). reflexivity.
Qed.

(** A boolean order on [N] *)

Definition Nleb (a b:N) := leb (nat_of_N a) (nat_of_N b).

Lemma Nleb_Nle : forall a b, Nleb a b = true <-> Nle a b.
Proof.
 intros; unfold Nle; rewrite nat_of_Ncompare.
 unfold Nleb; apply leb_compare.
Qed.

Lemma Nleb_refl : forall a, Nleb a a = true.
Proof.
  intro. unfold Nleb in |- *. apply leb_correct. apply le_n.
Qed.

Lemma Nleb_antisym :
 forall a b, Nleb a b = true -> Nleb b a = true -> a = b.
Proof.
  unfold Nleb in |- *. intros. rewrite <- (N_of_nat_of_N a). rewrite <- (N_of_nat_of_N b).
  rewrite (le_antisym _ _ (leb_complete _ _ H) (leb_complete _ _ H0)). reflexivity.
Qed.

Lemma Nleb_trans :
 forall a b c, Nleb a b = true -> Nleb b c = true -> Nleb a c = true.
Proof.
  unfold Nleb in |- *. intros. apply leb_correct. apply le_trans with (m := nat_of_N b).
  apply leb_complete. assumption.
  apply leb_complete. assumption.
Qed.

Lemma Nleb_ltb_trans :
 forall a b c,
   Nleb a b = true -> Nleb c b = false -> Nleb c a = false.
Proof.
  unfold Nleb in |- *. intros. apply leb_correct_conv. apply le_lt_trans with (m := nat_of_N b).
  apply leb_complete. assumption.
  apply leb_complete_conv. assumption.
Qed.

Lemma Nltb_leb_trans :
 forall a b c,
   Nleb b a = false -> Nleb b c = true -> Nleb c a = false.
Proof.
  unfold Nleb in |- *. intros. apply leb_correct_conv. apply lt_le_trans with (m := nat_of_N b).
  apply leb_complete_conv. assumption.
  apply leb_complete. assumption.
Qed.

Lemma Nltb_trans :
 forall a b c,
   Nleb b a = false -> Nleb c b = false -> Nleb c a = false.
Proof.
  unfold Nleb in |- *. intros. apply leb_correct_conv. apply lt_trans with (m := nat_of_N b).
  apply leb_complete_conv. assumption.
  apply leb_complete_conv. assumption.
Qed.

Lemma Nltb_leb_weak : forall a b:N, Nleb b a = false -> Nleb a b = true.
Proof.
  unfold Nleb in |- *. intros. apply leb_correct. apply lt_le_weak.
  apply leb_complete_conv. assumption.
Qed.

Lemma Nleb_double_mono :
 forall a b,
   Nleb a b = true -> Nleb (Ndouble a) (Ndouble b) = true.
Proof.
  unfold Nleb in |- *. intros. rewrite nat_of_Ndouble. rewrite nat_of_Ndouble. apply leb_correct.
  simpl in |- *. apply plus_le_compat. apply leb_complete. assumption.
  apply plus_le_compat. apply leb_complete. assumption.
  apply le_n.
Qed.

Lemma Nleb_double_plus_one_mono :
 forall a b,
   Nleb a b = true ->
   Nleb (Ndouble_plus_one a) (Ndouble_plus_one b) = true.
Proof.
  unfold Nleb in |- *. intros. rewrite nat_of_Ndouble_plus_one. rewrite nat_of_Ndouble_plus_one.
  apply leb_correct. apply le_n_S. simpl in |- *. apply plus_le_compat. apply leb_complete.
  assumption.
  apply plus_le_compat. apply leb_complete. assumption.
  apply le_n.
Qed.

Lemma Nleb_double_mono_conv :
 forall a b,
   Nleb (Ndouble a) (Ndouble b) = true -> Nleb a b = true.
Proof.
  unfold Nleb in |- *. intros a b. rewrite nat_of_Ndouble. rewrite nat_of_Ndouble. intro.
  apply leb_correct. apply (mult_S_le_reg_l 1). apply leb_complete. assumption.
Qed.

Lemma Nleb_double_plus_one_mono_conv :
 forall a b,
   Nleb (Ndouble_plus_one a) (Ndouble_plus_one b) = true ->
   Nleb a b = true.
Proof.
  unfold Nleb in |- *. intros a b. rewrite nat_of_Ndouble_plus_one. rewrite nat_of_Ndouble_plus_one.
  intro. apply leb_correct. apply (mult_S_le_reg_l 1). apply le_S_n. apply leb_complete.
  assumption.
Qed.

Lemma Nltb_double_mono :
 forall a b,
   Nleb a b = false -> Nleb (Ndouble a) (Ndouble b) = false.
Proof.
  intros. elim (sumbool_of_bool (Nleb (Ndouble a) (Ndouble b))). intro H0.
  rewrite (Nleb_double_mono_conv _ _ H0) in H. discriminate H.
  trivial.
Qed.

Lemma Nltb_double_plus_one_mono :
 forall a b,
   Nleb a b = false ->
   Nleb (Ndouble_plus_one a) (Ndouble_plus_one b) = false.
Proof.
  intros. elim (sumbool_of_bool (Nleb (Ndouble_plus_one a) (Ndouble_plus_one b))). intro H0.
  rewrite (Nleb_double_plus_one_mono_conv _ _ H0) in H. discriminate H.
  trivial.
Qed.

Lemma Nltb_double_mono_conv :
 forall a b,
   Nleb (Ndouble a) (Ndouble b) = false -> Nleb a b = false.
Proof.
  intros. elim (sumbool_of_bool (Nleb a b)). intro H0. rewrite (Nleb_double_mono _ _ H0) in H.
  discriminate H.
  trivial.
Qed.

Lemma Nltb_double_plus_one_mono_conv :
 forall a b,
   Nleb (Ndouble_plus_one a) (Ndouble_plus_one b) = false ->
   Nleb a b = false.
Proof.
  intros. elim (sumbool_of_bool (Nleb a b)). intro H0.
  rewrite (Nleb_double_plus_one_mono _ _ H0) in H. discriminate H.
  trivial.
Qed.

(* Nleb and Ncompare *)

(* NB: No need to prove that Nleb a b = true <-> Ncompare a b <> Gt,
   this statement is in fact Nleb_Nle! *)

Lemma Nltb_Ncompare : forall a b,
 Nleb a b = false <-> Ncompare a b = Gt.
Proof.
 intros.
 assert (IFF : forall x:bool, x = false <-> ~ x = true)
   by (destruct x; intuition).
 rewrite IFF, Nleb_Nle; unfold Nle.
 destruct (Ncompare a b); split; intro H; auto;
  elim H; discriminate.
Qed.

Lemma Ncompare_Gt_Nltb : forall a b,
 Ncompare a b = Gt -> Nleb a b = false.
Proof.
 intros; apply <- Nltb_Ncompare; auto.
Qed.

Lemma Ncompare_Lt_Nltb : forall a b,
 Ncompare a b = Lt -> Nleb b a = false.
Proof.
 intros a b H.
 rewrite Nltb_Ncompare, <- Ncompare_antisym, H; auto.
Qed.

(* An alternate [min] function over [N] *)

Definition Nmin' (a b:N) := if Nleb a b then a else b.

Lemma Nmin_Nmin' : forall a b, Nmin a b = Nmin' a b.
Proof.
 unfold Nmin, Nmin', Nleb; intros.
 rewrite nat_of_Ncompare.
 generalize (leb_compare (nat_of_N a) (nat_of_N b));
 destruct (nat_compare (nat_of_N a) (nat_of_N b));
 destruct (leb (nat_of_N a) (nat_of_N b)); intuition.
 lapply H1; intros; discriminate.
 lapply H1; intros; discriminate.
Qed.

Lemma Nmin_choice : forall a b, {Nmin a b = a} + {Nmin a b = b}.
Proof.
  unfold Nmin in *; intros; destruct (Ncompare a b); auto.
Qed.

Lemma Nmin_le_1 : forall a b, Nleb (Nmin a b) a = true.
Proof.
  intros; rewrite Nmin_Nmin'.
  unfold Nmin'; elim (sumbool_of_bool (Nleb a b)). intro H. rewrite H.
  apply Nleb_refl.
  intro H. rewrite H. apply Nltb_leb_weak. assumption.
Qed.

Lemma Nmin_le_2 : forall a b, Nleb (Nmin a b) b = true.
Proof.
  intros; rewrite Nmin_Nmin'.
  unfold Nmin'; elim (sumbool_of_bool (Nleb a b)). intro H. rewrite H. assumption.
  intro H. rewrite H. apply Nleb_refl.
Qed.

Lemma Nmin_le_3 :
 forall a b c, Nleb a (Nmin b c) = true -> Nleb a b = true.
Proof.
  intros; rewrite Nmin_Nmin' in *.
  unfold Nmin' in *; elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H.
  assumption.
  intro H0. rewrite H0 in H. apply Nltb_leb_weak. apply Nleb_ltb_trans with (b := c); assumption.
Qed.

Lemma Nmin_le_4 :
 forall a b c, Nleb a (Nmin b c) = true -> Nleb a c = true.
Proof.
  intros; rewrite Nmin_Nmin' in *.
  unfold Nmin' in *; elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H.
  apply Nleb_trans with (b := b); assumption.
  intro H0. rewrite H0 in H. assumption.
Qed.

Lemma Nmin_le_5 :
 forall a b c,
   Nleb a b = true -> Nleb a c = true -> Nleb a (Nmin b c) = true.
Proof.
  intros. elim (Nmin_choice b c). intro H1. rewrite H1. assumption.
  intro H1. rewrite H1. assumption.
Qed.

Lemma Nmin_lt_3 :
 forall a b c, Nleb (Nmin b c) a = false -> Nleb b a = false.
Proof.
  intros; rewrite Nmin_Nmin' in *.
  unfold Nmin' in *. intros. elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H.
  assumption.
  intro H0. rewrite H0 in H. apply Nltb_trans with (b := c); assumption.
Qed.

Lemma Nmin_lt_4 :
 forall a b c, Nleb (Nmin b c) a = false -> Nleb c a = false.
Proof.
  intros; rewrite Nmin_Nmin' in *.
  unfold Nmin' in *. elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H.
  apply Nltb_leb_trans with (b := b); assumption.
  intro H0. rewrite H0 in H. assumption.
Qed.