Require Import VST.floyd.proofauto.
Require Import VST.msl.iter_sepcon.
Require Import Lia. (* for lia tactic (nonlinear integer arithmetic) *)
Require Import malloc_lemmas. (* background *)
Require Import malloc_shares. (* for comp_Ews *)
Require Import spec_malloc.

(* this file has results that depend on the code and are used in its verification *)

Ltac start_function_hint ::= idtac. (* no hint reminder *)

Require Import malloc. (* the program *)

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

Local Open Scope Z.
Local Open Scope logic.

Ltac simple_if_tac' H :=
  match goal with |- context [if ?A then _ else _] =>
    lazymatch type of A with
    | bool => destruct A eqn: H
    | sumbool _ _ => fail "Use if_tac instead of simple_if_tac, since your expression "A" has type sumbool"
    | ?t => fail "Use simple_if_tac only for bool; your expression"A" has type" t
  end end.
Ltac simple_if_tac'' := let H := fresh in simple_if_tac' H.

(*+ mmlist *)

Lemma mmlist_local_facts:
  forall sz len p r,
   mmlist sz len p r |--
   !! (0 <= sz <= Ptrofs.max_unsigned /\
        is_pointer_or_null p /\ is_pointer_or_null r /\ (p = r <-> len=O)).
Proof.
  intros; generalize dependent p; induction len.
  - (* len 0 *)
    destruct p; try contradiction; simpl; entailer!;
    try (split; intro; reflexivity).
  - (* len > 0 *)
    intros p; unfold mmlist; fold mmlist.
    Intro q. specialize (IHlen q); entailer.
    sep_apply IHlen; entailer.
    assert (p = r <-> S len = 0%nat) by
        (split; intro; try contradiction; try omega).
    entailer.
Qed.
Hint Resolve mmlist_local_facts : saturate_local.

Lemma mmlist_ne_valid_pointer:
  forall sz len p r,  (len > 0)%nat ->
   mmlist sz len p r |-- valid_pointer p.
Proof.
  destruct len; unfold mmlist; fold mmlist; intros; normalize.
  omega.  auto with valid_pointer.
Qed.
Hint Resolve mmlist_ne_valid_pointer : valid_pointer.

Lemma mmlist_ne_len:
  forall sz len p q, p<>q ->
    mmlist sz (Z.to_nat len) p q |-- !! (len > 0).
Proof.
  intros. destruct len.
  simpl; normalize. entailer!; omega. simpl. entailer!.
Qed.

Lemma mmlist_ne_nonnull:
  forall sz len p, (len > 0)%nat ->
    mmlist sz len p nullval |-- !! (p <> nullval).
Proof.
  intros. destruct len. inversion H. unfold mmlist; fold mmlist. entailer.
Qed.

(* The following is formulated as an equality so it can be used in
both directions.  It's written using Nat.pred instead of len-1 because
Coq couldn't infer the type for len-1 in scripts that rely on this lemma.
(One workaround would involve replacing len by (Z.to_nat len).)

Note that by type of len, and mmlist_local_facts,
p <> nullval and (mmlist sz len p nullval) imply (Z.of_nat len) > 0,
so that antecedent is only needed for the RHS-to-LHS direction.
*)

Lemma mmlist_unroll_nonempty:
  forall sz len p r, (Z.of_nat len) > 0 ->
      mmlist sz len p r
  =   EX q:val,
      !!(malloc_compatible sz p /\ p <> r) &&
      data_at Tsh tuint (Vptrofs (Ptrofs.repr sz)) (offset_val (- WORD) p) *
      data_at Tsh (tptr tvoid) q p *
      memory_block Tsh (sz - WORD) (offset_val WORD p) *
      mmlist sz (Nat.pred len) q r.
Proof.
  intros. apply pred_ext.
  - (* LHS |-- RHS *)
    destruct len. elimtype False; simpl in *; omega.
    simpl. Intros q; Exists q. entailer.
  - (* RHS |-- LHS *)
    Intros q. destruct len. elimtype False; simpl in *; omega.
    simpl. Exists q. entailer!.
Qed.

Lemma mmlist_empty:
  forall sz, 0 < sz <= bin2sizeZ(BINS - 1) ->
             mmlist sz 0 nullval nullval = emp.
Proof.
  intros. apply pred_ext; simpl; entailer!.
Qed.

(* lemmas on constructing an mmlist from a big block (used in fill_bin) *)

Lemma mmlist_fold_last:
(* Adding tail chunk.
Formulated in the manner of lseg_app' in vst/progs/verif_append2.v.
The preserved chunk is just an idiom for list segments, because we have
seg p q * q|->r * r|-> s entails seg p r * r|-> s
but not
seg p q * q|->r entails seg p r (owing to potential cycle)

This lemma is for folding at the end, in the non-null case, so the
length of the preserved chunk can be assumed to be at least s+WORD. *)
  forall s n r q m,  malloc_compatible s (offset_val WORD q) ->
                WORD < m -> m - WORD <= Ptrofs.max_unsigned ->
                s <= bin2sizeZ(BINS-1) ->
  mmlist s n r (offset_val WORD q) *
  data_at Tsh (tarray tuint 1) [(Vint (Int.repr s))] q *
  data_at Tsh (tptr tvoid) (offset_val (s+WORD+WORD) q) (offset_val WORD q) *
  memory_block Tsh (s - WORD) (offset_val (WORD + WORD) q) *
  memory_block Tsh m (offset_val (s + WORD) q) (* preserved *)
  |-- mmlist s (n+1) r (offset_val (s + WORD + WORD) q ) *
      memory_block Tsh m (offset_val (s + WORD) q). (* preserved *)
Proof.
(* By induction.  For the ind step, unroll at the start of the lists,
in both antecedent and consequent, in order to apply the ind hyp. *)
intros. generalize dependent r. induction n.
- intros. unfold mmlist; fold mmlist. rewrite Nat.add_1_r.
  assert_PROP( r = (offset_val WORD q)) by entailer!; subst.
  rewrite mmlist_unroll_nonempty; change (Nat.pred 1) with 0%nat;
    try (change 0 with (Z.of_nat 0); rewrite <- Nat2Z.inj_gt; omega).
  Exists (offset_val (s + WORD + WORD) q).
  unfold mmlist; fold mmlist.
  replace ((offset_val (- WORD) (offset_val WORD q))) with q
    by (normalize; rewrite isptr_offset_val_zero; auto; try mcoi_tac).

  assert_PROP(offset_val WORD q <> offset_val (s + WORD + WORD) q).
  { (* use memory_block_conflict to prove this disequality *)
    (* similar to Andrew's proof steps in induction case below *)
    apply not_prop_right; intro; subst.
    simpl; normalize.
    replace m with (WORD + (m-WORD)) by omega.
    rewrite memory_block_split_offset; normalize; try rep_omega.
    match goal with | |- context[data_at ?sh (tptr tvoid) ?Vs ?op] =>
                  sep_apply (data_at_memory_block sh (tptr tvoid) Vs op) end.
    match goal with | HA: offset_val _ _ = offset_val _ _ |- _ => rewrite <- HA end.
    normalize.
    match goal with | |- context[
                      memory_block ?sh1 ?sz1 (offset_val WORD q) * (_ * (_ * (_ *
                      memory_block ?sh2 ?sz2 (offset_val WORD q) )))] =>
        sep_apply (memory_block_conflict sh1 sz1 sz2 (offset_val WORD q)) end.
    apply top_share_nonunit; try rep_omega.
    split.
    change (sizeof(tptr tvoid)) with WORD; rep_omega.
    change (sizeof(tptr tvoid)) with WORD; rep_omega.
    simpl; rep_omega.
    entailer!.
  }
  erewrite data_at_singleton_array_eq; try reflexivity.  entailer!. cancel.
- intros. rewrite Nat.add_1_r.
  rewrite (mmlist_unroll_nonempty s (S(S n)));
    try auto; try (change 0 with (Z.of_nat 0); rewrite <- Nat2Z.inj_gt; omega).
  rewrite (mmlist_unroll_nonempty s (S n));
    try auto; try (change 0 with (Z.of_nat 0); rewrite <- Nat2Z.inj_gt; omega).
  Intro p; Exists p.
  assert_PROP (r <> (offset_val (s+WORD+WORD) q)).
  { (* use memory_block_conflict to prove this disequality *)
    replace m with (WORD+(m-WORD)) by omega.
    destruct q; auto; try entailer.
    replace (offset_val (s + WORD) (Vptr b i))
      with (Vptr b (Ptrofs.add (Ptrofs.repr (s+WORD)) i))
      by (simpl; f_equal; rewrite Ptrofs.add_commut; reflexivity).
    rewrite memory_block_split_repr; try rep_omega.
    2: { split; try rep_omega.
         unfold size_compatible' in *; simpl in *;
         rewrite Ptrofs.add_commut; rep_omega.
    }
    replace (Ptrofs.add (Ptrofs.add (Ptrofs.repr (s + WORD)) i) (Ptrofs.repr WORD))
      with (Ptrofs.add i (Ptrofs.repr (s + WORD + WORD)))
      by ( rewrite <- Ptrofs.add_commut; rewrite Ptrofs.add_assoc;
           rewrite (Ptrofs.add_commut i); rewrite <- Ptrofs.add_assoc; normalize).
    replace (offset_val (s + WORD + WORD) (Vptr b i))
      with (Vptr b (Ptrofs.add i (Ptrofs.repr (s + WORD + WORD))))
        by (simpl; reflexivity).
    clear IHn H2 H4 H5 H6 H7 H8 H9 H10 H12 H13 H14 H15 H16 H17.
    assert (m - WORD > 0) by omega.
    (* Andrew's heroic proof of the disequality: *)
    apply not_prop_right; intro; subst.
    simpl. normalize.
    replace (s + WORD + WORD + - WORD) with (s + WORD) by omega.
    rewrite <- !(Ptrofs.add_commut i).  (* rewrite at least once *)
    sep_apply (data_at_memory_block Tsh tuint (Vint (Int.repr s)) (Vptr b (Ptrofs.add i (Ptrofs.repr (s + WORD)))) ).
    change (sizeof tuint) with WORD.
    sep_apply (memory_block_conflict Tsh WORD WORD (Vptr b (Ptrofs.add i (Ptrofs.repr (s + WORD))))); try rep_omega.
    apply top_share_nonunit; try rep_omega.
    entailer!.
  }
  entailer.  (* avoid cancelling trailing block needed by IHn *)
  change (Nat.pred (S n)) with n; change (Nat.pred (S(S n))) with (S n).
  replace (S n) with (n+1)%nat by omega.
  specialize (IHn p).
  sep_apply IHn; entailer!.
Qed.

Lemma mmlist_app_null:
  forall s p r m n, mmlist s n p r * mmlist s m r nullval |-- mmlist s (m+n) p nullval.
Proof.
  intros. revert p. induction n.
  - intros. simpl. replace (m+0)%nat with m%nat by lia. entailer!.
  - intros. rewrite mmlist_unroll_nonempty; try lia.
    change (Nat.pred(S n)) with n.
    Intros q. sep_apply (IHn q).
    eapply derives_trans.
    2: { rewrite mmlist_unroll_nonempty. apply derives_refl. lia. }
    Exists q.
    replace (Nat.pred (m + S n)) with (m+n)%nat by lia.
    entailer!.
Qed.

(*+ mem_mgr *)

Lemma mem_mgr_split':
 forall b:Z, forall bins lens idxs,
     0 <= b < BINS -> Zlength bins = BINS -> Zlength lens = BINS ->
     idxs = map Z.of_nat (seq 0 (Z.to_nat BINS)) ->
 iter_sepcon mmlist' (sublist 0 b (zip3 lens bins idxs)) *
 iter_sepcon mmlist' (sublist (b+1) BINS (zip3 lens bins idxs)) *
 mmlist (bin2sizeZ b) (Znth b lens) (Znth b bins) nullval
  =
 iter_sepcon mmlist' (zip3 lens bins idxs).
Proof.
  intros.
  replace (mmlist (bin2sizeZ b) (Znth b lens) (Znth b bins) nullval)
     with (mmlist' ((Znth b lens), (Znth b bins), b)) by (unfold mmlist'; auto).
  assert (Hassoc:
      iter_sepcon mmlist' (sublist 0 b (zip3 lens bins idxs)) *
      iter_sepcon mmlist' (sublist (b + 1) BINS (zip3 lens bins idxs)) *
      mmlist' (Znth b lens, Znth b bins, b)
    =
      iter_sepcon mmlist' (sublist 0 b (zip3 lens bins idxs)) *
      mmlist' (Znth b lens, Znth b bins, b) *
      iter_sepcon mmlist' (sublist (b + 1) BINS (zip3 lens bins idxs)) )
    by ( apply pred_ext; entailer!).
  rewrite Hassoc; clear Hassoc.
  assert (Hidxs: Zlength idxs = BINS)
    by  (subst; rewrite Zlength_map; rewrite Zlength_correct;
         rewrite seq_length; try rep_omega).
  replace (Znth b lens, Znth b bins, b) with (Znth b (zip3 lens bins idxs)).
  replace BINS with (Zlength (zip3 lens bins idxs)).
  erewrite <- (iter_sepcon_split3 b _ mmlist'); auto.
  split.
  - omega.
  - rewrite Zlength_zip3; try rep_omega.
  - rewrite Zlength_zip3; try rep_omega.
  - rewrite Znth_zip3 by rep_omega. replace b with (Znth b idxs) at 6; auto.
    subst. rewrite Znth_map. unfold Znth. if_tac. omega.
    rewrite seq_nth. simpl. rep_omega. rep_omega.
    rewrite Zlength_correct. rewrite seq_length. rep_omega.
Qed.

Lemma mem_mgr_split_R:
 forall gv:globals, forall b:Z, forall rvec: resvec, 0 <= b < BINS ->
   mem_mgr_R gv rvec
 =
  EX bins: list val, EX idxs: list Z, EX lens: list nat,
    !! (Zlength bins = BINS /\ Zlength lens = BINS /\ Zlength idxs = BINS
        /\ lens = map Z.to_nat rvec
        /\ idxs = map Z.of_nat (seq 0 (Z.to_nat BINS))
        /\ no_neg rvec ) &&
  data_at Ews (tarray (tptr tvoid) BINS) bins (gv _bin) *
  iter_sepcon mmlist' (sublist 0 b (zip3 lens bins idxs)) *
  mmlist (bin2sizeZ b) (Znth b lens) (Znth b bins) nullval *
  iter_sepcon mmlist' (sublist (b+1) BINS (zip3 lens bins idxs)) *
  TT.
Proof.
  intros. apply pred_ext.
  - (* LHS -> RHS *)
    unfold mem_mgr. unfold mem_mgr_R.
    Intros bins idxs lens. Exists bins idxs lens. entailer!.
    rewrite <- (mem_mgr_split' b); try assumption.
    entailer!. reflexivity.
  - (* RHS -> LHS *)
    Intros bins idxs lens.
    unfold mem_mgr; unfold mem_mgr_R. Exists bins idxs lens.
    entailer!.
    set (idxs:=(map Z.of_nat (seq 0 (Z.to_nat BINS)))).

    set (lens:=(map Z.to_nat rvec)).

    replace (
        iter_sepcon mmlist' (sublist 0 b (zip3 lens bins idxs)) *
        mmlist (bin2sizeZ b) (Znth b lens) (Znth b bins) nullval *
        iter_sepcon mmlist' (sublist (b + 1) BINS (zip3 lens bins idxs)) )
      with (
          iter_sepcon mmlist' (sublist 0 b (zip3 lens bins idxs)) *
          iter_sepcon mmlist' (sublist (b + 1) BINS (zip3 lens bins idxs)) *
          mmlist (bin2sizeZ b) (Znth b lens) (Znth b bins) nullval )
      by (apply pred_ext; entailer!).
    rewrite (mem_mgr_split' b); try assumption.
    cancel.  auto.
Qed.

(*+ splitting/joining memory blocks +*)

Lemma memory_block_Ews_join:
forall (n : Z) (p : val),
  memory_block (comp Ews) n p * memory_block Ews n p = memory_block Tsh n p.
Proof.
  intros.
  rewrite (memory_block_share_join (comp Ews) Ews Tsh). reflexivity.
  apply sepalg.join_comm.
  replace comp with Share.comp by normalize.
  rewrite comp_Ews.
  apply join_Ews.
Qed.

(* The following results involve memory predicates that depend on compspecs *)

(* notes towards possibly subsuming lemmas:
- malloc_large uses malloc_large_chunk to split off size and waste parts.
- malloc_small uses to_malloc_token_and_block to change a bin chunk into token plus user chunk.
- free uses from_malloc_token_and_block to access the size, for both large
  and small chunks; the lemma also exposes nxt which is helpful for free_small
- free free_large_chunk to reassemble block to give to munmap; this includes
  the nxt field (could simplify by not exposing that in the first place).
- fill_bin uses memory_block_split_block to split off size, next, and remainder for a chunk, from a big block.
*)

Lemma memory_block_split_block:
(* Note: an equality but only used in this direction. *)
  forall s m q, WORD <= s -> s+WORD <= m -> malloc_compatible (m - WORD) (offset_val WORD q) ->
   align_compatible (tarray tuint 1) q ->
   memory_block Tsh m q |--
   data_at_ Tsh (tarray tuint 1) q * (*size*)
   data_at_ Tsh (tptr tvoid) (offset_val WORD q) * (*nxt*)
   memory_block Tsh (s - WORD) (offset_val (WORD+WORD) q) * (*rest of chunk*)
   memory_block Tsh (m-(s+WORD)) (offset_val (s+WORD) q). (*rest of large*)
Proof.
  intros s m q Hs Hm Hmcq Hacq.
  (* split antecedent memory block into right sized pieces *)
  replace m with (WORD + (m - WORD)) at 1 by omega.
  rewrite (memory_block_split_offset _ q WORD (m - WORD)) by rep_omega.
  replace (m - WORD) with (WORD + (m - (WORD+WORD))) by omega.
  rewrite (memory_block_split_offset
             _ (offset_val WORD q) WORD (m - (WORD+WORD))) by rep_omega.
  replace (offset_val WORD (offset_val WORD q)) with (offset_val (WORD+WORD) q) by normalize.
  replace (m - (WORD+WORD)) with ((s - WORD) + (m - (s+WORD))) by rep_omega.
  rewrite (memory_block_split_offset
             _ (offset_val (WORD+WORD) q) (s - WORD) (m - (s+WORD))) by rep_omega.
  (* rewrite into data_at_ *)
  normalize.
  change WORD with (sizeof (tarray tuint 1)) at 1.
  change WORD with (sizeof (tptr tvoid)) at 1.
  replace (WORD + WORD + (s - WORD)) with (s + WORD) by omega.
  entailer!.
  rewrite memory_block_data_at_.
  rewrite memory_block_data_at_.
  cancel.
  - (* field_compatible (offset_val WORD q) *)
    hnf. repeat split; auto.
    destruct q; try auto.
    eapply align_compatible_rec_by_value; try reflexivity. simpl in *.
    destruct Hmcq as [Halign Hbound].
    assert (H48: (4|natural_alignment)).
    { unfold natural_alignment; replace 8 with (2*4)%Z by omega.
      apply Z.divide_factor_r; auto. }
    eapply Z.divide_trans. apply H48. auto.
  - (* field_compatible q *)
    hnf. repeat split; auto.
Qed.

Lemma free_large_chunk:
  forall s p, WORD <= s <= Ptrofs.max_unsigned ->
  data_at Tsh tuint (Vint (Int.repr s)) (offset_val (- WORD) p) *
  data_at_ Tsh (tptr tvoid) p *
  memory_block Tsh (s - WORD) (offset_val WORD p) *
  memory_block Tsh WA (offset_val (- (WA + WORD)) p)
  |-- memory_block Tsh (s + WA + WORD) (offset_val (- (WA + WORD)) p) .
Proof.
  intros.
  assert_PROP(field_compatible (tptr tvoid) [] p ) by entailer.
  assert_PROP(field_compatible tuint [] (offset_val (- WORD) p)) by entailer.
  assert(Hsiz: sizeof (tptr tvoid) = WORD) by auto.
  rewrite <- memory_block_data_at_; auto.
  match goal with | |- context[data_at ?sh ?t ?Vs ?op] =>
                    sep_apply (data_at_data_at_ sh t Vs op) end.
  rewrite <- memory_block_data_at_; auto.
  change (sizeof tuint) with WORD.
  rewrite Hsiz; clear Hsiz.
  do 2 rewrite <- sepcon_assoc.
  replace (
      memory_block Tsh WORD (offset_val (- WORD) p) * memory_block Tsh WORD p *
      memory_block Tsh (s - WORD) (offset_val WORD p) *
      memory_block Tsh WA (offset_val (- (WA + WORD)) p)
    )with(
         memory_block Tsh WORD p *
         memory_block Tsh (s - WORD) (offset_val WORD p) *
         memory_block Tsh WORD (offset_val (- WORD) p) *
         memory_block Tsh WA (offset_val (- (WA + WORD)) p)
       ) by (apply pred_ext; entailer!);
    rewrite <- memory_block_split_offset; try rep_omega.
  replace (WORD+(s-WORD)) with s by omega;
    replace p with (offset_val WORD (offset_val (- WORD) p)) at 1 by normalize;
    replace(
        memory_block Tsh s (offset_val WORD (offset_val (- WORD) p)) *
        memory_block Tsh WORD (offset_val (- WORD) p)
      )with(
           memory_block Tsh WORD (offset_val (- WORD) p) *
           memory_block Tsh s (offset_val WORD (offset_val (- WORD) p))
         ) by (apply pred_ext; entailer!);
    rewrite <- (memory_block_split_offset _ (offset_val (- WORD) p)); try rep_omega.
  replace (offset_val (-WORD) p)
    with (offset_val WA (offset_val (-(WA+WORD)) p)) by normalize;
    replace (
        memory_block Tsh (WORD + s) (offset_val WA (offset_val (- (WA + WORD)) p)) *
        memory_block Tsh WA (offset_val (- (WA + WORD)) p)
      )with(
           memory_block Tsh WA (offset_val (- (WA + WORD)) p) *
           memory_block Tsh (WORD + s) (offset_val WA (offset_val (- (WA + WORD)) p))
         ) by (apply pred_ext; entailer!);
    rewrite <- memory_block_split_offset; try rep_omega.
  replace (WA+(WORD+s)) with (s+WA+WORD) by omega;
    entailer!.
Qed.

(* following only used L to R but this form enables simple rewrite *)
Lemma malloc_large_chunk:
  forall n p, 0 <= n -> n + WA + WORD <= Ptrofs.max_unsigned ->
         malloc_compatible (n + WA + WORD) p ->
  memory_block Tsh (n + WA + WORD) p
  =
  memory_block Tsh WA p *                      (* waste *)
  data_at_ Tsh tuint (offset_val WA p) *       (* size *)
  memory_block Tsh n (offset_val (WA+WORD) p). (* data *)
Proof.
  intros n p H H0 H1. destruct p; try normalize.
  apply pred_ext.
  - (* L to R where (p is Vptr b i) *)
    rewrite data_at__memory_block.
    normalize.
    entailer!.
    -- (* field_compatible *)
      hnf.
      assert (H4: Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr WA))
               = Ptrofs.unsigned i + WA ).
      { replace i with (Ptrofs.repr(Ptrofs.unsigned i)) at 1
          by (rewrite Ptrofs.repr_unsigned; reflexivity).
        rewrite ptrofs_add_repr.
        rewrite Ptrofs.unsigned_repr; try reflexivity.
        split.
        assert (0 <= Ptrofs.unsigned i) by apply Ptrofs.unsigned_range.
        rep_omega. unfold size_compatible' in *. rep_omega.
      }
      repeat split; auto.
      --- (* size *)
        simpl; simpl in H1.
        replace ( Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr WA)) )
          with ( Ptrofs.unsigned i + WA ).
        replace (Ptrofs.unsigned i + (n + WA + WORD))
          with (n + Ptrofs.unsigned i + WA + 4)
          in H1 by rep_omega.
        assert (0 + Ptrofs.unsigned i + WA + 4 <= n + Ptrofs.unsigned i + WA + 4)
          by (do 3 apply Z.add_le_mono_r; auto).
        rep_omega.
      --- (* align *)
        simpl.
        eapply align_compatible_rec_by_value; try reflexivity. simpl in *.
        rewrite H4.
        apply Z.divide_add_r.
        destruct H1 as [Hal ?].
        assert (H48: (4|natural_alignment)).
        { unfold natural_alignment; replace 8 with (2*4)%Z by omega.
          apply Z.divide_factor_r; auto. }
        eapply Z.divide_trans. apply H48. auto.
        rewrite WA_eq.
        apply Z.divide_refl.
    --
      replace (sizeof tuint) with WORD by normalize.
      change (sizeof tuint) with WORD.
      replace (n + WORD + WORD) with (WORD + (n + WORD)) by omega.
      erewrite (memory_block_split_offset _ _ WORD (n+WORD)); try rep_omega.
      replace (n+WORD) with (WORD+n) by omega.
      change (sizeof tuint) with WORD.
      erewrite memory_block_split_offset; try rep_omega.
      entailer!; rep_omega.

  - (* R to L *)
    rewrite data_at__memory_block; normalize.
    erewrite <- memory_block_split_offset; try rep_omega.
    replace (sizeof tuint) with WORD by normalize.
    erewrite <- memory_block_split_offset; try rep_omega.
    replace (WORD+WORD+n) with (n+WORD+WORD) by omega.
    cancel; rep_omega.
    change (sizeof tuint) with WORD; rep_omega.
Qed.

Lemma to_malloc_token'_and_block:
forall n p q s, 0 <= n <= bin2sizeZ(BINS-1) -> s = bin2sizeZ(size2binZ(n)) ->
     malloc_compatible s p ->
  ( data_at Tsh tuint (Vptrofs (Ptrofs.repr s)) (offset_val (- WORD) p) *
     ( data_at Tsh (tptr tvoid) q p *
     memory_block Tsh (s - WORD) (offset_val WORD p) )
|--  malloc_token' Ews n p * memory_block Ews n p).
Proof.
  intros n p q s Hn Hs Hmc.
  unfold malloc_token'.
  Exists s.
  unfold malloc_tok.
  if_tac.
  - (* small chunk *)
    entailer!.
    split.
    -- pose proof (claim1 n (proj2 Hn)). rep_omega.
    -- match goal with | HA: field_compatible _ _ _ |- _ =>
                         unfold field_compatible in H2;
                           destruct H2 as [? [? [? [? ?]]]] end.
       destruct p; auto; try (apply claim1; rep_omega).
    -- set (s:=(bin2sizeZ(size2binZ n))).
       sep_apply (data_at_memory_block Tsh (tptr tvoid) q p).
       simpl.
       rewrite <- memory_block_split_offset; try rep_omega.
       ---
       replace (WORD+(s-WORD)) with s by omega.
       rewrite sepcon_assoc.
       replace (
           memory_block Ews (s - n) (offset_val n p) *
           memory_block Ews n p)
         with (memory_block Ews s p).
       + rewrite memory_block_Ews_join. cancel.
       + rewrite sepcon_comm.
         rewrite <- memory_block_split_offset; try rep_omega.
         replace (n + (s - n)) with s by omega. reflexivity.
         destruct Hn; auto.
         subst s.
         assert (n <= bin2sizeZ (size2binZ n)) by (apply claim1; rep_omega).
         rep_omega.
       ---
       subst s.
       pose proof (size2bin_range n Hn) as Hn'.
       pose proof (bin2size_range (size2binZ n) Hn').
       rep_omega.
  - (* large chunk - contradicts antecedents *)
    exfalso.
    assert (size2binZ n < BINS) by (apply size2bin_range; omega).
    assert (size2binZ n <= BINS - 1 ) by omega.
    rewrite Hs in H.
    assert (bin2sizeZ (size2binZ n) <= bin2sizeZ (BINS-1)) by
        (apply bin2size_range; apply size2bin_range; rep_omega).
    rep_omega.
Qed.

Lemma from_malloc_token'_and_block:
forall n p, 0 <= n <= Ptrofs.max_unsigned - WORD ->
    (malloc_token' Ews n p * memory_block Ews n p)
  |--  (EX s:Z,
      !! ( n <= s /\ s + WA + WORD <= Ptrofs.max_unsigned /\
           malloc_compatible s p /\
           (s <= bin2sizeZ(BINS-1) -> s = bin2sizeZ(size2binZ(n))) /\
           (s > bin2sizeZ(BINS-1) -> s = n)) &&
      data_at Tsh tuint (Vptrofs (Ptrofs.repr s)) (offset_val (- WORD) p) * (* size *)
      data_at_ Tsh (tptr tvoid) p *                                         (* nxt *)
      memory_block Tsh (s - WORD) (offset_val WORD p) *                     (* data *)
      (if zle s (bin2sizeZ(BINS-1)) then emp                                (* waste *)
       else memory_block Tsh WA (offset_val (-(WA+WORD)) p))).
(* Note that part labelled data can itself be factored into the user-visible
part of size n - WORD and, for small chunks, waste of size s - n *)
Proof.
  intros.
  unfold malloc_token'.
  Intros s; Exists s.
  unfold malloc_tok.
  entailer!.
  assert (WORD <= s). {
    destruct H0 as [Hn Hns].
    pose proof (zle s (bin2sizeZ (BINS-1))) as Hsmall.
    destruct Hsmall as [Hsmall | Hsbig]; try rep_omega.
    match goal with | HA: s<=bin2sizeZ(BINS-1) -> _ |- _ => apply HA in Hsmall end.
    pose proof (bin2size_range (size2binZ n)); subst.
    pose proof (size2bin_range n); rep_omega.
  }
  replace
  (  memory_block (comp Ews) s p * memory_block Ews (s - n) (offset_val n p) *
     memory_block Ews n p )
    with ( memory_block (comp Ews) s p * (memory_block Ews n p *
                                          memory_block Ews (s - n) (offset_val n p)))
    by (apply pred_ext; entailer!).
  rewrite <- memory_block_split_offset; try rep_omega.
  replace (n+(s-n)) with s by rep_omega.
  rewrite memory_block_Ews_join.
  replace s with (WORD + (s-WORD)) at 1 by omega.
  rewrite memory_block_split_offset; try rep_omega.
  change WORD with (sizeof (tptr tvoid)) at 1.
  rewrite memory_block_data_at_.
  cancel.
  (* field_compatible *)
  hnf.  repeat split; auto.
  -- (* size_compatible *)
    destruct p; try auto.
    unfold size_compatible.
    match goal with | HA: malloc_compatible _ _ |- _ =>
                      unfold malloc_compatible in HA; destruct HA end.
    change (sizeof (tptr tvoid)) with WORD; rep_omega.
  -- (* align_compatible *)
    destruct p; try auto.
    unfold align_compatible.
    eapply align_compatible_rec_by_value; try reflexivity.
    simpl.
    match goal with | HA: malloc_compatible _ _ |- _ =>
                      unfold malloc_compatible in HA; destruct HA end.
    assert (H48: (4|natural_alignment)).
    { unfold natural_alignment; replace 8 with (2*4)%Z by omega.
      apply Z.divide_factor_r; auto. }
    eapply Z.divide_trans. apply H48. auto.
Qed.


Require Export Setoid Coq.Classes.Morphisms.
Require Export CSet Containers.SetDecide.
Require Import EqDec Computable Util AutoIndTac.
Require Export MapBasics.

Set Implicit Arguments.

Definition lookup_set X `{OrderedType X} Y `{OrderedType Y} (m:X -> Y) (s:set X) : set Y :=
  SetConstructs.map m s.

Lemma lookup_set_spec X `{OrderedType X} Y `{OrderedType Y} (m:X -> Y) s y `{Proper _ (_eq ==> _eq) m}
  : y ∈ lookup_set m s <-> exists x, x ∈ s /\ y === m x.
Proof.
  intros. unfold lookup_set. eapply SetConstructs.map_spec; eauto.
Qed.

Ltac rewrite_lookup_set dummy := match goal with
                                | [ H : context [ In _ (lookup_set ?f ?s) ] |- _ ] =>
                                  rewrite (@lookup_set_spec _ _ _ _ f s) in H
                                | [ |- context [ In _ (lookup_set ?f ?s) ]] =>
                                  rewrite (@lookup_set_spec _ _ _ _ f s)
                                end.
Ltac lset_tac := set_tac rewrite_lookup_set.

Lemma lookup_set_helper X `{OrderedType X} Y `{OrderedType Y} (m:X -> Y) s x `{Proper _ (_eq ==> _eq) m}
  : x ∈ s -> m x ∈ lookup_set m s.
Proof.
  intros. eapply SetConstructs.map_spec; eauto.
Qed.

Lemma lookup_set_incl X `{OrderedType X} Y `{OrderedType Y} s t (m:X -> Y) `{Proper _ (_eq ==> _eq) m}
  : s ⊆ t -> (lookup_set m s) ⊆ (lookup_set m t).
Proof.
  intros P I; hnf. intros Q.
  eapply lookup_set_spec in Q; [|now eauto].
  dcr. eapply lookup_set_spec; eauto.
Qed.

Lemma lookup_set_union X `{OrderedType X} Y `{OrderedType Y} s t (m:X -> Y) `{Proper _ (_eq ==> _eq) m}
  : (lookup_set m (s ∪ t)) [=] (lookup_set m s ∪ lookup_set m t).
Proof.
  intro. split; intros; lset_tac.
Qed.

Lemma lookup_set_minus_incl X `{OrderedType X} Y `{OrderedType Y}
      (s t:set X) (m:X -> Y) `{Proper _ (_eq ==> _eq) m}
  : lookup_set m s \ (lookup_set m t) ⊆ lookup_set m (s \ t).
Proof.
  lset_tac.
Qed.

Lemma lookup_set_minus_single_incl X `{OrderedType X} Y `{OrderedType Y}
      (s:set X) x (m:X -> Y) `{Proper _ (_eq ==> _eq) m}
  : lookup_set m s \ singleton (m x) ⊆ lookup_set m (s \ singleton x).
Proof.
  intros; hnf; intros.
  eapply lookup_set_minus_incl; eauto.
Qed.

Arguments lookup_set {X} {H} {Y} {H0} m s.

(*
Instance In_morph_Subset_flip (Y : Type) (H : OrderedType Y)
  : Proper (_eq ==> flip Subset ==> flip impl) In.
Proof.
  unfold Proper, respectful, flip, impl; intros.
  rewrite <- H1, H0. eauto.
Qed.

Instance In_morph_Subset_flip' (Y : Type) (H : OrderedType Y)
  : Proper (equiv ==> flip Subset ==> flip impl) In.
Proof.
  unfold Proper, respectful, flip, impl; intros.
  rewrite <- H1, H0. eauto.
Qed.
 *)

Lemma lookup_set_on_id {X} `{OrderedType X} (s t : set X)
  : s ⊆ t -> (lookup_set (fun x => x) s) ⊆ t.
Proof.
  lset_tac.
Qed.

Instance lookup_set_morphism {X} `{OrderedType X} {Y} `{OrderedType Y} {f:X->Y}
 `{Proper _ (_eq ==> _eq) f}
  : Proper (Subset ==> Subset) (lookup_set f).
Proof.
  unfold Proper, respectful, Subset; intros.
  lset_tac.
Qed.

Instance lookup_set_morphism_flip {X} `{OrderedType X} {Y} `{OrderedType Y} {f:X->Y}
 `{Proper _ (_eq ==> _eq) f}
  : Proper (flip Subset ==> flip Subset) (lookup_set f).
Proof.
  unfold Proper, respectful, flip, Subset; intros.
  lset_tac.
Qed.

Instance lookup_set_morphism_eq {X} `{OrderedType X} {Y} `{OrderedType Y} {f:X->Y}
 `{Proper _ (_eq ==> _eq) f}
  : Proper (Equal ==> Equal) (lookup_set f).
Proof.
  unfold Proper, respectful, Subset; intros ? ? A.
  eapply double_inclusion in A; dcr. lset_tac.
Qed.

Lemma lookup_set_singleton {X} `{OrderedType X} {Y} `{OrderedType Y} (f:X->Y)
  `{Proper _ (_eq ==> _eq) f} x
  : lookup_set f {{x}} [=] {{f x}}.
Proof.
  cset_tac.
Qed.

Lemma lookup_set_singleton' {X} `{OrderedType X} {Y} `{OrderedType Y} (f:X->Y)
  `{Proper _ (_eq ==> _eq) f} x
  : lookup_set f (singleton x) [=] singleton (f x).
Proof.
  lset_tac.
  - rewrite H4; eauto.
Qed.

Lemma lookup_set_single X `{OrderedType X} Y `{OrderedType Y} (ϱ:X->Y)
      `{Proper _ (_eq ==> _eq) ϱ} D D' v
: v ∈ D
  -> lookup_set ϱ D ⊆ D'
  -> {{ ϱ v }} ⊆ D'.
Proof.
  intros. rewrite <- H3. lset_tac.
Qed.

Lemma lookup_set_single' X `{OrderedType X} Y `{OrderedType Y} (ϱ:X->Y)
      `{Proper _ (_eq ==> _eq) ϱ} D D' v
: v ∈ D
  -> lookup_set ϱ D ⊆ D'
  -> singleton (ϱ v) ⊆ D'.
Proof.
  intros. rewrite <- H3. lset_tac.
Qed.

Lemma lookup_set_add X `{OrderedType X} Y `{OrderedType Y} x s (m:X -> Y) `{Proper _ (_eq ==> _eq) m}
: (lookup_set m {x; s}) [=] {m x; lookup_set m s}.
Proof.
  intro. lset_tac.
Qed.

Lemma lookup_set_empty X `{OrderedType X} Y `{OrderedType Y} (ϱ:X->Y)
      `{Proper _ (_eq ==> _eq) ϱ}
: lookup_set ϱ {} [=] {}.
Proof.
  unfold lookup_set. cset_tac.
Qed.

Hint Extern 20 (lookup_set ?ϱ {} [=] {}) => eapply lookup_set_empty; eauto.
Hint Extern 20 ({} [=] lookup_set ?ϱ {}) => symmetry; eapply lookup_set_empty; eauto.

Hint Extern 20 (lookup_set ?ϱ (singleton ?v) [=] singleton (?ϱ ?v)) => eapply lookup_set_singleton'; eauto.
Hint Extern 20 (singleton (?ϱ ?v) [=] lookup_set ?ϱ (singleton ?v)) => symmetry; eapply lookup_set_singleton'; eauto.

Lemma lookup_set_single_fact X `{OrderedType X} (x:X) ϱ `{Proper _ (_eq ==> _eq) ϱ}
  : singleton (ϱ x) ⊆ lookup_set ϱ {x}.
Proof.
  cset_tac.
Qed.

Lemma lookup_set_union_incl X `{OrderedType X} s t u ϱ `{Proper _ (_eq ==> _eq) ϱ}
  : u ⊆ lookup_set ϱ s ∪ lookup_set ϱ t
    -> u ⊆ lookup_set ϱ (s ∪ t).
Proof.
  rewrite lookup_set_union; eauto.
Qed.

(*  This hint Resolve will slow everything down by 100x *)
(* Hint Resolve lookup_set_union_incl. *)
Hint Immediate lookup_set_union_incl : cset.
Hint Resolve lookup_set_single_fact : cset.

Lemma map_incl X `{OrderedType X} Y `{OrderedType Y} D D' (f:X->Y)
      `{Proper _ (_eq ==> _eq) f}
  : D ⊆ D'
    -> map f D ⊆ map f D'.
Proof.
  intros; hnf; intros. cset_tac.
Qed.

Hint Resolve map_incl : cset.

Lemma map_incl_incl X `{OrderedType X} Y `{OrderedType Y} (f:X->Y)
      `{Proper _ (_eq ==> _eq) f} (s t:set X) (u: set Y)
  : map f s ⊆ u
    -> t ⊆ s
    -> map f t ⊆ u.
Proof.
  intros. rewrite map_incl; eauto.
Qed.

Hint Resolve map_incl_incl : cset.


Notation "f $ x" := (f x) (at level 89, right associativity, only parsing).
Definition compose {A B C} (g:B -> C) (f:A -> B) (x:A) : C := g (f x).
Infix "⊙" := compose (right associativity, at level 60).
Arguments compose {A B C} g f x /.

Definition uncurry {A B C} (f:A -> B -> C) (xy:A*B) : C :=
  let (x,y) := xy in f x y.

Definition Function (A:Type) (B:Type) := A -> B.


(************************************************************************)
(*  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 Export Rbase.
Comments "Lemmas used by the tactic Fourier".

Open Scope R_scope.

Lemma Rfourier_lt : forall x1 y1 a:R, x1 < y1 -> 0 < a -> a * x1 < a * y1.
intros; apply Rmult_lt_compat_l; assumption.
Qed.

Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1.
red in |- *.
intros.
case H; auto with real.
Qed.

Lemma Rfourier_lt_lt :
 forall x1 y1 x2 y2 a:R,
   x1 < y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
intros x1 y1 x2 y2 a H H0 H1; try assumption.
apply Rplus_lt_compat.
try exact H.
apply Rfourier_lt.
try exact H0.
try exact H1.
Qed.

Lemma Rfourier_lt_le :
 forall x1 y1 x2 y2 a:R,
   x1 < y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
intros x1 y1 x2 y2 a H H0 H1; try assumption.
case H0; intros.
apply Rplus_lt_compat.
try exact H.
apply Rfourier_lt; auto with real.
rewrite H2.
rewrite (Rplus_comm y1 (a * y2)).
rewrite (Rplus_comm x1 (a * y2)).
apply Rplus_lt_compat_l.
try exact H.
Qed.

Lemma Rfourier_le_lt :
 forall x1 y1 x2 y2 a:R,
   x1 <= y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
intros x1 y1 x2 y2 a H H0 H1; try assumption.
case H; intros.
apply Rfourier_lt_le; auto with real.
rewrite H2.
apply Rplus_lt_compat_l.
apply Rfourier_lt; auto with real.
Qed.

Lemma Rfourier_le_le :
 forall x1 y1 x2 y2 a:R,
   x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2.
intros x1 y1 x2 y2 a H H0 H1; try assumption.
case H0; intros.
red in |- *.
left; try assumption.
apply Rfourier_le_lt; auto with real.
rewrite H2.
case H; intros.
red in |- *.
left; try assumption.
rewrite (Rplus_comm x1 (a * y2)).
rewrite (Rplus_comm y1 (a * y2)).
apply Rplus_lt_compat_l.
try exact H3.
rewrite H3.
red in |- *.
right; try assumption.
auto with real.
Qed.

Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x.
intros x H; try assumption.
rewrite Rplus_comm.
apply Rle_lt_0_plus_1.
red in |- *; auto with real.
Qed.

Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y.
intros x y H H0; try assumption.
replace 0 with (x * 0).
apply Rmult_lt_compat_l; auto with real.
ring.
Qed.

Lemma Rlt_zero_1 : 0 < 1.
exact Rlt_0_1.
Qed.

Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x.
intros x H; try assumption.
case H; intros.
red in |- *.
left; try assumption.
apply Rlt_zero_pos_plus1; auto with real.
rewrite <- H0.
replace (1 + 0) with 1.
red in |- *; left.
exact Rlt_zero_1.
ring.
Qed.

Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y.
intros x y H H0; try assumption.
case H; intros.
red in |- *; left.
apply Rlt_mult_inv_pos; auto with real.
rewrite <- H1.
red in |- *; right; ring.
Qed.

Lemma Rle_zero_1 : 0 <= 1.
red in |- *; left.
exact Rlt_zero_1.
Qed.

Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d.
intros n d H; red in |- *; intros H0; try exact H0.
generalize (Rgt_not_le 0 (n * / d)).
intros H1; elim H1; try assumption.
replace (n * / d) with (- - (n * / d)).
replace 0 with (- -0).
replace (- (n * / d)) with (- n * / d).
replace (-0) with 0.
red in |- *.
apply Ropp_gt_lt_contravar.
red in |- *.
exact H0.
ring.
ring.
ring.
ring.
Qed.

Lemma Rnot_lt0 : forall x:R, ~ 0 < 0 * x.
intros x; try assumption.
replace (0 * x) with 0.
apply Rlt_irrefl.
ring.
Qed.

Lemma Rlt_not_le_frac_opp : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d.
intros n d H; try assumption.
apply Rgt_not_le.
replace 0 with (-0).
replace (- n * / d) with (- (n * / d)).
apply Ropp_lt_gt_contravar.
try exact H.
ring.
ring.
Qed.

Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y.
unfold not in |- *; intros.
apply H.
apply Rplus_lt_reg_r with x.
replace (x + 0) with x.
replace (x + (y - x)) with y.
try exact H0.
ring.
ring.
Qed.

Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y.
unfold not in |- *; intros.
apply H.
case H0; intros.
left.
apply Rplus_lt_reg_r with x.
replace (x + 0) with x.
replace (x + (y - x)) with y.
try exact H1.
ring.
ring.
right.
rewrite H1; ring.
Qed.

Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y.
unfold Rgt in |- *; intros; assumption.
Qed.

Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y.
intros x y; exact (Rge_le y x).
Qed.

Lemma Rfourier_eqLR_to_le : forall x y:R, x = y -> x <= y.
exact Req_le.
Qed.

Lemma Rfourier_eqRL_to_le : forall x y:R, y = x -> x <= y.
exact Req_le_sym.
Qed.

Lemma Rfourier_not_ge_lt : forall x y:R, (x >= y -> False) -> x < y.
exact Rnot_ge_lt.
Qed.

Lemma Rfourier_not_gt_le : forall x y:R, (x > y -> False) -> x <= y.
exact Rnot_gt_le.
Qed.

Lemma Rfourier_not_le_gt : forall x y:R, (x <= y -> False) -> x > y.
exact Rnot_le_lt.
Qed.

Lemma Rfourier_not_lt_ge : forall x y:R, (x < y -> False) -> x >= y.
exact Rnot_lt_ge.
Qed.


Require Export Declarative.Language.
Require Export List.
Require Export Program.Equality.

Export ListNotations.

Require Export Metalib.Metatheory.

Scheme sub_mut := Induction for usub       Sort Prop
  with  wf_mut := Induction for wf_context Sort Prop.

Notation "G ⊢ e : A" := (usub G e e A)
    (at level 65, e at next level, no associativity) : type_scope.
Notation "G ⊢ e1 <: e2 : A" := (usub G e1 e2 A)
    (at level 65, e1 at next level, e2 at next level, no associativity) : type_scope.

Notation "e1 ⟶ e2"  := (reduce  e1 e2)
    (at level 60, no associativity) : type_scope.
Notation "e1 ⋆⟶ e2" := (ereduce e1 e2)
    (at level 60, no associativity) : type_scope.
Notation "e1 ⟹ e2" := (dreduce e1 e2)
    (at level 60, no associativity) : type_scope.

Lemma dreduce_reduce : forall e1 e2,
    e1 ⟹ e2 -> e1 ⟶ e2.
Proof.
  intros. dependent induction H; eauto.
Qed.

Hint Resolve dreduce_reduce : core.

Declare Scope ctx_scope.
Delimit Scope ctx_scope with ctx.
Bind Scope ctx_scope with context.

Declare Scope expr_scope.
Delimit Scope expr_scope with exp.
Bind Scope expr_scope with expr.

Declare Scope eexpr_scope.
Delimit Scope eexpr_scope with eexp.
Bind Scope eexpr_scope with eexpr.

Notation "*"  := (e_kind k_star) : expr_scope.
Notation "'BOX'" := (e_kind k_box) : expr_scope.

Notation "` x" := (e_var_f x)
    (at level 0, x at level 0, no associativity): expr_scope.

Notation "G , x : A" := ((x, A) :: G)
    (left associativity, at level 62, x at level 0) : ctx_scope.

Notation "G1 ,, G2" := (app G2 G1)
    (left associativity, at level 62) : ctx_scope.

Notation "⊢ G" := (wf_context G)
    (no associativity, at level 65) : type_scope.

Notation "x : A ∈ G" := (binds x A G)
    (no associativity, A at next level, at level 65) : type_scope.

Notation "x # e" := (x `notin` fv_expr e)
    (no associativity, at level 65) : type_scope.

Notation "e < n > ^^ e' " := (open_expr_wrt_expr_rec n e' e)
    (at level 40, n at level 0, left associativity) : expr_scope.

Notation "e ^^ e'" := (open_expr_wrt_expr e e')
    (at level 40, left associativity) : expr_scope.

Notation "e ^` x" := (open_expr_wrt_expr e (e_var_f x))
    (at level 40, left associativity) : expr_scope.

Definition subst_ctx (e : expr) (x : exprvar) : context -> context :=
  map (subst_expr e x).

Notation "[ e1 / x ] e2" := (subst_expr e1 x e2)
    (at level 60, e1 at level 0,  x at level 0, right associativity) : expr_scope.
Notation "[ e // x ] ctx" := (subst_ctx e x ctx)
    (at level 60, e at level 0, x at level 0, right associativity) : ctx_scope.

Notation "e ⋆^^ e'" := (open_eexpr_wrt_eexpr e e')
    (at level 40, left associativity) : eexpr_scope.

Notation "e ⋆^` x" := (open_eexpr_wrt_eexpr e (ee_var_f x))
    (at level 40, left associativity) : eexpr_scope.

Notation "[ e1 ⋆/ x ] e2" := (subst_eexpr e1 x e2)
    (at level 60, e1 at level 0, x at level 0, right associativity) : eexpr_scope.

Notation "e ⋆ n ^^ e'" := (open_eexpr_wrt_eexpr_rec n e' e)
    (at level 40, n at level 0, left associativity) : eexpr_scope.

Open Scope ctx_scope.
Open Scope eexpr_scope.
Open Scope expr_scope.

Lemma binds__in_dom : forall t Γ x (A : t),
    x : A ∈ Γ -> x `in` dom Γ.
Proof.
  intros. induction Γ.
  - inversion H.
  - destruct a. destruct H.
    + inversion H. subst. simpl. auto.
    + simpl. auto.
Qed.

Lemma in_dom_insert : forall x Γ1 Γ2 (A : expr),
    x `in` dom (Γ1 , x : A ,, Γ2).
Proof.
  induction Γ2; intros.
  - simpl. auto.
  - destruct a. simpl. auto.
Qed.

Lemma binds_insert : forall Γ1 x (A : expr) Γ2,
   x : A ∈ Γ1 , x : A ,, Γ2.
Proof.
  induction Γ2; simpl.
  - auto.
  - destruct a. unfold binds. simpl. now right.
Qed.

Lemma binds_type_equal : forall Γ1 x A B Γ2,
    x : A ∈ Γ1 , x : B ,, Γ2 ->
    ⊢ Γ1 , x : B ,, Γ2 ->
    A = B.
Proof.
  unfold binds. intros. induction Γ2.
  - destruct H.
    + now inversion H.
    + inversion H0. subst.
      now apply binds__in_dom in H.
  - destruct a. destruct H.
    + inversion H. inversion H0. subst.
      now assert (x `in` dom (Γ1 , x : B ,, Γ2))
        by apply in_dom_insert.
    + inversion H0; auto.
Qed.

Lemma binds_type_not_equal : forall Γ1 x x' (A : expr) B C Γ2,
    x : A ∈ Γ1 , x' : B ,, Γ2 ->
    x' <> x ->
    x : A ∈ Γ1 , x' : C ,, Γ2.
Proof.
  intros.
  induction Γ2.
  - destruct H.
    + now inversion H.
    + auto.
  - destruct a. destruct H.
    + inversion H. subst. auto.
    + right. apply IHΓ2. assumption.
Qed.

Lemma binds_inversion : forall Γ x (A : expr),
    x : A ∈ Γ -> exists Γ1 Γ2, Γ = Γ1 , x : A ,, Γ2.
Proof.
  intros. induction Γ.
  - inversion H.
  - unfold binds in *. destruct a. destruct H.
    + inversion H. subst. exists Γ. exists []. reflexivity.
    + destruct IHΓ. assumption.
      destruct H0. subst.
      exists x0. exists (x1 , a : e). reflexivity.
Qed.

Lemma wf_uncons : forall Γ x A,
    ⊢ Γ, x : A -> ⊢ Γ.
Proof.
  intros. now inversion H.
Qed.

Hint Resolve wf_uncons : wf.

Theorem sub_ctx_wf : forall Γ e1 e2 A,
  Γ ⊢ e1 <: e2 : A -> ⊢ Γ.
Proof.
  intros.
  induction H; solve [assumption | pick fresh x; eauto with wf].
Qed.

Hint Resolve sub_ctx_wf : wf.

Lemma prefix_wf : forall Γ1 Γ2, ⊢ Γ1 ,, Γ2 -> ⊢ Γ1.
Proof.
  intros. induction Γ2.
  - assumption.
  - inversion H. auto.
Qed.

Hint Resolve prefix_wf : wf.

Lemma binds_consistent : forall Γ x A B,
    ⊢ Γ -> x : A ∈ Γ -> x : B ∈ Γ -> A = B.
Proof.
  intros.
  apply binds_inversion in H1 as [Γ1 [Γ2 E]]. subst.
  eapply binds_type_equal; eauto.
Qed.

Open Scope expr_scope.

Lemma wf_ctx_type_correct : forall Γ1 Γ2 x A,
  ⊢ Γ1 , x : A ,, Γ2 -> exists k, Γ1 ⊢ A : e_kind k.
Proof.
  induction Γ2; intros.
  - inversion H. now exists k.
  - inversion H. subst. now apply IHΓ2 with x.
Qed.

Lemma wf_ctx_type_correct_cons : forall Γ x A,
    ⊢ Γ, x : A -> exists k, Γ ⊢ A : e_kind k.
Proof.
  intros. eapply wf_ctx_type_correct.
  replace (Γ, x : A) with (Γ, x : A,, nil) in H by reflexivity.
  eassumption.
Qed.

Lemma var_in_ctx_weakening : forall Γ2 Γ1 Γ3 x (A : expr),
    x : A ∈ Γ1 ,, Γ3 ->
    x : A ∈ Γ1 ,, Γ2 ,, Γ3.
Proof.
  intros. apply binds_app_1 in H as [H | H].
  - auto.
  - rewrite <- app_assoc in *.
    now apply binds_app_3.
Qed.

Theorem fresh_open_rec : forall x e1 e2 n,
  x # e1 -> x # e2 -> x # e1 <n> ^^ e2.
Proof.
  intros x e1.
  induction e1; simpl; intros e2 n' Hfresh1 Hfresh2; eauto 4.
  - now destruct (n' == n).
Qed.

Corollary fresh_open : forall x e1 e2,
  x # e1 -> x # e2 -> x # e1 ^^ e2.
Proof.
  intros. now apply fresh_open_rec.
Qed.

Corollary fresh_open_var : forall x e y,
  x # e -> x <> y -> x # e ^` y.
Proof.
  intros. apply fresh_open; auto.
Qed.

Theorem fresh_close_rec : forall e1 e2 x n,
    x # e1 <n> ^^ e2 -> x # e1.
Proof.
  induction e1; intros; simpl in *; eauto 4.
Qed.

Theorem fresh_close : forall e1 e2 x,
    x # e1 ^^ e2 -> x # e1.
Proof.
  intros until x. apply fresh_close_rec.
Qed.

Hint Resolve fresh_open_var : fresh.
Hint Resolve fresh_close : fresh.

Fixpoint context_fresh (x : atom) (ctx : context) : Prop :=
  match ctx with
  | nil => True
  | ((pair y t) :: ctx') => x # t /\ context_fresh x ctx'
  end
.

Hint Unfold context_fresh : core.

Lemma ctx_app_cons_assoc : forall (Γ1 Γ2 : context) x A,
    Γ1 ,, Γ2 , x : A = Γ1 ,, (Γ2 , x : A).
Proof.
  easy.
Qed.

Hint Rewrite ctx_app_cons_assoc : assoc.

Lemma open_rec_eq_cancel : forall e e1 e2 m n,
    m <> n -> e <m> ^^ e1 <n> ^^ e2 = e <m> ^^ e1 ->
    e <n> ^^ e2 = e.
Proof.
  induction e; simpl; intros; auto 3;
    try solve
        [inversion H0 as [[Hinv1 Hinv2]];
         (apply IHe1 in Hinv1; apply IHe2 in Hinv2); (auto 2 || congruence)].
  - destruct (m == n).
    + destruct (n0 == n); congruence.
    + simpl in H0. destruct (n0 == n); easy.
  - inversion H0 as [[Hinv1]].
    apply IHe in Hinv1; (auto || congruence).
Qed.

Hint Resolve open_rec_eq_cancel : ln.

Lemma lc_open_eq : forall e,
    lc_expr e -> forall n e', e <n> ^^ e' = e.
Proof.
  intros e LC. induction LC; simpl; intros;
    try solve
        [ reflexivity
        | pick fresh x; rewrite IHLC;
          try erewrite open_rec_eq_cancel with (m := 0); eauto
        | now (rewrite IHLC1; rewrite IHLC2)].
Qed.

Lemma subst_open_rec_distr : forall e x v e' n,
    lc_expr v ->
    [v / x] e <n> ^^ e' = ([v / x] e) <n> ^^ ([v / x] e').
Proof.
  induction e; simpl; intros; auto;
    try solve [(rewrite IHe || rewrite IHe1, IHe2); auto].
  - destruct (n0 == n); auto.
  - destruct (x == x0). rewrite lc_open_eq; auto. auto.
Qed.

Lemma subst_open_distr : forall e x v e',
    lc_expr v ->
    [v / x] e ^^ e' = ([v / x] e) ^^ ([v / x] e').
Proof.
  intros. unfold open_expr_wrt_expr. now rewrite subst_open_rec_distr.
Qed.

Lemma subst_open_var_assoc : forall e x v y,
    y <> x -> lc_expr v ->
    ([v / x] e) ^` y = [v / x] e ^` y.
Proof.
  intros.
  assert ([v / x] e ^` y = ([v / x] e) ^^ ([v / x] `y))
    by now apply subst_open_distr.
  assert ([v / x] `y = `y) by (simpl; destruct (y == x); easy).
  now rewrite H2 in H1.
Qed.

Hint Rewrite subst_open_var_assoc : assoc.

Lemma fresh_subst_eq : forall e x e', x # e -> [e' / x] e = e.
Proof.
  induction e; simpl; intros;
    try solve [auto | (rewrite IHe || rewrite IHe1, IHe2); auto].
  - destruct (x == x0).
    + apply notin_singleton_1 in H. contradiction.
    + auto.
Qed.

Lemma open_subst_eq : forall e x v,
    x # e -> lc_expr v ->
    e ^^ v = [v / x] e ^` x.
Proof.
  intros.
  rewrite subst_open_distr. simpl.
  rewrite eq_dec_refl.
  rewrite fresh_subst_eq.
  all: easy.
Qed.

Lemma lc_subst : forall e v x,
    lc_expr e -> lc_expr v -> lc_expr ([v / x] e).
Proof.
  intros. induction H; simpl; auto.
  - destruct (x0 == x); auto.

  Ltac solve_inductive_case_with C :=
    pick fresh x' and apply C; auto; intros; rewrite subst_open_var_assoc; auto.

  - solve_inductive_case_with lc_e_abs.
  - solve_inductive_case_with lc_e_pi.
  - solve_inductive_case_with lc_e_all.
  - solve_inductive_case_with lc_e_bind.
  - solve_inductive_case_with lc_e_mu.
Qed.

Lemma lc_open_preserve : forall e e',
    (exists L, forall x, x `notin` L -> lc_expr (e ^` x)) ->
    lc_expr e' -> lc_expr (e ^^ e').
Proof.
  intros e e' [L H] H'.
  pick fresh x for (fv_expr e `union` L).
  assert (x # e) by auto.
  rewrite (open_subst_eq _ _ _ H0 H').
  apply lc_subst; auto.
Qed.

Fixpoint lc_ctx (c : context) : Prop :=
  match c with
  | nil => True
  | c', x : A => lc_expr A /\ lc_ctx c'
  end
.

Import Program.Tactics.

Ltac instantiate_cofinite_with H x :=
  match type of H with
  | forall x, x `notin` ?L -> _ =>
    let H1 := fresh "H" in
    assert (H1 : x `notin` L) by eauto;
    specialize (H x H1); clear H1
  end
.

Ltac instantiate_cofinites_with x :=
  repeat match goal with
  | H : forall x, x `notin` ?L -> _ |- _ =>
    instantiate_cofinite_with H x
  end
.

Ltac detect_fresh_var_and_do t :=
  match goal with
  | Fr : ?x `notin` ?L1 |- _ => t x
  | _ =>
    let x := fresh "x" in
    pick fresh x; t x
  end
.

Ltac instantiate_cofinites :=
  detect_fresh_var_and_do instantiate_cofinites_with.

Ltac instantiate_cofinite H :=
  let f x := instantiate_cofinite_with H x in
  detect_fresh_var_and_do f
.

Ltac pose_cofinite_with H x H' :=
  match type of H with
  | forall x, x `notin` ?L -> _ =>
    let Fr := fresh "Fr" in
    assert (Fr : x `notin` L) by eauto;
    pose proof (H x Fr) as H'; clear Fr
  end
.

Ltac pose_cofinite H H' :=
  let f x := pose_cofinite_with H x H' in
  detect_fresh_var_and_do f
.

Tactic Notation "pose" "cofinite" ident(H) :=
  let H' := fresh H in
  pose_cofinite H H'.

Tactic Notation "pose" "cofinite" ident(H) "as" ident(H') :=
  pose_cofinite H H'.

Lemma usub_lc : forall Γ e1 e2 A,
    Γ ⊢ e1 <: e2 : A -> lc_ctx Γ /\ lc_expr e1 /\ lc_expr e2 /\ lc_expr A.
Proof.
  Local Ltac solve_with_pairs_in_cofinites := instantiate_cofinites; destruct_pairs; auto.

  apply sub_mut with
      (P := fun c e1 e2 A (_ : c ⊢ e1 <: e2 : A) =>
        lc_ctx c /\ lc_expr e1 /\ lc_expr e2 /\ lc_expr A)
      (P0 := fun c (_ : ⊢ c) => lc_ctx c); simpl; intros; auto;
    try solve
        [repeat split;
         solve [ solve_with_pairs_in_cofinites
               | econstructor; intros; solve_with_pairs_in_cofinites]].

  - induction G. inversion b.
    destruct a, H. inversion w. subst. destruct b.
    + inversion H1. now subst.
    + simpl. destruct IHG as (lc_G & lc_x & lc_x' & lc_A); auto.
  - repeat split; destruct_pairs; auto.
    inversion H3. subst. eauto using lc_open_preserve.
Qed.

Lemma mono_lc : forall e,
    mono_type e -> lc_expr e.
Proof.
  intros. induction H; eauto.
Qed.

Ltac solve_basic_lc :=
  match goal with
  | H : _ ⊢ ?e <: _ : _ |- lc_expr ?e => apply usub_lc in H
  | H : _ ⊢ _ <: ?e : _ |- lc_expr ?e => apply usub_lc in H
  | H : _ ⊢ _ <: _ : ?e |- lc_expr ?e => apply usub_lc in H
  | H : forall x, x `notin` ?L -> _, x : ?A ⊢ _ <: _ : _ |- lc_expr ?A =>
    instantiate_cofinite H; apply usub_lc in H; simpl in H
  end; destruct_pairs; assumption
.

Hint Resolve mono_lc : core.

Hint Extern 1 (lc_expr _) => solve_basic_lc : core.

Lemma lc_abs_param_l : forall Γ A b1 e T,
    Γ ⊢ e_abs A b1 <: e : T -> lc_expr A.
Proof.
  intros. dependent induction H; eauto.
Qed.

Lemma lc_bind_param_l : forall Γ A b1 e T,
    Γ ⊢ e_bind A b1 <: e : T -> lc_expr A.
Proof.
  intros. dependent induction H; eauto.
Qed.

Lemma lc_abs_param_r : forall Γ A b2 e T,
    Γ ⊢ e <: e_abs A b2 : T -> lc_expr A.
Proof.
  intros. dependent induction H; eauto.
Qed.

Lemma lc_bind_param_r : forall Γ A b2 e T,
    Γ ⊢ e <: e_bind A b2 : T -> lc_expr A.
Proof.
  intros. dependent induction H; eauto.
Qed.

Lemma lc_castup_l : forall Γ A b e T,
    Γ ⊢ e_castup A b <: e : T -> lc_expr A /\ lc_expr b.
Proof.
  intros. dependent induction H; eauto.
Qed.

Lemma lc_castup_r : forall Γ e A b T,
    Γ ⊢ e <: e_castup A b : T -> lc_expr A /\ lc_expr b.
Proof.
  intros. dependent induction H; eauto.
Qed.

Ltac solve_more_lc :=
  match goal with
  | H : _ ⊢ e_abs ?A _ <: _ : _ |- lc_expr ?A => apply lc_abs_param_l in H
  | H : _ ⊢ _ <: e_abs ?A _ : _ |- lc_expr ?A => apply lc_abs_param_r in H
  | H : _ ⊢ e_bind ?A _ <: _ : _ |- lc_expr ?A => apply lc_bind_param_l in H
  | H : _ ⊢ _ <: e_bind ?A _ : _ |- lc_expr ?A => apply lc_bind_param_r in H
  | H : _ ⊢ e_castup ?A _ <: _ : _ |- lc_expr ?A => apply lc_castup_l in H
  | H : _ ⊢ _ <: e_castup ?A _ : _ |- lc_expr ?A => apply lc_castup_r in H
  | H : _ ⊢ e_castup _ ?b <: _ : _ |- lc_expr ?b => apply lc_castup_l in H
  | H : _ ⊢ _ <: e_castup _ ?b : _ |- lc_expr ?b => apply lc_castup_r in H
  end; destruct_conjs; assumption
.

Hint Extern 1 (lc_expr _) => solve_more_lc : core.

Lemma subst_mono : forall e x e',
    mono_type e -> mono_type e' -> mono_type ([e' / x] e).
Proof.
  intros.
  induction H; simpl; eauto.
  (* var *)
  - destruct (x0 == x); auto.
  - pick fresh x' and apply mono_pi.
    + assumption.
    + autorewrite with assoc; auto.
  - pick fresh x' and apply mono_lambda.
    + assumption.
    + autorewrite with assoc; auto.
  - pick fresh x' and apply mono_bind.
    + assumption.
    + autorewrite with assoc; auto.
  - pick fresh x' and apply mono_mu.
    + assumption.
    + autorewrite with assoc; auto.
Qed.

Hint Resolve subst_mono : core.

Ltac instantiate_trivial_equals := repeat
  match goal with
  | H : ?a ~= ?a -> _ |- _ => specialize (H JMeq_refl)
  | H : ?a  = ?a -> _ |- _ => specialize (H eq_refl)
  end
.

Lemma strengthen_cofinite : forall L' P L ,
    (forall x, x `notin` L -> P x) ->
    (forall x, x `notin` (L `union` L') -> P x).
Proof.
  intros. auto.
Qed.

(*
Adjusting the cofinite requirement in the hypothesis to
help 'eauto' inferring the often-omitted cofinite lists
*)
Ltac adjust_cofinites L' :=
  repeat
    match goal with
    | H : forall x, x `notin` ?L -> _ |- _ =>
      match L with
      | context [L'] => fail 1
      | _ =>
        let H' := fresh H in
        pose proof (strengthen_cofinite L' _ _ H) as H';
        simpl in H'; clear H
      end
    end
.

Ltac adjust_cofinites_for gather :=
  let L := gather in
  adjust_cofinites L.

(*
1. Using the '+' tactical to enable backtracking in case of fail on
   branches of one constructor
2. Putting s_forall in front of s_forall_l and s_forall_r,
   and omitting s_sub to prevent potential infinite loop, when
   try_constructors are put into a repeat match loop
*)
Ltac try_constructors :=
  eapply s_abs +
  eapply s_pi +
  eapply s_app +
  eapply s_bind +
  eapply s_mu +
  eapply s_castup +
  eapply s_castdn +
  eapply s_forall +
  eapply s_forall_l +
  eapply s_forall_r.

(*
Neither gather_atoms_with in Metalib, or gather_vars_with in TLC
allows `F` to be a tactic function.
*)
Ltac gather_atoms_with_tactic F :=
  let rec gather V :=
    match goal with
    | H: ?S |- _ =>
      let FH := F H in
      match V with
      | context [FH] => fail 1
      | _ => gather (FH `union` V)
      end
    | _ => V
    end in
  let L := gather empty in eval simpl in L.

Ltac apply_fresh_base_fixed H gather_vars atom_name :=
  let L := gather_vars in
  let L := beautify_fset L in
  pick fresh atom_name excluding L and apply H.

Ltac discharge_equality E :=
  try solve [inversion E]; subst; try (rewrite E in *; clear E).


(**
This example is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2015-2018 Sylvie Boldo
#<br />#
Copyright (C) 2015-2018 Guillaume Melquiond

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

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

From Flocq Require Import Core Bracket Round Operations Div Sqrt.

Section Compute.

Variable beta : radix.

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.

Variable prec : Z.
Hypothesis Hprec : (0 < prec)%Z.
Hypothesis fexp_prec :
  forall e, (e - prec <= fexp e)%Z.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Variable choice : bool -> Z -> location -> Z.
Hypothesis rnd_choice :
  forall x m l,
  inbetween_int m (Rabs x) l ->
  rnd x = cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l).

Lemma Rsgn_F2R :
  forall m e,
  Rlt_bool (F2R (Float beta m e)) 0 = Zlt_bool m 0.
Proof.
intros m e.
case Zlt_bool_spec ; intros H.
apply Rlt_bool_true.
now apply F2R_lt_0.
apply Rlt_bool_false.
now apply F2R_ge_0.
Qed.

Definition plus (x y : float beta) :=
  let (m, e) := Fplus x y in
  let s := Zlt_bool m 0 in
  let '(m', e', l) := truncate beta fexp (Z.abs m, e, loc_Exact) in
  Float beta (cond_Zopp s (choice s m' l)) e'.

Theorem plus_correct :
  forall x y : float beta,
  round beta fexp rnd (F2R x + F2R y) = F2R (plus x y).
Proof.
intros x y.
unfold plus.
rewrite <- F2R_plus.
destruct (Fplus x y) as [m e].
rewrite (round_trunc_sign_any_correct beta fexp rnd choice rnd_choice _ (Z.abs m) e loc_Exact).
3: now right.
destruct truncate as [[m' e'] l'].
apply (f_equal (fun s => F2R (Float beta (cond_Zopp s (choice s _ _)) _))).
apply Rsgn_F2R.
apply inbetween_Exact.
apply sym_eq, F2R_Zabs.
Qed.

Definition mult (x y : float beta) :=
  let (m, e) := Fmult x y in
  let s := Zlt_bool m 0 in
  let '(m', e', l) := truncate beta fexp (Z.abs m, e, loc_Exact) in
  Float beta (cond_Zopp s (choice s m' l)) e'.

Theorem mult_correct :
  forall x y : float beta,
  round beta fexp rnd (F2R x * F2R y) = F2R (mult x y).
Proof.
intros x y.
unfold mult.
rewrite <- F2R_mult.
destruct (Fmult x y) as [m e].
rewrite (round_trunc_sign_any_correct beta fexp rnd choice rnd_choice _ (Z.abs m) e loc_Exact).
3: now right.
destruct truncate as [[m' e'] l'].
apply (f_equal (fun s => F2R (Float beta (cond_Zopp s (choice s _ _)) _))).
apply Rsgn_F2R.
apply inbetween_Exact.
apply sym_eq, F2R_Zabs.
Qed.

Definition sqrt (x : float beta) :=
  if Zlt_bool 0 (Fnum x) then
    let '(m', e', l) := truncate beta fexp (Fsqrt fexp x) in
    Float beta (choice false m' l) e'
  else Float beta 0 0.

Theorem sqrt_correct :
  forall x : float beta,
  round beta fexp rnd (R_sqrt.sqrt (F2R x)) = F2R (sqrt x).
Proof.
intros x.
unfold sqrt.
case Zlt_bool_spec ; intros Hm.
generalize (Fsqrt_correct fexp x (F2R_gt_0 _ _ Hm)).
destruct Fsqrt as [[m' e'] l].
intros [Hs1 Hs2].
rewrite (round_trunc_sign_any_correct' beta fexp rnd choice rnd_choice _ m' e' l).
destruct truncate as [[m'' e''] l'].
now rewrite Rlt_bool_false by apply sqrt_ge_0.
now rewrite Rabs_pos_eq by apply sqrt_ge_0.
now left.
destruct (Req_dec (F2R x) 0) as [Hz|Hz].
rewrite Hz, sqrt_0, F2R_0.
now apply round_0.
unfold R_sqrt.sqrt.
destruct Rcase_abs as [H|H].
rewrite F2R_0.
now apply round_0.
destruct H as [H|H].
elim Rgt_not_le with (1 := H).
now apply F2R_le_0.
now elim Hz.
Qed.

Lemma Rsgn_div :
  forall x y : R,
  x <> 0%R -> y <> 0%R ->
  Rlt_bool (x / y) 0 = xorb (Rlt_bool x 0) (Rlt_bool y 0).
Proof.
intros x y Hx0 Hy0.
unfold Rdiv.
case (Rlt_bool_spec x) ; intros Hx ;
  case (Rlt_bool_spec y) ; intros Hy.
apply Rlt_bool_false.
rewrite <- Rmult_opp_opp.
apply Rlt_le, Rmult_lt_0_compat.
now apply Ropp_gt_lt_0_contravar.
apply Ropp_gt_lt_0_contravar.
now apply Rinv_lt_0_compat.
apply Rlt_bool_true.
apply Ropp_lt_cancel.
rewrite Ropp_0, <- Ropp_mult_distr_l_reverse.
apply Rmult_lt_0_compat.
now apply Ropp_gt_lt_0_contravar.
apply Rinv_0_lt_compat.
destruct Hy as [Hy|Hy].
easy.
now elim Hy0.
apply Rlt_bool_true.
apply Ropp_lt_cancel.
rewrite Ropp_0, <- Ropp_mult_distr_r_reverse.
apply Rmult_lt_0_compat.
destruct Hx as [Hx|Hx].
easy.
now elim Hx0.
apply Ropp_gt_lt_0_contravar.
now apply Rinv_lt_0_compat.
apply Rlt_bool_false.
apply Rlt_le, Rmult_lt_0_compat.
destruct Hx as [Hx|Hx].
easy.
now elim Hx0.
apply Rinv_0_lt_compat.
destruct Hy as [Hy|Hy].
easy.
now elim Hy0.
Qed.

Definition div (x y : float beta) :=
  if Zeq_bool (Fnum x) 0 then Float beta 0 0
  else
    let '(m, e, l) := truncate beta fexp (Fdiv fexp (Fabs x) (Fabs y)) in
    let s := xorb (Zlt_bool (Fnum x) 0) (Zlt_bool (Fnum y) 0) in
    Float beta (cond_Zopp s (choice s m l)) e.

Theorem div_correct :
  forall x y : float beta,
  F2R y <> 0%R ->
  round beta fexp rnd (F2R x / F2R y) = F2R (div x y).
Proof.
intros x y Hy.
unfold div.
case Zeq_bool_spec ; intros Hm.
  destruct x as [mx ex].
  simpl in Hm.
  rewrite Hm, 2!F2R_0.
  unfold Rdiv.
  rewrite Rmult_0_l.
  now apply round_0.
assert (0 < F2R (Fabs x))%R as Hx.
  destruct x as [mx ex].
  now apply F2R_gt_0, Z.abs_pos.
assert (0 < F2R (Fabs y))%R as Hy'.
  destruct y as [my ey].
  apply F2R_gt_0, Z.abs_pos.
  contradict Hy.
  rewrite Hy.
  apply F2R_0.
generalize (Fdiv_correct fexp _ _ Hx Hy').
destruct Fdiv as [[m e] l].
intros [Hs1 Hs2].
rewrite (round_trunc_sign_any_correct' beta fexp rnd choice rnd_choice _ m e l).
- destruct truncate as [[m' e'] l'].
  apply (f_equal (fun s => F2R (Float beta (cond_Zopp s (choice s _ _)) _))).
  rewrite Rsgn_div.
  apply f_equal2 ; apply Rsgn_F2R.
  contradict Hm.
  apply eq_0_F2R with (1 := Hm).
  exact Hy.
- unfold Rdiv.
  rewrite Rabs_mult, Rabs_Rinv by exact Hy.
  now rewrite <- 2!F2R_abs.
- left.
  rewrite <- cexp_abs.
  unfold Rdiv.
  rewrite Rabs_mult, Rabs_Rinv by exact Hy.
  now rewrite <- 2!F2R_abs.
Qed.

End Compute.


Require Import Coq.Sets.Ensembles.
Require Import Coq.Lists.List.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.Ensembles_ext.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.reachable_computable.
Require Import CertiGraph.graph.graph_gen.
Require Import CertiGraph.graph.FiniteGraph.
Require Import CertiGraph.graph.MathGraph.
Require Import CertiGraph.graph.LstGraph.
Require Import CertiGraph.graph.UnionFind.

Section UnionFindGraph.

  Context {V E: Type}.
  Context {VE: EqDec V eq}.
  Context {EE: EqDec E eq}.

  Context {isNullDec: DecidablePred V}.
  Context {out_edge: V -> E}.

  (* Context {ufg: UnionFindGraph}. *)

  Class LiMaFin (g: PreGraph V E) :=
    {
      li: LstGraph g out_edge;
      ma: MathGraph g isNullDec;
      fin: FiniteGraph g
    }.

  Context {DV DE DG: Type}.

  Definition LGraph := LabeledGraph V E DV DE DG.
  Definition UFGraph := (GeneralGraph V E DV DE DG (fun g => LiMaFin (pg_lg g))).

  Definition UFGraph_LGraph (G: UFGraph): LGraph := lg_gg G.

  Local Coercion UFGraph_LGraph: UFGraph >-> LGraph.
  Local Identity Coercion LGraph_LabeledGraph: LGraph >-> LabeledGraph.
  Local Coercion pg_lg: LabeledGraph >-> PreGraph.

  Instance maGraph(G: UFGraph): MathGraph G isNullDec := @ma G (@sound_gg _ _ _ _ _ _ _ _ G).
  Instance finGraph (G: UFGraph): FiniteGraph G := @fin G (@sound_gg _ _ _ _ _ _ _ _ G).
  Instance liGraph (G: UFGraph):  LstGraph G out_edge := @li G (@sound_gg _ _ _ _ _ _ _ _ G).

  (*Returns the rank (vlabel) and parent of a vertex
    Parent is: take (any?) dst x has an edge to.
                What is projT2 isNullDec?
                I suppose it means if the expr of target is valid
  *)
  Definition vgamma (g: LGraph) (x: V) : DV * V := (vlabel g x, let target := dst (pg_lg g) (out_edge x) in if (projT2 isNullDec target) then x else target).

  (*If v is in graph, and vgamma g v = some rank and parent, then the parent is also valid. *)
  Lemma valid_parent: forall (g: UFGraph) v n p, vvalid g v -> vgamma g v = (n, p) -> vvalid g p.
  Proof.
    intros. unfold vgamma in H0. simpl in H0. inversion H0. clear H0 H2. destruct (projT2 isNullDec (dst g (out_edge v))); auto.
    assert (~ isNullDec (dst g (out_edge v))) by (intro; apply n0; auto).
    pose proof (only_one_edge v (out_edge v) H). assert (out_edge v = out_edge v) by auto. rewrite <- H1 in H2. destruct H2.
    pose proof (valid_graph _ _ H4). destruct H5 as [_ [? | ?]]; auto. exfalso; auto.
  Qed.

  Lemma parent_loop: forall (g: UFGraph) v n y, vgamma g v = (n, v) -> reachable g v y -> v = y.
  Proof.
    intros. unfold vgamma in H. destruct (projT2 isNullDec (dst g (out_edge v))).
    - apply (lst_out_edge_only_one g _ v (dst g (out_edge v)) y); auto. intro. apply reachable_head_valid in H1. apply (valid_not_null g (dst g (out_edge v)) H1); auto.
    - apply (lst_self_loop _ (liGraph g)) in H0; auto. inversion H. rewrite H3. auto.
  Qed.

  Lemma gamma_parent_reachable_included: forall (g: UFGraph) x r pa, vvalid g x -> vgamma g x = (r, pa) -> Included (reachable g pa) (reachable g x).
  Proof.
    intros. intro y; intros. unfold vgamma in H0. destruct (projT2 isNullDec (dst g (out_edge x))).
    - inversion H0. auto.
    - apply edge_reachable_by with pa; auto. split; auto. split.
      + apply reachable_head_valid in H1; auto.
      + inversion H0. rewrite H4. rewrite (dst_step _ (liGraph g) _ _ H H4). auto.
  Qed.

  Lemma Prop_join_reachable_parent: forall (g: UFGraph) x r pa,
      vvalid g x -> vgamma g x = (r, pa) ->
      Prop_join
        (reachable g pa)
        (Intersection _ (reachable g x) (Complement V (reachable g pa)))
        (reachable g x).
  Proof.
    intros. apply Ensemble_join_Intersection_Complement.
    - eapply gamma_parent_reachable_included; eauto.
    - intros. apply decidable_prop_decidable. pose proof (finGraph g).
      apply (@reachable_decidable_prime _ _ _ _ _ _ (maGraph g)).
      + apply LocalFiniteGraph_FiniteGraph; auto.
      + apply (valid_parent _ x r); auto.
      + apply FiniteGraph_EnumCovered; auto.
  Qed.

  Definition Graph_gen_redirect_parent (g: UFGraph) (x: V) (pa: V) (H: weak_valid g pa) (Hv: vvalid g x) (Hn: ~ reachable g pa x): UFGraph.
  Proof.
    refine (generalgraph_gen_dst g (out_edge x) pa _). constructor.
    - simpl. apply (gen_dst_preserve_lst g (liGraph g)); auto.
    - apply (gen_dst_preserve_math g (out_edge x) pa (maGraph g) H).
    - apply (gen_dst_preserve_finite g (out_edge x) pa (finGraph g)).
  Defined.

  Lemma Graph_reachable_dec: forall (G: UFGraph) x, Decidable (vvalid G x) -> forall y, Decidable (reachable G x y).
  Proof.
    intros. apply reachable_decidable with (is_null := isNullDec); auto.
    + apply maGraph.
    + apply LocalFiniteGraph_FiniteGraph, finGraph.
    + apply FiniteGraph_EnumCovered, finGraph.
  Qed.

  Definition Graph_vgen (G: UFGraph) (x: V) (d: DV) : UFGraph := generalgraph_vgen G x d (sound_gg G).

  Lemma uf_root_vgamma: forall (g: UFGraph) v n, vvalid g v -> vgamma g v = (n, v) -> uf_root g v v.
  Proof. intros. split; [apply reachable_refl | intros; apply (parent_loop g _ n)]; auto. Qed.

  Lemma vgamma_not_dst: forall (g: UFGraph) x r pa, vgamma g x = (r, pa) -> pa <> x -> dst g (out_edge x) = pa.
  Proof. intros. unfold vgamma in H. destruct (projT2 isNullDec (dst g (out_edge x))); inversion H; [exfalso |]; auto. Qed.

  Lemma vgamma_not_edge: forall (g: UFGraph) x r pa, vvalid g x -> vgamma g x = (r, pa) -> pa <> x -> g |= x ~> pa.
  Proof.
    intros. assert (vvalid g pa) by (apply valid_parent in H0; auto). hnf. split; [|split]; auto.
    apply (vgamma_not_dst g x r) in H1; auto. rewrite step_spec. exists (out_edge x).
    pose proof (vvalid_src_evalid _ (liGraph g) _ H). destruct H3. split; auto.
  Qed.

  Lemma vgamma_not_reachable': forall (g: UFGraph) x r pa y, vvalid g x -> vgamma g x = (r, pa) -> pa <> x -> reachable g pa y -> ~ reachable g y x.
  Proof. intros. apply (dst_not_reachable _ (liGraph g) _ pa); auto. apply (vgamma_not_dst g x r); auto. Qed.

  Lemma vgamma_not_reachable: forall (g: UFGraph) x r pa, vvalid g x -> vgamma g x = (r, pa) -> pa <> x -> ~ reachable g pa x.
  Proof. intros. assert (vvalid g pa) by (apply valid_parent in H0; auto). apply (vgamma_not_reachable' g x r pa pa); auto. apply reachable_refl; auto. Qed.

  Lemma uf_root_not_eq_root_vgamma: forall (g: UFGraph) x r pa root, vgamma g x = (r, pa) -> uf_root g x root -> x <> root -> x <> pa.
  Proof.
    intros. unfold vgamma in H. destruct (projT2 isNullDec (dst g (out_edge x))).
    - destruct H0. apply reachable_ind.reachable_ind in H0. destruct H0. 1: exfalso; auto. destruct H0 as [z [[? [? ?]] [? ?]]]. rewrite step_spec in H4.
      destruct H4 as [ed [? [? ?]]]. pose proof (conj H7 H4). rewrite (@only_one_edge _ _ _ _ g _ (liGraph g)) in H9; auto. subst ed. rewrite H8 in p.
      exfalso. apply (@valid_not_null _ _ _ _ g _ (maGraph g)) in H3; auto.
    - inversion H. clear H H3. assert (vvalid g x) by (destruct H0; apply reachable_head_valid in H; auto).
      assert (g |= (x, (out_edge x) :: nil) is x ~o~> pa satisfying (fun _ => True)). {
        split; split; intros; hnf; simpl; auto. unfold strong_evalid. assert (out_edge x = out_edge x) by auto. rewrite <- (@only_one_edge _ _ _ _ g _ (liGraph g)) in H2; auto.
        destruct H2. split; [|split]; auto. rewrite H2. split; auto. apply (@valid_graph _ _ _ _ g _ (maGraph g)) in H3. destruct H3 as [_ [? | ?]]; auto.
        hnf in H3. exfalso; auto.
      } rewrite H4. intro. rewrite <- H3 in H2. apply (@no_loop_path _ _ _ _ g _ (liGraph g)) in H2. inversion H2.
  Qed.

  Lemma vgamma_uf_root: forall (g: UFGraph) x r pa root, vvalid g x -> vgamma g x = (r, pa) -> uf_root g x root -> x <> root -> uf_root g pa root.
  Proof.
    intros. pose proof (uf_root_not_eq_root_vgamma g _ _ _ _ H0 H1 H2). destruct H1. split; auto. pose proof (valid_parent g _ _ _ H H0).
    assert (Decidable (reachable g pa root)) by (apply Graph_reachable_dec; left; auto). apply decidable_prop_decidable in H6. destruct H6; auto. exfalso.
    pose proof (lst_out_edge_only_one g (liGraph g) x pa root). simpl in H7. apply H2. apply H7; auto. apply (vgamma_not_dst _ _ r); auto.
  Qed.

  Instance fml : FML_General V E DV DE DG LiMaFin out_edge isNullDec. Proof. constructor; intros; destruct X; auto. Defined.

  Global Existing Instance fml.

  Lemma findS_preserves_vgamma: forall (g1 g2: UFGraph) x r pa, vvalid g1 x -> vgamma g1 x = (r, pa) -> pa <> x -> findS g1 pa g2 -> vgamma g2 x = (r, pa).
  Proof.
    intros. assert (Hr: ~ reachable g1 pa x) by (apply vgamma_not_reachable with r; auto). unfold vgamma in *. destruct (projT2 isNullDec (dst g1 (out_edge x))).
    1: inversion H0; exfalso; auto. rewrite <- H0. destruct H2 as [? [[? ?] ?]]. f_equal.
    - assert (vvalid g2 x) by (rewrite <- H3; auto). specialize (H5 x H H6). unfold UFGraph_LGraph. rewrite H5. auto.
    - assert (evalid (predicate_partialgraph (lg_gg g1) (fun n : V => ~ reachable (lg_gg g1) pa n)) (out_edge x)). {
        simpl. hnf. pose proof (vvalid_src_evalid _ (liGraph g1) _ H). unfold UFGraph_LGraph in H6. destruct H6. rewrite H6. split; auto.
      } destruct H2 as [_ [? [_ ?]]]. pose proof H6. rewrite H2 in H8. clear H2. specialize (H7 _ H6 H8). simpl in H7. unfold UFGraph_LGraph. rewrite <- H7.
      destruct (projT2 isNullDec (dst (lg_gg g1) (out_edge x))); [exfalso |]; auto.
  Qed.

  Lemma the_same_root_union: forall (g g1 g2: UFGraph) x y root,
      vvalid g x -> vvalid g y -> uf_equiv g g1 -> uf_equiv g1 g2 -> uf_root g1 x root -> uf_root g2 y root -> uf_union g x y g2.
  Proof. intros. apply (same_root_union g g1 g2 x y root); auto. Qed.

  Lemma uf_equiv_root_the_same: forall (g1 g2: UFGraph) x root, uf_equiv g1 g2 -> uf_root g1 x root <-> uf_root g2 x root.
  Proof. intros. pose proof (@uf_equiv_the_same_root _ _ _ _ _ _ _ _ out_edge isNullDec fml g1 g2 x root H). apply H0. Qed.

  Lemma uf_equiv_not_reachable: forall (g1 g2: UFGraph) x r pa root,
      vvalid g1 x -> vgamma g1 x = (r, pa) -> pa <> x -> uf_equiv g1 g2 -> uf_root g2 pa root -> ~ reachable g2 root x.
  Proof.
    intros. pose proof H3. rewrite <- (uf_equiv_root_the_same _ _ pa root H2) in H4. destruct H3. intro. apply H5 in H6. subst x.
    pose proof (vgamma_not_reachable g1 root r pa H H0 H1). destruct H4. auto.
  Qed.

  Lemma graph_gen_redirect_parent_equiv': forall (g1 g2: UFGraph) x root,
      uf_equiv g1 g2 -> vvalid g2 x -> (~ reachable g2 root x) -> uf_root g2 x root -> uf_equiv g1 (pregraph_gen_dst g2 (out_edge x) root).
  Proof.
    intros. apply (@uf_equiv_trans _ _ _ _ g2 _ (liGraph g2) _ (maGraph g2) (finGraph g2)); auto. split; intro y; simpl; [intuition |]. intros.
    assert (Decidable (reachable g2 y x)) by (apply Graph_reachable_dec; left; destruct H3; apply reachable_head_valid in H3; auto).
    apply decidable_prop_decidable in H5. destruct H5.
    - pose proof (uf_root_gen_dst_same g2 (liGraph g2) _ _ _ H2 H1 H5). simpl in H6.
      pose proof (uf_root_unique _ (gen_dst_preserve_lst g2 (liGraph g2) _ _ H1 H0) _ _ _ H4 H6). subst r2.
      pose proof (uf_root_reachable _ _ _ _ H5 H2). apply (uf_root_unique g2 (liGraph g2) _ _ _ H3 H7).
    - apply (uf_root_unique _ (gen_dst_preserve_lst g2 (liGraph g2) _ _ H1 H0) y); auto. apply (uf_root_gen_dst_preserve g2 (liGraph g2)); auto.
  Qed.

  Lemma graph_gen_redirect_parent_equiv: forall (g1 g2: UFGraph) x r pa root (Hv: vvalid g2 x) (Hn: ~ reachable g2 root x),
      vvalid g1 x -> vgamma g1 x = (r, pa) -> pa <> x -> uf_equiv g1 g2 -> uf_root g2 pa root -> uf_equiv g1 (pregraph_gen_dst g2 (out_edge x) root).
  Proof.
    intros. apply graph_gen_redirect_parent_equiv'; auto. rewrite <- (uf_equiv_root_the_same g1); auto.
    apply (uf_root_edge g1 (liGraph g1) x pa); [| apply (vgamma_not_dst g1 x r) | rewrite (uf_equiv_root_the_same g1 g2)]; auto.
  Qed.

  Lemma graph_gen_redirect_parent_findS: forall (g1 g2: UFGraph) x r1 r2 pa pa' (H: weak_valid g2 pa') (Hv: vvalid g2 x) (Hn: ~ reachable g2 pa' x),
      vvalid g1 x -> vgamma g1 x = (r1, pa) -> pa <> x -> vgamma g2 x = (r2, pa) -> findS g1 pa g2 -> uf_root g2 pa pa' ->
      findS g1 x (Graph_gen_redirect_parent g2 x pa' H Hv Hn).
  Proof.
    intros. hnf. simpl. destruct H4 as [? [? ?]]. hnf in H4. simpl in H4. unfold predicate_vvalid, predicate_weak_evalid in H4. split; [|split].
    - assert (forall v, ~ reachable (lg_gg g1) x v -> ~ reachable (lg_gg g1) pa v). {
        intros. intro. apply H8. pose proof (gamma_parent_reachable_included g1 x r1 pa H0 H1). apply H10. auto. }
      assert (forall v, ~ reachable (lg_gg g1) pa v <-> ~ reachable (lg_gg g1) x v \/ x = v). {
        intros. split; intros.
        - destruct_eq_dec x v; [right | left]; auto. intro. apply H9. apply reachable_ind.reachable_ind in H11. destruct H11. 1: exfalso; auto.
          destruct H11 as [z [[_ [_ ?]] [? ?]]]. rewrite (dst_step g1 (liGraph g1) x pa) in H11; auto; [subst pa | apply (vgamma_not_dst g1 x r1)]; auto.
        - destruct H9.
          + apply H8; auto.
          + subst v. apply vgamma_not_reachable with r1; auto.
      } hnf. simpl. unfold predicate_vvalid, predicate_weak_evalid. simpl. destruct H4 as [? [? [? ?]]]. split; [|split; [|split]]; intros.
      + split; intros; destruct H13; split; auto; apply H8 in H14; pose proof (conj H13 H14); [rewrite H4 in H15 | rewrite <- H4 in H15]; destruct H15; auto.
      + split; intros; destruct H13.
        * pose proof (H8 _ H14). pose proof (conj H13 H15). rewrite H10 in H16. destruct H16. rewrite H9 in H17. destruct H17. 1: split; auto. symmetry in H17.
          pose proof (conj H17 H16). rewrite (@only_one_edge _ _ _ _ g2 _ (liGraph g2)) in H18; auto. subst e. pose proof (vvalid_src_evalid _ (liGraph g1) _ H0).
          destruct H18 as [? _]. unfold UFGraph_LGraph in H18. rewrite H18 in H14. exfalso. apply H14. apply reachable_refl. auto.
        * pose proof (H8 _ H14). pose proof (conj H13 H15). rewrite <- H10 in H16. destruct H16. rewrite H9 in H17. destruct H17. 1: split; auto. symmetry in H17.
          pose proof (conj H17 H16). rewrite (@only_one_edge _ _ _ _ g1 _ (liGraph g1)) in H18; auto. subst e. pose proof (vvalid_src_evalid _ (liGraph g2) _ Hv).
          destruct H18 as [? _]. unfold UFGraph_LGraph in H18. rewrite H18 in H14. exfalso. apply H14. apply reachable_refl. auto.
      + destruct H13, H14. apply H8 in H15. apply H8 in H16. apply H11; auto.
      + unfold updateEdgeFunc. destruct (equiv_dec (out_edge x) e).
        * unfold Equivalence.equiv in e0. subst e. pose proof (vvalid_src_evalid _ (liGraph g1) _ H0).
          destruct H15. unfold UFGraph_LGraph in H15. destruct H13. exfalso. apply H17. rewrite H15. apply reachable_refl; auto.
        * destruct H13, H14. apply H8 in H15. apply H8 in H16. apply H12; auto.
    - apply (graph_gen_redirect_parent_equiv _ _ _ r1 pa); auto.
    - apply H7.
  Qed.

  Lemma diff_root_union_1: forall (g g1 g2: UFGraph) x y x_root y_root,
      uf_equiv g g1 -> uf_root g1 x x_root -> uf_equiv g1 g2 -> uf_root g2 y y_root -> x_root <> y_root ->
      (@weak_valid _ _ _ _ g2 _ (maGraph g2) y_root) -> vvalid g2 x_root ->
      ~ reachable g2 y_root x_root -> uf_union g x y (pregraph_gen_dst g2 (out_edge x_root) y_root).
  Proof.
    intros. assert (uf_equiv g g2) by (apply (@uf_equiv_trans _ _ _ _ g1 _ (liGraph g1) _ (maGraph g1) (finGraph g1)); auto).
    pose proof (uf_equiv_union g g2 (Graph_gen_redirect_parent g2 x_root y_root H4 H5 H6) x y H7). simpl in H8. apply H8.
    apply (@diff_root_union _ _ _ _ _ _ _ _ out_edge isNullDec fml); auto. apply (uf_equiv_root_the_same g1); auto.
  Qed.

  Lemma diff_root_union_2: forall (g g1 g2: UFGraph) x y x_root y_root,
      uf_equiv g g1 -> uf_root g1 x x_root -> uf_equiv g1 g2 -> uf_root g2 y y_root -> x_root <> y_root -> (@weak_valid _ _ _ _ g2 _ (maGraph g2) x_root) -> vvalid g2 y_root ->
      ~ reachable g2 x_root y_root -> uf_union g x y (pregraph_gen_dst g2 (out_edge y_root) x_root).
  Proof.
    intros. assert (uf_equiv g g2) by (apply (@uf_equiv_trans _ _ _ _ g1 _ (liGraph g1) _ (maGraph g1) (finGraph g1)); auto).
    pose proof (uf_equiv_union g g2 (Graph_gen_redirect_parent g2 y_root x_root H4 H5 H6) y x H7). simpl in H8. apply uf_union_sym. apply H8.
    apply (@diff_root_union _ _ _ _ _ _ _ _ out_edge isNullDec fml); auto. apply (uf_equiv_root_the_same g1); auto.
  Qed.

  Lemma graph_gen_redirect_parent_vgamma: forall (g1 g2: UFGraph) x r pa y (H: weak_valid g1 x) (Hv: vvalid g1 y) (Hn: ~ reachable g1 x y),
      (forall a b, out_edge a = out_edge b -> a = b) -> vgamma g1 x = (r, pa) -> g2 = (Graph_gen_redirect_parent g1 y x H Hv Hn) -> vgamma g2 x = (r, pa).
  Proof.
    intros. rewrite H2. clear H2. unfold vgamma in *. simpl in *. inversion H1. f_equal. unfold updateEdgeFunc.
    destruct (equiv_dec (out_edge y) (out_edge x)); auto. hnf in e. apply H0 in e. subst y. exfalso; apply Hn; apply reachable_refl; auto.
  Qed.

End UnionFindGraph.


Require Import Coq.Classes.Morphisms. (* for reserved [-->] notation *)
Require Import Coq.Strings.String Coq.Strings.Ascii.
Require Import Fiat.Parsers.ContextFreeGrammar.Reflective.
Require Import Fiat.Common.Notations.

Set Implicit Arguments.
Delimit Scope typecode_scope with typecode.
Delimit Scope term_scope with term.
Delimit Scope termargs_scope with termargs.
Local Set Boolean Equality Schemes.
Inductive SimpleTypeCode : Set :=
| cnat
| cbool
| cstring
| cascii
| critem_ascii
| crchar_expr_ascii
| clist (T : SimpleTypeCode)
| cprod (A B : SimpleTypeCode).
Inductive TypeCode : Set :=
| csimple (T : SimpleTypeCode)
| carrow (A B : TypeCode).
Module Export TypeCodeCoercions.
  Global Coercion csimple : SimpleTypeCode >-> TypeCode.
End TypeCodeCoercions.
Local Unset Boolean Equality Schemes.

Bind Scope typecode_scope with TypeCode.
Bind Scope typecode_scope with SimpleTypeCode.
Arguments clist _%typecode.
Arguments carrow (_ _)%typecode.
Arguments cprod (_ _)%typecode.

Infix "-->" := carrow : typecode_scope.
Infix "*" := cprod : typecode_scope.

Fixpoint range_of (T : TypeCode) : SimpleTypeCode
  := match T with
     | carrow A B => range_of B
     | csimple T => T
     end.

Section args.
  Section monadic.
    Context (M : TypeCode -> Type).

    Inductive args_for : TypeCode -> Type :=
    | an_arg {A B} (arg : M A) (args : args_for B) : args_for (A --> B)
    | noargs {T} : args_for (csimple T).

    Definition ahd {A B} (af : args_for (A --> B)) : M A :=
      match af in args_for T return match T with
                                    | carrow A B => M A
                                    | _ => unit
                                    end with
      | an_arg _ _ arg _ => arg
      | _ => tt
      end.

    Definition atl {A B} (af : args_for (A --> B)) : args_for B :=
      match af in args_for T return match T with
                                    | carrow A B => args_for B
                                    | _ => unit
                                    end with
      | an_arg _ _ _ af' => af'
      | _ => tt
      end.

    Fixpoint aIn {A T} (v : M A) (args : args_for T) : Type
      := match args with
         | an_arg A' B' arg args
           => ({ pf : A' = A
               | eq_rect A' M arg A pf = v}
               + @aIn _ _ v args)%type
         | noargs T => False
         end.

    Definition invert_args_for {T} (args : args_for T)
      : args = match T return args_for T -> args_for T with
               | csimple T' => fun _ => noargs
               | carrow A B => fun args' => an_arg (ahd args') (atl args')
               end args.
    Proof.
      destruct args; reflexivity.
    Defined.

    Definition invert_args_for_ex {T} (args : args_for T)
      : match T return args_for T -> Prop with
        | csimple T' => fun args => args = noargs
        | carrow A B => fun args => exists hd tl, args = an_arg hd tl
        end args.
    Proof.
      destruct args; repeat esplit.
    Defined.
  End monadic.

  Global Arguments an_arg {M _ _} _ _.
  Global Arguments noargs {M _}.
  Global Arguments ahd {M _ _} _.
  Global Arguments atl {M _ _} _.
  Global Arguments aIn {M _ _} _ _.

  Section aIn2.
    Fixpoint aIn2
             {M N : TypeCode -> Type}
             {A T} (v1 : M A) (v2 : N A) (args1 : args_for M T)
    : args_for N T -> Type
      := match args1 in args_for _ T return args_for _ T -> Type with
         | an_arg A' B' arg args
           => fun args2
              => ({ pf : A' = A
                  | eq_rect A' M arg A pf = v1
                    /\ eq_rect A' N (ahd args2) A pf = v2 }
                  + @aIn2 _ _ _ _ v1 v2 args (atl args2))%type
         | noargs T => fun _ => False
         end.
  End aIn2.

  Section map.
    Context {M N : TypeCode -> Type}
            (F : forall {A}, M A -> N A).

    Fixpoint map_args_for {T} (args : args_for M T) : args_for N T
      := match args in args_for _ T return args_for _ T with
         | an_arg A B arg args => an_arg (F arg) (map_args_for args)
         | noargs T => noargs
         end.
  End map.

  Section related.
    Context {M N : TypeCode -> Type}
            (R : forall {T}, M T -> N T -> Prop).

    Inductive args_for_related_ind : forall {T} (args0 : args_for M T), args_for N T -> Prop :=
    | rel_an_arg {A B arg0 arg1 args0 args1}
      : R arg0 arg1 -> args_for_related_ind args0 args1
        -> @args_for_related_ind (carrow A B) (an_arg arg0 args0) (an_arg arg1 args1)
    | rel_noargs {T}
      : @args_for_related_ind (csimple T) noargs noargs.

    Fixpoint args_for_related {T} (args0 : args_for M T) : args_for N T -> Prop
      := match args0 in args_for _ T return args_for _ T -> Prop with
         | an_arg A B arg args
           => fun args1
              => R arg (ahd args1)
                 /\ @args_for_related _ args (atl args1)
         | noargs T => fun args1 => noargs = args1
         end.

    Lemma args_for_related_noind_ind {T args0 args1}
      : @args_for_related T args0 args1 <-> @args_for_related_ind T args0 args1.
    Proof.
      split; intro H.
      { revert dependent args1; induction args0; intros; simpl in *;
        pose proof (invert_args_for_ex args1) as H'; simpl in *;
        subst; [ | solve [ repeat (intro || constructor) ] ].
        destruct H' as [? [? H']]; subst; simpl in *.
        inversion H; constructor; eauto. }
      { induction H; simpl; intuition. }
    Qed.
  End related.

  Lemma args_for_related_impl {M N P R T} args0 args1
    : (P -> @args_for_related M N R T args0 args1)
      <-> @args_for_related M N (fun _ m n => P -> R _ m n) T args0 args1.
  Proof.
    revert dependent args1; induction args0; simpl in *; intros;
      pose proof (invert_args_for_ex args1) as H'; simpl in H';
        subst; [ destruct H' as [? [? ?]]; subst | tauto ];
          simpl in *.
    setoid_rewrite <- IHargs0.
    tauto.
  Qed.
End args.

Section term.
  Context (var : TypeCode -> Type).

  Inductive RLiteralConstructor : TypeCode -> Set :=
  | Rpair {A B : SimpleTypeCode} : RLiteralConstructor (A --> B --> A * B)
  | RS : RLiteralConstructor (cnat --> cnat)
  | RO : RLiteralConstructor cnat
  | Rnil {A} : RLiteralConstructor (clist A)
  | Rcons {A : SimpleTypeCode} : RLiteralConstructor (A --> clist A --> clist A)
  | Rbool (b : bool) : RLiteralConstructor cbool
  | Rrchar_expr_ascii (_ : Reflective.RCharExpr ascii) : RLiteralConstructor crchar_expr_ascii
  | Rstring (_ : string) : RLiteralConstructor cstring
  | Rritem_ascii (_ : Reflective.ritem ascii) : RLiteralConstructor critem_ascii.
  Inductive RLiteralNonConstructor : TypeCode -> Set :=
  | Rfst {A B} : RLiteralNonConstructor (A * B --> A)
  | Rsnd {A B} : RLiteralNonConstructor (A * B --> B)
  | Rnth' {A} : RLiteralNonConstructor (cnat --> clist A --> A --> csimple A)
  | Rnth {A} : RLiteralNonConstructor (cnat --> clist A --> A --> csimple A)
  | Rbeq_nat : RLiteralNonConstructor (cnat --> cnat --> cbool)
  | Rmap {A B : SimpleTypeCode} : RLiteralNonConstructor ((A --> B) --> clist A --> clist B)
  | Rfold_left {A B : SimpleTypeCode} : RLiteralNonConstructor ((A --> B --> A) --> clist B --> A --> csimple A)
  | Rorb : RLiteralNonConstructor (cbool --> cbool --> cbool)
  | Randb : RLiteralNonConstructor (cbool --> cbool --> cbool)
  | Randbr : RLiteralNonConstructor (cbool --> cbool --> cbool)
  | Rorbr : RLiteralNonConstructor (cbool --> cbool --> cbool)
  | Rminusr : RLiteralNonConstructor (cnat --> cnat --> cnat)
  | Rpred : RLiteralNonConstructor (cnat --> cnat)
  | Rlength A : RLiteralNonConstructor (clist A --> cnat)
  | Rbool_rect_nodep {A : SimpleTypeCode} : RLiteralNonConstructor (A --> A --> cbool --> csimple A)
  | Rlist_rect_nodep {A : SimpleTypeCode} {P : TypeCode} : RLiteralNonConstructor (P --> (A --> clist A --> P --> P) --> clist A --> P)
  | Rlist_caset_nodep {A P : SimpleTypeCode} : RLiteralNonConstructor (P --> (A --> clist A --> P) --> clist A --> P)
  | Rleb : RLiteralNonConstructor (cnat --> cnat --> cbool)
  | Rcombine {A B} : RLiteralNonConstructor (clist A --> clist B --> clist (A * B))
  | Rrev {A} : RLiteralNonConstructor (clist A --> clist A)
  | Rup_to : RLiteralNonConstructor (cnat --> clist cnat)
  | Rplus : RLiteralNonConstructor (cnat --> cnat --> cnat)
  | Rmax : RLiteralNonConstructor (cnat --> cnat --> cnat)
  | Rritem_rect_nodep {A : SimpleTypeCode} : RLiteralNonConstructor ((crchar_expr_ascii --> A) --> (cstring --> A) --> critem_ascii --> csimple A)
  | Rfirst_index_default {A : SimpleTypeCode} : RLiteralNonConstructor ((A --> cbool) --> cnat --> clist A --> cnat)
  | Rinterp_RCharExpr_ascii : RLiteralNonConstructor (crchar_expr_ascii --> cascii --> cbool)
  | Rstring_beq : RLiteralNonConstructor (cstring --> cstring --> cbool).
  (*| Rchar_at_matches
    : RLiteralNonConstructor (cnat --> (cascii --> cbool) --> cbool)
  | Rsplit_string_for_production
    : RLiteralNonConstructor (cnat * (cnat * cnat) --> cnat --> cnat --> (clist cnat)).*)

  Inductive RLiteralTerm (T : TypeCode) : Set :=
  | RLC (_ : RLiteralConstructor T)
  | RLNC (_ : RLiteralNonConstructor T).

  Local Unset Elimination Schemes.
  Inductive Term : TypeCode -> Type :=
  | RVar {T} (v : var T) : Term T
  | RLambda {A B} (f : var A -> Term B)
    : Term (A --> B)
  | RApp {A B} (f : Term (A --> B)) (x : Term A)
    : Term B
  | RLiteralApp c (t : RLiteralTerm c) (args : args_for Term c)
    : Term (range_of c).

  Bind Scope term_scope with Term.
  Bind Scope termargs_scope with args_for.

  Section rect.
    Context (P : forall t, Term t -> Type)
            (RVarCase : forall T v, P T (RVar v))
            (RLambdaCase : forall A B f,
                (forall v, P B (f v))
                -> P (A --> B)%typecode (RLambda f))
            (RAppCase : forall A B f,
                P (A --> B)%typecode f
                -> forall x, P A x -> P B (RApp f x))
            (RLiteralAppCase
             : forall c (t : RLiteralTerm c) (args : args_for Term c),
                (forall T v, aIn v args -> P T v)
                -> P (range_of c) (RLiteralApp t args)).

    Fixpoint Term_rect
             T (t : Term T)
      : P t.
    Proof.
      refine match t return P t with
             | RVar T v => RVarCase _
             | RLambda A B f => RLambdaCase _ (fun v => @Term_rect _ _)
             | RApp A B f x => RAppCase (@Term_rect _ _) (@Term_rect _ _)
             | RLiteralApp c t' args => RLiteralAppCase _ _ _
             end.
      clear t'.
      induction args as [A B arg args IHargs|].
      { pose proof (@Term_rect _ arg) as rarg; clear Term_rect.
        intros ?? [[pf H]|H].
        { destruct pf, H; simpl.
          exact rarg. }
        { apply IHargs; assumption. } }
      { simpl.
        intros ?? []. }
    Defined.
  End rect.

  Section rec.
    Context (P : forall t, Term t -> Set)
            (RVarCase : forall T v, P T (RVar v))
            (RLambdaCase : forall A B f,
                (forall v, P B (f v))
                -> P (A --> B)%typecode (RLambda f))
            (RAppCase : forall A B f,
                P (A --> B)%typecode f
                -> forall x, P A x -> P B (RApp f x))
            (RLiteralAppCase
             : forall c (t : RLiteralTerm c) (args : args_for Term c),
                (forall T v, aIn v args -> P T v)
                -> P (range_of c) (RLiteralApp t args)).

    Fixpoint Term_rec
             T (t : Term T)
      : P t.
    Proof.
      refine match t return P t with
             | RVar T v => RVarCase _
             | RLambda A B f => RLambdaCase _ (fun v => @Term_rec _ _)
             | RApp A B f x => RAppCase (@Term_rec _ _) (@Term_rec _ _)
             | RLiteralApp c t' args => RLiteralAppCase _ _ _
             end.
      clear t'.
      induction args as [A B arg args IHargs|].
      { pose proof (@Term_rec _ arg) as rarg; clear Term_rec.
        intros ?? [[pf H]|H].
        { destruct pf, H; simpl.
          exact rarg. }
        { apply IHargs; assumption. } }
      { simpl.
        intros ?? []. }
    Defined.
  End rec.

  Section ind.
    Context (P : forall t, Term t -> Prop)
            (RVarCase : forall T v, P T (RVar v))
            (RLambdaCase : forall A B f,
                (forall v, P B (f v))
                -> P (A --> B)%typecode (RLambda f))
            (RAppCase : forall A B f,
                P (A --> B)%typecode f
                -> forall x, P A x -> P B (RApp f x))
            (RLiteralAppCase
             : forall c (t : RLiteralTerm c) (args : args_for Term c),
                (forall T v, aIn v args -> P T v)
                -> P (range_of c) (RLiteralApp t args)).

    Fixpoint Term_ind
             T (t : Term T)
      : P t.
    Proof.
      refine match t return P t with
             | RVar T v => RVarCase _
             | RLambda A B f => RLambdaCase _ (fun v => @Term_ind _ _)
             | RApp A B f x => RAppCase (@Term_ind _ _) (@Term_ind _ _)
             | RLiteralApp c t' args => RLiteralAppCase _ _ _
             end.
      clear t'.
      induction args as [A B arg args IHargs|].
      { pose proof (@Term_ind _ arg) as rarg; clear Term_ind.
        intros ?? [[pf H]|H].
        { destruct pf, H; simpl.
          exact rarg. }
        { apply IHargs; assumption. } }
      { simpl.
        intros ?? []. }
    Defined.
  End ind.
End term.

Bind Scope term_scope with Term.
Bind Scope termargs_scope with args_for.
Arguments RVar {var T%typecode} v.
Arguments RLambda {var} {A B}%typecode f%term.
Arguments RApp {var} {A B}%typecode (f x)%term.
Arguments RLiteralApp {var} {c}%typecode t%term args%termargs.

Notation "# v" := (RVar v) : term_scope.
Infix "@" := RApp : term_scope.

Notation "\ x , e" := (RLambda (fun x => e)) : term_scope.
Notation "\ ! , e" := (RLambda (fun _ => e)) : term_scope.
Notation "x :: y" := (@an_arg (Term _) _ _ x%term y%termargs) : termargs_scope.

Definition polyTerm T := forall var, Term var T.

Local Notation rcStepT cbool :=
  ((*Rchar_at_matches*)
    (cnat --> (cascii --> cbool) --> cbool)
      --> (*Rsplit_string_for_production*)
      (cnat * (cnat * cnat) --> cnat --> cnat --> (clist cnat))
      --> cnat --> cnat --> (cnat --> cnat --> cnat --> cbool) --> clist cnat --> cnat --> cnat --> cnat --> cbool)%typecode
                                                                                (only parsing).

Inductive has_parse_term var : Type :=
| RFix2
    (G_length : nat) (up_to_G_length : list nat)
    (f : Term var (rcStepT cbool))
    (valid_len : nat)
    (valids : list nat)
    (nt_idx : nat).

Definition polyhas_parse_term := forall var, has_parse_term var.

Module Export Coercions.
  Export TypeCodeCoercions.
  Coercion RLC : RLiteralConstructor >-> RLiteralTerm.
  Coercion RLNC : RLiteralNonConstructor >-> RLiteralTerm.
End Coercions.