From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C AB BC ABC Cprime BCprime : Universe, ((wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ BC O /\ (wd_ C Cprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E AB /\ (col_ O E C /\ (col_ O E BC /\ (col_ O E ABC /\ (col_ O Eprime Cprime /\ (col_ O Eprime B /\ col_ O Eprime BCprime)))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B I J K D : Universe, ((wd_ A B /\ (wd_ A D /\ (wd_ B D /\ (wd_ J A /\ (wd_ J D /\ (wd_ I B /\ (wd_ I D /\ (wd_ K A /\ (wd_ K B /\ (col_ D B J /\ (col_ D A I /\ (col_ K A B /\ (col_ I B D /\ col_ J A D))))))))))))) -> col_ A B D)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 conj19synthconj2 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus (mult lv0 lv1) lv0) (plus (mult lv1 lv0) lv0)).
Admitted.
QuickChick conj19synthconj2.


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

(***
Modulus : 2^468 - 17
Base: 58.5
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 58 + 1/2;
    bitwidth := 64;
    s := 2^468;
    c := [(1, 17)];
    carry_chains := Some [seq 0 (pred 8); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

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

    mul_code := None;

    square_code := None;

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

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


Unset Strict Universe Declaration.
(** It would be nice if we had more lax constraint checking of inductive types, and had variance annotations on their universes *)
Set Printing All.
Set Printing Implicit.
Set Printing Universes.
Set Universe Polymorphism.

Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a.
Arguments idpath {A a} , [A] a.

Notation "x = y" := (@paths _ x y) : type_scope.

Section lift.
  Let lift_type : Type.
  Proof.
    let U0 := constr:(Type) in
    let U1 := constr:(Type) in
    let unif := constr:(U0 : U1) in
    exact (U0 -> U1).
  Defined.

  Definition Lift (A : Type@{i}) : Type@{j} := A.
End lift.

Goal forall (A : Type@{i}) (x y : A), @paths@{i j} A x y -> @paths@{j k} A x y.
intros A x y p.
compute in *. destruct p. exact idpath.
Defined.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O A B C D X : Universe, ((wd_ B C /\ (wd_ A B /\ (wd_ X O /\ (wd_ A X /\ (wd_ A C /\ (wd_ X C /\ (wd_ O B /\ (wd_ O A /\ (col_ A B X /\ (col_ B X D /\ col_ A X C)))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Set Typeclasses Strict Resolution. *)
(* Set Typeclasses Unique Solutions. *)

Require Import UniDB.Spec.Core.
Require Import UniDB.Spec.Subst.
Require Import UniDB.Morph.Pair.
Require Import UniDB.Morph.Reg.
Require Import UniDB.Morph.Shifts.
Require Import UniDB.Morph.Unit.

(******************************************************************************)

Section Pointful.

  Section TrWkmComm.

    Context
      {T: Type} `{Vr T, Wk T, Tr T T, !WkVr T, !TrVr T, !TrWk T T, !TrWkmWk T T}
      {X: Type} `{Wk X, Tr T X, !TrPair T X, !TrRel T X}
      {Ξ: Type} `{Lk T Ξ, Up Ξ, !UpHom Ξ, !LkUp T Ξ}
      {Ζ: Type} `{Lk T Ζ, Up Ζ, Wkm Ζ, !UpHom Ζ, !LkUp T Ζ, !LkWkm T Ζ}.

    Lemma tr_up_wkm_comm (δ η:Dom) (x:X) (ξ: Ξ) :
      tr T X Ζ (tr T X Ξ x (up Ξ ξ δ)) (up Ζ (wkm Ζ η) δ) =
      tr T X Ξ (tr T X Ζ x (up Ζ (wkm Ζ η) δ)) (up Ξ (up Ξ ξ η) δ).
    Proof.
      rewrite !tr_pair; apply tr_rel_pw.
      change (up Ξ ξ δ ⊗ up Ζ (wkm Ζ η) δ) with (up (Pair Ξ Ζ) (ξ ⊗ wkm Ζ η) δ).
      change (up Ζ (wkm Ζ η) δ ⊗ up Ξ (up Ξ ξ η) δ) with (up (Pair Ζ Ξ) (wkm Ζ η ⊗ up Ξ ξ η) δ).
      apply (pointwise_up (ξ ⊗ wkm Ζ η) (wkm Ζ η ⊗ up Ξ ξ η) δ).
      constructor; intros; cbn.
      now rewrite tr_wkm_wk, lk_wkm, tr_vr, lk_up_wk.
    Qed.

    Lemma tr_up₁_wkm_comm (η:Dom) (x:X) (ξ: Ξ) :
      tr T X Ζ (tr T X Ξ x (up₁ Ξ ξ)) (up₁ Ζ (wkm Ζ η)) =
      tr T X Ξ (tr T X Ζ x (up₁ Ζ (wkm Ζ η))) (up₁ Ξ (up Ξ ξ η)).
    Proof. exact (tr_up_wkm_comm 1 η x ξ). Qed.

    Lemma tr_wkm_comm (η:Dom) (x:X) (ξ: Ξ) :
      tr T X Ζ (tr T X Ξ x ξ) (wkm Ζ η) =
      tr T X Ξ (tr T X Ζ x (wkm Ζ η)) (up Ξ ξ η).
    Proof. generalize (tr_up_wkm_comm 0 η x ξ). now rewrite !up_zero. Qed.

    Lemma tr_up_wkm₁_comm (δ:Dom) (x:X) (ξ:Ξ) :
      tr T X Ζ (tr T X Ξ x (up Ξ ξ δ)) (up Ζ (wkm₁ Ζ) δ) =
      tr T X Ξ (tr T X Ζ x (up Ζ (wkm₁ Ζ) δ)) (up Ξ (up₁ Ξ ξ) δ).
    Proof. exact (tr_up_wkm_comm δ 1 x ξ). Qed.

    Lemma tr_up₁_wkm₁_comm (x:X) (ξ: Ξ) :
      tr T X Ζ (tr T X Ξ x (up₁ Ξ ξ)) (up₁ Ζ (wkm₁ Ζ)) =
      tr T X Ξ (tr T X Ζ x (up₁ Ζ (wkm₁ Ζ))) (up₁ Ξ (up₁ Ξ ξ)).
    Proof. exact (tr_up₁_wkm_comm 1 x ξ). Qed.

    Lemma tr_wkm₁_comm (x:X) (ξ: Ξ) :
      tr T X Ζ (tr T X Ξ x ξ) (wkm₁ Ζ) =
      tr T X Ξ (tr T X Ζ x (wkm₁ Ζ)) (up₁ Ξ ξ).
    Proof. exact (tr_wkm_comm 1 x ξ). Qed.

  End TrWkmComm.

  Section TrWkmBeta.

    Context
      {T: Type} `{Vr T, Wk T, Tr T T, !WkVr T, !TrVr T, !TrWk T T}
      {X: Type} `{Tr T X, !TrPair T X, !TrRel T X, !TrIdm T X}
      {Ξ: Type} `{Lk T Ξ, Up Ξ, Wkm Ξ, !UpHom Ξ, !LkUp T Ξ, !LkWkm T Ξ}
      {Ζ: Type} `{Lk T Ζ, Up Ζ, Beta T Ζ, !UpHom Ζ, !LkUp T Ζ, !LkBeta T Ζ}.

    Lemma tr_up_wkm₁_beta₁ (δ : Dom) (t: T) (x: X) :
      tr T X Ζ (tr T X Ξ x (up Ξ (wkm₁ Ξ) δ)) (up Ζ (beta₁ T Ζ t) δ) = x.
    Proof.
      rewrite tr_pair, <- (tr_idm (Ξ := unit)), <- (up_idm δ).
      apply tr_rel_pw.
      change (up Ξ (wkm₁ Ξ) δ ⊗ up Ζ (beta₁ T Ζ t) δ)
        with (up (Pair Ξ Ζ) (wkm₁ Ξ ⊗ beta₁ T Ζ t) δ).
      apply (pointwise_up (wkm₁ Ξ ⊗ beta₁ T Ζ t) tt δ).
      constructor; intros; cbn.
      now rewrite lk_wkm₁, tr_vr, lk_beta₁_suc.
    Qed.

    Lemma tr_up₁_wkm₁_beta₁ (t: T) (x: X) :
      tr T X Ζ (tr T X Ξ x (up₁ Ξ (wkm₁ Ξ))) (up₁ Ζ (beta₁ T Ζ t)) = x.
    Proof. exact (tr_up_wkm₁_beta₁ 1 t x). Qed.

    Lemma tr_wkm₁_beta₁ (t: T) (x: X) :
      tr T X Ζ (tr T X Ξ x (wkm₁ Ξ)) (beta₁ T Ζ t) = x.
    Proof. generalize (tr_up_wkm₁_beta₁ 0 t x). now rewrite !up_zero. Qed.

  End TrWkmBeta.

  Section TrBetaComm.

    Context
      {T: Type} `{Vr T, Wk T, Tr T T, !WkVr T, !TrVr T, !TrWk T T,
                  !TrWkmWk T T, !TrPair T T, !TrRel T T, !TrIdm T T}
      {X: Type} `{Tr T X, !TrPair T X, !TrRel T X}
      {Ξ: Type} `{Lk T Ξ, Up Ξ, Beta T Ξ, !UpHom Ξ, !LkUp T Ξ, !LkBeta T Ξ}
      {Ζ: Type} `{Lk T Ζ, Up Ζ, !UpHom Ζ, !LkUp T Ζ}.

    Lemma tr_up_beta₁_comm (δ:Dom) (t:T) (x:X) (ζ:Ζ) :
      tr T X Ζ (tr T X Ξ x (up Ξ (beta₁ T Ξ t) δ)) (up Ζ ζ δ) =
      tr T X Ξ (tr T X Ζ x (up Ζ (up₁ Ζ ζ) δ)) (up Ξ (beta₁ T Ξ (tr T T Ζ t ζ)) δ).
    Proof.
      rewrite !tr_pair; apply tr_rel_pw.
      change (up Ξ (beta₁ T Ξ t) δ ⊗ up Ζ ζ δ)
        with (up (Pair Ξ Ζ) (beta₁ T Ξ t ⊗ ζ) δ).
      change (up Ζ (up₁ Ζ ζ) δ ⊗ up Ξ (beta₁ T Ξ (tr T T Ζ t ζ)) δ)
        with (up (Pair Ζ Ξ) (up₁ Ζ ζ ⊗ beta₁ T Ξ (tr T T Ζ t ζ)) δ).
      apply (pointwise_up (beta₁ T Ξ t ⊗ ζ) (up₁ Ζ ζ ⊗ beta₁ T Ξ (tr T T Ζ t ζ)) δ).
      constructor; intros; cbn.
      destruct i; cbn.
      - now rewrite lk_up₁_zero, tr_vr, !lk_beta₁_zero.
      - now rewrite lk_up₁_suc, lk_beta₁_suc, tr_vr,
          <- (tr_wkm₁_wk₁ (Ξ := Shifts)), tr_wkm₁_beta₁.
    Qed.

    Lemma tr_up₁_beta₁_comm (t:T) (x:X) (ζ:Ζ) :
      tr T X Ζ (tr T X Ξ x (up₁ Ξ (beta₁ T Ξ t))) (up₁ Ζ ζ) =
      tr T X Ξ (tr T X Ζ x (up₁ Ζ (up₁ Ζ ζ))) (up₁ Ξ (beta₁ T Ξ (tr T T Ζ t ζ))).
    Proof. exact (tr_up_beta₁_comm 1 t x ζ). Qed.

    Lemma tr_beta₁_comm (t:T) (x:X) (ζ:Ζ) :
      tr T X Ζ (tr T X Ξ x (beta₁ T Ξ t)) ζ =
      tr T X Ξ (tr T X Ζ x (up₁ Ζ ζ)) (beta₁ T Ξ (tr T T Ζ t ζ)).
    Proof. generalize (tr_up_beta₁_comm 0 t x ζ). now rewrite !up_zero. Qed.

  End TrBetaComm.

End Pointful.


(* This file is for lemmas that
  (a) are used in the proof that the functional prog = functional spec
  AND (b) are used in the proof about the C program.
This file DOES NOT IMPORT anything about C or CompCert
  (except the CompCert Integers module)
*)
Require Import compcert.lib.Coqlib.
Require Import VST.msl.Coqlib2.
Require Import sha.general_lemmas.
Require Import sha.SHA256.

Lemma length_Round:
  forall regs f n,
   length regs = 8%nat ->
   length (Round regs f n) = 8%nat.
Proof.
intros.
destruct (zlt n 0).
rewrite Round_equation.
rewrite if_true by auto; auto.
replace n with (n+1-1) by omega.
rewrite <- (Z2Nat.id (n+1)) by omega.
revert regs H; induction (Z.to_nat (n+1)); intros.
rewrite Round_equation.
change (Z.of_nat 0 - 1) with (-1).
rewrite if_true by omega. auto.
clear n g. rename n0 into n.
rewrite Round_equation.
rewrite inj_S.
unfold Z.succ.
rewrite Z.add_simpl_r.
rewrite if_false by omega.
specialize (IHn0 _ H).
clear - IHn0.
rename f into f'.
destruct (Round regs f' (Z.of_nat n - 1))
  as [ | a [ | b [ | c [ | d [ | e [ | f [ | g [ | h [ | ]]]]]]]]]; try inv IHn0.
reflexivity.
Qed.

Lemma length_hash_block:
 forall regs block,
   length regs = 8%nat ->
   length block = 16%nat ->
   length (hash_block regs block) = 8%nat.
Proof.
intros.
unfold hash_block.
rewrite (length_map2 _ _ _ _ _ _ 8%nat); auto.
apply length_Round; auto.
Qed.

(* END COMMON LEMMAS *)


From hahn Require Import Hahn.
Require Import Coq.Program.Basics.
Import ListNotations.

Set Implicit Arguments.

Section AuxDef.

Lemma restr_rel_idempotent {A} (s : A -> Prop) r :
  restr_rel s (restr_rel s r) ≡ restr_rel s r.
Proof using. basic_solver. Qed.

Lemma restr_rel2E {A} (s : A -> Prop) r : ⦗s⦘ ⨾ restr_rel s r ⨾ ⦗s⦘ ≡ restr_rel s r.
Proof using. basic_solver. Qed.

Lemma restr_rel_cr {A} (s : A -> Prop) r : restr_rel s r^? ⊆ (restr_rel s r)^?.
Proof using. basic_solver. Qed.

Section StrictPartialOrder.
Variable T : Type.

Lemma strict_partial_order_empty : @strict_partial_order T ∅₂.
Proof using. basic_solver. Qed.

Add Morphism (@strict_partial_order T) with signature
    same_relation ==> iff as strict_partial_order_more.
Proof using.
  intros x y HH. unfold strict_partial_order.
  assert (y ≡ x) as AA by (by symmetry).
  split; ins; desf; splits.
  all: try (eapply irreflexive_more; eauto).
  all: eapply transitive_more; eauto.
Qed.

End StrictPartialOrder.

Section FunctionalEquiv.
  Variables A B : Type.

  Definition func_equiv (f g : A -> B) := forall a, f a = g a.

  Lemma func_equiv_symmetric f g (FE : func_equiv f g) : func_equiv g f.
  Proof. unfold func_equiv in *; ins. Qed.
End FunctionalEquiv.

Definition lset {A} l x := @List.In A x l.

Lemma lset_app {A} (l l' : list A):
      lset (l ++ l') ≡₁ lset l ∪₁ lset l'.
Proof.
  unfold lset, flip.
  by split; intro; rewrite in_app_iff.
Qed.

Lemma lset_cons {A} (l : list A) (x : A) :
  lset (x :: l) ≡₁ (eq x) ∪₁ lset l.
Proof.
  basic_solver.
Qed.

Lemma lset_empty {A} :
  (lset (@nil A)) ≡₁ ∅.
Proof.
  basic_solver.
Qed.

Lemma lset_empty_iff {A} (l : list A) :
  (lset l ≡₁ ∅) <-> l = [].
Proof.
  split.
  { induction l; auto.
    rewrite lset_cons.
    intro HH. exfalso.
    repeat (red in HH; desf).
    apply (HH a). basic_solver. }
  basic_solver.
Qed.

Lemma lset_single {A} (x : A) :
  lset [x] ≡₁ eq x.
Proof.
  basic_solver.
Qed.

Lemma lset_undup {A} (l : list A) :
  lset l ≡₁ lset (undup l).
Proof.
  unfold lset.
  by split; red; ins; apply in_undup_iff.
Qed.

Definition list_minus {A} (l l' : list A) :=
  filterP (fun x => ~ In x l') l.

Definition lset_list_minus {A} (l l' : list A) :
  lset (list_minus l l') ≡₁ lset l \₁ lset l'.
Proof.
  unfold lset, list_minus.
  unfolder; splits; intros x HH.
  { apply in_filterP_iff in HH. auto. }
  apply in_filterP_iff; desf.
Qed.

Definition list_minus_nil {A} (l : list A) :
  list_minus [] l = [].
Proof.
  basic_solver.
Qed.

Definition in_list_minus {A} (l l' : list A) (x : A) :
  List.In x (list_minus l l') <-> List.In x l /\ ~ List.In x l'.
Proof.
  unfold list_minus.
  rewrite in_filterP_iff.
  done.
Qed.

Definition filter_list_minus {A} f (l l' : list A) :
  filter f (list_minus l l') = list_minus (filter f l) (filter f l').
Proof.
  generalize dependent l'.
  induction l; ins.
  unfold list_minus in *.
  ins; desf; ins; desf; try basic_solver.
  { by rewrite IHl. }
  { exfalso.
    apply NNPP, in_filter_iff in n0. desf. }
  exfalso.
  apply NNPP in n.
  apply n0, in_filter_iff. desf.
Qed.

Lemma list_minus_cons_in {A} a (l l' : list A) (IN : In a l') :
  list_minus (a :: l) l' = list_minus l l'.
Proof. unfold list_minus; ins. desf. Qed.

Lemma list_minus_cons_nin {A} a (l l' : list A) (IN : ~ In a l') :
  list_minus (a :: l) l' = a :: (list_minus l l').
Proof. unfold list_minus; ins. desf. Qed.

Lemma lset_concat {A} (l : list (list A)) :
  lset (concat l) ≡₁ ⋃₁ x ∈ (lset l), lset x.
Proof.
  induction l; ins; desf.
  { basic_solver. }
  rewrite lset_app, IHl.
  basic_solver.
Qed.

Lemma lset_map {A B} (f : A -> B)  (l : list A) :
      lset (map f l) ≡₁ set_collect f (lset l).
Proof.
  induction l; ins.
  { rewrite !lset_empty. basic_solver. }
  now rewrite !lset_cons, IHl, set_collect_union, set_collect_eq.
Qed.

Lemma lset_filterP {A} (p : A -> Prop) (l : list A) :
  lset (filterP p l) ≡₁ lset l ∩₁ p.
Proof.
  induction l; ins; desf.
  { basic_solver. }
  all: rewrite !lset_cons, IHl; basic_solver.
Qed.

Lemma Forall2_map {A B} (R : A -> B -> Prop) (l : list A) (f : A -> B)
      (R_x_fx : forall x  (IN : In x l), R x (f x)) :
  Forall2 R l (map f l).
Proof.
  induction l; ins; desf.
  apply Forall2_cons; auto.
Qed.

Lemma Forall2_map_map {A B C} (R : B -> C -> Prop) (l : list A) f g
      (R_fx_gx : forall x  (IN : In x l), R (f x) (g x)) :
  Forall2 R (map f l) (map g l).
Proof.
  induction l; ins; desf.
  apply Forall2_cons; auto.
Qed.

Definition func_list {A B} (l : list (A * B)) :=
  forall ev ev'
    (IN : In ev l) (IN' : In ev' l)
    (EQe : fst ev = fst ev'),
    ev = ev'.

Lemma func_list_cons {A B} (a : A * B) l (FL : func_list (a :: l)) : func_list l.
Proof.
  red. ins. apply FL; auto.
  all: now apply in_cons.
Qed.

End AuxDef.

Declare Scope list_additional_scope.
Open Scope list_additional_scope.

Infix "--" := list_minus (right associativity, at level 60) : list_additional_scope.

Close Scope list_additional_scope.

(* Declare Scope auxdef_scope. *)
(* Open Scope auxdef_scope. *)

(* Notation "f ⋄ r"  := (map_rel f r) (at level 45) : auxdef_scope. *)
(* Notation "f ⋄₁ s"  := (set_map f s) (at level 39) : auxdef_scope. *)
(* Notation "⊤₂" := (fun _ _ => True) : auxdef_scope. *)
(* Notation "⊤₁" := set_full : auxdef_scope. *)

(* Close Scope auxdef_scope. *)

(* Notation "f ⋄₁ s"  := (set_map f s) (at level 39). *)
(* Notation "f □₁ s" := (set_collect f s) (at level 39). *)
(* Notation "f □ r"  := (collect_rel f r) (at level 45). *)


Require Export XR_R.
Require Export XR_Ropp.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Ropp_eq_compat : forall r1 r2, r1 = r2 -> - r1 = - r2.
Proof.
  intros x y h.
  subst y.
  reflexivity.
Qed.


MacBook-Air:foundations billw$ coqtop
Welcome to Coq 8.4pl6 (January 2017)

Coq < Section Restart.

Coq < Goal forall a b c:Prop, ((a /\ b) /\ (a /\ c)) -> (a /\ c).
1 subgoal

  ============================
   forall a b c : Prop, (a /\ b) /\ a /\ c -> a /\ c

Unnamed_thm < intros.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  H : (a /\ b) /\ a /\ c
  ============================
   a /\ c

Unnamed_thm < destruct H.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  H : a /\ b
  H0 : a /\ c
  ============================
   a /\ c

Unnamed_thm < exact H0.
No more subgoals.

Unnamed_thm < Qed.
intros.
destruct H.
exact H0.

Unnamed_thm is defined


(**

This file describes what it means for the different constructs in the
language to be well-formed.

Author: Ramon Fernandez I Mir and Arthur Charguéraud.

License: MIT.

*)

Set Implicit Arguments.
Require Export TLCbuffer Language.

(* ---------------------------------------------------------------------- *)
(** Well-formedness of types *)

Inductive wf_typ (C:typdefctx) : typ -> Prop :=
  | wf_typ_unit :
      wf_typ C typ_unit
  | wf_typ_int :
      wf_typ C typ_int
  | wf_typ_double :
      wf_typ C typ_double
  | wf_typ_bool :
      wf_typ C typ_bool
  | wf_typ_ptr : forall T,
      wf_typ C T ->
      wf_typ C (typ_ptr T)
  | wf_typ_array : forall T os,
      wf_typ C T ->
      wf_typ C (typ_array T os)
  | wf_typ_struct : forall Tfs,
      (forall f,
        f \indom Tfs ->
        wf_typ C Tfs[f]) ->
      wf_typ C (typ_struct Tfs)
  | wf_typ_var : forall Tv,
      Tv \indom C ->
      wf_typ C C[Tv] ->
      wf_typ C (typ_var Tv).

(* ---------------------------------------------------------------------- *)
(** Well-formedness of values and terms *)

(** Accesses are well-formed if all the types that appear in them are. *)

Inductive wf_accesses (C:typdefctx) : accesses -> Prop :=
  | wf_accesses_nil :
      wf_accesses C nil
  | wf_accesses_cons_array : forall T i π,
      wf_typ C T ->
      wf_accesses C π ->
      wf_accesses C ((access_array T i)::π)
  | wf_accesses_cons_field : forall T f π,
      wf_typ C T ->
      wf_accesses C π ->
      wf_accesses C ((access_field T f)::π).

(** A [val] is well-formed if all of the types that appear in it are. *)

Inductive wf_val (C:typdefctx) : val -> Prop :=
  | wf_val_error :
      wf_val C val_error
  | wf_val_uninitialized :
      wf_val C val_uninitialized
  | wf_val_unit :
      wf_val C val_unit
  | wf_val_bool : forall b,
      wf_val C (val_bool b)
  | wf_val_int : forall i,
      wf_val C (val_int i)
  | wf_val_double : forall d,
      wf_val C (val_double d)
  | wf_val_abstract_ptr : forall l π,
      wf_accesses C π ->
      wf_val C (val_abstract_ptr l π)
  | wf_val_concrete_ptr : forall l o,
      wf_val C (val_concrete_ptr l o)
  | wf_val_array : forall Ta a,
      wf_typ C Ta ->
      (forall i,
        index a i ->
        wf_val C a[i]) ->
      wf_val C (val_array Ta a)
  | wf_val_struct : forall Ts s,
      wf_typ C Ts ->
      (forall f,
        f \indom s ->
        wf_val C s[f]) ->
      wf_val C (val_struct Ts s).

(** A [prim] is well-formed if all of the types that appear in it are
    and the arity is correct. *)

Inductive wf_prim (C:typdefctx) : int -> prim -> Prop :=
  | wf_prim_binop : forall bop,
      wf_prim C 2 (prim_binop bop)
  | wf_prim_get : forall T,
      wf_typ C T ->
      wf_prim C 1 (prim_get T)
  | wf_prim_set : forall T,
      wf_typ C T ->
      wf_prim C 2 (prim_set T)
  | wf_prim_new : forall T,
      wf_typ C T ->
      wf_prim C 0 (prim_new T)
  | wf_prim_new_array : forall T,
      wf_typ C T ->
      wf_prim C 1 (prim_new_array T)
  | wf_prim_struct_access : forall T f,
      wf_typ C T ->
      wf_prim C 1 (prim_struct_access T f)
  | wf_prim_array_access : forall T,
      wf_typ C T ->
      wf_prim C 2 (prim_array_access T)
  | wf_prim_struct_get : forall T f,
      wf_typ C T ->
      wf_prim C 1 (prim_struct_get T f)
  | wf_prim_array_get : forall T,
      wf_typ C T ->
      wf_prim C 2 (prim_array_get T)
  | wf_prim_ll_get : forall T,
      wf_typ C T ->
      wf_prim C 1 (prim_ll_get T)
  | wf_prim_ll_set : forall T,
      wf_typ C T ->
      wf_prim C 1 (prim_ll_set T)
  | wf_prim_ll_access : forall T,
      wf_typ C T ->
      wf_prim C 2 (prim_ll_access T)
  | wf_prim_ll_new : forall T,
      wf_typ C T ->
      wf_prim C 0 (prim_ll_new T).

(** A [trm] is well-formed if all of the types that appear in it are. *)

Inductive wf_trm (C:typdefctx) : trm -> Prop :=
  | wf_trm_val : forall v,
      wf_val C v ->
      wf_trm C (trm_val v)
  | wf_trm_var : forall x,
      wf_trm C (trm_var x)
  | wf_trm_if : forall t0 t1 t2,
      wf_trm C t0 ->
      wf_trm C t1 ->
      wf_trm C t2 ->
      wf_trm C (trm_if t0 t1 t2)
  | wf_trm_let : forall x t0 t1,
      wf_trm C t0 ->
      wf_trm C t1 ->
      wf_trm C (trm_let x t0 t1)
  | wf_trm_app_args_0 : forall op,
      wf_prim C 0 op ->
      wf_trm C (trm_app op nil)
  | wf_trm_app_args_1 : forall op t1,
      wf_prim C 1 op ->
      wf_trm C t1 ->
      wf_trm C (trm_app op (t1::nil))
  | wf_trm_app_args_2 : forall op t1 t2,
      wf_prim C 2 op ->
      wf_trm C t1 ->
      wf_trm C t2 ->
      wf_trm C (trm_app op (t1::t2::nil)).

(* ---------------------------------------------------------------------- *)
(** Well-formedness of stack and state *)

(** Well-formed [stack]. *)

Definition wf_stack (C:typdefctx) (S:stack) : Prop :=
  forall x v,
    Ctx.lookup x S = Some v ->
    wf_val C v.

(** Well-formed [state]. *)

Definition wf_state (C:typdefctx) (m:state) : Prop :=
  forall l,
    l \indom m ->
    wf_val C m[l].

(** Well-formed [gamma]. *)

Definition wf_gamma (C:typdefctx) (Γ:gamma) : Prop :=
  forall x T,
    Ctx.lookup x Γ = Some T ->
    wf_typ C T.

(** Well-formed [phi]. *)

Definition wf_phi (C:typdefctx) (φ:phi) : Prop :=
  forall l,
    l \indom φ ->
    wf_typ C φ[l].

(* ---------------------------------------------------------------------- *)
(** Typdefctx well-formedness *)

(** Checking if a type variable appears in a type. *)

Inductive free_typvar (C:typdefctx) (Tv:typvar) : typ -> Prop :=
  | free_typvar_typvar_eq :
      free_typvar C Tv (typ_var Tv)
  | free_typvar_typvar_other : forall Tv',
      Tv <> Tv' ->
      Tv' \indom C ->
      free_typvar C Tv C[Tv'] ->
      free_typvar C Tv (typ_var Tv')
  | free_typvar_ptr : forall T,
      free_typvar C Tv T ->
      free_typvar C Tv (typ_ptr T)
  | free_typvar_array : forall T os,
      free_typvar C Tv T ->
      free_typvar C Tv (typ_array T os)
  | free_typvar_struct : forall Tfs,
      (exists f,
        f \indom Tfs /\
        free_typvar C Tv Tfs[f]) ->
      free_typvar C Tv (typ_struct Tfs).

(** A [typdefctx] is well-formed if types are productive. *)

Definition wf_typdefctx (C:typdefctx) : Prop :=
  forall Tv,
    Tv \indom C ->
    ~ free_typvar C Tv C[Tv].


Require Import
  Coq.Classes.Morphisms
  Coq.Relations.Relation_Definitions
  Coq.Program.Program
  Coq.Unicode.Utf8
  Coq.Sets.Finite_sets
  Coq.Sets.Ensembles
  Coq.Logic.Classical.

Require Coq.Sets.Finite_sets_facts.
Require Coq.Sets.Powerset_facts.
Require Coq.Logic.Classical_Prop.
Require Coq.Lists.List.
Require Classical_Pred_Type.

Generalizable All Variables.

Definition first {A B C} (f : A -> C) (p : A * B) : C * B :=
  (f (fst p), snd p).

Definition second {A B C} (f : B -> C) (p : A * B) : A * C :=
  (fst p, f (snd p)).

Ltac inv H := inversion H; subst; clear H.

Tactic Notation "by" tactic(H) :=
  H; first [ tauto
           | discriminate
           | auto
           | congruence
           | eauto
           | intuition
           | firstorder ].

Notation "'IF' c1 'then' c2 'else' c3" := (c1 /\ c2 \/ ~ c1 /\ c3)
  (at level 200, right associativity).

Class EqDec (A : Type) := {
    eq_dec : ∀ x y : A, {x = y} + {x ≠ y}
}.

Ltac breakdown :=
  match goal with
  | [ H : IF _ then _ else _ |- _ ] => destruct H
  | [ H : _ /\ _             |- _ ] => destruct H
  | [ H : _ \/ _             |- _ ] => destruct H
  | [ H : _ * _              |- _ ] => destruct H
  | [ H : exists _, _        |- _ ] => destruct H
  | [ H : @sig _ _           |- _ ] => destruct H
  | [ H : @sig2 _ _ _        |- _ ] => destruct H
  | [ H : @sigT _ _          |- _ ] => destruct H
  | [ H : @sigT2 _ _ _       |- _ ] => destruct H
  | [ H : bool               |- _ ] => destruct H
  | [ H : option _           |- _ ] => destruct H
  | [ H : sum _ _            |- _ ] => destruct H
  | [ H : sumor _ _          |- _ ] => destruct H
  | [ H : sumbool _ _        |- _ ] => destruct H

  | [ H : forall x, Some ?X = Some x -> _  |- _ ] => specialize (H X eq_refl)
  | [ H : forall x y, Some (?X, ?Y) = Some (x, y) -> _  |- _ ] =>
    specialize (H X Y eq_refl)

  | [ H1 : ?X = true, H2 : ?X = false |- _ ] => rewrite H1 in H2; discriminate
  end.

Infix    "∪"      := (Union _)        (at level 75, right associativity).
Notation "∅"      := (Empty_set _)    (at level 0, no associativity).
Notation "p ⊆ q"  := (Included _ p q) (at level 69, no associativity).
Infix    "∩"      := (Intersection _) (at level 70, right associativity).
Notation "x ∷ xs" := (Add _ xs x)     (at level 60, right associativity, only parsing).

Notation "{ e } ∪ s" := (Add _ s e) (at level 75, right associativity, only parsing).

(* Notation "p ∈ q"  := (In _ q p)       (at level 68, no associativity). *)
(* Notation "p ∉ q"  := (~ In _ q p)     (at level 68, no associativity). *)

Reserved Infix "∈" (at level 68, no associativity).
Reserved Infix "∉" (at level 68, no associativity).

Class Membership (t : Type → Type) := {
  is_in {a} : a → t a → Prop
    where "p ∈ q" := (is_in p q) and "p ∉ q" := (~ is_in p q)
}.

Infix "∈" := is_in (at level 68, no associativity).
Notation "e ∉ s" := (~ (e ∈ s)) (at level 68, no associativity).

Global Instance Ensemble_Membership : Membership Ensemble := {|
  is_in := λ a, flip (Ensembles.In a)
|}.

Global Instance list_Membership : Membership list := {|
  is_in := List.In
|}.

(*#[export]*) Program Instance Same_set_Equivalence {A} : Equivalence (@Same_set A).
Next Obligation.
  intro x.
  constructor; intros y H; exact H.
Qed.
Obligation 2.
  intros x y H.
  destruct H.
  split; trivial.
Qed.
Obligation 3.
  intros x y z H1 H2.
  destruct H1, H2.
  split; trivial.
    intros w H3.
    apply H1.
    apply H.
    exact H3.
  intros w H3.
  apply H0.
  apply H2.
  exact H3.
Qed.

Add Parametric Relation {A : Type} : (Ensemble A) (Same_set A)
  reflexivity  proved by (@Equivalence_Reflexive  _ _ Same_set_Equivalence)
  symmetry     proved by (@Equivalence_Symmetric  _ _ Same_set_Equivalence)
  transitivity proved by (@Equivalence_Transitive _ _ Same_set_Equivalence)
  as Same_set_relation.

(*#[export]*) Program Instance Same_set_equiv A :
  Proper (Same_set A ==> Same_set A ==> Basics.impl) (Same_set A).
Next Obligation.
  repeat intro.
  destruct H, H0, H1.
  split; intros z H5.
    apply H0, H1, H2, H5.
  apply H, H4, H3, H5.
Qed.

(*#[export]*) Program Instance Same_set_equiv' A :
  Proper (Same_set A ==> Same_set A ==> Basics.flip Basics.impl) (Same_set A).
Next Obligation.
  repeat intro.
  destruct H, H0, H1.
  split; intros z H5.
    apply H3, H1, H, H5.
  apply H2, H4, H0, H5.
Qed.

(*#[export]*) Program Instance Singleton_Same_set A :
  Proper (eq ==> Same_set A) (Singleton A).
Next Obligation. intros; reflexivity. Qed.

(*#[export]*) Program Instance In_Same_set A :
  Proper (Same_set A ==> Same_set A) (In A).
Next Obligation.
  repeat intro.
  exact H.
Qed.

(*#[export]*) Program Instance In_Same_set_eq A :
  Proper (Same_set A ==> eq ==> Basics.impl) (In A).
Next Obligation.
  repeat intro; subst.
  destruct H.
  now apply H.
Qed.

(*#[export]*) Program Instance In_Same_set_eq' A :
  Proper (Same_set A ==> eq ==> Basics.flip Basics.impl) (In A).
Next Obligation.
  repeat intro; subst.
  destruct H.
  now apply H0.
Qed.

(*#[export]*) Program Instance In_Same_set_eq'' A :
  Proper (Same_set A --> eq ==> Basics.impl) (In A).
Next Obligation.
  repeat intro; subst.
  destruct H.
  now apply H0.
Qed.

(*#[export]*) Program Instance In_Same_set_eq''' A :
  Proper (Same_set A --> eq ==> Basics.flip Basics.impl) (In A).
Next Obligation.
  repeat intro; subst.
  destruct H.
  now apply H.
Qed.

(*#[export]*) Program Instance Union_Same_set A :
  Proper (Same_set A ==> Same_set A ==> Same_set A) (Union A).
Next Obligation.
  repeat intro.
  destruct H, H0.
  split; intros z H3;
  inversion H3; subst; clear H3.
  - apply Union_introl.
    apply H, H4.
  - apply Union_intror.
    apply H0, H4.
  - apply Union_introl.
    apply H1, H4.
  - apply Union_intror.
    apply H2, H4.
Qed.

(*#[export]*) Program Instance Add_Same_set A :
  Proper (Same_set A ==> eq ==> Same_set A) (Add A).
Next Obligation.
  unfold Add; repeat intro.
  subst.
  rewrite H.
  reflexivity.
Qed.

(*#[export]*) Program Instance Setminus_Same_set A :
  Proper (Same_set A ==> Same_set A ==> Same_set A) (Setminus A).
Next Obligation.
  repeat intro.
  destruct H, H0.
  split; intros z H3;
  inversion H3; subst; clear H3.
    split.
      apply H, H4.
    unfold not; intros.
    contradiction H5.
    apply H2, H3.
  split.
    apply H1, H4.
  unfold not; intros.
  contradiction H5.
  apply H0, H3.
Qed.

(*#[export]*) Program Instance Subtract_Same_set A :
  Proper (Same_set A ==> eq ==> Same_set A) (Subtract A).
Next Obligation.
  unfold Subtract; repeat intro.
  subst.
  rewrite H.
  reflexivity.
Qed.

(*#[export]*) Program Instance Included_Same_set A :
  Proper (Same_set A ==> Same_set A ==> Basics.impl) (Included A).
Next Obligation.
  unfold Included; repeat intro.
  rewrite <- H0.
  rewrite <- H in H2.
  exact (H1 _ H2).
Qed.

(*#[export]*) Program Instance Included_Same_set_subrelation A :
  subrelation (@Same_set A) (@Included A).
Next Obligation. repeat intro; now apply H. Qed.

(*#[export]*) Program Instance Finite_Proper A :
  Proper (Same_set A ==> impl) (Finite A).
Next Obligation.
  intros ????.
  eapply Finite_sets_facts.Finite_downward_closed; eauto with sets.
  intros ? H1.
  rewrite <- H in H1.
  assumption.
Qed.

(*#[export]*) Program Instance Finite_Proper_flip A :
  Proper (Same_set A --> flip impl) (Finite A).
Next Obligation.
  intros ????.
  eapply Finite_sets_facts.Finite_downward_closed; eauto with sets.
  intros ? H1.
  rewrite H in H1.
  assumption.
Qed.

Definition Map_set {A B} (f : A -> B) (r : Ensemble A) : Ensemble B :=
  fun b => exists a : A, In _ r a /\ b = f a.

Lemma Map_set_left_identity {A} (r : Ensemble A) : Same_set A r (Map_set id r).
Proof.
  unfold Map_set; split; intros.
    eexists; intuition.
    assumption.
  intros ??.
  do 2 destruct H.
  unfold id in H0.
  congruence.
Qed.

Lemma Map_set_right_identity {A} (r : Ensemble A) : Same_set A (Map_set id r) r.
Proof.
  unfold Map_set; split; intros.
    intros ??.
    do 2 destruct H.
    unfold id in H0.
    congruence.
  eexists; intuition.
  assumption.
Qed.

Lemma Map_set_composition {A B C} (r : Ensemble A) :
  forall (f : B -> C) (g : A -> B),
   Same_set C (Map_set (fun x => f (g x)) r) (Map_set f (Map_set g r)).
Proof.
  unfold Map_set; split; intros; intros ??.
    do 2 destruct H; subst.
    exists (g x0); simpl in *.
    split; trivial.
    exists x0; simpl.
    intuition.
  do 2 destruct H; subst.
  do 2 destruct H; simpl in *; subst.
  exists x; simpl in *.
  intuition.
Qed.

Definition Product {T U} (X : Ensemble T) (Y : Ensemble U) : Ensemble (T * U) :=
  fun p => In T X (fst p) /\ In U Y (snd p).

Lemma Product_Add_left : forall T U (X : Ensemble T) (Y : Ensemble U) x,
  Same_set _ (Product (Add T X x) Y)
             (Union _ (Product (Singleton _ x) Y) (Product X Y)).
Proof.
  unfold Product; split; intros;
  intros ??; unfold Ensembles.In in *;
  destruct H;
  destruct x0; simpl in *;
  destruct H.
  - right; constructor; simpl; auto.
  - left; constructor; simpl; auto.
  - simpl in *; intuition; right; intuition.
  - simpl in *; intuition; left; intuition.
Qed.

Lemma Product_Add_right : forall T (X : Ensemble T) U (Y : Ensemble U) y,
  Same_set _ (Product X (Add U Y y))
             (Union _ (Product X Y) (Product X (Singleton _ y))).
Proof.
  unfold Product; split; intros;
  intros ??; unfold Ensembles.In in *;
  destruct H;
  destruct x; simpl in *.
  - destruct H0.
    + left; constructor; simpl; auto.
    + right; constructor; simpl; auto.
  - destruct H. intuition; left; intuition.
  - destruct H. intuition; right; intuition.
Qed.

Lemma Product_Empty_set_left : forall T U (X : Ensemble U),
  Same_set _ (Product (Empty_set T) X) (Empty_set (T * U)).
Proof.
  unfold Product; split; intros;
  intros ??; unfold Ensembles.In in *.
  destruct H;
  destruct x; simpl in *;
  destruct H.
  destruct H.
Qed.

Lemma Product_Empty_set_right : forall T (X : Ensemble T) U,
  Same_set _ (Product X (Empty_set U)) (Empty_set (T * U)).
Proof.
  unfold Product; split; intros;
  intros ??; unfold Ensembles.In in *.
  destruct H;
  destruct x; simpl in *.
  destruct H0.
  destruct H.
Qed.

Lemma Product_Singleton_Singleton : forall T U x y,
  Same_set _ (Product (Singleton T x) (Singleton U y))
             (Singleton (T * U) (x, y)).
Proof.
  unfold Product; split; intros;
  intros ??; unfold Ensembles.In in *;
  destruct H.
    inversion H; subst; clear H.
    inversion H0; subst; clear H0.
    rewrite <- surjective_pairing.
    constructor.
  simpl.
  intuition.
Qed.

Theorem Setminus_Add_in A x s t :
  x ∈ t → Same_set _ (Setminus A (Add A s x) t) (Setminus A s t).
Proof.
  split; repeat intro.
  - unfold In, Setminus in *.
    destruct H0.
    split; auto.
    inv H0; auto.
    inv H2.
    contradiction.
  - unfold In, Setminus in *.
    destruct H0.
    split; auto.
    now left.
Qed.

Theorem Setminus_Add_not_in A x s t :
  x ∉ t → Same_set _ (Setminus A (Add A s x) t) (Add A (Setminus A s t) x).
Proof.
  split; repeat intro.
  - unfold In, Setminus in *.
    destruct H0.
    inv H0; auto.
    + now left.
    + inv H2.
      now right.
  - unfold In, Setminus in *.
    inv H0.
    + destruct H1.
      split; auto.
      now left.
    + inv H1.
      split; auto.
      now right.
Qed.

Theorem Finite_Setminus A x y : Finite A x → Finite A (Setminus A x y).
Proof.
  intros.
  induction H.
  - rewrite Powerset_facts.Seminus_Empty_set_l.
    now constructor.
  - destruct (classic (In _ y x)).
    + now rewrite Setminus_Add_in.
    + rewrite Setminus_Add_not_in; auto.
      constructor; auto.
      intro.
      destruct H2.
      contradiction.
Qed.

Section TupleEnsemble.

Variables A B : Type.

Definition Map := Ensemble (A * B).

Definition FinMap := { M : Map | Finite _ M }.

Definition FinMap_to_Map (M : FinMap) : Map := proj1_sig M.
Coercion FinMap_to_Map : FinMap >-> Map.

Definition FunMap := { M : list (A * B) | ∀ k v v', (k, v) ∈ M → (k, v') ∈ M → v = v' }.

Definition AList := list (A * B).

Definition FunMap_to_list (M : FunMap) : AList := proj1_sig M.
Coercion FunMap_to_list : FunMap >-> AList.

Definition Empty : Map := Empty_set _.

Program Definition EmptyF : FinMap := exist _ Empty _.
Next Obligation. constructor. Qed.

Program Definition EmptyU : FunMap := exist _ nil _.
Next Obligation. inversion H. Qed.

Definition Single (a : A) (b : B) : Map := Singleton _ (a, b).

Program Definition SingleF (a : A) (b : B) : FinMap := exist _ (Single a b) _.
Next Obligation. now apply Finite_sets_facts.Singleton_is_finite. Qed.

Program Definition SingleU (a : A) (b : B) : FunMap := exist _ (cons (a, b) nil) _.
Next Obligation. now inv H; inv H0; inv H; inv H1. Qed.

Definition Lookup (a : A) (b : B) (r : Map) := In _ r (a, b).

Program Definition LookupF (a : A) (b : B) (r : FinMap) :
  In _ r (a, b) ∨ ~ In _ r (a, b).
Proof.
  destruct r; simpl in *.
  unfold flip, In in *.
  induction f using Finite_ind.
  - right.
    intro.
    now inversion H.
  - destruct (classic (x = (a, b))).
    + subst.
      left.
      right.
      now constructor.
    + destruct IHf; intros.
      * left.
        now left.
      * right.
        intro.
        inv H2.
        ** contradiction.
        ** inv H3.
           contradiction.
Defined.

Program Definition LookupU (a : A) (r : FunMap) : option B.
Proof.
  destruct r as [m H].
  induction m.
  - exact None.
  - destruct IHm.
    + intros.
      now firstorder.
    + exact (Some b).
    + exact None.
Defined.

Definition Keys (r : Map) : Ensemble A := λ a, ∃ b, In _ r (a, b).

Definition Values (r : Map): Ensemble B := λ b, ∃ a, In _ r (a, b).

Definition Same (x y : Map) : Prop :=
  forall a b, Lookup a b x <-> Lookup a b y.

Global Program Instance Same_Equivalence : Equivalence Same.
Next Obligation.
  constructor; auto.
Qed.
Obligation 2.
  constructor; apply H; auto.
Qed.
Obligation 3.
  constructor; intros.
    apply H0, H; auto.
  apply H, H0; auto.
Qed.

Lemma Same_Same_set : forall x y, Same x y <-> Same_set _ x y.
Proof.
  unfold Same, Lookup.
  split; intros.
    split; intros;
    intros ? H0;
    destruct x0;
    apply H; assumption.
  split; intros;
  apply H; assumption.
Qed.

Global Program Instance Lookup_Proper :
  Proper (eq ==> eq ==> Same ==> Basics.impl) Lookup.
Next Obligation. repeat intro; subst; now apply H1. Qed.

Global Program Instance Lookup_Proper_flip :
  Proper (eq ==> eq ==> Same --> Basics.impl) Lookup.
Next Obligation. repeat intro; subst; now apply H1. Qed.

Definition Member (a : A) (r : Map) := exists b, Lookup a b r.

Definition Member_dec (a : A) (r : Map) : Member a r \/ ~ Member a r.
Proof.
  unfold Member.
  elim (Classical_Prop.classic (exists b, Lookup a b r));
  intuition.
Qed.

Definition Insert (a : A) (b : B) (r : Map) : Map :=
  Add _ r (a, b).

Program Definition InsertF (a : A) (b : B) (r : FinMap) : FinMap :=
  exist _ (Insert a b r) _.
Next Obligation.
  destruct r; simpl.
  unfold Insert, Lookup in *.
  now apply Finite_sets_facts.Add_preserves_Finite.
Qed.

Definition Remove (a : A) (r : Map) : Map :=
  Setminus _ r (fun p => fst p = a).

Program Definition RemoveF (a : A) (r : FinMap) : FinMap :=
  exist _ (Remove a r) _.
Next Obligation.
  unfold Remove.
  apply Finite_Setminus.
  now destruct r.
Qed.

Fixpoint list_remove (k : A) `{EqDec A} (m : list (A * B)) : list (A * B) :=
  match m with
  | nil => nil
  | cons x xs =>
      match eq_dec k (fst x) with
      | left _ => list_remove k xs
      | right _ => cons x (list_remove k xs)
      end
  end.

Lemma List_In_remove `{EqDec A} x y m :
  List.In x (list_remove y m) -> fst x ≠ y ∧ List.In x m.
Proof.
  intros.
  induction m; simpl in *; auto.
  destruct (eq_dec y (fst a)).
  - subst.
    now intuition.
  - destruct H0.
    + subst.
      now split; intuition.
    + now intuition.
Qed.

Program Definition RemoveU (a : A) `{EqDec A} (r : FunMap) : FunMap :=
  exist _ (list_remove a r) _.
Next Obligation.
  destruct r as [m H2]; simpl in *.
  apply H2 with (k:=k); eapply List_In_remove; eauto.
Qed.

Program Definition Update (a : A) (b : B) (r : Map) : Map :=
  Insert a b (Remove a r).

Program Definition UpdateF (a : A) (b : B) (r : FinMap) : FinMap :=
  exist _ (Update a b r) _.
Next Obligation.
  unfold Update, Insert.
  apply Finite_sets_facts.Add_preserves_Finite.
  unfold Remove.
  apply Finite_Setminus.
  now destruct r.
Qed.

Program Definition UpdateU (a : A) `{EqDec A} (b : B) (r : FunMap) : FunMap :=
  exist _ (cons (a, b) (list_remove a r)) _.
Next Obligation.
  destruct r as [m H2]; simpl in *.
  destruct H0.
  - inv H0.
    destruct H1.
    + now inv H0.
    + apply List_In_remove in H0.
      destruct H0; simpl in H0.
      contradiction.
  - destruct H1.
    + inv H1.
      apply List_In_remove in H0.
      destruct H0; simpl in H0.
      contradiction.
    + apply List_In_remove in H0.
      destruct H0; simpl in H0.
      apply List_In_remove in H1.
      destruct H1; simpl in H1.
      now apply H2 with (k:=k).
Qed.

Definition Relate {C D} (f : A -> B -> C -> D -> Prop) (r : Map) :
  Ensemble (C * D) :=
  fun p => exists k' e', Lookup k' e' r /\ f k' e' (fst p) (snd p).

Definition Move (a a' : A) (r : Map) : Map :=
  Relate (fun k e k' e' =>
            e = e' /\ ((k' = a' /\ k = a) \/ (k' <> a /\ k = k'))) r.

Definition Filter (P : A -> B -> Prop) (r : Map) :
  Map :=
  fun p => Lookup (fst p) (snd p) r /\ P (fst p) (snd p).

Definition Define (P : A -> Prop) (b : B) (r : Map) :
  Map :=
  Ensembles.Union
    _ (fun p => P (fst p) /\ In _ (Singleton _ b) (snd p))
      (Filter (fun k _ => ~ P k) r).

Definition Modify (a : A) (f : B -> B) (r : Map) :
  Map :=
  Relate (fun k e k' e' => k = k' /\ IF k' = a then e' = f e else e' = e) r.

Definition All (P : A -> B -> Prop) (r : Map) : Prop :=
  forall a b, Lookup a b r -> P a b.

Definition Any (P : A -> B -> Prop) (r : Map) : Prop :=
  exists a b, Lookup a b r /\ P a b.

Lemma Lookup_Empty : forall a b, ~ Lookup a b Empty.
Proof. firstorder. Qed.

Lemma Lookup_Single : forall a a' b b',
  a = a' -> b = b' -> Lookup a b (Single a' b').
Proof. intros; rewrite H, H0; firstorder. Qed.

Lemma Lookup_Single_inv : forall a b c d,
  Lookup a b (Single c d) -> a = c /\ b = d.
Proof. split; inversion H; reflexivity. Qed.

Lemma Lookup_Insert : forall a b c d r,
  (a = c /\ b = d) \/ (a <> c /\ Lookup a b r)
    -> Lookup a b (Insert c d r).
Proof.
  intros.
  intuition.
    subst.
    right; constructor.
  left.
  exact H1.
Qed.

(*
Lemma Lookup_Insert_inv : forall a b c d r,
  Lookup a b (Insert c d r)
    -> (a = c /\ b = d) \/ (a <> c /\ Lookup a b r).
Proof.
  intros.
  inversion H; clear H.
    subst.
    right.
    firstorder.
    unfold not; intros; subst.
    contradiction (H0 b).
  inversion H1; clear H1.
  firstorder.
Qed.
*)

Lemma Lookup_Remove : forall a b a' r,
  Lookup a b r -> a <> a' -> Lookup a b (Remove a' r).
Proof. firstorder. Qed.

Lemma Lookup_Remove_ex_r : forall a b r,
  Lookup a b r -> exists a', a <> a' -> Lookup a' b (Remove a r).
Proof. firstorder. Qed.

Lemma Lookup_Remove_inv : forall a b a' r,
  Lookup a b (Remove a' r) -> a <> a' /\ Lookup a b r.
Proof. firstorder. Qed.

Lemma Lookup_Update : forall a b a' b' r,
  (a = a' /\ b = b') \/ (a <> a' /\ Lookup a b r)
    -> Lookup a b (Update a' b' r).
Proof.
  intros.
  intuition.
    rewrite H, H1.
    right; constructor.
  left; constructor.
    exact H1.
  exact H.
Qed.

Lemma Lookup_Update_eq : forall a b b' r,
  b = b' -> Lookup a b (Update a b' r).
Proof.
  intros; subst.
  apply Lookup_Update.
  left; intuition.
Qed.

Lemma Lookup_Update_neq : forall a a' b b' r,
  a <> a' -> Lookup a b r -> Lookup a b (Update a' b' r).
Proof.
  intros; subst.
  apply Lookup_Update.
  right; intuition.
Qed.

Lemma Lookup_Update_inv : forall a b a' b' r,
  Lookup a b (Update a' b' r)
    -> (a = a' /\ b = b') \/ (a <> a' /\ Lookup a b r).
Proof.
  intros.
  inversion H; clear H.
    firstorder.
  inversion H0; clear H0.
  firstorder.
Qed.

Definition Functional (r : Map) :=
  forall addr blk1, Lookup addr blk1 r ->
  forall blk2, Lookup addr blk2 r -> blk1 = blk2.

Lemma Lookup_Update_idem : forall a b r,
  Functional r ->
  (forall a a' : A, a = a' \/ a <> a') ->
    Lookup a b r -> Same r (Update a b r).
Proof.
  split; intros.
    apply Lookup_Update.
    destruct (H0 a0 a).
      left; intuition; subst.
      eapply H; eauto.
    right; intuition.
  apply Lookup_Update_inv in H2.
  firstorder; subst; assumption.
Qed.

Lemma Lookup_Relate : forall a b c d (f : A -> B -> A -> B -> Prop) r,
  Lookup a b r -> f a b c d -> Lookup c d (Relate f r).
Proof. firstorder. Qed.

Lemma Lookup_Relate_inv : forall a b (f : A -> B -> A -> B -> Prop) r,
  Lookup a b (Relate f r) -> exists a' b', f a' b' a b /\ Lookup a' b' r.
Proof.
  intros.
  inversion H; clear H.
  firstorder.
Qed.

Lemma Lookup_Move : forall k e a a' r,
  (IF k = a'
   then Lookup a e r
   else k <> a /\ Lookup k e r)
    -> Lookup k e (Move a a' r).
Proof. firstorder. Qed.

Lemma Lookup_Move_inv : forall k e a a' r,
  Lookup k e (Move a a' r)
    -> (k = a' /\ Lookup a e r) \/ (k <> a /\ Lookup k e r).
Proof.
  firstorder;
  simpl in *; subst;
  firstorder.
Qed.

Lemma Lookup_Map_set : forall a b f r,
  (exists p', f p' = (a, b) /\ Lookup (fst p') (snd p') r)
    -> Lookup a b (Map_set f r).
Proof.
  unfold Map_set, Lookup, Ensembles.In; simpl.
  intuition.
  destruct H.
  rewrite <- surjective_pairing in H.
  exists x; simpl.
  intuition.
Qed.

Lemma Lookup_Map_set_inv : forall a b f r,
  Lookup a b (Map_set f r)
    -> exists p', f p' = (a, b) /\ Lookup (fst p') (snd p') r.
Proof.
  intros.
  inversion H; clear H.
  exists x.
  unfold Lookup.
  rewrite <- surjective_pairing.
  firstorder.
Qed.

Lemma Lookup_Filter : forall a b P r,
  Lookup a b r /\ P a b -> Lookup a b (Filter P r).
Proof. firstorder. Qed.

Lemma Lookup_Filter_inv : forall a b P r,
  Lookup a b (Filter P r) -> P a b /\ Lookup a b r.
Proof. firstorder. Qed.

Lemma Lookup_Union : forall a b r r',
  Lookup a b r \/ Lookup a b r'
    -> Lookup a b (Union (A * B) r r').
Proof.
  firstorder.
    left; exact H.
  right; exact H.
Qed.

Lemma Lookup_Union_inv : forall a b r r',
  Lookup a b (Union (A * B) r r')
    -> Lookup a b r \/ Lookup a b r'.
Proof.
  firstorder.
  unfold Lookup, Ensembles.In in *.
  apply Constructive_sets.Union_inv in H.
  intuition.
Qed.

Lemma Lookup_Define : forall a b c P r,
  (IF P a then In _ (Singleton _ c) b else Lookup a b r)
    -> Lookup a b (Define P c r).
Proof.
  unfold Define; intros.
  apply Lookup_Union.
  do 2 destruct H.
    left.
    unfold Lookup, Ensembles.In; simpl.
    intuition.
  right.
  apply Lookup_Filter.
  intuition.
Qed.

Lemma Lookup_Define_inv : forall a b c P r,
  Lookup a b (Define P c r)
    -> IF P a
       then In _ (Singleton _ c) b
       else Lookup a b r.
Proof.
  unfold Define; intros.
  apply Lookup_Union_inv in H.
  destruct H.
    firstorder.
  apply Lookup_Filter_inv in H.
  firstorder.
Qed.

Lemma Lookup_Modify : forall a b a' f r,
  (a = a' /\ exists b', f b' = b /\ Lookup a b' r)
    \/ (a <> a' /\ Lookup a b r)
    -> Lookup a b (Modify a' f r).
Proof.
  firstorder;
  simpl in *; subst;
  firstorder.
Qed.

Lemma Lookup_Modify_inv : forall a b a' f r,
  Lookup a b (Modify a' f r)
    -> (a = a' /\ exists b', f b' = b /\ Lookup a b' r)
         \/ (a <> a' /\ Lookup a b r).
Proof.
  firstorder;
  simpl in *; subst;
  firstorder.
Qed.

Lemma Lookup_Member : forall a b r,
  Lookup a b r -> Member a r.
Proof. firstorder. Qed.

Lemma Member_Lookup_not : forall a r,
  ~ Member a r -> forall b, ~ Lookup a b r.
Proof. firstorder. Qed.

Lemma All_Remove : forall a P r,
  All P r -> All P (Remove a r).
Proof. firstorder. Qed.

Lemma All_Remove_inv : forall a P r,
  All P (Remove a r) -> ~ Member a r -> All P r.
Proof.
  intros.
  intros ???.
  apply H.
  apply Lookup_Remove.
    assumption.
  unfold not; intros.
  subst.
  unfold Member in H0.
  apply Classical_Pred_Type.not_ex_all_not with (n:=b) in H0.
  contradiction.
Qed.

Lemma All_Remove_Lookup_inv : forall a P r,
  All P (Remove a r) -> forall a' b', a' <> a -> Lookup a' b' r -> P a' b'.
Proof. intros; apply H, Lookup_Remove; trivial. Qed.

Lemma All_Update_inv : forall k e P r,
  All P (Update k e r) -> P k e /\ All P (Remove k r).
Proof.
  intros.
  split.
    apply H, Lookup_Update.
    left; auto.
  intros ???.
  apply Lookup_Remove_inv in H0.
  destruct H0.
  apply H, Lookup_Update.
  right; intuition.
Qed.

Definition Unique P a r := All (fun a b => P a b = false) (Remove a r).

End TupleEnsemble.

Arguments Functional : default implicits.
Arguments Empty {_ _} _.
Arguments Single : default implicits.
Arguments Insert : default implicits.
Arguments Remove : default implicits.
Arguments Update : default implicits.
Arguments Modify : default implicits.
Arguments Move : default implicits.
Arguments Filter : default implicits.
Arguments Relate : default implicits.
Arguments All : default implicits.
Arguments Any : default implicits.
Arguments Define : default implicits.
Arguments Lookup : default implicits.
Arguments Same : default implicits.
Arguments Member : default implicits.
Arguments Keys : default implicits.
Arguments Values : default implicits.

Arguments Lookup_Empty : default implicits.

Definition Map_value {A B C} (f : A -> B -> C) (r : Map A B) : Map A C :=
  fun p => exists b : B, Lookup (fst p) b r /\ snd p = f (fst p) b.

Arguments Map_value : default implicits.

Lemma Map_value_left_identity {A B} (r : Map A B) : Same r (Map_value (fun _ x => x) r).
Proof.
  unfold Map_value; split; intros.
    eexists b.
    intuition.
  do 2 destruct H.
  simpl in *.
  rewrite H0.
  assumption.
Qed.

Lemma Map_value_right_identity {A B} (r : Map A B) : Same (Map_value (fun _ x => x) r) r.
Proof.
  unfold Map_value; split; intros.
    do 2 destruct H.
    simpl in *.
    rewrite H0.
    assumption.
  eexists b.
  intuition.
Qed.

Lemma Map_value_composition {A B C D} (r : Map A B) (g : A -> B -> C) (f : A -> C -> D) :
  Same (Map_value (fun k e => f k (g k e)) r) (Map_value f (Map_value g r)).
Proof.
  unfold Map_value; split; intros.
    destruct H.
    destruct H; simpl in *.
    subst.
    exists (g a x); simpl in *.
    split; trivial.
    exists x; simpl.
    intuition.
  destruct H.
  destruct H; simpl in *.
  subst.
  destruct H; simpl in *.
  exists x0; simpl in *.
  destruct H.
  intuition.
  rewrite <- H0.
  reflexivity.
Qed.

Lemma Lookup_Map_value {A B C} a b (f : A -> B -> C) (r : Map A B) :
  (exists b', f a b' = b /\ Lookup a b' r) -> Lookup a b (Map_value f r).
Proof. firstorder. Qed.

Lemma Lookup_Map_value_inv {A B C} a b (f : A -> B -> C) (r : Map A B) :
  Lookup a b (Map_value f r) -> exists b', f a b' = b /\ Lookup a b' r.
Proof.
  intros.
  inversion H; clear H.
  firstorder.
Qed.

Notation "s ∖ { e }" := (Remove e s) (at level 75, right associativity).
Notation "s ∖∖ k" := (RemoveU _ _ k s) (at level 75, right associativity).

Ltac t H :=
  unfold Relate;
  split; intros;
  repeat destruct H;
  simpl in *; subst;
  firstorder;
  simpl in *; subst;
  firstorder.

Lemma Relate_left_identity : forall A B (r : Map A B),
  Same r (Relate (fun k x k' x' => k = k' /\ x = x') r).
Proof. t H. Qed.

Lemma Relate_right_identity : forall A B (r : Map A B),
  Same (Relate (fun k x k' x' => k = k' /\ x = x') r) r.
Proof. t H. Qed.

Lemma Relate_composition :
  forall A B C D E F
         (f : C -> D -> E -> F -> Prop) (g : A -> B -> C -> D -> Prop) r,
    Same (Relate (fun k e k' e' =>
                  exists k'' e'', g k e k'' e'' /\ f k'' e'' k' e') r)
         (Relate f (Relate g r)).
Proof. t H; exists x1; exists x2; t H. Qed.

Ltac teardown :=
  match goal with
  | [ H : Lookup _ _ Empty            |- _ ] => contradiction (Lookup_Empty H)
  | [ H : Lookup _ _ (Single _ _)     |- _ ] => apply Lookup_Single_inv in H
  (* | [ H : Lookup _ _ (Insert _ _ _)   |- _ ] => apply Lookup_Insert_inv in H *)
  | [ H : Lookup _ _ (Remove _ _)     |- _ ] => apply Lookup_Remove_inv in H
  | [ H : Lookup _ _ (Update _ _ _)   |- _ ] => apply Lookup_Update_inv in H
  | [ H : Lookup _ _ (Move _ _ _)     |- _ ] => apply Lookup_Move_inv in H
  | [ H : Lookup _ _ (Map_value _ _)  |- _ ] => apply Lookup_Map_value_inv in H
  | [ H : Lookup _ _ (Map_set _ _)    |- _ ] => apply Lookup_Map_set_inv in H
  | [ H : Lookup _ _ (Relate _ _)     |- _ ] => apply Lookup_Relate_inv in H
  | [ H : Lookup _ _ (Filter _ _)     |- _ ] => apply Lookup_Filter_inv in H
  | [ H : Lookup _ _ (Define _ _ _)   |- _ ] => apply Lookup_Define_inv in H
  | [ H : Lookup _ _ (Modify _ _ _)   |- _ ] => apply Lookup_Modify_inv in H
  | [ H : Lookup _ _ (Union _ _ _)    |- _ ] => apply Lookup_Union_inv in H

  | [ H : Member _ Empty            |- _ ] => unfold Member in H
  | [ H : Member _ (Single _ _)     |- _ ] => unfold Member in H
  | [ H : Member _ (Insert _ _ _)   |- _ ] => unfold Member in H
  | [ H : Member _ (Remove _ _)     |- _ ] => unfold Member in H
  | [ H : Member _ (Update _ _ _)   |- _ ] => unfold Member in H
  | [ H : Member _ (Move _ _ _)     |- _ ] => unfold Member in H
  | [ H : Member _ (Map_value _ _)  |- _ ] => unfold Member in H
  | [ H : Member _ (Map_set _ _)    |- _ ] => unfold Member in H
  | [ H : Member _ (Relate _ _)     |- _ ] => unfold Member in H
  | [ H : Member _ (Filter _ _)     |- _ ] => unfold Member in H
  | [ H : Member _ (Define _ _ _)   |- _ ] => unfold Member in H
  | [ H : Member _ (Modify _ _ _)   |- _ ] => unfold Member in H
  | [ H : Member _ (Union _ _ _)    |- _ ] => unfold Member in H

  | [ |- Lookup _ _ Empty            ] => apply Lookup_Empty
  | [ |- Lookup _ _ (Single _ _)     ] => apply Lookup_Single
  | [ |- Lookup _ _ (Insert _ _ _)   ] => apply Lookup_Insert
  | [ |- Lookup _ _ (Remove _ _)     ] => apply Lookup_Remove
  | [ |- Lookup ?A _ (Update ?A _ _) ] => apply Lookup_Update_eq
  | [ H : ?A = ?B  |- Lookup ?A _ (Update ?B _ _) ] => apply Lookup_Update_eq
  | [ H : ?A <> ?B |- Lookup ?A _ (Update ?B _ _) ] => apply Lookup_Update_neq
  | [ |- Lookup _ _ (Update _ _ _)   ] => apply Lookup_Update_eq ||
                                          apply Lookup_Update
  | [ |- Lookup _ _ (Move _ _ _)     ] => apply Lookup_Move
  | [ |- Lookup _ _ (Map_value _ _)  ] => apply Lookup_Map_value
  | [ |- Lookup _ _ (Map_set _ _)    ] => apply Lookup_Map_set
  | [ |- Lookup _ _ (Relate _ _)     ] => apply Lookup_Relate
  | [ |- Lookup _ _ (Filter _ _)     ] => apply Lookup_Filter
  | [ |- Lookup _ _ (Define _ _ _)   ] => apply Lookup_Define
  | [ |- Lookup _ _ (Modify _ _ _)   ] => apply Lookup_Modify
  | [ |- Lookup _ _ (Union _ _ _)    ] => apply Lookup_Union

  | [ H : Lookup ?X ?Y ?R |- Member ?X ?R ] => exists Y; exact H

  (* | [ H1 : All _ (Remove _ _)   |- _ ] => apply All_Remove_inv in H1 *)
  (* | [ H1 : All _ (Update _ _ _) |- _ ] => apply All_Update_inv in H1 *)

  | [ |- All _ (Remove _ _) ] => apply All_Remove

  | [ H1 : All ?P ?R, H2 : Lookup ?X ?Y ?R |- _ ] =>
    specialize (H1 _ _ H2); simpl in H1

  | [ H : IF _ then _ else _ |- _ ] => destruct H
  | [ H : _ /\ _             |- _ ] => destruct H
  | [ H : _ \/ _             |- _ ] => destruct H
  | [ H : _ * _              |- _ ] => destruct H
  | [ H : exists _, _        |- _ ] => destruct H
  | [ H : @sig _ _           |- _ ] => destruct H
  | [ H : @sig2 _ _ _        |- _ ] => destruct H
  | [ H : @sigT _ _          |- _ ] => destruct H
  | [ H : @sigT2 _ _ _       |- _ ] => destruct H
  | [ H : bool               |- _ ] => destruct H
  | [ H : option _           |- _ ] => destruct H
  | [ H : sum _ _            |- _ ] => destruct H
  | [ H : sumor _ _          |- _ ] => destruct H
  | [ H : sumbool _ _        |- _ ] => destruct H

  | [ H : forall x, Some ?X = Some x -> _  |- _ ] => specialize (H X eq_refl)
  | [ H : forall x y, Some (?X, ?Y) = Some (x, y) -> _  |- _ ] =>
    specialize (H X Y eq_refl)

  | [ H1 : ?X = true, H2 : ?X = false |- _ ] => rewrite H1 in H2; discriminate

  end; simpl in *; try tauto.

Lemma Update_Update : forall A (addr : A) B (blk1 blk2 : B) r,
  Same (Update addr blk1 (Update addr blk2 r)) (Update addr blk1 r).
Proof.
  split; intros; repeat teardown.
  right; intuition.
  teardown.
Qed.

Global Program Instance Keys_Proper A B :
  Proper (@Same _ _ ==> @Same_set _) (@Keys A B).
Next Obligation.
  split; repeat intro; subst; repeat teardown.
    destruct H0.
    exists x1.
    now apply H.
  destruct H0.
  exists x1.
  now apply H.
Qed.

Global Program Instance Values_Proper A B :
  Proper (@Same _ _ ==> @Same_set _) (@Values A B).
Next Obligation.
  split; repeat intro; subst; repeat teardown.
    destruct H0.
    exists x1.
    now apply H.
  destruct H0.
  exists x1.
  now apply H.
Qed.

Global Program Instance Remove_Proper A B :
  Proper (eq ==> @Same _ _ ==> @Same _ _) (@Remove A B).
Next Obligation.
  split; repeat intro; subst; repeat teardown.
    rewrite <- H0; assumption.
  rewrite H0; assumption.
Qed.

Global Program Instance Map_value_Proper A B :
  Proper (pointwise_relation _ (pointwise_relation _ eq)
            ==> @Same _ _ ==> @Same _ _) (@Map_value A B B).
Next Obligation.
  unfold pointwise_relation.
  split; repeat intro; subst; repeat teardown;
  exists x1;
  split.
  - now rewrite <- H.
  - rewrite <- H0; assumption.
  - now rewrite H.
  - rewrite H0; assumption.
Qed.

Lemma Unique_Map_value_Update : forall A B (P : A -> B -> bool) a b r f,
  (forall x y : A, {x = y} + {x <> y}) ->
  Functional r ->
  Lookup a b r ->
  P a b = true ->
  Unique _ _ P a r ->
  Same (Map_value (fun k e => if P k e then f k e else e) r) (Update a (f a b) r).
Proof.
  intros.
  split; intros; repeat teardown; subst.
  - destruct (X a0 a) eqn:Heqe.
      subst; left.
      specialize (H _ _ H0 _ H4); subst.
      rewrite H1.
      intuition.
    right.
    eapply All_Remove_Lookup_inv in H2; eauto.
    rewrite H2.
    intuition.
  - exists b.
    rewrite H1.
    intuition.
  - exists b0.
    eapply All_Remove_Lookup_inv in H2; eauto.
    rewrite H2.
    intuition.
Qed.

Global Program Instance Finite_Proper_Same {A B} :
  Proper (Same (B:=B) ==> Basics.impl) (Finite (A * B)).
Next Obligation.
  repeat intro.
  apply Same_Same_set in H.
  now rewrite <- H.
Qed.

Global Program Instance Finite_Proper_Same_flip_1 {A B} :
  Proper (Same (B:=B) ==> Basics.flip Basics.impl) (Finite (A * B)).
Next Obligation.
  repeat intro.
  apply Same_Same_set in H.
  now rewrite H.
Qed.

Global Program Instance Finite_Proper_Same_flip_2 {A B} :
  Proper (Same (B:=B) --> Basics.flip Basics.impl) (Finite (A * B)).
Next Obligation.
  repeat intro.
  apply Same_Same_set in H.
  now rewrite <- H.
Qed.

Section TupleEnsembleFinite.

Variable A : Type.
Variable B : Type.

Lemma Empty_preserves_Finite : Finite _ (@Empty A B).
Proof. constructor. Qed.

Lemma Single_is_Finite : forall a b, Finite _ (@Single A B a b).
Proof. intros; apply Finite_sets_facts.Singleton_is_finite. Qed.

Lemma Insert_preserves_Finite : forall a b `(_ : Finite _ r),
  Finite _ (@Insert A B a b r).
Proof. intros; apply Finite_sets_facts.Add_preserves_Finite; assumption. Qed.

Lemma Setminus_preserves_finite {U} :
  forall A:Ensemble U,
    Finite U A -> forall X:Ensemble U, Finite U (Setminus U A X).
Proof.
  intros A' ? ?; apply Finite_sets_facts.Finite_downward_closed with A'; auto with sets.
  intros ? H0; inversion H0; assumption.
Qed.

Lemma Remove_preserves_Finite : forall a `(_ : Finite _ r),
  Finite _ (@Remove A B a r).
Proof. intros; apply Setminus_preserves_finite; assumption. Qed.

Lemma Update_preserves_Finite : forall a b `(_ : Finite _ r),
  Finite _ (@Update A B a b r).
Proof.
  intros; apply Finite_sets_facts.Add_preserves_Finite, Setminus_preserves_finite; assumption.
Qed.

Lemma Filter_preserves_Finite : forall P `(_ : Finite _ r),
  Finite _ (@Filter A B P r).
Proof.
  unfold Filter; intros.
  eapply Finite_sets_facts.Finite_downward_closed; eauto with sets.
  intros ? H0; inversion H0; clear H0.
  unfold Lookup in H.
  rewrite <- surjective_pairing in H.
  assumption.
Qed.

Lemma Finite_Add_Subtract : forall T (Y : Ensemble T) x,
  Finite _ (Add T (Subtract T Y x) x) -> Finite _ Y.
Proof.
  intros.
  eapply Finite_sets_facts.Finite_downward_closed; eauto with sets; intros ??.
  (* Jason Gross: To avoid the axiom of choice, you'd need a stronger version
     of [Finite], something like having a list of elements together with a
     mapping of elements of the type to indices of the list such that if an
     element of the type is in the subset, then it is equal to the element of
     the list at the corresponding index. In this case, everything is
     constructive, and you shouldn't need either Extensionality_Ensembles nor
     decidable equality. *)
  elim (Classical_Prop.classic (x = x0)); intros.
    subst; right; constructor.
  left; constructor; auto.
  unfold not; intros.
  contradiction H1.
  inversion H2.
  reflexivity.
Qed.

Definition Surjective {A B} (X : Ensemble A) (Y : Ensemble B) f :=
  forall y : B, In _ Y y -> exists x : A, In _ X x /\ y = f x.

Lemma Surjective_Add_Subtract : forall T T' X Y f x,
  Surjective (Add T X x) Y f -> Surjective X (Subtract T' Y (f x)) f.
Proof.
  unfold Surjective; intros.
  inversion H0; clear H0.
  destruct (H _ H1) as [? [? ?]]; subst; clear H H1.
  inversion H0; subst; clear H0.
    exists x0; intuition.
  inversion H; subst; clear H.
  contradiction H2.
  constructor.
Qed.

Lemma Surjection_preserves_Finite : forall T T' X Y f,
  Surjective X Y f -> Finite T X -> Finite T' Y.
Proof.
  intros.
  generalize dependent Y.
  induction H0; intros.
    eapply Finite_sets_facts.Finite_downward_closed; eauto with sets; intros ??.
    firstorder.
  apply Surjective_Add_Subtract in H1; auto.
  specialize (IHFinite _ H1).
  eapply Finite_Add_Subtract.
  constructor.
  exact IHFinite.
  unfold not; intros.
  inversion H2.
  contradiction H4.
  constructor.
Qed.

Lemma Map_value_preserves_Finite {C} : forall f `(_ : Finite _ r),
  Finite _ (@Map_value A B C f r).
Proof.
  unfold Map_value; intros.
  apply Surjection_preserves_Finite
   with (X:=r) (f:=fun p => (fst p, f (fst p) (snd p))); trivial.
  intros ??.
  unfold Ensembles.In in H.
  do 2 destruct H.
  destruct y; simpl in *; subst.
  exists (a, x); simpl.
  intuition.
Qed.

Lemma Map_set_preserves_Finite {T T'} : forall f `(_ : Finite _ r),
  Finite _ (@Map_set T T' f r).
Proof.
  unfold Map_set; intros.
  apply Surjection_preserves_Finite with (X:=r) (f:=f); trivial.
  intros ??.
  unfold Ensembles.In in H.
  do 2 destruct H; subst.
  exists x; simpl.
  intuition.
Qed.

Lemma Relate_preserves_Finite :
  forall A B C D (f : A -> B -> C -> D -> Prop) `(_ : Finite _ r)
         (is_functional : forall k e k' e' k'' e'',
            f k e k' e' -> f k e k'' e'' -> k' = k'' /\ e' = e'')
         (is_total : forall (k : A) (e : B),
            { p : C * D | f k e (fst p) (snd p) }),
    Finite _ (Relate f r).
Proof.
  unfold Relate; intros ????? r ? g k.
  eapply Surjection_preserves_Finite
    with (X:=r) (f:=fun p => proj1_sig (k (fst p) (snd p))); trivial.
  intros ??.
  unfold Ensembles.In in H.
  do 2 destruct H.
  destruct y; simpl in *; subst.
  exists (x, x0); simpl.
  destruct (k x x0), x1.
  simpl in *; intuition.
  destruct (g _ _ _ _ _ _ f0 H1); subst.
  reflexivity.
Qed.

Lemma Relate_Add_preserves_Finite :
  forall A B C D (f : A -> B -> C -> D -> Prop) `(_ : Finite _ r) x
         (is_functional : forall k e k' e' k'' e'',
            f k e k' e' -> f k e k'' e'' -> k' = k'' /\ e' = e'')
         (is_total : forall (k : A) (e : B),
            { p : C * D | f k e (fst p) (snd p) }),
    ~ In (A * B) r x
      -> Finite _ (Relate f r)
      -> Finite _ (Relate f (Add (A * B) r x)).
Proof.
  intros.
  apply Relate_preserves_Finite; auto.
  constructor; auto.
Qed.

Lemma Move_preserves_Finite : forall a a' `(_ : Finite _ r),
  (forall x y : A, {x = y} + {x <> y})
    -> Finite _ (@Move A B a a' r).
Proof.
  intros.
  apply Relate_preserves_Finite; trivial; intros.
    intuition; subst; congruence.
  destruct (X k a); subst.
    exists (a', e); simpl; intuition.
  exists (k, e); simpl; intuition.
Qed.

Lemma Modify_preserves_Finite : forall a f `(_ : Finite _ r),
  (forall x y : A, {x = y} + {x <> y})
    -> Finite _ (@Modify A B a f r).
Proof.
  intros.
  apply Relate_preserves_Finite; trivial; intros.
  - firstorder eauto; subst; auto;
    contradiction.
  - destruct (X k a); subst.
    + exists (a, f e); simpl; firstorder.
    + exists (k, e); simpl; firstorder.
Qed.

Lemma Conjunction_preserves_finite_right {U} :
  forall A:Ensemble U,
    Finite U A -> forall X:Ensemble U,
      Finite U (fun x : U => In U X x /\ In U A x).
Proof.
  intros A' H' X.
  apply Finite_sets_facts.Finite_downward_closed with A'; auto with sets.
  intros ? H0; inversion H0; assumption.
Qed.

Lemma Conjunction_preserves_finite_left {U} :
  forall X:Ensemble U,
    Finite U X -> forall A:Ensemble U,
      Finite U (fun x : U => In U X x /\ In U A x).
Proof.
  intros X H' A'.
  apply Finite_sets_facts.Finite_downward_closed with X; auto with sets.
  intros ? H0; inversion H0; assumption.
Qed.

Lemma Product_preserves_Finite {T U X Y} :
  Finite T X -> Finite U Y -> Finite (T * U) (Product X Y).
Proof.
  intros.
  generalize dependent Y.
  induction H; intros.
    eapply Finite_sets_facts.Finite_downward_closed; eauto with sets.
    intros ? H1; inversion H1; inversion H.
  rewrite Product_Add_left.
  apply Finite_sets_facts.Union_preserves_Finite; auto.
  clear IHFinite H0 H A0.
  induction H1.
    eapply Finite_sets_facts.Finite_downward_closed; eauto with sets.
    intros ? H1; inversion H1; inversion H0.
  rewrite Product_Add_right.
  apply Finite_sets_facts.Union_preserves_Finite; auto.
  rewrite Product_Singleton_Singleton.
  rewrite <- Powerset_facts.Empty_set_zero'.
  constructor.
    constructor.
  unfold not; intros.
  inversion H0.
Qed.

Lemma Define_preserves_Finite : forall P b `(_ : Finite _ r),
  (forall x : A, {P x} + {~ P x})
    -> Finite _ P -> Finite _ (@Define A B P b r).
Proof.
  unfold Define; intros.
  apply Finite_sets_facts.Union_preserves_Finite.
    apply Product_preserves_Finite; auto.
    apply Finite_sets_facts.Singleton_is_finite.
  apply Filter_preserves_Finite; auto.
Qed.

End TupleEnsembleFinite.

(*#[export]*) Hint Resolve Conjunction_preserves_finite_left : sets.
(*#[export]*) Hint Resolve Conjunction_preserves_finite_right : sets.
(*#[export]*) Hint Resolve Define_preserves_Finite : sets.
(*#[export]*) Hint Resolve Empty_preserves_Finite : sets.
(*#[export]*) Hint Resolve Filter_preserves_Finite : sets.
(*#[export]*) Hint Resolve Finite_Add_Subtract : sets.
(*#[export]*) Hint Resolve Insert_preserves_Finite : sets.
(*#[export]*) Hint Resolve Map_value_preserves_Finite : sets.
(*#[export]*) Hint Resolve Modify_preserves_Finite : sets.
(*#[export]*) Hint Resolve Move_preserves_Finite : sets.
(*#[export]*) Hint Resolve Product_Add_left : sets.
(*#[export]*) Hint Resolve Product_Add_right : sets.
(*#[export]*) Hint Resolve Product_Empty_set_left : sets.
(*#[export]*) Hint Resolve Product_Empty_set_right : sets.
(*#[export]*) Hint Resolve Product_Singleton_Singleton : sets.
(*#[export]*) Hint Resolve Product_preserves_Finite : sets.
(*#[export]*) Hint Resolve Relate_Add_preserves_Finite : sets.
(*#[export]*) Hint Resolve Relate_preserves_Finite : sets.
(*#[export]*) Hint Resolve Remove_preserves_Finite : sets.
(*#[export]*) Hint Resolve Setminus_preserves_finite : sets.
(*#[export]*) Hint Resolve Single_is_Finite : sets.
(*#[export]*) Hint Resolve Surjection_preserves_Finite : sets.
(*#[export]*) Hint Resolve Surjective_Add_Subtract : sets.
(*#[export]*) Hint Resolve Update_preserves_Finite : sets.

Ltac finite_preservation :=
  repeat (
  match goal with
  | [ |- Finite _ Empty           ] => apply Empty_preserves_Finite
  | [ |- Finite _ (Single _ _)    ] => apply Single_is_Finite
  | [ |- Finite _ (Insert _ _ _)  ] => apply Insert_preserves_Finite
  | [ |- Finite _ (Remove _ _)    ] => apply Remove_preserves_Finite
  | [ |- Finite _ (Update _ _ _)  ] => apply Update_preserves_Finite
  | [ |- Finite _ (Move _ _ _)    ] => apply Move_preserves_Finite
  | [ |- Finite _ (Map_value _ _) ] => apply Map_value_preserves_Finite
  | [ |- Finite _ (Map_set _ _)   ] => apply Map_set_preserves_Finite
  | [ |- Finite _ (Relate _ _)    ] => apply Relate_preserves_Finite
  | [ |- Finite _ (Filter _ _)    ] => apply Filter_preserves_Finite
  | [ |- Finite _ (Define _ _ _)  ] => apply Define_preserves_Finite
  | [ |- Finite _ (Modify _ _ _)  ] => apply Modify_preserves_Finite
  | [ |- Finite _ (Union _ _ _)   ] => apply Finite_sets_facts.Union_preserves_Finite
  | [ |- Finite _ (Add _ _ _)     ] => apply Finite_sets_facts.Add_preserves_Finite
  end; auto).

Reserved Notation "k ↦ v 'in' m" (at level 68, no associativity).

Class MapMembership (t : Type → Type → Type) (k : Type) := {
  has_elem {a} : k → a → t k a → Prop;
  insert_elem {a} : k → a → t k a → t k a
}.

Notation "k ↦ v 'in' m" := (has_elem k v m) (at level 68, no associativity).

Notation "k ↦ v 'not' 'in' m" := (~ has_elem k v m) (at level 68, no associativity).

Notation "m 'having' k ∷= v" := (insert_elem k v m) (at level 68, no associativity).

Global Instance Ensemble_MapMembership {k} : MapMembership (λ k v, Ensemble (k * v)) k := {|
  has_elem := λ {v} i x, flip (Ensembles.In (k * v)) (i, x);
  insert_elem := λ {v} i x m, Ensembles.Add _ m (i, x)
|}.

Global Instance list_MapMembership {k} : MapMembership (λ k v, list (k * v)) k := {|
  has_elem := λ {v} i x, List.In (i, x);
  insert_elem := λ {v} i x m, cons (i, x) m
|}.

Global Instance Map_MapMembership {k} : MapMembership Map k := {|
  has_elem := λ {v}, @Lookup k v;
  insert_elem := λ {v} i x m, Update i x m
|}.

Global Instance FinMap_MapMembership {k} : MapMembership FinMap k := {|
  has_elem := λ {v} i x (m : FinMap k v), @Lookup k v i x m;
  insert_elem := λ {v} i x m, UpdateF _ _ i x m
|}.

Global Instance FunMap_MapMembership {k} `{EqDec k} : MapMembership FunMap k := {|
  has_elem := λ {v} i x (m : FunMap k v), @LookupU k v i m = Some x;
  insert_elem := λ {v} i x m, UpdateU _ _ i x m
|}.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal30.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (l1:lst) (n0:natural) (l2:lst) (IHl2:@eq lst (rev (append (Cons n l1) l2)) (append (rev l2) (rev (Cons n l1)))):@eq lst (append (rev (append l1 (Cons n0 l2))) (Cons n Nil))
  (append (append (rev l2) (Cons n0 Nil)) (append (rev l1) (Cons n Nil))).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal30_rev_append_54_append_rev_cons/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (l1:lst) (n0:natural) (l2:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"l1:" ++ "(" ++ show l1 ++ ")"++ "|" ++"n0:" ++ "(" ++ show n0 ++ ")"++ "|" ++"l2:" ++ "(" ++ show l2 ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  l1 n0 l2.
QuickChick collect_data.
Success.


Require Import Fiat.QueryStructure.Automation.MasterPlan.

Open Scope list_scope.

(* This is an internet packet classifier example. We model a packet with its ip address and
   network protocol. The ADT has one relation (table) named [Rules], which contains classification rules *)

Section Packet.
  (* an Ip address is a list of ascii each of which represents a group *)
  Definition Ip := list nat.

  (* a Protocol can be either tcp or udp *)
  Inductive Protocol := tcp | udp.

  Lemma Protocol_dec : forall a b : Protocol, {a = b} + {a <> b}.
  Proof. decide equality. Defined.

  Global Instance Query_eq_Protocol :
    Query_eq Protocol := {| A_eq_dec := Protocol_dec |}.

  (* a Policy of P is either enforcing some constant P, or accepting any *)
  Section Packet_Protocol.
    Variable (P : Type).
    Context {P_eq_dec : Query_eq P}.

    Inductive Policy :=
    | enforce : P -> Policy
    | wildcard.

    Definition FollowPolicy (p : Policy) (s : P) :=
      match p with
        | enforce p' => p' = s
        | wildcard => True
      end.

    Definition FollowPolicy_dec (p: Policy) (s : P) : {FollowPolicy p s} + {~ FollowPolicy p s}.
      refine (match p with
                | enforce p' =>
                  if A_eq_dec p' s then
                    left _
                  else
                    right _
                | wildcard => left _
              end); simpl; intuition eauto. Defined.

    Global Instance DecideableFollowPolicy {T} (f : T -> Policy) {n}
    : DecideableEnsemble (fun tup => FollowPolicy (f tup) n) :=
      {| dec n' :=  ?[FollowPolicy_dec (f n') n] |}. intuition; find_if_inside; intuition. Defined.
  End Packet_Protocol.

  (* a Packet consists of Ip and Protocol *)
  Record Packet :=
    { destination : Ip;
      protocol : Protocol }.

  (* a Response of a query can be accept, deny, or uncertain *)
  Inductive Response := Accept | Deny | Uncertain.
End Packet.

Section ADT.
  (* Rule schema *)
  Definition RULES := "Rules".
  Definition PRIORITY := "Priority".
  Definition DESTINATION := "Destination".
  Definition PROTOCOL := "Protocol".
  Definition ACTION := "Action".

  Definition RuleRecord :=
    @Tuple <PRIORITY :: nat,
            DESTINATION :: Ip,
            PROTOCOL :: Policy Protocol,
            ACTION :: bool>%Heading.

  Definition ClassifierSchema :=
  Query Structure Schema
        [ relation RULES has
                   schema <PRIORITY :: nat,
                           DESTINATION :: Ip,
                           PROTOCOL :: Policy Protocol,
                           ACTION :: bool> ]
        enforcing [ ].

  Definition ClassifierSig : ADTSig :=
  ADTsignature {
      Constructor "Init" : rep,
      Method "AddRule" : rep * RuleRecord -> rep * bool,
      Method "Classify" : rep * Packet -> rep * (list RuleRecord)
    }.

  Definition ClassifierSpec : ADT ClassifierSig :=
    Def ADT {
      rep := QueryStructure ClassifierSchema,

    Def Constructor0 "Init" : rep := empty,,

    Def Method1 "AddRule" (r : rep) (rule : RuleRecord) : rep * bool :=
      Insert rule into r!RULES,

    Def Method1 "Classify" (r : rep) (p : Packet) : rep * list RuleRecord :=
      rules <- For (rule in r!RULES)
            (* the rule's ip must be a prefix of the packet's ip *)
            Where (IsPrefix rule!DESTINATION (destination p) /\
            (* the rule's protocol must match the packet's protocol *)
                   FollowPolicy rule!PROTOCOL (protocol p))
            Return rule;
      ret (r, rules)
  }.

  Theorem SharpenedClassifier :
    FullySharpened ClassifierSpec.
  Proof.

    (* Uncomment this to see the mostly sharpened implementation *)
    (* partial_master_plan ltac:(CombineIndexTactics PrefixIndexTactics EqIndexTactics).*)

    master_plan ltac:(CombineIndexTactics PrefixIndexTactics EqIndexTactics).

  Time Defined.

  Time Definition ClassifierImpl : ComputationalADT.cADT ClassifierSig :=
    Eval simpl in (projT1 SharpenedClassifier).

  Print ClassifierImpl.
  Print ADTImplRep.

End ADT.


(* Define a Monad class that can be instantiated *)

(** Start with typeclass for [Monad] parameterized over the type
 [M:Type -> Type].  Note that [M] is a single parameter function.
 Definition is taken original from the web at *find the link* *)

Class Monad (M: Type -> Type):Type :=
{
  unit: forall {A}, A -> M A
  ; bind: forall {A B}, M A -> (A -> (M B)) -> M B
  ; sequence: forall {A B}, M A -> M B -> M B
  ; left_unit : forall {A B} (a:A) (f:A -> M B), bind (unit a) f = f a
  ; right_unit : forall {A} (ma:M A), bind ma unit = ma
  ; assoc : forall {A B C} (ma:M A) (f:A -> M B) (g:B -> M C),
              bind (bind ma f) g = bind ma (fun a => bind (f a) g)
  ; bind_seq_eq : forall {A B} (f:M A) (g:M B),
                    (sequence f g) = (bind f (fun (a:A) => g))
}.

Notation "m >>= f" :=
  (bind m f) (left associativity, at level 49).

Notation "m >> f" :=
  (sequence m f) (left associativity, at level 49).