Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Variance.

Inductive type4rec : typ -> Prop :=
  | type4_top :
      type4rec typ_top
  | type4_bot :
      type4rec typ_bot
  | type4_nat :
      type4rec typ_nat
  | type4_var : forall X,
      type4rec (typ_fvar X)
  | type4_arrow : forall T1 T2,
      type4rec T1 ->
      type4rec T2 ->
      type4rec (typ_arrow T1 T2)
  | type4_mu : forall L T,
      (forall X, X \notin L -> type4rec (open_tt T (typ_label X (open_tt T (typ_fvar X))))) ->
      (forall X, X \notin L -> type4rec (open_tt T (typ_fvar X))) ->
      type4rec (typ_mu T)
  | type4_all : forall L T1 T2,
      type4rec T1 ->
      (forall X, X `notin` L -> type4rec (open_tt T2 (typ_fvar X))) ->
      type4rec (typ_all T1 T2)
  | type4_all_lb : forall L T1 T2,
      type4rec T1 ->
      (forall X, X `notin` L -> type4rec (open_tt T2 (typ_fvar X))) ->
      type4rec (typ_all_lb T1 T2)
  | type4_label: forall l A,
      type4rec A ->
      type4rec (typ_label l A)
.

Hint Constructors type4rec : core.

Lemma type4rec_to_type : forall A,
    type4rec A -> type A.
Proof with auto.
  intros.
  induction H...
  apply type_mu with (L:=L)...
  apply type_all with (L:=L)...
  apply type_all_lb with (L:=L)...
Qed.

Lemma subst_tt_type4rec : forall Z P T,
  type4rec T ->
  type4rec P ->
  type4rec (subst_tt Z P T).
Proof with auto using type4rec_to_type.
  intros Z P T HT HP.
  induction HT; simpl...
  -
    destruct (X == Z)...
  -
    apply type4_mu with (L:=L \u {{Z}});intros...
    rewrite <- subst_tt_open_tt_twice...
    rewrite subst_tt_open_tt_var...
  -
    apply type4_all with (L:=L \u {{Z}});intros...
    rewrite subst_tt_open_tt_var...
  -
    apply type4_all_lb with (L:=L \u {{Z}});intros...
    rewrite subst_tt_open_tt_var...
Qed.

Lemma type_to_rec : forall A,
    type A -> type4rec A.
Proof with auto.
  intros.
  induction H...
  -
    apply type4_mu with (L:=L \u fv_tt T)...
    intros.
    rewrite subst_tt_intro with (X:=X)...
    apply subst_tt_type4rec...
  -
    apply type4_all with (L:=L \u fv_tt T1 \u fv_tt T2)...
  -
    apply type4_all_lb with (L:=L \u fv_tt T1 \u fv_tt T2)...
Qed.

Definition transitivity_on Q := forall E S T,
    sub E S Q -> sub E Q T -> sub E S T.

Lemma wf_env_narrowing: forall F Z Q E P,
    wf_env (F ++ Z ~ bind_sub Q ++ E) ->
    WF E P ->
    wf_env  (F ++ Z ~ bind_sub P ++ E).
Proof with auto.
  induction F;intros...
  -
    simpl...
    dependent destruction H...
    constructor...
  -
    dependent destruction H...
    +
      rewrite_env ((X, bind_sub T) :: F ++ Z ~ bind_sub P ++ E).
      constructor...
      apply IHF with (Q:=Q)...
      apply WF_narrowing with (V:=Q)...
    +
      rewrite_env ((X, bind_sub_lb T) :: F ++ Z ~ bind_sub P ++ E).
      constructor...
      apply IHF with (Q:=Q)...
      apply WF_narrowing with (V:=Q)...
    +
      rewrite_env ((x, bind_typ T) :: F ++ Z ~ bind_sub P ++ E).
      constructor...
      apply IHF with (Q:=Q)...
      apply WF_narrowing with (V:=Q)...
Qed.

Lemma wf_env_narrowing_lb: forall F Z Q E P,
    wf_env (F ++ Z ~ bind_sub_lb Q ++ E) ->
    WF E P ->
    wf_env  (F ++ Z ~ bind_sub_lb P ++ E).
Proof with auto.
  induction F;intros...
  -
    simpl...
    dependent destruction H...
    constructor...
  -
    dependent destruction H...
    +
      rewrite_env ((X, bind_sub T) :: F ++ Z ~ bind_sub_lb P ++ E).
      constructor...
      apply IHF with (Q:=Q)...
      apply WF_narrowing_lb with (V:=Q)...
    +
      rewrite_env ((X, bind_sub_lb T) :: F ++ Z ~ bind_sub_lb P ++ E).
      constructor...
      apply IHF with (Q:=Q)...
      apply WF_narrowing_lb with (V:=Q)...
    +
      rewrite_env ((x, bind_typ T) :: F ++ Z ~ bind_sub_lb P ++ E).
      constructor...
      apply IHF with (Q:=Q)...
      apply WF_narrowing_lb with (V:=Q)...
Qed.

Lemma sub_narrowing_aux : forall Q F E Z P S T,
  transitivity_on Q ->
  sub (F ++ Z ~ bind_sub Q ++ E) S T ->
  sub E P Q ->
  sub (F ++ Z ~ bind_sub P ++ E) S T.
Proof with auto.
  intros.
  generalize dependent P.
  dependent induction H0;intros...
  -
    constructor...
    apply wf_env_narrowing with (Q:=Q)...
    get_well_form...
  -
    constructor...
    apply wf_env_narrowing with (Q:=Q)...
    get_well_form...
    apply WF_narrowing with (V:=Q)...
  -
    constructor...
    apply wf_env_narrowing with (Q:=Q)...
    get_well_form...
    apply WF_narrowing with (V:=Q)...
  -
    constructor...
    apply wf_env_narrowing with (Q:=Q)...
    get_well_form...
    apply WF_narrowing with (V:=Q)...
  -
    destruct (X==Z);subst...
    +
      apply sa_trans_tvar with (U:=P)...
      apply H...
      * Case "P < Q".
        rewrite_env (nil ++ (F ++ Z ~ bind_sub P) ++ E).
        apply Sub_weakening...
        get_well_form...
        rewrite_env (F ++ Z ~ bind_sub P ++ E).
        apply wf_env_narrowing with (Q:=Q)...
      * Case "Q < T".
        analyze_binds_uniq H1...
        apply uniq_from_wf_env...
        get_well_form...
        dependent destruction BindsTacVal.
        apply IHsub with (Q0:=Q)...
    +
      apply sa_trans_tvar with (U:=U)...
      analyze_binds_uniq H1...
      apply uniq_from_wf_env...
      get_well_form...
      apply IHsub with (Q0:=Q)...
  -
    destruct (X==Z);subst...
    + analyze_binds_uniq H1... apply uniq_from_wf_env. get_well_form...
    +
      apply sa_trans_tvar_lb with (U:=U)...
      analyze_binds_uniq H1...
      apply uniq_from_wf_env...
      get_well_form...
      apply IHsub with (Q0:=Q)...
  -
    constructor...
    apply IHsub1 with (Q0:=Q)...
    apply IHsub2 with (Q0:=Q)...
  -
    apply sa_all with (L:=L);intros...
    +
      apply IHsub1 with (Q0:=Q)...
    +
      apply IHsub2 with (Q0:=Q)...
    +
      rewrite_env ((X ~ bind_sub S2 ++ F) ++ Z ~ bind_sub P ++ E).
      apply H0 with (Q0:=Q)...
  -
    apply sa_all_lb with (L:=L);intros...
    +
      apply IHsub1 with (Q0:=Q)...
    +
      apply IHsub2 with (Q0:=Q)...
    +
      rewrite_env ((X ~ bind_sub_lb S2 ++ F) ++ Z ~ bind_sub P ++ E).
      apply H0 with (Q0:=Q)...
  -
    apply sa_rec with (L:=L \u fv_tt A1 \u fv_tt A2);intros...
    +
      rewrite_env ((X ~ bind_sub typ_top ++ F) ++ Z ~ bind_sub P ++ E).
      apply WF_narrowing with (V:=Q)...
      apply H3...
    +
      rewrite_env ((X ~ bind_sub typ_top ++ F) ++ Z ~ bind_sub P ++ E).
      apply WF_narrowing with (V:=Q)...
      apply H0...
    +
      rewrite_env ((X ~ bind_sub typ_top ++ F) ++ Z ~ bind_sub P ++ E).
      apply H2 with (Q0:=Q)...
  -
    constructor.
    apply IHsub with (Q0:=Q)...
Qed.

Lemma sub_narrowing_aux_lb : forall Q F E Z P S T,
  transitivity_on Q ->
  sub (F ++ Z ~ bind_sub_lb Q ++ E) S T ->
  sub E Q P ->
  sub (F ++ Z ~ bind_sub_lb P ++ E) S T.
Proof with auto.
  intros.
  generalize dependent P.
  dependent induction H0;intros...
  -
    constructor...
    apply wf_env_narrowing_lb with (Q:=Q)...
    get_well_form...
  -
    constructor...
    apply wf_env_narrowing_lb with (Q:=Q)...
    get_well_form...
    apply WF_narrowing_lb with (V:=Q)...
  -
    constructor...
    apply wf_env_narrowing_lb with (Q:=Q)...
    get_well_form...
    apply WF_narrowing_lb with (V:=Q)...
  -
    constructor...
    apply wf_env_narrowing_lb with (Q:=Q)...
    get_well_form...
    apply WF_narrowing_lb with (V:=Q)...
  -
    destruct (X==Z);subst...
    + analyze_binds_uniq H1... apply uniq_from_wf_env. get_well_form...
    +
      apply sa_trans_tvar with (U:=U)...
      analyze_binds_uniq H1...
      apply uniq_from_wf_env...
      get_well_form...
      apply IHsub with (Q0:=Q)...
  -
    destruct (X==Z);subst...
    +
      apply sa_trans_tvar_lb with (U:=P)...
      apply H...
      * Case "T < Q".
        analyze_binds_uniq H1...
        apply uniq_from_wf_env...
        get_well_form...
        dependent destruction BindsTacVal.
        apply IHsub with (Q0:=Q)...
      * Case "Q < P".
        rewrite_env (nil ++ (F ++ Z ~ bind_sub_lb P) ++ E).
        apply Sub_weakening...
        get_well_form...
        rewrite_env (F ++ Z ~ bind_sub_lb P ++ E).
        apply wf_env_narrowing_lb with (Q:=Q)...
    +
      apply sa_trans_tvar_lb with (U:=U)...
      analyze_binds_uniq H1...
      apply uniq_from_wf_env...
      get_well_form...
      apply IHsub with (Q0:=Q)...

  -
    constructor...
    apply IHsub1 with (Q0:=Q)...
    apply IHsub2 with (Q0:=Q)...
  -
    apply sa_all with (L:=L);intros...
    +
      apply IHsub1 with (Q0:=Q)...
    +
      apply IHsub2 with (Q0:=Q)...
    +
      rewrite_env ((X ~ bind_sub S2 ++ F) ++ Z ~ bind_sub_lb P ++ E).
      apply H0 with (Q0:=Q)...
  -
    apply sa_all_lb with (L:=L);intros...
    +
      apply IHsub1 with (Q0:=Q)...
    +
      apply IHsub2 with (Q0:=Q)...
    +
      rewrite_env ((X ~ bind_sub_lb S2 ++ F) ++ Z ~ bind_sub_lb P ++ E).
      apply H0 with (Q0:=Q)...
  -
    apply sa_rec with (L:=L \u fv_tt A1 \u fv_tt A2);intros...
    +
      rewrite_env ((X ~ bind_sub typ_top ++ F) ++ Z ~ bind_sub_lb P ++ E).
      apply WF_narrowing_lb with (V:=Q)...
      apply H3...
    +
      rewrite_env ((X ~ bind_sub typ_top ++ F) ++ Z ~ bind_sub_lb P ++ E).
      apply WF_narrowing_lb with (V:=Q)...
      apply H0...
    +
      rewrite_env ((X ~ bind_sub typ_top ++ F) ++ Z ~ bind_sub_lb P ++ E).
      apply H2 with (Q0:=Q)...
  -
    constructor.
    apply IHsub with (Q0:=Q)...
Qed.

Lemma sub_top: forall E T S,
  sub E typ_top T ->
  WF E S ->
  sub E S T.
Proof with auto.
  intros.
  dependent induction H.
  - constructor...
  - apply sa_trans_tvar_lb with (U:=U)...
Qed.

Lemma sub_bot: forall E T S,
  sub E T typ_bot ->
  WF E S ->
  sub E T S.
Proof with auto.
  intros.
  dependent induction H.
  - constructor...
  - apply sa_trans_tvar with (U:=U)...
Qed.

(* Lemma sub_nat: forall E T U,
  sub E typ_nat T ->
  sub E T U ->
  sub E typ_nat U.
Proof with auto.
  intros.
  dependent induction H...
  - apply sub_top...
  - apply IHsub... apply sa_trans_tvar_lb with (U:=U0)...
Qed. *)

Lemma binds_ub_lb_invalid: forall E X U U0,
  binds X (bind_sub_lb U) E ->
  binds X (bind_sub U0) E ->
  uniq E ->
  False.
Proof.
  intros.
  pose proof binds_unique _ _ _ _ _ H H0 H1.
  inversion H2.
Qed.

Lemma sub_transitivity : forall Q,
  transitivity_on Q.
Proof with auto.
  intros.
  unfold transitivity_on.
  intros.
  assert (type Q).
  get_type...
  apply type_to_rec in H1.
  generalize dependent S.
  generalize dependent T.
  generalize dependent E.
  induction H1;intros...
  -
    apply sub_top... get_well_form...
  -
    apply sub_bot... get_well_form...
  -
    dependent induction H0...
    + constructor...
      get_well_form...
    + apply sa_trans_tvar_lb with (U:=U)...
  -
    dependent induction H0...
    + constructor...
      get_well_form...
    +
      (* S <: X /\  X <: U <: T *)
      generalize dependent T.
      generalize dependent U.
      dependent induction H1;intros...
      *
        apply sa_trans_tvar with (U:=U)...
      *
        apply sa_bot... get_well_form...
      *
        apply sa_trans_tvar with (U:=U)...
        apply IHsub with (X0:=X) (U0 := U0)...
      *
        (* T0 <:  U0 <: X /\  X <: U <: T *)
        pose proof binds_ub_lb_invalid _ _ _ H H0.
        exfalso. apply H3. apply uniq_from_wf_env. get_well_form...
    +
      (* S <: X /\  X <: U <: X0 *)
      apply sa_trans_tvar_lb with (U:=U)...
      apply IHsub with (X0:=X)...
  -
    dependent induction H0...
    + constructor...
      get_well_form...
    +
      (* S <: T1 -> T2 /\ T1 -> T2 <: U <: X0 *)
      apply sa_trans_tvar_lb with (U:=U)...
      apply IHsub with (T4:=T1) (T3:=T2)...
    +
      dependent induction H...
      { apply sa_bot... get_well_form... }
      apply sa_trans_tvar with (U:=U)...
      apply IHsub with (T4:=T1) (T3:=T2)...
  -
    dependent induction H3...
    + constructor...
      get_well_form...
    +
      apply sa_trans_tvar_lb with (U:=U)...
      apply IHsub with (T0:=T)...
    +
      clear H6.
      dependent induction H7...
      { apply sa_bot... apply WF_rec with (L:=L0)...
        intros. specialize_x_and_L X L0. get_well_form... }
      apply sa_trans_tvar with (U:=U)...
      apply IHsub with (T0:=T)...
      clear H9.
      apply sa_rec with (L:=L \u L0 \u L1);intros...
      apply H0 with (X:=X)...
  -
    dependent induction H2...
    +
      constructor...
      get_well_form...
    +
      apply sa_trans_tvar_lb with (U:=U)...
      apply IHsub with (T3:=T2)(T4:=T1)...
    +
      clear H2 IHsub1 IHsub2.
      dependent induction H4...
      { apply sa_bot... apply WF_all with (L:=L0)...
        get_well_form...
        intros. specialize_x_and_L X L0. get_well_form... }
      apply sa_trans_tvar with (U:=U)...
      apply IHsub with (T4:=T1) (T3:=T2)...
      clear H2 IHsub1 IHsub2.
      apply sa_all with (L:=L \u L0 \u L1)...
      intros.
      apply H0 with (X:=X)...
      rewrite_env (nil ++ X ~ bind_sub S2 ++ E).
      apply sub_narrowing_aux with (Q:=T1)...
      unfold transitivity_on...
      apply H4...
  -
    dependent induction H2...
    +
      constructor...
      get_well_form...
    +
      apply sa_trans_tvar_lb with (U:=U)...
      apply IHsub with (T3:=T2)(T4:=T1)...
    +
      clear H2 IHsub1 IHsub2.
      dependent induction H4...
      { apply sa_bot... apply WF_all_lb with (L:=L0)...
        get_well_form...
        intros. specialize_x_and_L X L0. get_well_form... }
      apply sa_trans_tvar with (U:=U)...
      apply IHsub with (T4:=T1) (T3:=T2)...
      clear H2 IHsub1 IHsub2.
      apply sa_all_lb with (L:=L \u L0 \u L1)...
      intros.
      apply H0 with (X:=X)...
      rewrite_env (nil ++ X ~ bind_sub_lb S2 ++ E).
      apply sub_narrowing_aux_lb with (Q:=T1)...
      unfold transitivity_on...
      apply H4...
  -
    dependent induction H0...
    +
      constructor...
      get_well_form...
    +
      apply sa_trans_tvar_lb with (U:=U)...
      apply IHsub with (l0:=l) (A0:=A)...
    +
      clear IHsub.
      dependent induction H...
      { apply sa_bot... constructor... get_well_form... }
      apply sa_trans_tvar with (U:=U)...
      apply IHsub with (l0:=l) (A0:=A)...
Qed.

Lemma sub_narrowing : forall Q E F Z P S T,
  sub E P Q ->
  sub (F ++ Z ~ bind_sub Q ++ E) S T ->
  sub (F ++ Z ~ bind_sub P ++ E) S T.
Proof with auto.
  intros.
  apply sub_narrowing_aux with (Q:=Q)...
  apply sub_transitivity.
Qed.

Lemma sub_narrowing_lb : forall Q E F Z P S T,
  sub E Q P ->
  sub (F ++ Z ~ bind_sub_lb Q ++ E) S T ->
  sub (F ++ Z ~ bind_sub_lb P ++ E) S T.
Proof with auto.
  intros.
  apply sub_narrowing_aux_lb with (Q:=Q)...
  apply sub_transitivity.
Qed.


From discprob.basic Require Import base order nify.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.rec Require Import karp quickselect_rec log_rec decreasing_rec.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
From Coquelicot Require Import Derive.
From Coquelicot Require AutoDerive.
From Interval Require Import Tactic.
Require Import Reals Fourier FunctionalExtensionality.
Require Import Psatz.
Require Import Coq.omega.Omega.
Require Import Ranalysis5.

Module recurrence_counter.
  Import log_rec.
  Module count_factor <: rec_factor.
    Definition alpha := 10/17.
    Lemma alpha_range: 1/2 < alpha < 1.
    Proof. rewrite /alpha.  split; nra. Qed.
    Lemma ln_alpha: -/ln alpha > 1 /alpha.
    Proof. rewrite /alpha. interval. Qed.
  End count_factor.

  Module rec_solution := recurrence_log (count_factor).
  Import rec_solution.

Section recurrence_counter_sec.
  Definition X := nat.
  Variable A B : X → finType.
  Variable ΩT : ∀ x : X, distrib (A x).
  Variable Ωh : ∀ x : X, distrib (B x).
  Variable T: ∀ x: X, rrvar (ΩT x).
  Variable h: ∀ x: X, rvar (Ωh x) [eqType of X].
  Variable P: X → Prop.
  Variable hP: ∀ x n, P x → P (((h x) n)).
  Definition size (x: X) := INR x.
  Hypothesis T_non_neg: ∀ x n, (T x) n ≥ 0.
  Hypothesis hrange_dec: ∀ x n, size x > 1 → size ((h x) n) ≤ size x - 1.
  Hypothesis hrange1: ∀ x n, size ((h x) n) ≤ size x.
  Hypothesis hrange2: ∀ x n, d < size x →  0 ≤ size ((h x) n).

  Hypothesis Tbelow: ∀ x e, size x ≤ d → (T x) e = 0.

  Hypothesis Trec:
    ∀ x r,  pr_gt (T x) r ≤ \big[Rplus/0]_(x' : imgT (h x))
                  ((pr_eq (h x) (sval x')) * pr_gt (T (sval x')) (r - a (size x))).

  Variable m_bound_Eh: ∀ x, Ex (rvar_comp (h x) size) ≤ m (size x).

  Lemma size_x_int x: size x > 1 → size x < 2 → False.
  Proof.
    rewrite /size.
    replace 2 with (INR 2) by auto.
    replace 1 with (INR 1) by auto.
    intros ?%INR_lt ?%INR_lt.
    omega.
  Qed.

  Theorem counter_bound x w:
    P x →
    size x > 1 →
    pr_gt (T x) ((k * ln (size x) + 1) + INR w) ≤ (10/17)^w.
  Proof.
    intros HP Hgt1.
    replace ((k * ln (size x) + 1)) with (u (size x)); last first.
    {  rewrite /u. destruct (Rle_dec); first nra. rewrite //=. }
    replace (INR w) with (INR w * a (size x)); last first.
    { rewrite /a.  destruct Rle_dec; try destruct Rlt_dec; try nra.
      exfalso; eapply size_x_int; eauto. }
    etransitivity; first
    eapply karp_bound_simple with
      (A := A)
      (B := B)
      (T := T)
      (h := h)
      (P := P)
      (umin := umin)
      (d := d)
      (u := u)
      (a := a)
      (m := m).
    - apply umin_non_neg.
    - cut (∀ x, umin ≤ u x).
      { intros Hcut x'. specialize (Hcut (m x')). intros. etransitivity; first eauto.
        specialize (urec0 x'). nra.
      }
      intros x'. destruct (Rle_dec x' d) as [Hle|Hnle%Rnot_le_gt].
      * rewrite /umin/u. move: Hle. rewrite /d. destruct (Rle_dec); nra.
      * rewrite -ud_umin. apply u_mono. fourier.
    - apply u_mono.
    - apply u_strict_inc.
    - apply u'_mono.
    - apply u'_pos.
    - apply u'u.
    - apply u'_inv_above.
    - apply u_inv_above.
    - apply ud_umin.
    - apply m_bound_Eh.
    - intros. apply u_cont.
    - intros. apply a_cont_pt. done.
    - intros. apply Trec; auto.
    - apply urec0.
    - intros. auto.
    - intros. apply hrange1; auto.
    - intros. apply hrange2. nra.
    - apply alower.
    - apply a_nonneg.
    - apply a_mono.
    - apply a_pos.
    - apply mnondec.
    - apply d_non_neg.
    - eapply decreasing_rec.decreasing_rec.hinf_0 with (msr := size) (msr_cutoff := d);
        rewrite /d; eauto using hrange_dec, hrange1, hrange2.
      nra. intros. etransitivity; eauto.
    - intros. rewrite Tbelow // /umin. nra.
    - rewrite /m/count_factor.alpha. intros.
      destruct (Rlt_dec); nra.
    - auto.
    - auto.
    - right. rewrite /id/m/count_factor.alpha. destruct Rlt_dec.
      { exfalso.  eapply size_x_int; first eauto. nra. }
      f_equal. field. nra.
  Qed.

End recurrence_counter_sec.
End recurrence_counter.


Require Import ast_instructions binary Bool.
Require Import Coq.FSets.FMapList Coq.Structures.OrderedTypeEx.

(* generate equality function for tag *)
Scheme Equality for tag.
Check tag_beq.
Check tag_eq_dec.

(* generate equality function for binary_instruction (over list bool) *)
Scheme Equality for list.
Check list_beq.
Check list_eq_dec.

Definition binary_instruction_eq (l1 l2 : list bool) := list_beq bool eqb l1 l2.

(* create association map to link nat to list bool *)
Module Import M := FMapList.Make(Nat_as_OT).

Definition map_nat_bool: Type := M.t (list bool).
Definition find_tag k (m: map_nat_bool) := M.find k m.

Definition update_tag (p: nat * (list bool)) (m: map_nat_bool) :=
  M.add (fst p) (snd p) m.

(* this theorem seem's to be useless *)
(* Theorem some_equal : forall x : nat, forall y : nat,
                       x = y -> Some x = Some y.
Proof. intros x y H. rewrite H. reflexivity.
Qed. *)

(* these are the functions to use for the association map betwen tag and boolean list *)
Definition tag_to_binary (t : tag) (m : map_nat_bool) : option(list bool) :=
  find_tag (tag_to_nat t) m.

Definition binary_to_tag (l : list bool) : option tag :=
  nat_to_tag(binary_to_nat l).

Print tag.
(* these are the functions to encode your instruction *)
Definition tag_to_list_bool (t : tag) : list bool :=
  match t with
    |


Require Import Cdcl.Itauto.
Require Import pigeon_hole.

Goal pigeon_hole false 1 0 -> False.
Proof.
  simpl_pigeon.
  Time timeout 3600 nitautog.
  Time Qed.

Goal pigeon_hole false 2 1 -> False.
Proof.
  simpl_pigeon.
  Time timeout 3600 nitautog.
Time Qed.

Goal pigeon_hole false 3 2 -> False.
Proof.
  simpl_pigeon.
  Time timeout 3600 nitautog.
Time Qed.

Goal pigeon_hole false 4 3 -> False.
Proof.
  simpl_pigeon.
  Time timeout 3600 nitautog.
Time Qed.

Goal pigeon_hole false 5 4 -> False.
Proof.
  simpl_pigeon.
  Time timeout 3600 nitautog.
Time Qed.

Goal pigeon_hole false 6 5 -> False.
Proof.
  simpl_pigeon.
  Time timeout 3600 nitautog.
Time Qed.

Goal pigeon_hole false 7 6 -> False.
Proof.
  simpl_pigeon.
  Time timeout 3600 nitautog.
Time Qed.

Goal pigeon_hole false 8 7 -> False.
Proof.
  simpl_pigeon.
  Time timeout 3600 nitautog.
Time Qed.

Goal pigeon_hole false 9 8 -> False.
Proof.
  simpl_pigeon.
  Time timeout 3600 nitautog.
Time Qed.

Goal pigeon_hole false 10 9 -> False.
Proof.
  simpl_pigeon.
  Time timeout 3600 nitautog.
Time Qed.

Goal pigeon_hole false 11 10 -> False.
Proof.
  simpl_pigeon.
  Time timeout 3600 nitautog.
Time Qed.

Goal pigeon_hole false 12 11 -> False.
Proof.
  simpl_pigeon.
  Time timeout 3600 nitautog.
Time Qed.


(* To be imported qualified. *)
Require
  MathClasses.categories.varieties MathClasses.categories.product MathClasses.theory.forget_algebra MathClasses.theory.forget_variety MathClasses.theory.groups.
Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.universal_algebra MathClasses.theory.ua_homomorphisms MathClasses.misc.workaround_tactics categories.categories.

Inductive op := mult | inv | one.

Definition sig: Signature := single_sorted_signature
  (λ o, match o with one => O | inv => 1%nat | mult => 2%nat end).

Section laws.
  Global Instance: SgOp (Term0 sig nat tt) :=
    λ x, App sig _ _ _ (App sig _ _ _ (Op sig nat mult) x).
  Global Instance: MonUnit (Term0 sig nat tt) := Op sig nat one.
  Global Instance: Negate (Term0 sig nat tt) :=
    λ x, App sig _ _ _ (Op sig nat inv) x.

  Local Notation x := (Var sig nat 0%nat tt).
  Local Notation y := (Var sig nat 1%nat tt).
  Local Notation z := (Var sig nat 2%nat tt).

  Import notations.

  Inductive Laws: EqEntailment sig → Prop :=
    | e_mult_assoc: Laws (x & (y & z) === (x & y) & z)
    | e_mult_1_l: Laws (mon_unit & x === x)
    | e_mult_1_r: Laws (x & mon_unit === x)
    | e_recip_l: Laws (-x & x === mon_unit)
    | e_recip_r: Laws (x & -x === mon_unit).
End laws.

Definition theory: EquationalTheory := Build_EquationalTheory sig Laws.
Definition Object := varieties.Object theory.

Definition forget: Object → setoids.Object :=
  @product.project unit
    (λ _, setoids.Object)
    (λ _, _: Arrows setoids.Object) _
    (λ _, _: CatId setoids.Object)
    (λ _, _: CatComp setoids.Object)
    (λ _, _: Category setoids.Object) tt
     ∘ forget_algebra.object theory ∘ forget_variety.forget theory.
  (* todo: too ugly *)

(* Now follow a series of encoding/decoding functions to convert between the
 specialized Monoid/Monoid_Morphism type classes and the universal
 Algebra/InVariety/HomoMorphism type classes instantiated with the above
 signature and theory. *)

#[global]
Instance encode_operations A `{!SgOp A} `(Negate A) `{!MonUnit A}: AlgebraOps sig (λ _, A) :=
  λ o, match o with mult => (&) | inv => (-) | one => mon_unit: A end.

Section decode_operations.
  Context `{AlgebraOps theory A}.

  Global Instance: MonUnit (A tt) := algebra_op one.
  Global Instance: SgOp (A tt) := algebra_op mult.
  Global Instance: Negate (A tt) := algebra_op inv.
End decode_operations.

Section encode_variety_and_ops.
  Context A `{Group A}.

  Global Instance encode_algebra_and_ops: Algebra sig _.
  Proof. constructor. intro. apply _. intro o. destruct o; simpl; try apply _; unfold Proper; reflexivity. Qed.

  Global Instance encode_variety_and_ops: InVariety theory (λ _, A).
  Proof.
   constructor. apply _.
   intros ? [] ?; simpl; unfold algebra_op; simpl.
       apply associativity.
      apply left_identity.
     apply right_identity.
    eapply left_inverse.
   eapply right_inverse.
  Qed.

  Definition object: Object := varieties.object theory (λ _, A).
End encode_variety_and_ops.

Lemma encode_algebra_only `{!AlgebraOps theory A} `{∀ u, Equiv (A u)} `{!Group (A tt)}: Algebra theory A .
Proof. constructor; intros []; simpl in *; try apply _. Qed.

Global Instance decode_variety_and_ops `{InVariety theory A}: Group (A tt).
Proof with simpl; auto.
 pose proof (λ law lawgood x y z, variety_laws law lawgood (λ s n,
  match s with tt => match n with 0 => x | 1 => y | _ => z end end)) as laws.
 repeat constructor; try apply _.
       intro. apply_simplified (laws _ e_mult_assoc).
      apply_simplified (algebra_propers mult)...
     intro. apply_simplified (laws _ e_mult_1_l)...
    intro. apply_simplified (laws _ e_mult_1_r)...
   apply_simplified (algebra_propers inv).
  intro. apply_simplified (laws _ e_recip_l)...
 intro. apply_simplified (laws _ e_recip_r)...
Qed.

Lemma encode_morphism_only
  `{AlgebraOps theory A} `{∀ u, Equiv (A u)}
  `{AlgebraOps theory B} `{∀ u, Equiv (B u)}
  (f: ∀ u, A u → B u) `{!Group (A tt)} `{!Group (B tt)} `{!Monoid_Morphism (f tt)}: HomoMorphism sig A B f.
Proof.
 pose proof (monmor_a (f:=f tt)).
 pose proof (monmor_b (f:=f tt)).
 constructor.
    intros []. apply _.
   intros []; simpl.
     apply preserves_sg_op.
    apply groups.preserves_negate.
   rapply preserves_mon_unit.
  eapply encode_algebra_only.
 eapply encode_algebra_only.
Qed.

Lemma encode_morphism_and_ops `{Group A} `{Group B}  `{!Monoid_Morphism (f: A → B)}:
  @HomoMorphism sig (λ _, A) (λ _, B) _ _ ( _) ( _) (λ _, f).
Proof. intros. apply encode_morphism_only; assumption. Qed.

Lemma decode_morphism_and_ops
  `{InVariety theory x} `{InVariety theory y} `{!HomoMorphism theory x y f}:
    Monoid_Morphism (f tt).
Proof.
 constructor; try apply _.
  constructor; try apply _.
  apply (preserves theory x y f mult).
 apply (preserves theory x y f one).
Qed.


Add LoadPath "/home/user/Downloads/archives/sets-in-coq".
Require Export ZF.
Import IZF.

(*Theorem thm: not (exists x:set, ((power x) == x) ).*)
Theorem thm: not (exists x:set, ((power x) \incl x) ).
Proof.
intro H.
destruct H as [x A].
unfold "\incl" in A.
assert (H1 : not(x\in x)).
+ intro w.
  assert (G : x \in (singl x) ).
  * apply singl_intro.
  * destruct (regularity_ax _ _ G) as [z J C].
    apply C.
    exists x.
    trivial.
    rewrite -> (singl_elim _ _ J).
    trivial.
+ apply H1.
  apply (A x).
  apply power_intro.
  trivial.
Defined.

(* END OF PROOFS *)
(*
(*
Check (@eq_elim).
Check symmetry H.
Check (@eq_elim _ _ _ H).
pose (A := fun r => @eq_elim r _ _ H).
(*pose (B := fun r => @eq_elim r _ _ (symmetry H)).*)*)

Check regularity_ax (singl x) x.

destruct (regularity_ax x (x) w) as [z J C].
apply C.
exists x.
trivial.

pose (M1:=B x w).
pose (M2:=B z J).
rewrite <- H in M1.

%change x with (power x) in M1.
pose (M1:=B x w).

pose (eq_intro)

Theorem thm: not (exists x:set, ((power x) \incl x) ).
Proof.
intro H.
destruct H.
Print power.
unfold "\incl" in H.
assert (H1 : not(x\in x)).
Focus 2.
+ apply H1.
  apply (H x).
  apply power_intro.
  trivial.
+ intro w.
  pose(u:= minus2 x (singl x)).
  (*pose(u:= subset x (fun y => y \in singl x)).*)
  destruct (regularity_ax x x w).

  (*destruct (regularity_ax x x w).*)
  apply H1.
  exists u.
  admit.

  trivial.
  trivial.
  constructor.

Check (H x).
*)


From Equations Require Import Equations.

Require Import Coq.Arith.PeanoNat.
Require Import Coq.Lists.List.

Require Export SystemFR.ErasedLet2.
Require Export SystemFR.ReducibilityOpenEquivalent.

Opaque reducible_values.
Opaque makeFresh.

Lemma reducible_left:
  forall ρ t A B,
    valid_interpretation ρ ->
    [ ρ ⊨ t : A ] ->
    [ ρ ⊨ tleft t : T_sum A B ].
Proof.
  unfold reduces_to; steps.
  eexists; steps; eauto with cbvlemmas;
    repeat step || simp_red || t_closing; eauto with values.
Qed.

Lemma open_reducible_left:
  forall Θ Γ t A B,
    [ Θ; Γ ⊨ t : A ] ->
    [ Θ; Γ ⊨ tleft t : T_sum A B ].
Proof.
  unfold open_reducible; steps; eauto using reducible_left.
Qed.

Lemma reducible_right:
  forall ρ t A B,
    valid_interpretation ρ ->
    [ ρ ⊨ t : B ] ->
    [ ρ ⊨ tright t : T_sum A B ].
Proof.
  unfold reduces_to; steps.
  eexists; steps; eauto with cbvlemmas;
    repeat step || simp_red || t_closing; eauto with values.
Qed.

Lemma open_reducible_right:
  forall Θ Γ t A B,
    [ Θ; Γ ⊨ t : B ] ->
    [ Θ; Γ ⊨ tright t : T_sum A B ].
Proof.
  unfold open_reducible; steps; eauto using reducible_right.
Qed.

Lemma open_reducible_sum_match:
  forall Θ Γ t tl tr T1 T2 T y p,
    subset (fv t) (support Γ) ->
    subset (fv tl) (support Γ) ->
    subset (fv tr) (support Γ) ->
    subset (fv T1) (support Γ) ->
    subset (fv T2) (support Γ) ->
    subset (fv T) (support Γ) ->
    wf T 1 ->
    wf T1 0 ->
    wf T2 0 ->
    wf t 0 ->
    wf tr 1 ->
    wf tl 1 ->
    ~(y ∈ fv_context Γ) ->
    ~(y ∈ fv T) ->
    ~(y ∈ fv T1) ->
    ~(y ∈ fv T2) ->
    ~(y ∈ pfv T term_var) ->
    ~(p ∈ pfv_context Γ term_var) ->
    ~(p ∈ pfv t term_var) ->
    ~(p ∈ pfv T1 term_var) ->
    ~(p ∈ pfv T2 term_var) ->
    ~(p ∈ pfv T term_var) ->
    ~(p = y) ->
    is_erased_term t ->
    is_erased_term tl ->
    is_erased_term tr ->
    is_erased_type T ->
    [ Θ; Γ ⊨ t : T_sum T1 T2 ] ->
    [ Θ; (p, T_equiv t (tleft (fvar y term_var))) :: (y, T1) :: Γ ⊨
        open 0 tl (fvar y term_var) : open 0 T (tleft (fvar y term_var)) ] ->
    [ Θ; (p, T_equiv t (tright (fvar y term_var))) :: (y, T2) :: Γ ⊨
        open 0 tr (fvar y term_var) : open 0 T (tright (fvar y term_var)) ] ->
    [ Θ; Γ ⊨ sum_match t tl tr : open 0 T t ].
Proof.
  unfold open_reducible; repeat step || t_instantiate_sat3 || top_level_unfold reduces_to || simp_red || t_substitutions.

  - eapply reducibility_rtl; eauto; t_closer.

    unshelve epose proof (H27 ρ ((p, uu) :: (y,v') :: lterms) _ _ _);
      repeat step || apply SatCons || list_utils || t_substitutions || simp_red ||
             t_values_info2 || t_deterministic_star;
      try solve [ equivalent_star ];
      t_closer;
      eauto with twf.

    eapply star_backstep_reducible; eauto with cbvlemmas;
      repeat step || list_utils; t_closer.
    eapply backstep_reducible; eauto with smallstep;
      repeat step || list_utils; t_closer.

  - eapply reducibility_rtl; eauto; t_closer.

    unshelve epose proof (H28 ρ ((p, uu) :: (y,v') :: lterms) _ _ _);
      repeat step || apply SatCons || list_utils || t_substitutions || simp_red ||
             t_values_info2 || t_deterministic_star;
      try solve [ equivalent_star ];
      t_closer;
      eauto with twf.

    eapply star_backstep_reducible; eauto with cbvlemmas;
      repeat step || list_utils; t_closer.
    eapply backstep_reducible; eauto with smallstep;
      repeat step || list_utils; t_closer.
Qed.


Require Import MapProofs.Common.
Set Bullet Behavior "Strict Subproofs".
Require Import MapProofs.Bounds.
Require Import MapProofs.Tactics.
Require Import MapProofs.UnionIntersectDifferenceProofs.
Require Import MapProofs.LookupProofs.
Require Import MapProofs.InsertProofs.
Require Import MapProofs.DeleteUpdateProofs.
Require Import MapProofs.ToListProofs.
Require Import MapProofs.FilterPartitionProofs.
Require Import MapProofs.MaxMinProofs.
Require Import Coq.Classes.Morphisms.

Section WF_Part1.
Context {e : Type} {a b : Type} {HEq : Eq_ e} {HOrd : Ord e} {HEqLaws : EqLaws e}  {HOrdLaws : OrdLaws e}.

(* The following theorems are the theorems about containers, used by
   [examples/ghc]. Some are slightly modified, such as adding the condition that
   the function in filter respects equality and using Haskell equality on maps
   rather than Coq equality. I have noted where the definitions are changed
   Also, in nearly every theorem, I had to add the hypothesis that the map is
   Bounded. *)

(* First, the following are lemmas that are used in proving various theorems. *)

(* Simpler definition of lookup *)
Fixpoint lookup' (key : e) (map : Map e a) : option a :=
  match map with
  | Tip => None
  | Bin sz k1 v1 lt rt => match compare key k1 with
                          | Eq => Some v1
                          | Lt => lookup' key lt
                          | Gt => lookup' key rt
                          end
 end.

(* Prove the two definitions are equivalent *)
Lemma lookup_lookup'_equiv : forall  (key : e) (map : Map e a),
    lookup key map = lookup' key map.
Proof.
  intros. induction map.
  - simpl. destruct (compare key k); try (reflexivity); assumption.
  - simpl. reflexivity.
Qed.

(* Follows from sem_inside, says that if a key is in a map, it is between the
   bounds *)
Lemma keys_inside_bounds : forall (map: Map e a) key lb ub,
  Bounded map lb ub ->
  member key map = true ->
  isLB lb key = true /\ isUB ub key = true .
Proof.
  intros. eapply member_spec in H0. destruct H0.
  eapply sem_inside. apply H. apply H0. apply H.
Qed.

(* This function represents sem on a filtered map. It is needed when we have
   goals about filterWithKey in the hypothesis, since filterWithKey_Desc only
   works on the goal *)
Fixpoint sem_filter (m: Map e a) f i:=
  match m with
  |Tip => None
  |Bin _ k v m1 m2 => match compare i k with
                     | Lt => sem_filter m1 f i
                     | Eq => SomeIf (f k v) v
                     | Gt => sem_filter m2 f i
                    end
  end.

(* Proves the equivalence of this function with using sem on the filtered map
  directly *)
Lemma sem_filter_equiv: forall m lb ub key f,
  Bounded m lb ub ->
  Proper ((fun (i j : e) => _GHC.Base.==_ i j = true) ==> eq) f ->
  sem (filterWithKey f m) key = sem_filter m f key.
Proof.
  intros. induction H.
  - simpl. reflexivity.
  - eapply filterWithKey_Desc. apply BoundedBin. apply H. apply H1. apply H2. apply H3.
    apply H4. apply H5. apply H0. intros. simpl in *. specialize (H8 key).
    destruct (compare key x) eqn : ?.
    + assert (key == x = true) by (order e). rewrite H9 in H8.
      assert (sem s1 key = None). eapply sem_outside_above. apply H. solve_Bounds e. rewrite H10 in H8.
      simpl in H8. unfold SomeIf. assert (f x v = f key v). apply equal_f. apply H0. order e.
      rewrite H11. assumption.
    + rewrite <- IHBounded1. eapply filterWithKey_Desc. apply H. apply H0. intros.
      specialize (H11 key). destruct (sem s1 key) eqn : ?. simpl in H8.
      rewrite <- H8 in H11. symmetry. assumption.
      assert (key == x = false) by (order e). rewrite H12 in H8. assert (sem s2 key = None).
      eapply sem_outside_below. apply H1. solve_Bounds e. rewrite H13 in H8. simpl in H8.
      rewrite H8. symmetry. assumption.
    + assert (sem s1 key = None). eapply sem_outside_above. apply H. solve_Bounds e. rewrite H9 in H8.
      simpl in H8. assert (key == x = false) by (order e). rewrite H10 in H8; simpl in H8.
      rewrite <- IHBounded2. eapply filterWithKey_Desc. apply H1. apply H0. intros.
      specialize (H13 key). rewrite <- H13 in H8. apply H8.
Qed.

(* If a key, value pair is in the filtered map, it was in the original map *)
Lemma filterPreservesValues: forall (m: Map e a) lb ub f,
  Bounded m lb ub ->
  Proper ((fun (i j : e) => _GHC.Base.==_ i j = true) ==> eq) f ->
  forall i v, sem (filterWithKey f m) i = Some v -> sem m i = Some v.
Proof.
  intros. rewrite (sem_filter_equiv m lb ub i f H) in H1. induction H.
  - simpl in H1. inversion H1.
  - simpl in H1. simpl. destruct (compare i x) eqn : ?.
    + assert (i == x = true) by (order e). rewrite H7. simpl. assert (sem s1 i = None).
      eapply sem_outside_above. apply H. solve_Bounds e. rewrite H8. unfold SomeIf in H1. simpl.
      destruct (f x v0). assumption. inversion H1.
    + apply IHBounded1 in H1. rewrite H1. reflexivity.
    + assert (sem s1 i = None). eapply sem_outside_above. apply H. solve_Bounds e. rewrite H7.
      assert (i == x = false) by (order e). rewrite H8. simpl. apply IHBounded2.
      assumption.
  - assumption.
Qed.

(* If a key, value pair is in the filtered map, the function returns true on the
   pair *)
Lemma filter_sem_true: forall (m: Map e a) lb ub f,
  Bounded m lb ub ->
  Proper ((fun (i j : e) => _GHC.Base.==_ i j = true) ==> eq) f ->
  forall i v, sem (filterWithKey f m) i = Some v -> f i v = true.
Proof.
  intros. rewrite (sem_filter_equiv _ lb ub) in H1. induction H.
  - simpl in H1. inversion H1.
  - simpl in H1. destruct (compare i x) eqn : ?.
    + unfold SomeIf in H1. destruct (f x v0) eqn : ?.
      rewrite <- Heqb0. inversion H1; subst. eapply equal_f. apply H0. order e. inversion H1.
    + apply IHBounded1. apply H1.
    + apply IHBounded2. apply H1.
  - assumption.
  - assumption.
Qed.

(* Conversely, if a key, value pair was in the map and not in the filtered map,
   f k v is false *)
Lemma filter_sem_false: forall (m: Map e a) lb ub f,
  Bounded m lb ub ->
  Proper ((fun (i j : e) => _GHC.Base.==_ i j = true) ==> eq) f ->
  forall i v, sem m i = Some v ->
   sem (filterWithKey f m) i = None -> f i v = false.
Proof.
  intros. rewrite (sem_filter_equiv _ lb ub) in H2. induction H.
  - simpl in H1. inversion H1.
  - simpl in H2. destruct (compare i x) eqn : ?.
    + unfold SomeIf in H2. destruct (f x v0) eqn : ?. inversion H2.
      rewrite <- Heqb0. simpl in H1. assert (sem s1 i = None). { eapply sem_outside_above. apply H.
      solve_Bounds e. } rewrite H8 in H1. simpl in H1. assert (i == x = true) by (order e).
      rewrite H9 in H1. inversion H1; subst. eapply equal_f. apply H0. assumption.
    + simpl in H1. destruct (sem s1 i) eqn : ?. inversion H1; subst. apply IHBounded1.
      reflexivity. assumption. assert (i == x = false) by (order e). assert (sem s2 i = None). {
      eapply sem_outside_below. apply H3. solve_Bounds e. } rewrite H8 in H1. rewrite H9 in H1.
      inversion H1.
    + simpl in H1. assert (sem s1 i = None). { eapply sem_outside_above. apply H. solve_Bounds e. }
      assert (i == x = false) by (order e). rewrite H8 in H1. rewrite H9 in H1. simpl in H1.
      apply IHBounded2. assumption. assumption.
  - assumption.
  - assumption.
Qed.

(* This is similar for intersection. This allows us to work with [sem
   (intersection _)] in a hypothesis *)
Definition sem_intersect (m1: Map e a)(m2: Map e b) i :=
  match (sem m1 i), (sem m2 i) with
  | Some v, Some v2 => Some v
  | _, _ => None
  end.

(*Proves equaivalence*)
Lemma sem_intersect_equiv: forall m1 m2 lb ub key,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  sem (intersection m1 m2) key = sem_intersect m1 m2 key.
Proof.
  intros. applyDesc e (@intersection_Desc e a). specialize (Hsem key).
  destruct (sem m1 key ) eqn : ?. destruct (sem m2 key) eqn: ?.
  simpl in Hsem. unfold sem_intersect. rewrite Heqo. rewrite Heqo0. assumption.
  simpl in Hsem. unfold sem_intersect. rewrite Heqo. rewrite Heqo0. assumption.
  unfold sem_intersect. rewrite Heqo. destruct (sem m2 key); simpl in Hsem; assumption.
Qed.

(*Same for [union]*)
Definition sem_union (m1: Map e a)(m2: Map e a) i :=
  match (sem m1 i), (sem m2 i) with
  | Some v, _ => Some v
  | _, Some v2 => Some v2
  | _, _ => None
  end.

Lemma sem_union_equiv: forall m1 m2 lb ub key,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  sem (union m1 m2) key = sem_union m1 m2 key.
Proof.
  intros. applyDesc e (@union_Desc e a). specialize (Hsem key). unfold sem_union.
  destruct (sem m1 key) eqn : ?. destruct (sem m2 key) eqn : ?.
  - simpl in Hsem. assumption.
  - rewrite oro_None_r in Hsem. assumption.
  - simpl in Hsem. rewrite Hsem. destruct (sem m2 key); reflexivity.
Qed.

(*If a value is in a map and f returns true on the key, value, then sem_filter will also
return that value (that is to say, the result is in the filtered map)*)
Lemma sem_filter_in_map: forall key value map lb ub f,
  Bounded map lb ub ->
  Proper ((fun (i j : e) => _GHC.Base.==_ i j = true) ==> eq) f ->
  sem map key = Some value ->
  f key value = true ->
  sem_filter map f key = Some value.
Proof.
  intros. induction H.
  - inversion H1.
  - simpl. simpl in H1. destruct (compare key x) eqn : ?.
     + assert (sem s1 key = None). eapply sem_outside_above. apply H. solve_Bounds e.
       rewrite H8 in H1. assert (key == x = true) by (order e). rewrite H9 in H1.
        simpl in H1. inversion H1; subst. assert (f x value = f key value).
        apply equal_f. apply H0. order e. rewrite H6.
        rewrite H2. simpl. reflexivity.
      + apply IHBounded1. destruct (sem s1 key). inversion H1; subst; reflexivity.
        destruct (key == x) eqn : ?. order e. destruct (sem s2 key) eqn : ?. solve_Bounds e.
        inversion H1.
      + apply IHBounded2. destruct (sem s1 key) eqn : ?. solve_Bounds e.
        destruct (key == x) eqn : ?. order e. simpl in H1. apply H1.
Qed.

Lemma eq_coq_implies_haskell : forall {a} `{EqLaws a} (x y : a),
  x = y -> x == y = true.
Proof.
  intros. subst. apply Eq_Reflexive.
Qed.

Lemma fst_partition_sem: forall m P key lb ub,
  Bounded m lb ub ->
  Proper ((fun (i j : e) => _GHC.Base.==_ i j = true) ==> eq) P ->
  sem (fst (partitionWithKey P m)) key = sem_filter m P key.
Proof.
  intros. induction H.
  - reflexivity.
  - apply (partitionWithKey_spec _ _ lb ub).
    + apply BoundedBin; assumption.
    + assumption.
    + intros. simpl. simpl in H6. apply H6. intros. destruct (compare key x) eqn : ?.
      * specialize (H9 key). assert (sem s1 key = None). eapply sem_outside_above. apply H.
        solve_Bounds e. rewrite H10 in H9. simpl in H9. assert (key == x = true) by (order e).
        rewrite H11 in H9. simpl in H9. unfold SomeIf. assert (P key v = P x v).
        apply equal_f. apply H0. apply H11. rewrite <- H12. apply H9.
      * rewrite <- IHBounded1. eapply partitionWithKey_spec. apply H. apply H0. intros.
        simpl. apply H10. intros. specialize (H13 key). specialize (H9 key).
        destruct (sem s1 key) eqn : ?. simpl in H9.
        rewrite H9. rewrite H13. reflexivity. assert (key == x = false) by (order e).
        assert (sem s2 key = None). eapply sem_outside_below. apply H1. solve_Bounds e.
        rewrite H14 in H9. rewrite H15 in H9. simpl in H9. rewrite H9. rewrite H13.
        reflexivity.
      * rewrite <- IHBounded2. eapply partitionWithKey_spec. apply H1. apply H0. intros.
        simpl. apply H10. intros. specialize (H13 key). specialize (H9 key).
        assert (sem s1 key = None). eapply sem_outside_above. apply H. solve_Bounds e.
        assert (key == x = false) by (order e). rewrite H14 in H9. rewrite H15 in H9.
        simpl in H9. rewrite H13. rewrite H9. reflexivity.
Qed.

Lemma snd_partition_sem: forall m P key lb ub,
  Bounded m lb ub ->
  Proper ((fun (i j : e) => _GHC.Base.==_ i j = true) ==> eq) P ->
  sem (snd (partitionWithKey P m)) key = sem_filter m (fun a b => negb( P a b)) key.
Proof.
  intros. induction H.
  - reflexivity.
  - apply (partitionWithKey_spec _ _ lb ub).
    + apply BoundedBin; assumption.
    + assumption.
    + intros. simpl. simpl in H6. apply H6. intros. destruct (compare key x) eqn : ?.
      * specialize (H9 key). assert (sem s1 key = None). eapply sem_outside_above. apply H.
        solve_Bounds e. rewrite H10 in H9. simpl in H9. assert (key == x = true) by (order e).
        rewrite H11 in H9. simpl in H9. unfold SomeIf. assert (P key v = P x v).
        apply equal_f. apply H0. apply H11. rewrite <- H12. destruct (P key v) eqn : ?;
        simpl; apply H9.
      * rewrite <- IHBounded1. eapply partitionWithKey_spec. apply H. apply H0. intros.
        simpl. apply H10. intros. specialize (H13 key). specialize (H9 key).
        destruct (sem s1 key) eqn : ?. simpl in H9.
        rewrite H9. rewrite H13. reflexivity. assert (key == x = false) by (order e).
        assert (sem s2 key = None). eapply sem_outside_below. apply H1. solve_Bounds e.
        rewrite H14 in H9. rewrite H15 in H9. simpl in H9. rewrite H9. rewrite H13.
        reflexivity.
      * rewrite <- IHBounded2. eapply partitionWithKey_spec. apply H1. apply H0. intros.
        simpl. apply H10. intros. specialize (H13 key). specialize (H9 key).
        assert (sem s1 key = None). eapply sem_outside_above. apply H. solve_Bounds e.
        assert (key == x = false) by (order e). rewrite H14 in H9. rewrite H15 in H9.
        simpl in H9. rewrite H13. rewrite H9. reflexivity.
Qed.

Lemma partitionPreservesNone: forall m lb ub f,
  Bounded m lb ub ->
  forall i, sem m i = None -> sem_filter m f i = None.
Proof.
  intros. induction H.
  - reflexivity.
  - simpl. simpl in H0. destruct (compare i x) eqn : ?.
   + destruct (sem s1 i). inversion H0. assert (i == x = true) by (order e).
    rewrite H6 in H0. simpl in H0. inversion H0.
   + destruct (sem s1 i). inversion H0. destruct (i == x) eqn : ?.
     inversion H0. order e.
   + destruct (sem s1 i). inversion H0. destruct (i == x) eqn : ?. inversion H0.
     destruct (sem s2 i) eqn : ?. inversion H0. apply IHBounded2. reflexivity.
Qed.

(*If a key, value pair is in the filtered map, it was in the original map*)
Lemma partitionPreservesValues: forall m lb ub f,
  Bounded m lb ub ->
  forall i v, sem_filter m f i = Some v -> sem m i = Some v.
Proof.
  intros. induction H.
  - inversion H0.
  - simpl. destruct (compare i x) eqn : ?.
    + assert (sem s1 i = None). eapply sem_outside_above. apply H. solve_Bounds e.
      simpl in H0. rewrite Heqc in H0. rewrite H6. simpl. assert (i == x = true) by (order e).
      rewrite H7. simpl. destruct (f x v0). assumption. inversion H0.
    + simpl in H0. rewrite Heqc in H0. destruct (sem s1 i) eqn : ?. simpl.
      apply IHBounded1. apply H0. eapply partitionPreservesNone in Heqo.
      rewrite Heqo in H0. congruence. eassumption.
    + simpl in H0. rewrite Heqc in H0. assert (sem s1 i = None).
      eapply sem_outside_above.
      apply H. solve_Bounds e. rewrite H6.
      assert (i == x = false) by (order e). rewrite H7.
      simpl. apply IHBounded2. assumption.
Qed.

(*Same as above, but for intersection*)
Lemma sem_intersection: forall (m1 : Map e a) (m2 : Map e b) key lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  sem (intersection m1 m2) key = ando' (sem m1 key) (sem m2 key).
Proof.
  intros. applyDesc e (@intersection_Desc e a). apply Hsem.
Qed.

(*null is true iff m is empty*)
Lemma null_empty_iff: forall (m: Map e a),
  null m = true <-> m = empty.
Proof.
  intros; split; intros.
  - destruct m. inversion H. reflexivity.
  - rewrite H. reflexivity.
Qed.

(*Same as other sem definitions but for insert*)
Lemma sem_insert: forall (m1: Map e a) key value lb ub i,
  Bounded m1 lb ub ->
  isLB lb key = true ->
  isUB ub key = true ->
  sem (insert key value m1) i = SomeIf (i == key) value ||| sem m1 i.
Proof.
  intros. applyDesc e (@insert_Desc e a). unfold SomeIf. apply Hsem.
Qed.

(*Same but for for difference*)
Lemma difference_sem: forall (m1: Map e a) m2 lb ub key,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  sem (difference m1 m2) key = diffo (sem m1 key) (sem m2 key).
Proof.
  intros. eapply difference_Desc. apply H. apply H0. intros.
  rewrite H4. reflexivity.
Qed.

End WF_Part1.

Section WF_Part2.

Context {e : Type} {a b : Type} {HEq : Eq_ e} {HOrd : Ord e} {HEqLaws : EqLaws e}  {HOrdLaws : OrdLaws e}.

(*Start of ContainerFacts *)

(*This lemma says that if two keys are equal, then the result of member is the same when either is called*)
Lemma member_eq: forall {a : Type} (n : e) (n' : e) (m : Map e a),
  n == n' = true ->
  member n m = member n' m.
Proof.
  intros.
 induction m.
   - simpl. destruct (compare n k) eqn : E.
    + assert (compare n' k = Eq) by (order e). rewrite H0. reflexivity.
    + assert (compare n' k = Lt) by (order e). rewrite H0. assumption.
    + assert (compare n' k = Gt) by (order e). rewrite H0. assumption.
  - reflexivity.
Qed.

(*If we insert a (key, value) in a map, then looking up the key gives the value. *)
Lemma lookup_insert : forall (key: e) (value : a) (map : Map e a) lb ub,
  Bounded map lb ub ->
  isLB lb key = true ->
  isUB ub key = true ->
  lookup key (insert key value map) = Some value.
Proof.
  intros. applyDesc e (@insert_Desc e a). erewrite lookup_spec. specialize (Hsem key).
  rewrite Eq_Reflexive in Hsem. simpl in Hsem. assumption. apply HB.
Qed.

(*A more general version that makes it explicit that the keys do not have to be bounded*)
Lemma lookup_insert': forall key value (m: Map e a),
  WF m ->
  lookup key (insert key value m) = Some value.
Proof.
  intros. eapply lookup_insert. apply H. reflexivity. reflexivity.
Qed.

(*If we lookup a key key1, the result is the same regardless of whether or not we have inserted key2
(a different key than key1). I had to  change the 4th hypothesis to Haskell equality*)
Lemma lookup_insert_neq : forall (key1: e) (key2: e) (value : a) (map : Map e a) lb ub,
  Bounded map lb ub ->
  isLB lb key2 = true ->
  isUB ub key2 = true ->
  key1 == key2 = false ->
  lookup key1 (insert key2 value map) = lookup key1 map.
Proof.
  intros. applyDesc e (@insert_Desc e a). specialize (Hsem key1). rewrite H2 in Hsem.
  simpl in Hsem. erewrite lookup_spec.  erewrite lookup_spec. apply Hsem. apply H. apply HB.
Qed.

Lemma lookup_insert_neq': forall key1 key2 value (m: Map e a),
  WF m ->
  key1 == key2 = false ->
  lookup key1 (insert key2 value m) = lookup key1 m.
Proof.
  intros. eapply lookup_insert_neq. apply H. reflexivity. reflexivity. assumption.
Qed.

(*States that if we check for key1 in the map in which we have inserted key2, then either
key1 was already in the map, or key1 == key2. *)
Lemma member_insert: forall key1 key2 value (map: Map e a) lb ub,
  Bounded map lb ub ->
  isLB lb key2 = true ->
  isUB ub key2 = true ->
  member key1 (insert key2 value map) = (key1 == key2) || member key1 map.
Proof.
  intros. applyDesc e (@insert_Desc e a). destruct (member key1 s) eqn : ?.
  - erewrite member_spec in Heqb0. destruct Heqb0. specialize (Hsem key1). destruct (key1 == key2).
    reflexivity. simpl in Hsem. simpl. symmetry. erewrite member_spec. exists x.
    rewrite <- Hsem. assumption. apply H. apply HB.
  - specialize (Hsem key1). destruct (key1 == key2). simpl in Hsem.
    assert (member key1 s = true). { erewrite member_spec. exists value. assumption. apply HB. }
    rewrite Heqb0 in H2. inversion H2. simpl. simpl in Hsem.
    assert (sem s key1 = None). { erewrite <- notMember_spec. unfold notMember. rewrite negb_true_iff.
    assumption. apply HB. } rewrite Hsem in H2. erewrite <- notMember_spec in H2.
    unfold notMember in H2. rewrite negb_true_iff in H2. symmetry. assumption. apply H.
Qed.

Lemma member_insert': forall key1 key2 value (map: Map e a),
  WF map ->
  member key1 (insert key2 value map) = (key1 == key2) || member key1 map.
Proof.
  intros. eapply member_insert; try (eassumption); try(reflexivity).
Qed.

(*If we lookup a key that is deleted, we should get None*)
Lemma delete_eq : forall key (map : Map e a) lb ub,
  Bounded map lb ub ->
  lookup key (delete key map) = None.
Proof.
  intros. applyDesc e (@delete_Desc e a). specialize (Hsem key). rewrite Eq_Reflexive in Hsem. rewrite <- Hsem.
  eapply lookup_spec. apply HB.
Qed.

(*If we delete a key key2 and then lookup a different key key1, then it should be the same regardless of
whether or not key2 was deleted. I had the change the 2nd hypothesis to use Haskell equality*)
Lemma delete_neq : forall key1 key2 (map : Map e a) lb ub,
  Bounded map lb ub ->
  key1 == key2 = false ->
  lookup key1 (delete key2 map) = lookup key1 map.
Proof.
  intros. applyDesc e (@delete_Desc e a). erewrite lookup_spec. erewrite lookup_spec.
  specialize (Hsem key1). rewrite H0 in Hsem. assumption. apply H. apply HB.
Qed.

(*Same as above but for member. I also had to change the 2nd hypothesis to Haskell equality.*)
Lemma member_delete_neq: forall key1 key2 (map: Map e a) lb ub,
  Bounded map lb ub ->
  key1 == key2 = false ->
  member key2 (delete key1 map) = member key2 map.
Proof.
  intros. applyDesc e (@delete_Desc e a). specialize (Hsem key2).
  assert (key2 == key1 = false) by (order e). rewrite H1 in Hsem. destruct (member key2 s) eqn : ?.
  - erewrite member_spec in Heqb0. destruct Heqb0. rewrite H2 in Hsem. symmetry. erewrite member_spec.
    exists x. symmetry in Hsem. assumption. apply H. apply HB.
  - assert (notMember key2 s = true). { unfold notMember. apply negb_true_iff. assumption. }
    erewrite notMember_spec in H2. rewrite H2 in Hsem. symmetry in Hsem. erewrite <- notMember_spec in Hsem.
    unfold notMember in Hsem. rewrite negb_true_iff in Hsem. symmetry. assumption. apply H. apply HB.
Qed.

(*States that if a key is not in the map, then looking it up will give None, and vice versa. I had to change
the condition to an iff rather than equality.*)
Lemma non_member_lookup :
  forall key (map: Map e a) lb ub,
  Bounded map lb ub ->
  (member key map = false) <-> (lookup key map = None).
Proof.
  intros. assert (notMember key map = true <-> member key map = false). { unfold notMember.
  rewrite negb_true_iff. reflexivity. } rewrite <- H0. erewrite lookup_spec.
  eapply notMember_spec. apply H. apply H.
Qed.

(*If two keys are equal (according to the Eq typeclass), then their values in
a map are equal*)
Lemma lookup_eq : forall k k' (m : Map e a),
    k == k' = true ->
    lookup k m = lookup k' m.
Proof.
  intros.
 induction m.
  - simpl. destruct (compare k k0) eqn : E.
    + assert (compare k' k0 = Eq) by (order e). rewrite H0. reflexivity.
    + assert (compare k' k0 = Lt) by (order e). rewrite H0. assumption.
    + assert (compare k' k0 = Gt) by (order e). rewrite H0. assumption.
  - reflexivity.
Qed.

(*This follows almost immediately from member_spec. I also had to change it to an iff rather
than equality*)
Lemma member_lookup :
  forall key (map: Map e a) lb ub,
  Bounded map lb ub ->
  (member key map = true) <-> (exists value, lookup key map = Some value).
Proof.
  intros. assert(A:=H). eapply member_spec in A. eapply lookup_spec in H.
  rewrite <- H in A. apply A.
Qed.

(** ** Verification of [null] *)
Lemma null_empty:
    @null e a empty = true.
Proof.
  unfold null. simpl. reflexivity.
Qed.

(*A key is a member of the union of two maps whenever it is a member of at least one of the maps*)
Lemma member_union :
  forall key (map1: Map e a) map2 lb ub,
  Bounded map1 lb ub ->
  Bounded map2 lb ub ->
  member key (union map1 map2) = member key map2 || member key map1.
Proof.
  intros. applyDesc e (@union_Desc e a). specialize (Hsem key). destruct (member key s) eqn : ?.
  - erewrite member_spec in Heqb0. destruct Heqb0. rewrite H1 in Hsem. destruct (sem map1 key) eqn : ?.
    inversion Hsem; subst. assert (member key map1 = true). { erewrite member_spec.
    exists a0. assumption. apply H. } rewrite H2. rewrite orb_true_r. reflexivity.
    simpl in Hsem. assert (member key map2 = true). { erewrite member_spec. exists x. symmetry.
    assumption. apply H0. } rewrite H2. reflexivity. apply HB.
  - rewrite <- negb_true_iff in Heqb0. assert (notMember key s = true). { unfold notMember.
    assumption. } eapply notMember_spec in H1. rewrite H1 in Hsem. destruct (sem map1 key) eqn : ?.
    inversion Hsem. destruct (sem map2 key) eqn : ?. inversion Hsem.
    erewrite <- notMember_spec in Heqo. erewrite <- notMember_spec in Heqo0.
    unfold notMember in *. rewrite negb_true_iff in *. rewrite Heqo. rewrite Heqo0. reflexivity.
    apply H0. apply H. apply HB.
Qed.

(*The union of a map with the empty map (in both directions) is itself*)
Lemma union_nil_l : forall (map: Map e a) ub lb,
  Bounded map ub lb ->
  union empty map = map.
Proof.
  intros. unfold empty. induction H.
  - reflexivity.
  - simpl. destruct s1 eqn : ?. reflexivity. destruct s2 eqn : ?. reflexivity.
    unfold insertR. unfold singleton. rewrite H3. simpl. reflexivity.
Qed.

Lemma union_nil_r : forall (map: Map e a) ub lb,
  Bounded map ub lb ->
  union map empty = map.
Proof.
  intros. induction H.
  - simpl. reflexivity.
  - simpl. destruct s1. reflexivity. destruct s2. reflexivity. reflexivity.
Qed.

(*The difference between a map and itself is the empty map*)
Lemma difference_self: forall (map: Map e a) lb ub,
  Bounded map lb ub ->
  difference map map = empty.
Proof.
  intros.
 eapply difference_Desc. apply H. apply H. intros.
  unfold diffo in H3.
  assert (forall i, sem s i = None). { intros i. specialize (H3 i).
  destruct (sem map i); assumption. } apply empty_no_elts. apply H4.
Qed.

(*The difference of a map with the empty map is itself*)
Lemma difference_nil_r: forall (B : Type) (map: Map e a) lb ub,
  Bounded map lb ub ->
  difference map (@empty e B) = map.
Proof.
  intros. inversion H.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

(*The difference of the empty map with any map is empty*)
Lemma difference_nil_l: forall  (B : Type) (map: Map e a) lb ub,
  Bounded map lb ub ->
  difference (@empty e B) map = empty.
Proof.
  intros. inversion H.
  - simpl. reflexivity.
  - simpl. unfold empty. reflexivity.
Qed.

(*If a key is in a map, the difference of the singleton map containing only that key
and the original map is empty*)
Lemma difference_Tip_member: forall (map: Map e a) (key :e) lb ub,
  Bounded map lb ub ->
  member key map = true ->
  forall (value : a), difference (singleton key value) map = empty.
Proof.
  intros. assert (A:=H0). apply (keys_inside_bounds _ _ lb ub) in H0. destruct H0.
  applyDesc e (@singleton_Desc e a). eapply difference_Desc. apply HB. apply H. intros.
  eapply empty_no_elts. intros. specialize (H5 i). specialize (Hsem i).
  destruct (i == key) eqn : ?. simpl in Hsem. rewrite Hsem in H5.
  erewrite member_spec in A. destruct A. erewrite sem_resp_eq in H6.
  rewrite H6 in H5. simpl in H5. assumption. order e. apply H. simpl in Hsem.
  rewrite Hsem in H5. destruct (sem map i); simpl in H5; assumption. apply H.
Qed.

(*For this lemma, I had to change to use Haskell equality. Even though the structure of a singleton map is
unique, we only know the key up to Haskell equality. We also had to add {EqLaws a} in order to compare the
maps *)
Lemma difference_Tip_non_member: forall `{EqLaws a} (map: Map e a) (key :e) lb ub,
  Bounded map lb ub ->
  isUB ub key = true ->
  isLB lb key = true ->
  member key map = false ->
  forall (value : a), difference (singleton key value) map == (singleton key value) = true.
Proof.
  intros. assert (Bounded (singleton key value) lb ub). apply BoundedBin; try (apply BoundedTip); try(assumption).
  simpl. reflexivity. simpl. unfold balance_prop. simpl. omega. eapply difference_Desc.
  - apply H5.
  - apply H1.
  - intros. unfold diffo in H9.
    assert( forall i : e, sem s i = SomeIf(i == key) value). { intros. specialize (H9 i).
    destruct (i == key) eqn : ?. assert (sem map i = sem map key) by (apply sem_resp_eq; assumption).
    rewrite H10 in H9. assert (sem map key = None). eapply notMember_spec.
    apply H1. unfold notMember. rewrite negb_true_iff. assumption. rewrite H11 in H9.
    unfold SomeIf. rewrite H9. rewrite (sem_resp_eq _ i key). simpl. rewrite Eq_Reflexive.
    simpl. reflexivity. apply Heqb0. simpl. destruct(sem map i) eqn : ?.
    assumption. simpl in H9. rewrite Heqb0 in H9. simpl in H9. assumption. }
    applyDesc e (@singleton_Desc e a). eapply weak_equals_spec. apply H6. apply HB.
    intros. specialize (H10 i). specialize (Hsem i). rewrite H10. rewrite Hsem.
    apply Eq_Reflexive.
Qed.

(*For filterWithKey, we need to add the assumptions that the functions we are concerned with
  respect Haskell equality. Note that the third condition follows from the first two, but only
  if we use functional extensionality. We also need to change the result to Haskell equality and
  assumpe {EqLaws a}.*)
Lemma filterWithKey_comp: forall `{EqLaws a} f f' (m: Map e a) lb ub ,
  Bounded m lb ub ->
  Proper ((fun (i j : e) => _GHC.Base.==_ i j = true) ==> eq) f ->
  Proper ((fun i j : e => _GHC.Base.==_ i j = true) ==> eq) f' ->
  Proper ((fun i j : e => _GHC.Base.==_ i j = true) ==> eq) (fun v a => f v a && f' v a) ->
  filterWithKey f (filterWithKey f' m) == filterWithKey (fun v a => f v a && f' v a) m = true.
Proof.
  intros. assert (Bounded (filterWithKey f' m) lb ub). apply filterWithKey_Bounded. apply H1.
  eapply filterWithKey_Desc. apply H5. apply H2. intros.
  eapply filterWithKey_Desc. apply H1. apply H4.
  intros.
  - eapply weak_equals_spec. apply H6. apply H9. intros.
    destruct (sem (filterWithKey f' m) i) eqn : ?.
    + specialize (H8 i). rewrite Heqo in H8.
      assert (A:= Heqo). eapply filter_sem_true in Heqo. eapply filterPreservesValues in A.
      specialize (H11 i). rewrite A in H11. rewrite Heqo in H11. rewrite andb_true_r in H11.
      rewrite H11. rewrite H8. apply Eq_Reflexive. apply H1. apply H3. apply H1. apply H3.
    + specialize (H8 i). rewrite Heqo in H8. specialize (H11 i). destruct (sem m i) eqn : ?.
      assert (f' i a0 = false). { eapply filter_sem_false. apply H1. apply H3. apply Heqo0.
      apply Heqo. } rewrite H12 in H11. rewrite andb_false_r in H11. rewrite H11. rewrite H8.
      apply Eq_Reflexive. rewrite H8. rewrite H11. apply Eq_Reflexive.
Qed.

(*We do not need any such assumptions for filter_comp (the version actually in
  ContainerFacts). However, we do use Haskell equality and assume {EqLaws a}*)
Lemma filter_comp: forall `{EqLaws a} (f: a -> bool) (f': a -> bool) (m: Map e a) lb ub ,
  Bounded m lb ub ->
  Internal.filter f (Internal.filter f' m) == Internal.filter (fun v => f v && f' v) m = true.
Proof.
  intros. unfold filter. eapply filterWithKey_comp. apply H1. unfold respectful.
  unfold Proper. intros. reflexivity. unfold respectful. unfold Proper.
  intros. reflexivity.
  - unfold respectful. unfold Proper. intros. reflexivity.
Qed.

(* This (commented out) ContainerFact is actually false, as long as the type a
   is inhabited by at least 2 nonequal elements. Since the function we use only
   depends on the value, this actually proves that [filter_insert] is false as
   well *)
Lemma filterWithKey_insert_false:forall `{EqLaws a} (key: e) (v v1: a), v == v1 = false ->
~(forall  key v lb ub f m,
  Bounded m lb ub ->
  isUB ub key = true ->
  isLB lb key = true ->
  Proper ((fun (i j : e) => _GHC.Base.==_ i j = true) ==> eq) f ->
  filterWithKey f (insert key v m) ==
  (if (f key v) then
    insert key v (filterWithKey f m)
    else filterWithKey f m) = true).
Proof.
  intros. intro contra. remember (singleton key v1) as m1. remember (fun (x : e) value => value == v1) as f1.
  assert (_GHC.Base.==_ (filterWithKey f1 (insert key v m1))
           (if f1 key v then insert key v (filterWithKey f1 m1) else filterWithKey f1 m1) = true).
  apply (contra _ _ None None).  rewrite Heqm1. unfold singleton. apply BoundedBin.
  apply BoundedTip. apply BoundedTip. solve_Bounds e. solve_Bounds e. simpl. reflexivity. simpl.
  unfold balance_prop. omega. solve_Bounds e. solve_Bounds e. rewrite Heqf1. unfold respectful.
  unfold Proper. intros. reflexivity.
  rewrite Heqm1 in H2. rewrite weak_equals_spec in H2. specialize (H2 key).
  erewrite sem_filter_equiv in H2. unfold singleton in H2. unfold insert at 1 in H2.
  assert (compare key key = Eq) by (order e). rewrite H3 in H2.
  assert (PtrEquality.ptrEq v v1 = false). { destruct (PtrEquality.ptrEq v v1) eqn : ?.
  apply PtrEquality.ptrEq_eq in Heqb0. subst. rewrite Eq_Reflexive in H1. inversion H1. reflexivity. }
  rewrite H4 in H2. rewrite andb_false_l in H2. assert (f1 key v = false). { rewrite Heqf1. order a. }
  simpl in H2. rewrite H5 in H2. rewrite H3 in H2. simpl in H2.
  assert (f1 key v1 = true). { rewrite Heqf1.  order a. } rewrite H6 in H2.
  destruct (PtrEquality.ptrEq Tip Tip). simpl in H2. rewrite Eq_Reflexive in H2. simpl in H2.
  inversion H2. simpl in H2. rewrite Eq_Reflexive in H2. simpl in H2. inversion H2.
  apply insert_WF. unfold WF. unfold singleton. apply BoundedBin. apply BoundedTip. apply BoundedTip.
  solve_Bounds e. solve_Bounds e. simpl. reflexivity. unfold balance_prop. simpl. omega.
  unfold respectful. unfold Proper. intros. rewrite Heqf1. reflexivity. apply filterWithKey_Bounded.
  apply insert_WF. applyDesc e (@singleton_Desc e a). assert (isLB None key = true) by (solve_Bounds e).
  apply H3. assert (isUB None key = true) by (solve_Bounds e). apply H3. apply HB.
  destruct (f1 key v). applyDesc e (@singleton_Desc e a). assert (isLB None key = true) by (solve_Bounds e).
  apply H3. assert (isUB None key = true) by (solve_Bounds e). apply H3.
  apply insert_WF. apply filterWithKey_Bounded. assumption. applyDesc e (@singleton_Desc e a).
   assert (isLB None key = true) by (solve_Bounds e).
  apply H3. assert (isUB None key = true) by (solve_Bounds e). apply H3. apply filterWithKey_Bounded.
  assumption.
Qed.

(*If we lookup a key in the filtered map and get Some value, we will get the
  same in the original map.  I needed to added the assumption that f is proper*)
Lemma lookup_filterWithKey:
  forall key value (m: Map e a) f lb ub,
  Bounded m lb ub ->
  Proper ((fun (i j : e) => _GHC.Base.==_ i j = true) ==> eq) f ->
  lookup key (filterWithKey f m) = Some value ->
  lookup key m = Some value.
Proof.
  intros. erewrite lookup_spec in H1. eapply filterPreservesValues in H1.
  erewrite lookup_spec. assumption. eassumption. eassumption. eassumption.
  apply filterWithKey_Bounded. eassumption.
Qed.

(*This says that filtering with the function that always returns true gives the original map. I had
  to change the result to equality of maps and add the {EqLaws} assumption due to this. *)
Lemma filter_true: forall `{EqLaws a} (m: Map e a) lb ub,
  Bounded m lb ub ->
  filter (const true) m == m = true.
Proof.
  intros. unfold filter. eapply filterWithKey_Desc. eassumption.
  unfold respectful. unfold Proper. intros. reflexivity. intros.
  eapply weak_equals_spec; try(eassumption). intros.
  simpl in H4. specialize (H4 i). destruct (sem s i). destruct (sem m i).
  inversion H4; subst; apply Eq_Reflexive. inversion H4. destruct (sem m i).
  inversion H4. apply Eq_Reflexive.
Qed.

(*If a key is in both maps, the the value in the intersection is the value in the first map.*)
Lemma lookup_intersection: forall v1 key (m1: Map e a) (m2: Map e b) lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  lookup key m1 = Some v1 /\ (exists v2, lookup key m2 = Some v2) <->
  lookup key (intersection m1 m2) = Some v1.
Proof.
  intros. split; intros.
  - applyDesc e (@intersection_Desc e a). erewrite lookup_spec. destruct H1.
    erewrite lookup_spec in H1. specialize (Hsem key). rewrite H1 in Hsem.
    destruct H2. erewrite lookup_spec in H2.  rewrite H2 in Hsem. simpl in Hsem.
    assumption. all: eassumption.
  - erewrite lookup_spec in H1. erewrite sem_intersect_equiv in H1.
    unfold sem_intersect in H1. destruct (sem m1 key) eqn : ?.
    destruct (sem m2 key) eqn : ?. inversion H1; subst.
    split. erewrite lookup_spec. assumption. eassumption. exists b0.
    erewrite lookup_spec. assumption. eassumption. inversion H1. inversion H1.
    eassumption. eassumption. applyDesc e (@intersection_Desc e a). apply HB.
Qed.

(*If a key is in the first or not in the first but in the second, the union contains
  the same value for that key*)
Lemma lookup_union:
  forall key value (m1: Map e a) m2 lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  lookup key m1 = Some value \/ (lookup key m1 = None /\ lookup key m2 = Some value) <->
  lookup key (union m1 m2) = Some value.
Proof.
  intros. split; intros.
  - applyDesc e (@union_Desc e a). erewrite lookup_spec. specialize (Hsem key). destruct H1.
    erewrite lookup_spec in H1. rewrite H1 in Hsem. simpl in Hsem. assumption. eassumption.
    destruct H1. erewrite lookup_spec in H1. erewrite lookup_spec in H2.
    rewrite H1 in Hsem. rewrite H2 in Hsem. simpl in Hsem. assumption. all: eassumption.
  - erewrite lookup_spec in H1. erewrite sem_union_equiv in H1. unfold sem_union in H1.
    destruct (sem m1 key) eqn : ?.
    + left. erewrite lookup_spec.  inversion H1; subst; assumption. eassumption.
    + destruct (sem m2 key) eqn : ?. right. split. erewrite lookup_spec.
      assumption. eassumption. erewrite lookup_spec.  inversion H1; subst; assumption. eassumption.
       inversion H1.
   + apply H.
   + apply H0.
    + applyDesc e (@union_Desc e a). apply HB.
Qed.

(*Note: had to change all to Haskell equality since that is the only information equality of maps
gives us*)
(*Also, unfortunately we need another extra hypothesis because of functional extensionality -
that the negation of P is proper as well*)
(*Also, I don't think this is actually true (the reverse direction) - it seems to
say that if lookup key m == Some value = true, then for all maps m',
we have the 3 conditions, which is not true
TODO: ASk*)
Lemma lookup_partition: forall key value (m: Map e a) m' P lb ub,
    Bounded m lb ub ->
    Bounded m' lb ub ->
    (m' = fst (partition P m) \/
     m' = snd (partition P m)) /\
    lookup key m' = Some value -> lookup key m = Some value.
Proof.
  unfold partition. intros.
  erewrite lookup_spec; [|eassumption].
  erewrite lookup_spec in H1; [|eassumption].
  destruct H1 as [[Hf | Hs] Hl].
  - rewrite Hf in Hl.
    erewrite fst_partition_sem in Hl; try eassumption.
    + eapply partitionPreservesValues.
      * eassumption.
      * eassumption.
    + intros ???. reflexivity.
  - rewrite Hs in Hl.
    erewrite snd_partition_sem in Hl; try eassumption.
    + eapply partitionPreservesValues.
      * eassumption.
      * eassumption.
    + intros ???. reflexivity.
Qed.

(*Need to have proven EqLaws for Map first, since we need to show that left = snd Partition
-> left == snd Partition, but we need equality in the hypothesis because equality of
maps does not imply bounds at all*)

Lemma lookup_partition': forall `{EqLaws a} key value map left right f lb ub,
  Bounded map lb ub ->
  Proper ((fun (i j : e) => _GHC.Base.==_ i j = true) ==> eq) f ->
  Proper ((fun (i j : e) => _GHC.Base.==_ i j = true) ==> eq) (fun a b => negb (f a b)) ->
  lookup key map = Some value ->
  (left, right) = partitionWithKey f map  ->
  lookup key left == Some value = true \/ lookup key right == Some value = true.
Proof.
  intros. assert (left = fst (partitionWithKey f map)). unfold fst. rewrite <- H5.
  reflexivity. assert (right = snd (partitionWithKey f map)). unfold snd. rewrite <- H5.
  reflexivity. assert (A :=H6). assert (A1:=H7).
  assert(forall i, sem left i =  sem (fst (partitionWithKey f map)) i). intros. rewrite H6.
  reflexivity. assert (forall i, sem right i = sem (snd (partitionWithKey f map)) i).
  rewrite H7. intros. reflexivity.
  erewrite lookup_spec in H4. erewrite lookup_spec. erewrite lookup_spec.
  - specialize (H8 key). specialize (H9 key). erewrite fst_partition_sem in H8.
    erewrite snd_partition_sem in H9. destruct (f key value) eqn : ?.
    erewrite sem_filter_in_map in H8. rewrite H8. left. apply Eq_Reflexive.
    apply H1. apply H2. apply H4. apply Heqb0.
    assert ((fun a b => negb (f a b)) key value = true). rewrite Heqb0. reflexivity.
    erewrite sem_filter_in_map in H9. rewrite H9. right. apply Eq_Reflexive.
    apply H1. apply H3. apply H4. apply H10. apply H1. apply H2. apply H1. apply H2.
  - assert (Bounded right lb ub). rewrite H7. eapply partitionWithKey_spec. apply H1.
    apply H2. intros. apply H10. intros. simpl. apply H11. apply H10.
  - assert (Bounded left lb ub). rewrite H6. eapply partitionWithKey_spec. apply H1.
    apply H2. intros. simpl. apply H10. intros. apply H11. apply H10.
  - apply H1.
Qed.

(*A key is not in m1 and m2 iff it is not in their union*)
Lemma lookup_union_None: forall key (m1: Map e a) m2 lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  lookup key m1 = None /\ lookup key m2 = None <-> lookup key (union m1 m2) = None.
Proof.
  intros. split; intros.
  - applyDesc e (@union_Desc e a). erewrite lookup_spec in H1. erewrite lookup_spec in H1. destruct H1.
    specialize (Hsem key). rewrite H1 in Hsem. rewrite H2 in Hsem. erewrite lookup_spec.
    apply Hsem. apply HB. apply H0. apply H.
  - erewrite lookup_spec in H1. erewrite sem_union_equiv in H1. erewrite lookup_spec.
    erewrite lookup_spec. unfold sem_union in H1. destruct (sem m1 key) eqn : ?.
    inversion H1. destruct (sem m2 key). inversion H1. split; reflexivity.
    apply H0. apply H. apply H. apply H0. applyDesc e (@union_Desc e a). apply HB.
Qed.

(*If the key is in the second map, it is not in the difference*)
Lemma lookup_difference_in_snd: forall key (m1: Map e a) (m2: Map e a) value lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  lookup key m2 = Some value ->
  lookup key (difference m1 m2) = None.
Proof.
  intros. eapply difference_Desc. apply H. apply H0. intros.
  specialize (H5 key). erewrite lookup_spec in H1. rewrite H1 in H5.
  simpl in H5. erewrite lookup_spec. apply H5. apply H2. apply H0.
Qed.

(*If the key is not in the second map, it is in the difference iff it is in the first map, with the same
value*)
Lemma lookup_difference_not_in_snd: forall key (m1: Map e a) (m2: Map e a) lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  lookup key m2 = None ->
  lookup key (difference m1 m2) = lookup key m1.
Proof.
  intros. eapply difference_Desc. apply H. apply H0. intros.
  erewrite lookup_spec in H1. specialize (H5 key). rewrite H1 in H5.
  simpl in H5. erewrite lookup_spec. erewrite lookup_spec. apply H5.
  apply H. apply H2. apply H0.
Qed.

(*The stronger claim in ContainerFacts (using Coq equality) is not true,
  because we may have rebalancing.  But we do have the weaker version with
  Haskell equality (and therefore {EqLaws a}) *)
Lemma delete_commute: forall `{EqLaws a} k1 k2 m lb ub,
  Bounded m lb ub ->
  delete k1 (delete k2 m) == delete k2 (delete k1 m) = true.
Proof.
  intros. eapply delete_Desc.
  - applyDesc e (@delete_Desc e a). apply HB.
  - intros. eapply delete_Desc.
    + applyDesc e (@delete_Desc e a). apply HB.
    + intros. eapply weak_equals_spec. apply H2. apply H5. intros.
      specialize (H4 i). specialize (H7 i). rewrite H4. rewrite H7.
      eapply delete_Desc. apply H1. intros. eapply delete_Desc. apply H1.
      intros. specialize (H10 i). specialize (H13 i). rewrite H10. rewrite H13.
      destruct (i == k1) eqn : ?; (destruct (i == k2); apply Eq_Reflexive).
Qed.

(*The intersection of an empty map with another map is empty*)
Lemma intersection_empty: forall (m1: Map e a) (m2: Map e b) lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  m2 = empty ->
  null (intersection m1 m2) = true.
Proof.
  intros. applyDesc e (@intersection_Desc e a). assert (forall i, sem m2 i = None).
  intros. rewrite H1. reflexivity. setoid_rewrite H2 in Hsem. simpl in Hsem.
  rewrite null_empty_iff. apply empty_no_elts. assumption.
Qed.

(*This says that the intersection of m1 and insert key value m2 is empty iff key is not in m1 and
  m1 intersection m2 is empty
  Have to add hypotheses that key are between bounds so that (insert key value m2) is still Bounded*)
Lemma null_intersection_non_member: forall (m1: Map e a) (m2: Map e b) key value lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  isLB lb key = true ->
  isUB ub key = true ->
  null (intersection m1 (insert key value m2)) = true <->
  member key m1 = false /\ null (intersection m1 m2) = true.
Proof.
  intros. split; intros.
  - applyDesc e (@intersection_Desc e a). rewrite null_empty_iff in H3. rewrite <- empty_no_elts in H3.
    assert (forall i, ando' (sem m1 i) (sem (insert key value m2) i) = None). intros.
    erewrite <- sem_intersection. apply H3. apply H. applyDesc e (@insert_Desc e b).
    assert (forall i, ando' (sem m1 i) (SomeIf (i == key) value ||| sem m2 i) = None).
    intros. erewrite <- sem_insert. apply H4. apply H0. assumption. assumption.
    assert (A:=H5). specialize (H5 key). destruct (sem m1 key) eqn : ?.
    rewrite Eq_Reflexive in H5. simpl in H5. inversion H5. split.
    + erewrite <- notMember_spec in Heqo. unfold notMember in Heqo. rewrite negb_true_iff in Heqo.
      apply Heqo. apply H.
    + assert (forall i, sem s i = None). intros. specialize (Hsem i). rewrite Hsem. specialize (A i).
      destruct (sem m1 i). unfold ando in *. destruct (sem m2   i) eqn : ?.
      destruct (i == key); inversion A. reflexivity.
      destruct (sem m2 i); reflexivity.
      rewrite null_empty_iff. apply empty_no_elts. apply H6.
  - applyDesc e (@insert_Desc e b). applyDesc e (@intersection_Desc e a). destruct H3. setoid_rewrite Hsem in Hsem0.
    rewrite null_empty_iff in H4. rewrite <- empty_no_elts in H4.
    setoid_rewrite (sem_intersection m1 m2 _ lb ub H H0) in H4.
    assert (forall i, sem s0 i = None). { intros. destruct (i == key) eqn : ?.
    - assert (sem m1 i = None). erewrite <- notMember_spec. unfold notMember.
      assert (forall a b, a == b = true -> member a m1 = member b m1). { intros.
      destruct (member b0 m1) eqn : ?. erewrite member_spec. erewrite member_spec in Heqb1.
      destruct Heqb1. exists x. erewrite sem_resp_eq. apply H6. apply H5. apply H.
      apply H. rewrite non_member_lookup. rewrite non_member_lookup in Heqb1.
      erewrite lookup_spec. erewrite lookup_spec in Heqb1. erewrite sem_resp_eq.
      apply Heqb1. apply H5. apply H. apply H. apply H. apply H. }
      apply H5 in Heqb0. rewrite Heqb0. rewrite H3. reflexivity. apply H.
      specialize (Hsem0 i). rewrite H5 in Hsem0. rewrite Heqb0 in Hsem0. simpl in Hsem0.
      apply Hsem0.
    - specialize (Hsem0 i). rewrite Heqb0 in Hsem0. simpl in Hsem0.
      rewrite H4 in Hsem0. apply Hsem0. }
      rewrite null_empty_iff. apply empty_no_elts. apply H5.
Qed.

(*If m2 intersect m2 is emtpy and m1 \ m2 is empty, then so is m1 intersection m3*)
Lemma disjoint_difference: forall (m1: Map e a) (m2: Map e a) (m3: Map e a) lb ub,
  Bounded m1 lb ub ->
  Bounded m2 lb ub ->
  Bounded m3 lb ub ->
  null (intersection m2 m3) = true ->
  null (difference m1 m2) = true ->
  null (intersection m1 m3) = true.
Proof.
  intros. applyDesc e (@intersection_Desc e a). rewrite null_empty_iff in H2.
  rewrite null_empty_iff in H3. rewrite <- empty_no_elts in H2.
  rewrite <- empty_no_elts in H3. setoid_rewrite (sem_intersection m2 m3 _ lb ub H0 H1) in H2.
  setoid_rewrite (difference_sem m1 m2 lb ub _ H H0) in H3.
  assert (forall i, sem s i = None). { intros. specialize (Hsem i).
  specialize (H2 i). specialize (H3 i). rewrite Hsem. destruct (sem m1 i).
  destruct (sem m3 i). simpl in H2. rewrite H2 in H3. simpl in H3. inversion H3.
  simpl. reflexivity. destruct (sem m3 i). simpl. reflexivity. simpl. reflexivity. }
  rewrite null_empty_iff. eapply empty_no_elts. apply H4.
Qed.

Lemma non_member_spec  : forall (s : Map e a) (lb ub : bound) (i : e),
       Bounded s lb ub -> member i s = false <-> sem s i = None.
Proof.
  intros. pose proof (member_spec s lb ub i H). destruct H0. split; intros.
  - apply contrapositive in H1. destruct (sem s i) eqn : ?. exfalso. apply H1. exists a0. reflexivity.
    reflexivity. rewrite H2. auto.
  - apply contrapositive in H0. destruct (member i s) eqn : ?; auto. contradiction. rewrite H2.
    intro. destruct H3. inversion H3.
Qed.

Lemma null_intersection_eq : forall (x1 x2 y1 y2 : Map e a) lb ub,
  Bounded x1 lb ub ->
  Bounded x2 lb ub ->
  Bounded y1 lb ub ->
  Bounded y2 lb ub ->
  (forall a, member a x1 = member a y1) ->
  (forall a, member a x2 = member a y2) ->
  null (intersection x1 x2) = null (intersection y1 y2).
Proof.
  intros. applyDesc e (@intersection_Desc e a). applyDesc e (@intersection_Desc e a).
  destruct (null s) eqn : N.
  - symmetry. rewrite null_empty_iff. rewrite null_empty_iff in N.
    rewrite <- empty_no_elts. rewrite <- empty_no_elts in N.
    intros. specialize (N i). rewrite Hsem in N. unfold ando' in N.
    destruct (sem x2 i) eqn : S. specialize (Hsem0 i). unfold ando' in Hsem0.
    rewrite <- non_member_spec in N. rewrite H3 in N. rewrite non_member_spec in N.
    rewrite Hsem0. destruct (sem y2 i). assumption. reflexivity. apply H1. apply H.
    unfold ando' in Hsem. rewrite <- non_member_spec in S.
    rewrite H4 in S. rewrite non_member_spec in S. unfold ando' in Hsem0.
    rewrite Hsem0. rewrite S. reflexivity. apply H2. apply H0.
  - unfold null in N. destruct s. remember (Bin s1 e0 a0 s2 s3) as s. assert (sem s e0 = Some a0). {
    rewrite Heqs. simpl. subst. inversion HB; subst. destruct (sem s2 e0) eqn : ?. solve_Bounds e.
    simpl. unfold SomeIf. rewrite Eq_Reflexive. reflexivity. }
    destruct (null s0) eqn : N'.
    + rewrite Hsem in H5. unfold ando' in H5. destruct (sem x2 e0) eqn : X2.
      assert (member e0 x1 = true). rewrite member_spec. exists a0. assumption.
      apply H. rewrite H3 in H6. rewrite member_spec in H6. destruct H6.
      rewrite null_empty_iff in N'. rewrite <- empty_no_elts in N'.
      specialize (N' e0). rewrite Hsem0 in N'. rewrite H6 in N'. unfold ando' in N'.
      destruct (sem y2 e0) eqn : ?. inversion N'.
      rewrite <- non_member_spec in Heqo. rewrite <- H4 in Heqo.
      rewrite non_member_spec in Heqo. rewrite Heqo in X2. inversion X2. apply H0. apply H2.
      apply H1. inversion H5.
    + reflexivity.
    + inversion N.
Qed.

End WF_Part2.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma lfind_hyp_test : (@eq natural (mult (plus (Zero) (Zero)) (Succ Zero)) (plus (mult (Zero) (Succ Zero)) (mult (Zero) (Succ Zero)))).
Admitted.
QuickChick lfind_hyp_test.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This tests the dynamic semantics of heap objects, pg. 60.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.

Require Export FormalSyntax.
Require Export DynamicSemanticsHeapObjects.
Require Export TestUtilities.
Require Export Tacticals.

Example test_get_pdot : get vi0 [] vi0.
Proof.
  apply get_pdot.
  eauto 10 with Chapter3.
Qed.

Example test_get_l: get (cpair vi0 vi1) [i_pe (i_i 0)] vi0.
Proof.
  apply get_l;
  eauto 10 with Chapter3.
Qed.

Example test_get_r:
  get (cpair vi0 vi1) [i_pe (i_i 1)] vi1.
Proof.
  apply get_r;
  eauto 10 with Chapter3.
Qed.

Example test_get_pack:
  get (pack
         (cross cint cint)
         (i_e (i_i 0))
         (etype aliases alpha A cint))
      [u_pe]
      (i_e (i_i 0)).
Proof.
  apply get_pack;
  eauto 10 with Chapter3.
Qed.

Example test_set_ip: set vi0 [] vi1 vi1.
Proof.
  apply set_ip;
  eauto 10 with Chapter3.
Qed.

Example test_set_l:
  set (cpair (i_e (i_i 0)) (i_e (i_i 1)))
      ([i_pe (i_i 0)] ++ [])
      (i_e (i_i 2))
      (cpair (i_e (i_i 2)) (i_e (i_i 1))).
Proof.
  apply set_l;
  eauto 10 with Chapter3.
Qed.

Example test_set_r:
  set (cpair (i_e (i_i 0)) (i_e (i_i 1)))
      ([i_pe (i_i 1)] ++ [])
      (i_e (i_i 2))
      (cpair (i_e (i_i 0)) (i_e (i_i 2))).
Proof.
  apply set_r;
  eauto 10 with Chapter3.
Qed.

Example test_set_pack:
  set (pack tau' v1 (etype q alpha k tau))
      (u_pe :: p0) v (pack tau' v' (etype q alpha k tau)).
Proof.
  apply set_pack;
  eauto 10 with Chapter3.
Qed.


(**
In this exercise, we prove the correctness of a spin lock module.
*)
From iris.base_logic.lib Require Import invariants.
From iris.heap_lang Require Import proofmode notation.

Ltac wp_exec := repeat (wp_pure _ || wp_load || wp_store).

Definition newlock : val := λ: <>,
  ref #false.
Definition try_acquire : val := λ: "l",
  CAS "l" #false #true.
Definition acquire : val :=
  rec: "acquire" "l" :=
    if: try_acquire "l" then #() else "acquire" "l".
Definition release : val := λ: "l",
  "l" <- #false.

(**
As shown, the spin lock is implemented as a reference to a Boolean. If the
Boolean is [true], it means some thread has acquired the lock/entered the
critical section. We initiate the lock with the value [false], which means that
the lock is initially in the unlocked state.

The most interesting function of the spin lock is [acquire], which checks if the
lock is in the unlocked state, and if not, changes the lock into [true]. Since
multiple threads could try to acquire the lock at the same time, we use the
[CAS l v w] (compare-and-set) instruction. This instruction atomically checks
if the value of the reference [l] is equal to [v], and if so, changes it into
[w] and returns [true]. If the value of [l] is unequal to [v], it leaves the
value of [l] as if, and returns [false].
*)

(**
We will prove the following lock specification in Iris:

  {{{ R }}} newlock #() {{{ lk, RET lk; is_lock lk R }}}.
  {{{ is_lock lk R }}} acquire lk {{{ RET #(); R }}}
  {{{ is_lock lk R ∗ R }}} release lk {{{ RET #(); True }}}.

Here, [is_lock lk R] is a representation predicate which says that a lock at
location [lk] guards the payload [R] described as an Iris proposition.
*)

Section proof.
  Context `{!heapG Σ}.

  (** The invariant of the lock:

  - It owns the memory location [l ↦ #b], which contain a Boolean [b],
  - If the Boolean [b] is [false] (the lock is in the unlocked state),
    then the payload [R] of the lock holds.
  *)
  Definition lock_inv (l : loc) (R : iProp Σ) : iProp Σ :=
    (∃ b : bool, l ↦ #b ∗ if b then True else R)%I.

  (** Invariants in Iris are named by a *namespace* so that several invariants
  can be opened at the same time, while guaranteeing that no invariant is opened
  twice at the same time (which would be unsound). Here, this is irrelevant,
  since acquiring and releasing a lock only requires to open one invariant.

  The namespace [lockN] of the lock invariant:
  *)
  Definition lockN : namespace := nroot .@ "lock".
  Definition is_lock (lk : val) (R : iProp Σ) : iProp Σ :=
    (∃ l: loc, ⌜ lk = #l ⌝ ∧ inv lockN (lock_inv l R))%I.

  Lemma newlock_spec_trial (R : iProp Σ):
    {{{ R }}} newlock #() {{{ lk, RET lk; is_lock lk R }}}.
  Proof.
    iIntros (A) "B C".
    unfold newlock.
    wp_lam. simpl.
    wp_alloc loc as "LOC".
    iApply "C".
    iExists _.
    iSplit.
    - iPureIntro. reflexivity.
    - Fail iMod (inv_alloc lockN _ (lock_inv loc R) with "[B LOC]") as "#Hinv".
(* Tactic failure: iMod: cannot eliminate modality  (|={?E}=> inv lockN (lock_inv loc R))%I in (inv lockN (lock_inv loc R)) *)
      red.
      rewrite seal_eq. cbn. red.
      unfold environments.of_envs. simpl.
      econstructor.
      intros.
      unfold inv.
      rewrite seal_eq. cbn.
      unfold inv_def.
  Abort.

  Lemma newlock_spec_trial (R : iProp Σ):
    {{{ R }}} newlock #() {{{ lk, RET lk; is_lock lk R }}}.
  Proof.
    iIntros (A) "B C".
    unfold newlock.
    wp_lam. simpl.
    iApply wp_fupd. (* <-------------------- "inv_alloc" needs this *)
    wp_alloc loc as "LOC".
    iApply "C".
    unfold is_lock.

    (* iAssert (|={⊤}=> True)%I with "[B LOC]" as "TMP". *)
    (* { iMod (inv_alloc lockN _ (lock_inv loc R) with "[B LOC]") as "#Hinv". *)
    (*   { iExists _. iFrame. } *)
    (*   eauto. *)
    (* } *)

    iMod (inv_alloc lockN _ (lock_inv loc R) with "[B LOC]") as "#Hinv".
    { iExists _. iFrame. }
    iModIntro.
    iExists _. iSplit; eauto.
  Qed.

  (** The main proofs. *)
  Lemma newlock_spec (R : iProp Σ):
    {{{ R }}} newlock #() {{{ lk, RET lk; is_lock lk R }}}.
  Proof.
    iIntros (Φ) "HR HΦ". iApply wp_fupd.
    wp_lam. wp_alloc l as "Hl".
    (** Use the Iris rule [inv_alloc] for allocating a lock. We put both the
    resources [HR : R] and the points-to [l ↦ #false] into the lock. *)
    iMod (inv_alloc lockN _ (lock_inv l R) with "[HR Hl]") as "#Hinv".
    { iNext. iExists false. iFrame. }
    iModIntro. iApply "HΦ". iExists l. eauto.
  Qed.

  (** *Exercise*: finish the proof below. *)
  Lemma try_acquire_spec lk R :
    {{{ is_lock lk R }}} try_acquire lk
    {{{ b, RET #b; if b is true then R else True }}}.
  Proof.
    iIntros (Φ) "#Hl HΦ". iDestruct "Hl" as (l ->) "#Hinv".
    wp_rec.
    (** Using the tactic [iInv] we open the invariant. *)
    iInv lockN as (b) "[Hl HR]" "Hclose".
    (** The post-condition of the WP is augmented with an *update* modality
    [ |={⊤ ∖ ↑lockN,⊤}=> ... ], which keeps track of the fact that we opened
    the invariant named [lockN]. We can introduce this update modality by
    closing the lock using the hypothesis:

      "Hclose" : ▷ lock_inv l R ={⊤ ∖ ↑lockN,⊤}=∗ True

    *)
    destruct b.
    - wp_cas_fail.
      iMod ("Hclose" with "[Hl]") as "Hclose_again". { iNext. iExists true. iFrame. }
      iModIntro.

      (* exercise *)

      iDestruct "HR" as "#HR". iDestruct "HR" as %HR.
      (* iSpecialize "HΦ" with #false. *)
      (* iSpecialize ("HΦ" #false). *)
      iApply "HΦ". auto.
    - wp_cas_suc. iMod ("Hclose" with "[Hl]") as "_".
      { iNext. iExists true. iFrame. }
      iModIntro.
      iApply "HΦ". auto.
  Qed.

  (** *Exercise*: prove the spec of [acquire]. Since [acquire] is a recursive
  function, you should use the tactic [iLöb] for Löb induction. Use the tactic
  [wp_apply] to use [try_acquire_spec] when appropriate. *)
  Lemma acquire_spec lk R :
    {{{ is_lock lk R }}} acquire lk {{{ RET #(); R }}}.
  Proof.
    (* exercise *)
    iIntros (P) "#LOCK PROP".
    (* iDestruct "LOCK" as (loc ->) "#INV". *)
    iLöb as "IH".
    unfold acquire.
    wp_rec. simpl.
    wp_apply (try_acquire_spec with "LOCK").
    iIntros (b) "B".
    destruct b.
    - wp_exec. iApply "PROP". iExact "B".
    - wp_if.
      iApply "IH". iNext. iApply "PROP".
  Qed.

  (** *Exercise*: prove the spec of [release]. At a certain point in this proof,
  you need to open the invariant. For this you can use:

    iInv lockN as (b) "[Hl HR]" "Hclose".

  In the same way as in the proof of [try_acquire]. You also need to close the
  invariant. *)
  Lemma release_spec lk R :
    {{{ is_lock lk R ∗ R }}} release lk {{{ RET #(); True }}}.
  Proof.
    (* exercise *)
    iIntros (P) "[#LOCK INV0] PROP".
    iDestruct "LOCK" as (loc ->) "#INV1".
    simpl.
    Fail iInv lockN as (b) "[Hl HR]" "Hclose". (* WHY?????? *)
    simpl.
    unfold release.
    wp_lam. simpl.
    wp_exec.
    iInv lockN as (b) "[Hl HR]" "Hclose". iClear "INV1".
    wp_exec.
    iMod ("Hclose" with "[Hl INV0]") as "Hclose_again". { iNext. iExists false. iFrame. }
    iModIntro.
    iApply "PROP".
    eauto.
  Qed.

End proof.