From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable sQ_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable rT_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable per_ : Universe -> Universe -> Universe -> Prop.
Variable pG_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable midpoint_ : Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defsquare_1 : (forall A B C D : Universe, (sQ_ A B C D -> (cong_ A B C D /\ (cong_ A B B C /\ (cong_ A B D A /\ (per_ D A B /\ (per_ A B C /\ (per_ B C D /\ per_ C D A)))))))).
Variable defsquare2_2 : (forall A B C D : Universe, ((cong_ A B C D /\ (cong_ A B B C /\ (cong_ A B D A /\ (per_ D A B /\ (per_ A B C /\ (per_ B C D /\ per_ C D A)))))) -> sQ_ A B C D)).
Variable lemma_rightangleNC_3 : (forall A B C : Universe, (per_ A B C -> ~(col_ A B C))).
Variable lemma_NCdistinct_4 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable lemma_extension_5 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable axiom_betweennesssymmetry_6 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable defcollinear_7 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_8 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_9 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_10 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_11 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_12 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_13 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_betweennotequal_14 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_NChelper_15 : (forall A B C P Q : Universe, ((~(col_ A B C) /\ (col_ A B P /\ (col_ A B Q /\ P <> Q))) -> ~(col_ P Q C))).
Variable lemma_NCorder_16 : (forall A B C : Universe, (~(col_ A B C) -> (~(col_ B A C) /\ (~(col_ B C A) /\ (~(col_ C A B) /\ (~(col_ A C B) /\ ~(col_ C B A))))))).
Variable proposition_46_17 : (forall A B R : Universe, (exists X Y : Universe, ((A <> B /\ ~(col_ A B R)) -> (sQ_ A B X Y /\ (tS_ Y A B R /\ pG_ A B X Y))))).
Variable lemma_collinearorder_18 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_collinearright_19 : (forall A B C D : Universe, ((per_ A B D /\ (col_ A B C /\ C <> B)) -> per_ C B D)).
Variable lemma_8_2_20 : (forall A B C : Universe, (per_ A B C -> per_ C B A)).
Variable lemma_oppositesideflip_21 : (forall A B P Q : Universe, (tS_ P A B Q -> tS_ P B A Q)).
Variable lemma_righttogether_22 : (forall A B C G : Universe, ((per_ G A B /\ (per_ B A C /\ tS_ G B A C)) -> (rT_ G A B B A C /\ betS_ G A C))).
Variable defray_23 : (forall A B C : Universe, (exists X : Universe, (out_ A B C -> (betS_ X A C /\ betS_ X A B)))).
Variable defray2_24 : (forall A B C X : Universe, ((betS_ X A C /\ betS_ X A B) -> out_ A B C)).
Variable lemma_congruencesymmetric_25 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_congruencetransitive_26 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).
Variable lemma_congruenceflip_27 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable lemma_ray4_1_28 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_29 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_30 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable lemma_layoffunique_31 : (forall A B C D : Universe, ((out_ A B C /\ (out_ A B D /\ cong_ A C A D)) -> C = D)).
Variable lemma_Euclid4_32 : (forall A B C Xa Xb Xc : Universe, ((per_ A B C /\ per_ Xa Xb Xc) -> congA_ A B C Xa Xb Xc)).
Variable proposition_04_33 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ congA_ B A C Xb Xa Xc)) -> (cong_ B C Xb Xc /\ (congA_ A B C Xa Xb Xc /\ congA_ A C B Xa Xc Xb)))).
Variable lemma_diagonalsbisect_34 : (forall A B C D : Universe, (exists X : Universe, (pG_ A B C D -> (midpoint_ A X C /\ midpoint_ B X D)))).
Variable defmidpoint_35 : (forall A B C : Universe, (midpoint_ A B C -> (betS_ A B C /\ cong_ A B B C))).
Variable defmidpoint2_36 : (forall A B C : Universe, ((betS_ A B C /\ cong_ A B B C) -> midpoint_ A B C)).
Variable lemma_equalanglessymmetric_37 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable cn_congruencereflexive_38 : (forall A B : Universe, cong_ A B A B).
Variable lemma_collinear4_39 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable lemma_equalangleshelper_40 : (forall A B C Xa Xb Xc Xp Xq : Universe, ((congA_ A B C Xa Xb Xc /\ (out_ Xb Xa Xp /\ out_ Xb Xc Xq)) -> congA_ A B C Xp Xb Xq)).
Variable lemma_betweennesspreserved_41 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ (cong_ B C Xb Xc /\ betS_ A B C))) -> betS_ Xa Xb Xc)).

Theorem lemma_squareparallelogram_42 : (forall A B C D : Universe, (sQ_ A B C D -> pG_ A B C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export GeoCoq.Elements.OriginalProofs.lemma_equalitysymmetric.

Section Euclid.

Context `{Ax:euclidean_neutral}.

Lemma lemma_inequalitysymmetric :
   forall A B,
   neq A B ->
   neq B A.
Proof.
intros.
assert (~ eq B A).
 {
 intro.
 assert (eq A B) by (conclude lemma_equalitysymmetric).
 contradict.
 }
close.
Qed.

End Euclid.


From mathcomp Require Import ssreflect eqtype.
From deriving Require Import deriving.

Require Import type.

Scheme word_rect := Induction for word Sort Type.

Fail Definition word_indDef := [indDef for word_rect].


Require Import Reals.
Set Implicit Arguments.
Open Local Scope R_scope.

(* We require CR because we use it for Time.
 Todo: Take an arbitrary (C)Ring/(C)Field for Time, so that
 the classical development does not need a separate concrete module. *)

Let Time := R.
Let Duration := { r: R | r >= 0 }.

Program Definition immediately: Duration := 0.
Next Obligation. right. reflexivity. Defined.

Program Definition duration_plus (d d': Duration): Duration := d + d'.
Next Obligation.
  destruct d. destruct d'. simpl.
  replace 0 with (0+0).
    apply Rplus_ge_compat; auto.
  field.
Qed.

Record Flow (X: Set): Type :=
  { flow_fun:> X -> Time -> X
  ; flow_zero: forall x, flow_fun x 0 = x
  ; flow_additive: forall x t t',
      flow_fun x (t + t') = flow_fun (flow_fun x t) t'
  }.

Section product_flow.

  Variables (X Y: Set) (fx: Flow X) (fy: Flow Y).

  Let f (xy: X * Y) (t: Time): X * Y :=
    (fx (fst xy) t, fy (snd xy) t).

  Definition product_flow: Flow (X * Y).
  Proof with auto.
    apply (Build_Flow f); destruct x; unfold f; simpl; intros.
      do 2 rewrite flow_zero...
    do 2 rewrite flow_additive...
  Defined.

End product_flow.


(**
The bicategory of 1-types.

Authors: Dan Frumin, Niels van der Weide

Ported from: https://github.com/nmvdw/groupoids
*)
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Core.AdjointUnique.

Local Open Scope cat.
Local Open Scope bicategory_scope.

Definition one_type
  : UU
  := HLevel 3.

Definition make_one_type
           (X : UU)
           (i : isofhlevel 3 X)
  : one_type
  := tpair (λ A, isofhlevel 3 A) X i.

Definition one_type_to_type : one_type -> UU := pr1.
Coercion one_type_to_type : one_type >-> UU.

Definition one_type_isofhlevel
           (X : one_type)
  : isofhlevel 3 X.
Proof.
  apply X.
Defined.

(** The bicategory *)
Definition one_type_bicat_data
  : prebicat_data.
Proof.
  use build_prebicat_data.
  - exact one_type.
  - exact (λ X Y, X → Y).
  - exact (λ _ _ f g, f ~ g).
  - exact (λ _ x, x).
  - exact (λ _ _ _ f g x, g(f x)).
  - intros.
    exact (homotrefl _).
  - cbn ; intros X Y f g h p q.
    exact (homotcomp p q).
  - cbn ; intros X Y Z f g h p.
    exact (funhomotsec f p).
  - cbn ; intros X Y Z f g h p.
    exact (homotfun p h).
  - intros ; intro.
    apply idpath.
  - intros ; intro.
    apply idpath.
  - intros ; intro.
    apply idpath.
  - intros ; intro.
    apply idpath.
  - intros ; intro.
    apply idpath.
  - intros ; intro.
    apply idpath.
Defined.

Lemma one_type_bicat_laws
  : prebicat_laws one_type_bicat_data.
Proof.
  repeat (use tpair).
  - intros X Y f g p ; cbn in *.
    apply idpath.
  - intros X Y f g p ; cbn in *.
    unfold homotcomp, homotrefl.
    apply funextsec. intro x.
    apply pathscomp0rid.
  - intros X Y f g h k p q r.
    apply funextsec. intro x.
    apply path_assoc.
  - intros; apply idpath.
  - intros; apply idpath.
  - intros X Y Z f g h i p q ; cbn in *.
    apply funextsec. intro x.
    apply idpath.
  - intros X Y Z f g h i p q ; cbn in *.
    apply funextsec. intro x.
    unfold homotcomp, homotfun. simpl.
    apply (! maponpathscomp0 _ _ _).
  - intros X Y f g p ; cbn in *.
    apply funextsec. intro x.
    unfold homotcomp, homotfun. simpl.
    apply pathscomp0rid.
  - intros X Y f g p ; cbn in *.
    apply funextsec. intro x.
    unfold homotcomp, homotfun. simpl.
    etrans. { apply pathscomp0rid. }
    apply maponpathsidfun.
  - intros W X Y Z f g h i p ; cbn in *.
    apply funextsec. intro x.
    unfold homotcomp, funhomotsec. simpl.
    apply pathscomp0rid.
  - intros W X Y Z f g h i p ; cbn in *.
    apply funextsec. intro x.
    apply pathscomp0rid.
  - intros W X Y Z f g h i p ; cbn in *.
    apply funextsec. intro x.
    unfold homotcomp, homotfun. simpl.
    etrans. { apply maponpathscomp. }
    apply (! pathscomp0rid _).
  - intros X Y Z f g h i p q ; cbn in *.
    apply funextsec. intro x.
    unfold homotcomp, homotfun, funhomotsec.
    induction (p x). apply (! pathscomp0rid _).
  - intros; apply idpath.
  - intros; apply idpath.
  - intros; apply idpath.
  - intros; apply idpath.
  - intros; apply idpath.
  - intros; apply idpath.
  - intros; apply idpath.
  - intros V W X Y Z f g h i ; cbn in *.
    apply idpath.
Qed.

Definition one_types
  : bicat.
Proof.
  use build_bicategory.
  - exact one_type_bicat_data.
  - exact one_type_bicat_laws.
  - intros X Y f g ; cbn in *.
    apply (impred 2 (λ x, f x = g x)).
    exact (λ x, pr2 Y (f x) (g x)).
Defined.

(** Each 2-cell is an iso *)
Definition one_type_2cell_iso
  : locally_groupoid one_types.
Proof.
  intros X Y f g α.
  refine (invhomot α ,, _).
  split ; cbn.
  - apply funextsec.
    intro x.
    apply pathsinv0r.
  - apply funextsec.
    intro x.
    apply pathsinv0l.
Defined.

(** It is univalent *)
Definition one_types_is_univalent_2_1
  : is_univalent_2_1 one_types.
Proof.
  intros X Y f g.
  use isweq_iso.
  - intros α. apply funextsec. apply α.
  - intros p.
    induction p ; cbn.
    change (homotrefl f) with (toforallpaths _ f f (idpath f)).
    apply funextsec_toforallpaths.
  - intros α. cbn.
    use subtypePath ; cbn.
    + intro. exact (@isaprop_is_invertible_2cell one_types X Y f g _).
    + etrans. 2:{ apply toforallpaths_funextsec. }
      unfold idtoiso_2_1, toforallpaths. cbn.
      apply funextsec. intro x.
      induction (funextsec _ f g (pr1 α)).
      apply idpath.
Defined.

Definition adjoint_equivalence_is_weq
           {X Y : one_types}
           (f : one_types⟦X,Y⟧)
           (Hf : left_adjoint_equivalence f)
  : isweq f.
Proof.
  use isweq_iso.
  - exact (left_adjoint_right_adjoint Hf).
  - intros x.
    exact (!left_adjoint_unit Hf x).
  - intros x.
    exact (left_adjoint_counit Hf x).
Defined.

Definition weq_is_adjoint_equivalence_help
           {X Y : one_types}
           (f : X --> Y)
           (Hf : isweq f)
  : left_equivalence f.
Proof.
  use tpair.
  - refine (invmap (f ,, Hf) ,, _).
    split.
    + intros x.
      exact (!(homotinvweqweq (f ,, Hf) x)).
    + intros x.
      exact (homotweqinvweq (f ,, Hf) x).
  - split ; apply one_type_2cell_iso.
Defined.

Definition weq_is_adjoint_equivalence
           {X Y : one_types}
           (f : X --> Y)
           (Hf : isweq f)
  : left_adjoint_equivalence f.
Proof.
  apply equiv_to_isadjequiv.
  exact (weq_is_adjoint_equivalence_help f Hf).
Defined.

Definition adjequiv_to_weq (X Y : one_types)
  : (pr1 X ≃ pr1 Y) ≃ adjoint_equivalence X Y.
Proof.
  use weqfibtototal.
  intro f.
  apply weqimplimpl.
  - intro Hf.
    exact (weq_is_adjoint_equivalence f Hf).
  - exact (adjoint_equivalence_is_weq f).
  - apply isapropisweq.
  - apply isaprop_left_adjoint_equivalence.
    exact one_types_is_univalent_2_1.
Defined.

Definition idoiso_2_0_onetypes (X Y : one_types)
  : X = Y ≃ adjoint_equivalence X Y
  := (adjequiv_to_weq X Y ∘ UA_for_HLevels 3 X Y)%weq.

Definition one_types_is_univalent_2_0
  : is_univalent_2_0 one_types.
Proof.
  intros X Y.
  use weqhomot.
  - exact (idoiso_2_0_onetypes X Y).
  - intros p.
    induction p ; cbn.
    apply path_internal_adjoint_equivalence.
    + apply one_types_is_univalent_2_1.
    + apply idpath.
Defined.

Definition one_types_is_univalent_2
  : is_univalent_2 one_types.
Proof.
  split.
  - exact one_types_is_univalent_2_0.
  - exact one_types_is_univalent_2_1.
Defined.


(** * Facts about the [In] and [NoDup] predicates. *)

Require Import CoqLib.
Require Import FstSplit.

(** Lemmas and tactics pertaining to the [In] and [NoDup] predicates
    defined in the [Lists] library.
 *)

Section InAndNoDupLemmas.

  (* In and append *)

  Lemma in_appl : forall {A : Type} {l m} {a : A}, In a l -> In a (l ++ m).
    intros *; intros Hin; apply in_or_app; left; assumption.
  Defined.

  Lemma in_appr : forall {A : Type} {l m} {a : A}, In a m -> In a (l ++ m).
    intros *; intros Hin; apply in_or_app; right; assumption.
  Defined.

  (* In tail of list *)
  Lemma in_last {A : Type} : forall (a : A) l, In a (l ++ [a]).
    intros; apply in_elt.
  Defined.

  (** If a is in list l and l is in list of lists ll then a is in (concat ll).
      The result of (concat ll) is one list corresponding
      to the concatenation of all lists in ll. *)

  Lemma in_concat {A : Type} :
    forall (a : A) (l : list A) (ll : list (list A)),
      In a l -> In l ll -> In a (List.concat ll).
  Proof.
    intros.
    induction ll.
    (* Base case, ll = []. *)
    - elim H0.
    (* Inductive case. *)
    - apply in_inv in H0; elim H0; intros.
      + rewrite <- H1 in H.
        apply or_introl with (B := In a (List.concat ll)) in H.
        apply in_or_app in H.
        rewrite concat_cons.
        auto.
      + apply IHll in H1.
        apply or_intror with (A := In a a0) in H1.
        apply in_or_app in H1.
        rewrite concat_cons.
        auto.
  Qed.

  (** ∀ l, l', NoDup (l ++ l') ⇒ NoDup l ∧ NoDup l'. *)

  Lemma nodup_app {A : Type} :
    forall l l' : list A,
      NoDup (l ++ l') -> NoDup l /\ NoDup l'.
  Proof.
    intros l l'; intro Hnodup_app; split.
    - induction l.
      + apply NoDup_nil.
      + apply NoDup_cons;
          simpl in Hnodup_app;
          apply NoDup_cons_iff in Hnodup_app;
          elim Hnodup_app; intros Hnot_in_concat Hnodup_app'.
        -- intro.
           apply or_introl with (B := In a l') in H.
           apply in_app_iff in H.
           elim Hnot_in_concat; assumption.
        -- apply (IHl Hnodup_app').

    - induction l'.
      + apply NoDup_nil.
      + apply NoDup_cons;
          apply NoDup_remove in Hnodup_app;
          elim Hnodup_app; intros Hnodup_app' Hnot_in_concat.
        -- intro.
           apply or_intror with (A := In a l) in H.
           apply in_app_iff in H.
           elim Hnot_in_concat; assumption.
        -- apply (IHl' Hnodup_app').

  Qed.

  Lemma nodup_appl {A : Type} :
    forall l l' : list A,
      NoDup (l ++ l') -> NoDup l.
  Proof. eapply nodup_app; eauto. Qed.

  Lemma nodup_appr {A : Type} :
    forall l l' : list A,
      NoDup (l ++ l') -> NoDup l'.
  Proof. eapply nodup_app; eauto. Qed.

  (** ∀ l, ll, NoDup (l ++ l') ⇒
    ∀ a ∈ l ⇒ a ∉ l'. *)

  Lemma nodup_app_not_in {A : Type} :
    forall l l': list A,
      NoDup (l ++ l') ->
      forall a : A, In a l -> ~In a l'.
  Proof.
    intros l l' Hnodup a Hin.
    induction l'.
    - simpl; auto.
    - apply not_in_cons.
      apply NoDup_remove in Hnodup.
      elim Hnodup; intros Hnodup_app Hnot_in.
      split.
      + intro; elim Hnot_in; apply in_or_app; left.
        rewrite <- H; assumption.
      + apply IHl'; assumption.
  Qed.

  (** ∀ ll : list (list), NoDup (concat ll) ⇒ ∀ l ∈ ll, NoDup l. *)

  Lemma nodup_concat_gen {A : Type} :
    forall ll : list (list A),
      NoDup (List.concat ll) ->
      forall l : list A, In l ll -> NoDup l.
  Proof.
    intros ll Hnodup_concat l Hin.
    induction ll.
    - inversion Hin.
    - apply in_inv in Hin;
        elim Hin;
        rewrite concat_cons in Hnodup_concat;
        apply nodup_app in Hnodup_concat;
        elim Hnodup_concat;
        intros Hnodup_a Hnodup_concat'.
      + intro Heq; rewrite Heq in Hnodup_a; assumption.
      + intro Hin_ll; apply (IHll Hnodup_concat' Hin_ll).
  Qed.

  (** If one element a is not in the list l and another element b
    is in the list l then a and b are different. *)

  Lemma not_in_in_diff {A : Type} :
    forall {a b} {l : list A}, ~In a l /\ In b l -> a <> b.
  Proof.
    intros.
    elim H; intros.
    intro.
    rewrite H2 in H0.
    contradiction.
  Qed.

  (** ∀ a, a ∉ l ∧ a ∉ l' ⇒ a ∉ (l ++ l') *)

  Lemma not_in_app {A : Type} :
    forall (a : A) (l l' : list A),
      ~In a l /\ ~In a l' -> ~In a (l ++ l').
  Proof.
    intros a l l' Hnot_in.
    elim Hnot_in; intros Hnot_in_l Hnot_in_l'.
    intro Hin_app.
    apply in_app_or in Hin_app.
    elim Hin_app.
    - intro Hin_l; elim Hnot_in_l; assumption.
    - intro Hin_l'; elim Hnot_in_l'; assumption.
  Qed.

  (** ∀ a, a ∉ (l ++ l') ⇒ a ∉ l ∧ a ∉ l' *)

  Lemma not_app_in {A : Type} :
    forall {a : A} {l l' : list A},
      ~In a (l ++ l') -> ~In a l /\ ~In a l'.
  Proof.
    intros a l l' Hnot_in_app.
    split.
    - induction l.
      + apply in_nil.
      + apply not_in_cons. split.
        -- intro Heq.
           elim Hnot_in_app.
           apply in_or_app.
           left.
           rewrite Heq; apply in_eq.
        -- simpl in Hnot_in_app.
           apply Decidable.not_or in Hnot_in_app.
           elim Hnot_in_app; intros Hdiff Hnot_in_app'.
           apply (IHl Hnot_in_app').
    - induction l.
      + simpl in Hnot_in_app; assumption.
      + simpl in Hnot_in_app.
        apply Decidable.not_or in Hnot_in_app.
        elim Hnot_in_app; intros Hdiff Hnot_in_app'.
        apply (IHl Hnot_in_app').
  Qed.

  (** ∀ a, b, a ≠ b ⇒ a ∉ [b] *)

  Lemma diff_not_in {A : Type} :
    forall a b : A, a <> b -> ~In a [b].
  Proof.
    intros a b Hdiff.
    intro Hin.
    simpl in Hin.
    elim Hin; [ intro Heq; symmetry in Heq; contradiction | auto].
  Qed.

  (** If the two elements are different then
    all pairs built with these elements are different. *)

  Lemma fst_diff_pair_diff {A B : Type} :
    forall (a x : A),
      a <> x -> (forall (b y : B), (a, b) <> (x, y)).
  Proof.
    intros.
    injection; intros.
    contradiction.
  Qed.

  (**
    ∀ l : A ⨱ B, NoDup (fst (split l)) ⇒
    ∀ p, p' ∈ l, fst p = fst p' ⇒ p = p'

    If there are no duplicates in the first elements
    of l, then all pairs with the same first element
    are equal.
   *)

  Lemma nodup_same_pair {A B : Type} :
    forall (l : list (A * B)),
      NoDup (fst (split l)) ->
      forall (p p' : A * B),
        In p l -> In p' l -> fst p = fst p' -> p = p'.
  Proof.
    intro.
    induction l; intros.
    - inversion H0.
    - dependent induction a.
      rewrite fst_split_cons_app in H; simpl in H.
      apply NoDup_cons_iff in H; elim H; intros.
      apply in_inv in H0; elim H0; intros.
      + apply in_inv in H1.
        elim H1; intros.
        -- rewrite <- H5; rewrite <- H6; reflexivity.
        -- rewrite <- H5 in H2.
           dependent destruction p'.
           simpl in H2.
           apply in_fst_split in H6.
           rewrite <- H2 in H6.
           contradiction.
      + apply in_inv in H1.
        elim H1; intros.
        -- rewrite <- H6 in H2.
           dependent destruction p.
           simpl in H2.
           apply in_fst_split in H5.
           rewrite H2 in H5.
           contradiction.
        -- generalize (IHl H4); intro.
           apply (H7 p p' H5 H6 H2).
  Qed.

  (** incl (a :: l) l' ⇒ incl l l' *)

  Lemma incl_cons_inv {A : Type} :
    forall (a : A) (l l' : list A), incl (a :: l) l' -> incl l l'.
  Proof.
    intros a l l' Hincl_cons.
    induction l.
    - unfold incl; intros a' Hin_nil; inversion Hin_nil.
    - apply incl_cons.
      + unfold incl in Hincl_cons.
        assert (In a0 (a :: a0 :: l)) by (apply in_cons; apply in_eq).
        apply (Hincl_cons a0 H).
      + apply IHl. unfold incl.
        intros a' Hin_cons.
        apply in_inv in Hin_cons; elim Hin_cons.
        -- intro Heq; unfold incl in Hincl_cons.
           assert (Hin_cons' : In a (a :: a0 :: l)) by apply in_eq.
           rewrite <- Heq; apply (Hincl_cons a Hin_cons').
        -- intro Hin.
           apply in_cons with (a := a0) in Hin.
           apply in_cons with (a := a) in Hin.
           apply (Hincl_cons a' Hin).
  Qed.

  (** NoDup (l ++ l') ⇒ NoDup (l' ++ l) *)

  Lemma NoDup_app_comm {A : Type} :
    forall (l l' : list A), NoDup (l ++ l') -> NoDup (l' ++ l).
  Proof.
    intros l l' Hnodup.
    induction l'.
    - simpl; rewrite <- app_nil_end in Hnodup; assumption.
    - rewrite <- app_comm_cons. apply NoDup_cons.
      + apply NoDup_remove_2 in Hnodup.
        apply not_app_in in Hnodup.
        apply not_in_app.
        apply and_comm.
        assumption.
      + apply NoDup_remove in Hnodup; elim Hnodup; intros Hnodup' Hnot_in.
        apply (IHl' Hnodup').
  Qed.

  Lemma NoDup_app_cons :
    forall {A : Type} (l m : list A),
      List.NoDup l -> List.NoDup m ->
      (forall a, List.In a l -> ~List.In a m) ->
      List.NoDup (l ++ m).
  Proof.
    induction 1.
    - rewrite app_nil_l; auto.
    - intros; rewrite <- app_comm_cons.
      apply NoDup_cons.
      + apply not_in_app; split; [auto | firstorder].
      + apply IHNoDup; firstorder.
  Qed.

  (** (l ++ l') ⊆ m ⇒ (l ⊆ m ∧ l' ⊆ m) *)

  Lemma incl_app_inv {A : Type} :
    forall (l l' m : list A), incl (l ++ l') m -> incl l m /\ incl l' m.
  Proof.
    intros l l' m Hincl_app. split.
    + unfold incl. induction l.
      -- intros a Hin_nil; inversion Hin_nil.
      -- intros a' Hin_cons.
         unfold incl in Hincl_app.
         apply or_introl with (B := In a' l') in Hin_cons.
         apply in_or_app in Hin_cons.
         apply (Hincl_app a' Hin_cons).
    + induction l'.
      -- intros a Hin_nil; inversion Hin_nil.
      -- apply incl_cons.
         ++ unfold incl in Hincl_app.
            assert (In a (l ++ a :: l')) by (apply in_or_app; right; apply in_eq).
            apply (Hincl_app a H).

         ++ unfold incl. intros a' Hin.
            apply in_cons with (a := a) in Hin.
            apply or_intror with (A := In a' l) in Hin.
            apply in_or_app in Hin.
            apply (Hincl_app a' Hin).

  Qed.

  (** NoDup (l ++ m ++ n) ∧ NoDup o ∧ o ⊆ m ⇒ NoDup (l ++ o ++ n) *)

  Theorem nodup_app_incl {A : Type} :
    forall (l m n o : list A),
      NoDup (l ++ m ++ n) ->
      NoDup o ->
      incl o m ->
      NoDup (l ++ o ++ n).
  Proof.
    intros l m n o Hnodup_lmn Hnodup_o Hincl_om.
    induction o.
    - simpl.
      apply NoDup_app_comm with (l' := (m ++ n)) in Hnodup_lmn.
      rewrite <- app_assoc in Hnodup_lmn.
      apply NoDup_app_comm with (l' := (n ++ l)) in Hnodup_lmn.
      apply nodup_app in Hnodup_lmn.
      elim Hnodup_lmn; intros Hnodup_ln Hnodup_m.
      apply NoDup_app_comm in Hnodup_ln.
      assumption.
    - apply NoDup_app_comm.
      rewrite <- app_assoc.
      rewrite <- app_comm_cons.
      apply NoDup_cons.
      + apply NoDup_cons_iff in Hnodup_o; elim Hnodup_o; intros Hnot_in_o Hnodup_o'.
        apply NoDup_app_comm with (l' := (m ++ n)) in Hnodup_lmn.
        rewrite <- app_assoc in Hnodup_lmn.
        specialize (nodup_app_not_in m (n ++ l) Hnodup_lmn) as Hin_m_not_in_nl.
        assert (Hin_ao : In a (a :: o)) by apply in_eq.
        specialize (Hincl_om a Hin_ao) as Hin_am.
        specialize (Hin_m_not_in_nl a Hin_am) as Hnot_in_nl.
        apply (not_in_app a o (n ++ l) (conj Hnot_in_o Hnot_in_nl)).
      + apply incl_cons_inv in Hincl_om.
        apply NoDup_cons_iff in Hnodup_o; elim Hnodup_o; intros Hnot_in Hnodup_o'.
        specialize (IHo Hnodup_o' Hincl_om) as Hnodup_lon.
        apply NoDup_app_comm in Hnodup_lon.
        rewrite app_assoc.
        assumption.
  Qed.

  (** Lemmas about remove function. *)

  Functional Scheme remove_ind := Induction for remove Sort Prop.

  Lemma not_in_remove_eq {A : Type} :
    forall (eq_dec : forall (x y : A), {x = y} + {x <> y})
           (a  : A)
           (l : list A),
      ~In a l -> remove eq_dec a l = l.
  Proof.
    intros eq_dec a l;
      functional induction (remove eq_dec a l) using remove_ind;
      intros Hnot_in_l.
    - reflexivity.
    - apply not_in_cons in Hnot_in_l; apply proj1 in Hnot_in_l.
      elim Hnot_in_l; reflexivity.
    - apply not_in_cons in Hnot_in_l; apply proj2 in Hnot_in_l.
      specialize (IHl0 Hnot_in_l) as Heq_rm; rewrite Heq_rm; reflexivity.
  Qed.

  Lemma in_remove_iff {A : Type} :
    forall (a  : A)
           (eq_dec : forall (x y : A), {x = y} + {x <> y})
           (x : A)
           (l : list A),
      In a (remove eq_dec x l) <-> In a l /\ a <> x.
  Proof.
    intros a eq_dec x l;
      functional induction (remove eq_dec x l) using remove_ind.
    - split; [auto | intro Hw_in; apply proj1 in Hw_in; inversion Hw_in].
    - split.
      + intro Hin_a_rm.
        rewrite  IHl0 in Hin_a_rm.
        split; [apply in_cons; apply proj1 in Hin_a_rm; assumption |
                apply proj2 in Hin_a_rm; assumption].
      + intro Hw_in.
        elim Hw_in; intros Hin_ctl Hdiff_ax; clear Hw_in.
        inversion Hin_ctl as [Heq_ax | Hin_tl];
          [ symmetry in Heq_ax; contradiction |
            rewrite IHl0; apply (conj Hin_tl Hdiff_ax) ].
    - split.
      + intro Hin_a_rm; inversion_clear Hin_a_rm as [Heq_ay | Hin_rm_tl].
        -- split.
           ++ rewrite Heq_ay; apply in_eq.
           ++ intro Heq_ax;
                symmetry in Heq_ax;
                rewrite <- Heq_ay in Heq_ax;
                contradiction.
        -- rewrite IHl0 in Hin_rm_tl; split.
           ++ apply in_cons; apply proj1 in Hin_rm_tl; assumption.
           ++ apply (proj2 Hin_rm_tl).
      + intro Hin_a_l.
        elim Hin_a_l; clear Hin_a_l; intros Hin_a_l Hdiff_ax.
        simpl; inversion_clear Hin_a_l as [Heq_ay | Hin_tl].
        -- left; assumption.
        -- right; rewrite IHl0; apply (conj Hin_tl Hdiff_ax).
  Qed.

  Lemma not_in_not_in_remove {A : Type} :
    forall (a  : A) (l : list A),
      ~In a l ->
      forall (x : A)
             (eq_dec : forall (x y : A), {x = y} + {x <> y}),
        ~In a (remove eq_dec x l).
  Proof.
    intros a l Hnot_in_a_l x eq_dec;
      functional induction (remove eq_dec x l) using remove_ind.
    - apply in_nil.
    - rewrite (not_in_cons a y tl) in Hnot_in_a_l; apply proj2 in Hnot_in_a_l.
      apply (IHl0 Hnot_in_a_l).
    - rewrite not_in_cons; split.
      + rewrite (not_in_cons a y tl) in Hnot_in_a_l; apply proj1 in Hnot_in_a_l; assumption.
      + rewrite (not_in_cons a y tl) in Hnot_in_a_l; apply proj2 in Hnot_in_a_l.
        apply (IHl0 Hnot_in_a_l).
  Qed.

  (** If list l has no duplicates then removing one element from list l
    preserves this property. *)

  Lemma nodup_if_remove {A : Type} :
    forall (l : list A),
      NoDup l ->
      forall (a : A)
             (eq_dec : forall (x y : A), {x = y} + {x <> y}),
        NoDup (remove eq_dec a l).
  Proof.
    intros l Hnodup_l a eq_dec;
      functional induction (remove eq_dec a l) using remove_ind.
    - apply NoDup_nil.
    - rewrite NoDup_cons_iff in Hnodup_l;
        apply proj2 in Hnodup_l;
        apply (IHl0 Hnodup_l).
    - apply NoDup_cons.
      + rewrite NoDup_cons_iff in Hnodup_l; apply proj1 in Hnodup_l.
        apply (not_in_not_in_remove y tl Hnodup_l a eq_dec).
      + rewrite NoDup_cons_iff in Hnodup_l; apply proj2 in Hnodup_l.
        apply (IHl0 Hnodup_l).
  Qed.

  (**
    Conditions:
    - l and m are lists of couples
    - l and m have no duplicates in the first
      elements of their couples
    - All couples of l are in m
    - The list of first elements of l and m are equal
      modulo permutation

    Conclusion: l and m are equal modulo permutation

   *)

  Lemma permutation_fs_permutation {A B : Type} :
    forall (l m : list (A * B)),
      NoDup (fs l) ->
      NoDup (fs m) ->
      incl l m ->
      Permutation (fs l) (fs m) ->
      Permutation l m.
  Proof.
    intros l m Hnodup_fs_l Hnodup_fs_m Hincl Hperm_fs.

    (* Strategy: apply [NoDup_Permutation].

     Premises:
     - NoDup l
     - NoDup m
     - ∀x, x ∈ l ⇔ x ∈ m
     *)

    (* Builds ∀x, x ∈ l ⇔ x ∈ m *)
    assert (Hequiv_lm : forall (x : A * B), In x l <-> In x m).
    {
      intros x; split.

      (* x ∈ l ⇒ x ∈ m *)
      - unfold incl in Hincl; apply (Hincl x).

      (* x ∈ m ⇒ x ∈ l *)
      - intros Hin_m.
        destruct x.
        specialize (in_fst_split a b m Hin_m) as Hin_fs_m.
        apply Permutation_sym in Hperm_fs.
        specialize (@Permutation_in A (fs m) (fs l) a Hperm_fs Hin_fs_m) as Hin_fs_l.
        specialize (@in_fst_split_in_pair A B a l Hin_fs_l) as Hex_in_l.
        inversion_clear Hex_in_l as (b' & Hin_ab'_l).
        specialize (Hincl (a, b') Hin_ab'_l) as Hin_ab'_m.

        (* Specializes nodup_same_pair. *)
        assert (Heq_ab : fst (a, b) = fst (a, b')) by auto.
        specialize (nodup_same_pair m Hnodup_fs_m (a, b) (a, b') Hin_m Hin_ab'_m Heq_ab)
          as Heq_ab_ab'.
        injection Heq_ab_ab' as Heq_bb'.

        (* Rewrites b' with b, then QED. *)
        rewrite <- Heq_bb' in Hin_ab'_l; assumption.
    }

    (* Builds NoDup l and NoDup m *)
    apply nodup_fst_split in Hnodup_fs_l.
    apply nodup_fst_split in Hnodup_fs_m.

    (* Applies  *)
    apply (NoDup_Permutation Hnodup_fs_l Hnodup_fs_m Hequiv_lm).
  Qed.

End InAndNoDupLemmas.

#[export]
Hint Resolve in_appl in_appr in_last : core.

#[export]
Hint Resolve nodup_app nodup_appl nodup_appr : nodup.

(** ** Misc. tactics for [In] and [NoDup] predicates *)

(** If Hincl_fs is a the form (incl (fst (split (?a, ?b) :: _)) _)
    then rewrites Hincl_fs in (incl (fst (split _))), i.e removes
    the head. *)

Ltac incl_rm_hd_fs Hincl_fs :=
  lazymatch type of Hincl_fs with
  | incl (fst (split ((_, _) :: _))) _ =>
    rewrite fst_split_cons_app in Hincl_fs;
    simpl in Hincl_fs;
    apply incl_cons_inv in Hincl_fs
  | _ => fail "Argument is not of the form (incl (fst (split (?a, ?b) :: _)) _)"
  end.

Ltac apply_nodup_same_pair :=
  lazymatch goal with
  | [ Hin_p_l: In (?x, ?y) ?l, Hin_p'_l: In (?x, ?z) ?l, Hnodup_l: NoDup (fst (split ?l)) |- _ ] =>
    assert (Heq_fs_pair : fst (x, y) = fst (x, z)) by (simpl; auto);
    specialize (nodup_same_pair l Hnodup_l (x, y) (x, z) Hin_p_l Hin_p'_l Heq_fs_pair);
    intros Heq_pairs;
    clear Heq_fs_pair
  | _ => fail "Missing hypotheses: In ?p ?l or In ?p' ?l or NoDup (fst (split ?l))"
  end.

(**  *)

Ltac contradiction_with_nodup_same_pair Hin_p_l Hin_p'_l :=

  (* Checks that arguments are well-typed. *)
  lazymatch type of Hin_p_l with
  | In ?p ?l =>
    lazymatch type of Hin_p'_l with
    | In ?p' l =>
      lazymatch goal with
      | [ Hnodup: NoDup (fst (split l)) |- _ ] =>

        (* Specializes nodup_same_pair then shows a contradiction. *)
        assert (Heq_fs_pair : fst p = fst p') by (simpl; auto);
        specialize (nodup_same_pair l Hnodup p p' Hin_p_l Hin_p'_l Heq_fs_pair);
        intros Heq_pp';
        (injection Heq_pp' as Heq_snd_pp'; inversion Heq_snd_pp') || auto

      | _ => fail "No hypothesis of the form NoDup (fst (split l))"
      end
    | _ => fail "2nd argument is not of the form In (?a, ?b) ?l"
    end
  | _ => fail "1st argument is not of the form In (?a, ?b) ?l"
  end.

(** Looks for a hypothesis of the form [NoDup (?a :: ?l)]
    in the context, and deduces [~In ?a ?l] from it.

    Produces a new hypothesis [Hnot_in_tl : ~In ?a ?l]
    in the context. *)

Ltac deduce_nodup_hd_not_in :=
  match goal with
  | [ Hnodup: NoDup (_ :: _) |- _ ] =>
    let Hnot_in := fresh "Hnot_in_tl" in
    assert (Hnot_in := Hnodup);
    rewrite NoDup_cons_iff in Hnot_in;
    apply proj1 in Hnot_in
  | _ => fail "No hypothesis of the form 'NoDup (?a :: ?l)'"
  end.

(** *** Lemmas using the above tactics . *)

(** Proves the equivalence between to list
      of couples l' and l'', with some hypotheses
      on these two lists.
 *)

Lemma eq_if_eq_fs {A B : Type} :
  forall (l l' l'' : list (A * B)),
    (forall (a : A)
            (b : B),
        In (a, b) l -> exists (b' : B), In (a, b') l' /\ In (a, b') l'') ->
    fst (split l) = fst (split l') ->
    fst (split l) = fst (split l'') ->
    NoDup (fst (split l)) ->
    NoDup (fst (split l')) ->
    NoDup (fst (split l'')) ->
    forall (x : A) (y : B), In (x, y) l' <-> In (x, y) l''.
Proof.
  intros l l' l'' Hin_l_in_ll Heq_fs_ll' Heq_fs_ll''
         Hnodup_l Hnodup_l' Hnodup_l'' x y.

  (* Proves both side of the implication. *)
  split;
    let deduce_goal list Heq_fs_list :=
        (intros Hin_xy_list;
         specialize (in_fst_split x y list Hin_xy_list) as Hin_x_fs_list;
         rewrite <- Heq_fs_list in Hin_x_fs_list;
         apply (in_fst_split_in_pair x l) in Hin_x_fs_list;
         inversion_clear Hin_x_fs_list as (z & Hin_xz_l);
         specialize (Hin_l_in_ll x z Hin_xz_l) as Hex_in_ll;
         inversion_clear Hex_in_ll as (c & Hw_in_xc_ll);
         inversion_clear Hw_in_xc_ll as (Hin_xc_list & Hin_xc_list');
         apply_nodup_same_pair;
         injection Heq_pairs as Heq_yc;
         rewrite Heq_yc;
         assumption) in
    (deduce_goal l' Heq_fs_ll' || deduce_goal l'' Heq_fs_ll'').
Qed.

(** Proves the equivalence between to list
    of couples m and n, with some hypotheses
    on these two lists.
 *)

Lemma equiv_if_perm_and_nodup_fs {A B : Type} :
  forall (l m n : list (A * B)),
    (forall (a : A)
            (b : B),
        In (a, b) l -> exists (b' : B), In (a, b') m /\ In (a, b') n) ->
    Permutation (fs l) (fs m) ->
    Permutation (fs l) (fs n) ->
    NoDup (fs l) ->
    NoDup (fs m) ->
    NoDup (fs n) ->
    forall (x : A) (y : B), In (x, y) m <-> In (x, y) n.
Proof.
  intros l m n Hin_l_in_mn Hperm_fs_lm Hperm_fs_ln
         Hnodup_l Hnodup_m Hnodup_n x y.

  (* Proves both side of the implication. *)
  split;
    let deduce_goal list Heq_fs_list :=
        (intros Hin_xy_list;
         specialize (in_fst_split x y list Hin_xy_list) as Hin_x_fs_list;
         rewrite <- Heq_fs_list in Hin_x_fs_list;
         apply (in_fst_split_in_pair x l) in Hin_x_fs_list;
         inversion_clear Hin_x_fs_list as (z & Hin_xz_l);
         specialize (Hin_l_in_mn x z Hin_xz_l) as Hex_in_ll;
         inversion_clear Hex_in_ll as (c & Hw_in_xc_ll);
         inversion_clear Hw_in_xc_ll as (Hin_xc_list & Hin_xc_list');
         unfold fs in *;
         apply_nodup_same_pair;
         injection Heq_pairs as Heq_yc;
         rewrite Heq_yc;
         assumption) in
    (deduce_goal m Hperm_fs_lm || deduce_goal n Hperm_fs_ln).
Qed.

(* Hints to solve In predicate goals *)

#[export] Hint Resolve in_app_or : core.
#[export] Hint Resolve in_cons : core.
#[export] Hint Resolve nodup_app : core.

(* Hints to solve NoDup predicate goals *)

#[export] Hint Constructors NoDup : core.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.SmartMap.
Require Import Crypto.Reflection.MapCastByDeBruijn.
Require Import Crypto.Reflection.Z.Syntax.

Section language.
  Context {interp_base_type_bounds : base_type -> Type}
          (interp_op_bounds : forall src dst, op src dst -> interp_flat_type interp_base_type_bounds src -> interp_flat_type interp_base_type_bounds dst)
          (pick_typeb : forall t, interp_base_type_bounds t -> base_type).
  Local Notation pick_type v := (SmartFlatTypeMap pick_typeb v).
  Context (cast_op : forall t tR (opc : op t tR) args_bs,
              op (pick_type args_bs) (pick_type (interp_op_bounds t tR opc args_bs))).
  Context {t : type base_type}.

  Definition MapCastCompile := @MapCastCompile base_type op t.
  Definition MapCastDoCast
    := @MapCastDoCast
         base_type op base_type_beq internal_base_type_dec_bl
         interp_base_type_bounds interp_op_bounds pick_typeb cast_op t.
  Definition MapCastDoInterp
    := @MapCastDoInterp
         base_type op base_type_beq internal_base_type_dec_bl
         (fun _ t => Op (OpConst 0%Z) TT)
         interp_base_type_bounds pick_typeb t.
  Definition MapCast e input_bounds
    := MapCastDoInterp input_bounds (MapCastDoCast input_bounds (MapCastCompile e)).
End language.


From Hammer Require Import Hammer.

Set Implicit Arguments.

Require Export Notations.

Notation "A -> B" := (forall (_ : A), B) : type_scope.

Inductive True : Prop :=
I : True.

Inductive False : Prop :=.

Definition not (A:Prop) := A -> False.

Notation "~ x" := (not x) : type_scope.

Hint Unfold not: core.

Inductive and (A B:Prop) : Prop :=
conj : A -> B -> A /\ B

where "A /\ B" := (and A B) : type_scope.

Section Conjunction.

Variables A B : Prop.

Theorem proj1 : A /\ B -> A.
Proof. hammer_hook "Logic" "Logic.proj1".
destruct 1; trivial.
Qed.

Theorem proj2 : A /\ B -> B.
Proof. hammer_hook "Logic" "Logic.proj2".
destruct 1; trivial.
Qed.

End Conjunction.

Inductive or (A B:Prop) : Prop :=
| or_introl : A -> A \/ B
| or_intror : B -> A \/ B

where "A \/ B" := (or A B) : type_scope.

Arguments or_introl [A B] _, [A] B _.
Arguments or_intror [A B] _, A [B] _.

Definition iff (A B:Prop) := (A -> B) /\ (B -> A).

Notation "A <-> B" := (iff A B) : type_scope.

Section Equivalence.

Theorem iff_refl : forall A:Prop, A <-> A.
Proof. hammer_hook "Logic" "Logic.iff_refl".
split; auto.
Qed.

Theorem iff_trans : forall A B C:Prop, (A <-> B) -> (B <-> C) -> (A <-> C).
Proof. hammer_hook "Logic" "Logic.iff_trans".
intros A B C [H1 H2] [H3 H4]; split; auto.
Qed.

Theorem iff_sym : forall A B:Prop, (A <-> B) -> (B <-> A).
Proof. hammer_hook "Logic" "Logic.iff_sym".
intros A B [H1 H2]; split; auto.
Qed.

End Equivalence.

Hint Unfold iff: extcore.

Theorem and_iff_compat_l : forall A B C : Prop,
(B <-> C) -> (A /\ B <-> A /\ C).
Proof. hammer_hook "Logic" "Logic.and_iff_compat_l".
intros ? ? ? [Hl Hr]; split; intros [? ?]; (split; [ assumption | ]);
[apply Hl | apply Hr]; assumption.
Qed.

Theorem and_iff_compat_r : forall A B C : Prop,
(B <-> C) -> (B /\ A <-> C /\ A).
Proof. hammer_hook "Logic" "Logic.and_iff_compat_r".
intros ? ? ? [Hl Hr]; split; intros [? ?]; (split; [ | assumption ]);
[apply Hl | apply Hr]; assumption.
Qed.

Theorem or_iff_compat_l : forall A B C : Prop,
(B <-> C) -> (A \/ B <-> A \/ C).
Proof. hammer_hook "Logic" "Logic.or_iff_compat_l".
intros ? ? ? [Hl Hr]; split; (intros [?|?]; [left; assumption| right]);
[apply Hl | apply Hr]; assumption.
Qed.

Theorem or_iff_compat_r : forall A B C : Prop,
(B <-> C) -> (B \/ A <-> C \/ A).
Proof. hammer_hook "Logic" "Logic.or_iff_compat_r".
intros ? ? ? [Hl Hr]; split; (intros [?|?]; [left| right; assumption]);
[apply Hl | apply Hr]; assumption.
Qed.

Theorem imp_iff_compat_l : forall A B C : Prop,
(B <-> C) -> ((A -> B) <-> (A -> C)).
Proof. hammer_hook "Logic" "Logic.imp_iff_compat_l".
intros ? ? ? [Hl Hr]; split; intros H ?; [apply Hl | apply Hr]; apply H; assumption.
Qed.

Theorem imp_iff_compat_r : forall A B C : Prop,
(B <-> C) -> ((B -> A) <-> (C -> A)).
Proof. hammer_hook "Logic" "Logic.imp_iff_compat_r".
intros ? ? ? [Hl Hr]; split; intros H ?; [apply H, Hr | apply H, Hl]; assumption.
Qed.

Theorem not_iff_compat : forall A B : Prop,
(A <-> B) -> (~ A <-> ~B).
Proof. hammer_hook "Logic" "Logic.not_iff_compat".
intros; apply imp_iff_compat_r; assumption.
Qed.

Theorem neg_false : forall A : Prop, ~ A <-> (A <-> False).
Proof. hammer_hook "Logic" "Logic.neg_false".
intro A; unfold not; split.
- intro H; split; [exact H | intro H1; elim H1].
- intros [H _]; exact H.
Qed.

Theorem and_cancel_l : forall A B C : Prop,
(B -> A) -> (C -> A) -> ((A /\ B <-> A /\ C) <-> (B <-> C)).
Proof. hammer_hook "Logic" "Logic.and_cancel_l".
intros A B C Hl Hr.
split; [ | apply and_iff_compat_l]; intros [HypL HypR]; split; intros.
+ apply HypL; split; [apply Hl | ]; assumption.
+ apply HypR; split; [apply Hr | ]; assumption.
Qed.

Theorem and_cancel_r : forall A B C : Prop,
(B -> A) -> (C -> A) -> ((B /\ A <-> C /\ A) <-> (B <-> C)).
Proof. hammer_hook "Logic" "Logic.and_cancel_r".
intros A B C Hl Hr.
split; [ | apply and_iff_compat_r]; intros [HypL HypR]; split; intros.
+ apply HypL; split; [ | apply Hl ]; assumption.
+ apply HypR; split; [ | apply Hr ]; assumption.
Qed.

Theorem and_comm : forall A B : Prop, A /\ B <-> B /\ A.
Proof. hammer_hook "Logic" "Logic.and_comm".
intros; split; intros [? ?]; split; assumption.
Qed.

Theorem and_assoc : forall A B C : Prop, (A /\ B) /\ C <-> A /\ B /\ C.
Proof. hammer_hook "Logic" "Logic.and_assoc".
intros; split; [ intros [[? ?] ?]| intros [? [? ?]]]; repeat split; assumption.
Qed.

Theorem or_cancel_l : forall A B C : Prop,
(B -> ~ A) -> (C -> ~ A) -> ((A \/ B <-> A \/ C) <-> (B <-> C)).
Proof. hammer_hook "Logic" "Logic.or_cancel_l".
intros ? ? ? Fl Fr; split; [ | apply or_iff_compat_l]; intros [Hl Hr]; split; intros.
{ destruct Hl; [ right | destruct Fl | ]; assumption. }
{ destruct Hr; [ right | destruct Fr | ]; assumption. }
Qed.

Theorem or_cancel_r : forall A B C : Prop,
(B -> ~ A) -> (C -> ~ A) -> ((B \/ A <-> C \/ A) <-> (B <-> C)).
Proof. hammer_hook "Logic" "Logic.or_cancel_r".
intros ? ? ? Fl Fr; split; [ | apply or_iff_compat_r]; intros [Hl Hr]; split; intros.
{ destruct Hl; [ left | | destruct Fl ]; assumption. }
{ destruct Hr; [ left | | destruct Fr ]; assumption. }
Qed.

Theorem or_comm : forall A B : Prop, (A \/ B) <-> (B \/ A).
Proof. hammer_hook "Logic" "Logic.or_comm".
intros; split; (intros [? | ?]; [ right | left ]; assumption).
Qed.

Theorem or_assoc : forall A B C : Prop, (A \/ B) \/ C <-> A \/ B \/ C.
Proof. hammer_hook "Logic" "Logic.or_assoc".
intros; split; [ intros [[?|?]|?]| intros [?|[?|?]]].
+ left; assumption.
+ right; left; assumption.
+ right; right; assumption.
+ left; left; assumption.
+ left; right; assumption.
+ right; assumption.
Qed.
Lemma iff_and : forall A B : Prop, (A <-> B) -> (A -> B) /\ (B -> A).
Proof. hammer_hook "Logic" "Logic.iff_and".
intros A B []; split; trivial.
Qed.

Lemma iff_to_and : forall A B : Prop, (A <-> B) <-> (A -> B) /\ (B -> A).
Proof. hammer_hook "Logic" "Logic.iff_to_and".
intros; split; intros [Hl Hr]; (split; intros; [ apply Hl | apply Hr]); assumption.
Qed.

Definition IF_then_else (P Q R:Prop) := P /\ Q \/ ~ P /\ R.

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

Inductive ex (A:Type) (P:A -> Prop) : Prop :=
ex_intro : forall x:A, P x -> ex (A:=A) P.

Inductive ex2 (A:Type) (P Q:A -> Prop) : Prop :=
ex_intro2 : forall x:A, P x -> Q x -> ex2 (A:=A) P Q.

Definition all (A:Type) (P:A -> Prop) := forall x:A, P x.

Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..))
(at level 200, x binder, right associativity,
format "'[' 'exists'  '/  ' x  ..  y ,  '/  ' p ']'")
: type_scope.

Notation "'exists2' x , p & q" := (ex2 (fun x => p) (fun x => q))
(at level 200, x ident, p at level 200, right associativity) : type_scope.
Notation "'exists2' x : A , p & q" := (ex2 (A:=A) (fun x => p) (fun x => q))
(at level 200, x ident, A at level 200, p at level 200, right associativity,
format "'[' 'exists2'  '/  ' x  :  A ,  '/  ' '[' p  &  '/' q ']' ']'")
: type_scope.

Section universal_quantification.

Variable A : Type.
Variable P : A -> Prop.

Theorem inst : forall x:A, all (fun x => P x) -> P x.
Proof. hammer_hook "Logic" "Logic.inst".
unfold all; auto.
Qed.

Theorem gen : forall (B:Prop) (f:forall y:A, B -> P y), B -> all P.
Proof. hammer_hook "Logic" "Logic.gen".
red; auto.
Qed.

End universal_quantification.

Inductive eq (A:Type) (x:A) : A -> Prop :=
eq_refl : x = x :>A

where "x = y :> A" := (@eq A x y) : type_scope.

Notation "x = y" := (x = y :>_) : type_scope.
Notation "x <> y  :> T" := (~ x = y :>T) : type_scope.
Notation "x <> y" := (x <> y :>_) : type_scope.

Arguments eq {A} x _.
Arguments eq_refl {A x} , [A] x.

Arguments eq_ind [A] x P _ y _.
Arguments eq_rec [A] x P _ y _.
Arguments eq_rect [A] x P _ y _.

Hint Resolve I conj or_introl or_intror : core.
Hint Resolve eq_refl: core.
Hint Resolve ex_intro ex_intro2: core.

Section Logic_lemmas.

Theorem absurd : forall A C:Prop, A -> ~ A -> C.
Proof. hammer_hook "Logic" "Logic.absurd".
unfold not; intros A C h1 h2.
destruct (h2 h1).
Qed.

Section equality.
Variables A B : Type.
Variable f : A -> B.
Variables x y z : A.

Theorem eq_sym : x = y -> y = x.
Proof. hammer_hook "Logic" "Logic.eq_sym".
destruct 1; trivial.
Defined.

Theorem eq_trans : x = y -> y = z -> x = z.
Proof. hammer_hook "Logic" "Logic.eq_trans".
destruct 2; trivial.
Defined.

Theorem f_equal : x = y -> f x = f y.
Proof. hammer_hook "Logic" "Logic.f_equal".
destruct 1; trivial.
Defined.

Theorem not_eq_sym : x <> y -> y <> x.
Proof. hammer_hook "Logic" "Logic.not_eq_sym".
red; intros h1 h2; apply h1; destruct h2; trivial.
Qed.

End equality.

Definition eq_ind_r :
forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y:A, y = x -> P y.
intros A x P H y H0. elim eq_sym with (1 := H0); assumption.
Defined.

Definition eq_rec_r :
forall (A:Type) (x:A) (P:A -> Set), P x -> forall y:A, y = x -> P y.
intros A x P H y H0; elim eq_sym with (1 := H0); assumption.
Defined.

Definition eq_rect_r :
forall (A:Type) (x:A) (P:A -> Type), P x -> forall y:A, y = x -> P y.
intros A x P H y H0; elim eq_sym with (1 := H0); assumption.
Defined.
End Logic_lemmas.

Module EqNotations.
Notation "'rew' H 'in' H'" := (eq_rect _ _ H' _ H)
(at level 10, H' at level 10,
format "'[' 'rew'  H  in  '/' H' ']'").
Notation "'rew' [ P ] H 'in' H'" := (eq_rect _ P H' _ H)
(at level 10, H' at level 10,
format "'[' 'rew'  [ P ]  '/    ' H  in  '/' H' ']'").
Notation "'rew' <- H 'in' H'" := (eq_rect_r _ H' H)
(at level 10, H' at level 10,
format "'[' 'rew'  <-  H  in  '/' H' ']'").
Notation "'rew' <- [ P ] H 'in' H'" := (eq_rect_r P H' H)
(at level 10, H' at level 10,
format "'[' 'rew'  <-  [ P ]  '/    ' H  in  '/' H' ']'").
Notation "'rew' -> H 'in' H'" := (eq_rect _ _ H' _ H)
(at level 10, H' at level 10, only parsing).
Notation "'rew' -> [ P ] H 'in' H'" := (eq_rect _ P H' _ H)
(at level 10, H' at level 10, only parsing).

End EqNotations.

Import EqNotations.

Lemma rew_opp_r : forall A (P:A->Type) (x y:A) (H:x=y) (a:P y), rew H in rew <- H in a = a.
Proof. hammer_hook "Logic" "Logic.rew_opp_r".
intros.
destruct H.
reflexivity.
Defined.

Lemma rew_opp_l : forall A (P:A->Type) (x y:A) (H:x=y) (a:P x), rew <- H in rew H in a = a.
Proof. hammer_hook "Logic" "Logic.rew_opp_l".
intros.
destruct H.
reflexivity.
Defined.

Theorem f_equal2 :
forall (A1 A2 B:Type) (f:A1 -> A2 -> B) (x1 y1:A1)
(x2 y2:A2), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2.
Proof. hammer_hook "Logic" "Logic.f_equal2".
destruct 1; destruct 1; reflexivity.
Qed.

Theorem f_equal3 :
forall (A1 A2 A3 B:Type) (f:A1 -> A2 -> A3 -> B) (x1 y1:A1)
(x2 y2:A2) (x3 y3:A3),
x1 = y1 -> x2 = y2 -> x3 = y3 -> f x1 x2 x3 = f y1 y2 y3.
Proof. hammer_hook "Logic" "Logic.f_equal3".
destruct 1; destruct 1; destruct 1; reflexivity.
Qed.

Theorem f_equal4 :
forall (A1 A2 A3 A4 B:Type) (f:A1 -> A2 -> A3 -> A4 -> B)
(x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4),
x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> f x1 x2 x3 x4 = f y1 y2 y3 y4.
Proof. hammer_hook "Logic" "Logic.f_equal4".
destruct 1; destruct 1; destruct 1; destruct 1; reflexivity.
Qed.

Theorem f_equal5 :
forall (A1 A2 A3 A4 A5 B:Type) (f:A1 -> A2 -> A3 -> A4 -> A5 -> B)
(x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4) (x5 y5:A5),
x1 = y1 ->
x2 = y2 ->
x3 = y3 -> x4 = y4 -> x5 = y5 -> f x1 x2 x3 x4 x5 = f y1 y2 y3 y4 y5.
Proof. hammer_hook "Logic" "Logic.f_equal5".
destruct 1; destruct 1; destruct 1; destruct 1; destruct 1; reflexivity.
Qed.

Theorem f_equal_compose : forall A B C (a b:A) (f:A->B) (g:B->C) (e:a=b),
f_equal g (f_equal f e) = f_equal (fun a => g (f a)) e.
Proof. hammer_hook "Logic" "Logic.f_equal_compose".
destruct e. reflexivity.
Defined.

Theorem eq_trans_refl_l : forall A (x y:A) (e:x=y), eq_trans eq_refl e = e.
Proof. hammer_hook "Logic" "Logic.eq_trans_refl_l".
destruct e. reflexivity.
Defined.

Theorem eq_trans_refl_r : forall A (x y:A) (e:x=y), eq_trans e eq_refl = e.
Proof. hammer_hook "Logic" "Logic.eq_trans_refl_r".
destruct e. reflexivity.
Defined.

Theorem eq_sym_involutive : forall A (x y:A) (e:x=y), eq_sym (eq_sym e) = e.
Proof. hammer_hook "Logic" "Logic.eq_sym_involutive".
destruct e; reflexivity.
Defined.

Theorem eq_trans_sym_inv_l : forall A (x y:A) (e:x=y), eq_trans (eq_sym e) e = eq_refl.
Proof. hammer_hook "Logic" "Logic.eq_trans_sym_inv_l".
destruct e; reflexivity.
Defined.

Theorem eq_trans_sym_inv_r : forall A (x y:A) (e:x=y), eq_trans e (eq_sym e) = eq_refl.
Proof. hammer_hook "Logic" "Logic.eq_trans_sym_inv_r".
destruct e; reflexivity.
Defined.

Theorem eq_trans_assoc : forall A (x y z t:A) (e:x=y) (e':y=z) (e'':z=t),
eq_trans e (eq_trans e' e'') = eq_trans (eq_trans e e') e''.
Proof. hammer_hook "Logic" "Logic.eq_trans_assoc".
destruct e''; reflexivity.
Defined.

Theorem eq_id_comm_l : forall A (f:A->A) (Hf:forall a, a = f a), forall a, f_equal f (Hf a) = Hf (f a).
Proof. hammer_hook "Logic" "Logic.eq_id_comm_l".
intros.
unfold f_equal.
rewrite <- (eq_trans_sym_inv_l (Hf a)).
destruct (Hf a) at 1 2.
destruct (Hf a).
reflexivity.
Defined.

Theorem eq_id_comm_r : forall A (f:A->A) (Hf:forall a, f a = a), forall a, f_equal f (Hf a) = Hf (f a).
Proof. hammer_hook "Logic" "Logic.eq_id_comm_r".
intros.
unfold f_equal.
rewrite <- (eq_trans_sym_inv_l (Hf (f (f a)))).
set (Hfsymf := fun a => eq_sym (Hf a)).
change (eq_sym (Hf (f (f a)))) with (Hfsymf (f (f a))).
pattern (Hfsymf (f (f a))).
destruct (eq_id_comm_l f Hfsymf (f a)).
destruct (eq_id_comm_l f Hfsymf a).
unfold Hfsymf.
destruct (Hf a). simpl.
rewrite eq_trans_refl_l.
reflexivity.
Defined.

Lemma eq_refl_map_distr : forall A B x (f:A->B), f_equal f (eq_refl x) = eq_refl (f x).
Proof. hammer_hook "Logic" "Logic.eq_refl_map_distr".
reflexivity.
Qed.

Lemma eq_trans_map_distr : forall A B x y z (f:A->B) (e:x=y) (e':y=z), f_equal f (eq_trans e e') = eq_trans (f_equal f e) (f_equal f e').
Proof. hammer_hook "Logic" "Logic.eq_trans_map_distr".
destruct e'.
reflexivity.
Defined.

Lemma eq_sym_map_distr : forall A B (x y:A) (f:A->B) (e:x=y), eq_sym (f_equal f e) = f_equal f (eq_sym e).
Proof. hammer_hook "Logic" "Logic.eq_sym_map_distr".
destruct e.
reflexivity.
Defined.

Lemma eq_trans_sym_distr : forall A (x y z:A) (e:x=y) (e':y=z), eq_sym (eq_trans e e') = eq_trans (eq_sym e') (eq_sym e).
Proof. hammer_hook "Logic" "Logic.eq_trans_sym_distr".
destruct e, e'.
reflexivity.
Defined.

Lemma eq_trans_rew_distr : forall A (P:A -> Type) (x y z:A) (e:x=y) (e':y=z) (k:P x),
rew (eq_trans e e') in k = rew e' in rew e in k.
Proof. hammer_hook "Logic" "Logic.eq_trans_rew_distr".
destruct e, e'; reflexivity.
Qed.

Lemma rew_const : forall A P (x y:A) (e:x=y) (k:P),
rew [fun _ => P] e in k = k.
Proof. hammer_hook "Logic" "Logic.rew_const".
destruct e; reflexivity.
Qed.

Notation sym_eq := eq_sym (compat "8.3").
Notation trans_eq := eq_trans (compat "8.3").
Notation sym_not_eq := not_eq_sym (compat "8.3").

Notation refl_equal := eq_refl (compat "8.3").
Notation sym_equal := eq_sym (compat "8.3").
Notation trans_equal := eq_trans (compat "8.3").
Notation sym_not_equal := not_eq_sym (compat "8.3").

Hint Immediate eq_sym not_eq_sym: core.

Definition subrelation (A B : Type) (R R' : A->B->Prop) :=
forall x y, R x y -> R' x y.

Definition unique (A : Type) (P : A->Prop) (x:A) :=
P x /\ forall (x':A), P x' -> x=x'.

Definition uniqueness (A:Type) (P:A->Prop) := forall x y, P x -> P y -> x = y.

Notation "'exists' ! x .. y , p" :=
(ex (unique (fun x => .. (ex (unique (fun y => p))) ..)))
(at level 200, x binder, right associativity,
format "'[' 'exists'  !  '/  ' x  ..  y ,  '/  ' p ']'")
: type_scope.

Lemma unique_existence : forall (A:Type) (P:A->Prop),
((exists x, P x) /\ uniqueness P) <-> (exists! x, P x).
Proof. hammer_hook "Logic" "Logic.unique_existence".
intros A P; split.
- intros ((x,Hx),Huni); exists x; red; auto.
- intros (x,(Hx,Huni)); split.
+ exists x; assumption.
+ intros x' x'' Hx' Hx''; transitivity x.
symmetry; auto.
auto.
Qed.

Lemma forall_exists_unique_domain_coincide :
forall A (P:A->Prop), (exists! x, P x) ->
forall Q:A->Prop, (forall x, P x -> Q x) <-> (exists x, P x /\ Q x).
Proof. hammer_hook "Logic" "Logic.forall_exists_unique_domain_coincide".
intros A P (x & Hp & Huniq); split.
- intro; exists x; auto.
- intros (x0 & HPx0 & HQx0) x1 HPx1.
assert (H : x0 = x1) by (transitivity x; [symmetry|]; auto).
destruct H.
assumption.
Qed.

Lemma forall_exists_coincide_unique_domain :
forall A (P:A->Prop),
(forall Q:A->Prop, (forall x, P x -> Q x) <-> (exists x, P x /\ Q x))
-> (exists! x, P x).
Proof. hammer_hook "Logic" "Logic.forall_exists_coincide_unique_domain".
intros A P H.
destruct H with (Q:=P) as ((x & Hx & _),_); [trivial|].
exists x. split; [trivial|].
destruct H with (Q:=fun x'=>x=x') as (_,Huniq).
apply Huniq. exists x; auto.
Qed.

Inductive inhabited (A:Type) : Prop := inhabits : A -> inhabited A.

Hint Resolve inhabits: core.

Lemma exists_inhabited : forall (A:Type) (P:A->Prop),
(exists x, P x) -> inhabited A.
Proof. hammer_hook "Logic" "Logic.exists_inhabited".
destruct 1; auto.
Qed.

Lemma inhabited_covariant (A B : Type) : (A -> B) -> inhabited A -> inhabited B.
Proof. hammer_hook "Logic" "Logic.inhabited_covariant".
intros f [x];exact (inhabits (f x)).
Qed.

Lemma eq_stepl : forall (A : Type) (x y z : A), x = y -> x = z -> z = y.
Proof. hammer_hook "Logic" "Logic.eq_stepl".
intros A x y z H1 H2. rewrite <- H2; exact H1.
Qed.

Declare Left Step eq_stepl.
Declare Right Step eq_trans.

Lemma iff_stepl : forall A B C : Prop, (A <-> B) -> (A <-> C) -> (C <-> B).
Proof. hammer_hook "Logic" "Logic.iff_stepl".
intros ? ? ? [? ?] [? ?]; split; intros; auto.
Qed.

Declare Left Step iff_stepl.
Declare Right Step iff_trans.

Local Notation "'rew' 'dependent' H 'in' H'"
:= (match H with
| eq_refl => H'
end)
(at level 10, H' at level 10,
format "'[' 'rew'  'dependent'  '/    ' H  in  '/' H' ']'").

Section ex.
Local Unset Implicit Arguments.
Definition eq_ex_uncurried {A : Type} (P : A -> Prop) {u1 v1 : A} {u2 : P u1} {v2 : P v1}
(pq : exists p : u1 = v1, rew p in u2 = v2)
: ex_intro P u1 u2 = ex_intro P v1 v2.
Proof. hammer_hook "Logic" "Logic.eq_ex_uncurried".
destruct pq as [p q].
destruct q; simpl in *.
destruct p; reflexivity.
Qed.

Definition eq_ex {A : Type} {P : A -> Prop} (u1 v1 : A) (u2 : P u1) (v2 : P v1)
(p : u1 = v1) (q : rew p in u2 = v2)
: ex_intro P u1 u2 = ex_intro P v1 v2
:= eq_ex_uncurried P (ex_intro _ p q).

Definition eq_ex_hprop {A} {P : A -> Prop} (P_hprop : forall (x : A) (p q : P x), p = q)
(u1 v1 : A) (u2 : P u1) (v2 : P v1)
(p : u1 = v1)
: ex_intro P u1 u2 = ex_intro P v1 v2
:= eq_ex u1 v1 u2 v2 p (P_hprop _ _ _).

Lemma rew_ex {A x} {P : A -> Type} (Q : forall a, P a -> Prop) (u : exists p, Q x p) {y} (H : x = y)
: rew [fun a => exists p, Q a p] H in u
= match u with
| ex_intro _ u1 u2
=> ex_intro
(Q y)
(rew H in u1)
(rew dependent H in u2)
end.
Proof. hammer_hook "Logic" "Logic.rew_ex".
destruct H, u; reflexivity.
Qed.
End ex.

Section ex2.
Local Unset Implicit Arguments.

Definition eq_ex2_uncurried {A : Type} (P Q : A -> Prop) {u1 v1 : A}
{u2 : P u1} {v2 : P v1}
{u3 : Q u1} {v3 : Q v1}
(pq : exists2 p : u1 = v1, rew p in u2 = v2 & rew p in u3 = v3)
: ex_intro2 P Q u1 u2 u3 = ex_intro2 P Q v1 v2 v3.
Proof. hammer_hook "Logic" "Logic.eq_ex2_uncurried".
destruct pq as [p q r].
destruct r, q, p; simpl in *.
reflexivity.
Qed.

Definition eq_ex2 {A : Type} {P Q : A -> Prop}
(u1 v1 : A)
(u2 : P u1) (v2 : P v1)
(u3 : Q u1) (v3 : Q v1)
(p : u1 = v1) (q : rew p in u2 = v2) (r : rew p in u3 = v3)
: ex_intro2 P Q u1 u2 u3 = ex_intro2 P Q v1 v2 v3
:= eq_ex2_uncurried P Q (ex_intro2 _ _ p q r).

Definition eq_ex2_hprop {A} {P Q : A -> Prop}
(P_hprop : forall (x : A) (p q : P x), p = q)
(Q_hprop : forall (x : A) (p q : Q x), p = q)
(u1 v1 : A) (u2 : P u1) (v2 : P v1) (u3 : Q u1) (v3 : Q v1)
(p : u1 = v1)
: ex_intro2 P Q u1 u2 u3 = ex_intro2 P Q v1 v2 v3
:= eq_ex2 u1 v1 u2 v2 u3 v3 p (P_hprop _ _ _) (Q_hprop _ _ _).

Lemma rew_ex2 {A x} {P : A -> Type}
(Q : forall a, P a -> Prop)
(R : forall a, P a -> Prop)
(u : exists2 p, Q x p & R x p) {y} (H : x = y)
: rew [fun a => exists2 p, Q a p & R a p] H in u
= match u with
| ex_intro2 _ _ u1 u2 u3
=> ex_intro2
(Q y)
(R y)
(rew H in u1)
(rew dependent H in u2)
(rew dependent H in u3)
end.
Proof. hammer_hook "Logic" "Logic.rew_ex2".
destruct H, u; reflexivity.
Qed.
End ex2.


Require Import Omega.
Require Import Coq.ZArith.ZArith.
Require Import Coq.NArith.NArith.
Require Import Coq.Bool.Bool.

Require Import BitUtils.
Require Import DyadicIntervals.
Require Import Tactics.

(** * The IntMap formalization *)

Require Import GHC.DeferredFix.
Require Import IntSetProofs.
Require Import Data.IntSet.Internal.
Require Import Data.IntMap.Internal.

Import GHC.Base.

Set Bullet Behavior "Strict Subproofs".

Axiom deferredFix2_eq : forall a b r `{Default r} (f : (a -> b -> r) -> (a -> b -> r)),
  deferredFix2 f = f (deferredFix2 f).

From Coq Require Import ssreflect.

Lemma oro_None_r {a} (x:option a) : oro x None = x.
Proof. destruct x; simpl; reflexivity. Qed.
Lemma oro_None_l {a} (x:option a) : oro None x = x.
Proof. reflexivity. Qed.
Lemma oro_Some_l a (v:a) x : oro (Some v) x = Some v.
Proof. destruct x; simpl; auto. Qed.
Lemma oro_Some a (v:a) x y : oro x y = Some v -> x = Some v \/ y = Some v.
Proof.
  destruct x; destruct y; simpl; auto.
Qed.

(** ** Well-formed IntMap.

This section introduces the predicate to describe the well-formedness of
an IntMap. It has parameters that describe the range that this map covers,
and a function that carries it denotation. This way, invariant preservation
and functional correctness of an operation can be expressed in one go.
*)

Definition singletonRange k : range := (k, 0%N).

Local Open Scope N_scope.

Inductive Desc : forall {a}, IntMap a -> range -> (N -> option a) -> Prop :=
  | DescTip : forall a k (v : a) r f,
    (forall i, f i = if i =? k then Some v else None) ->
    r = singletonRange k ->
    Desc (Tip k v) r f
  | DescBin : forall a m1 r1 f1 m2 r2 f2 p msk r (f : N  -> option a),
    Desc m1 r1 f1 ->
    Desc m2 r2 f2 ->
    (0 < rBits r)%N ->
    isSubrange r1 (halfRange r false) = true ->
    isSubrange r2 (halfRange r true) = true ->
    p = rPrefix r ->
    msk = rMask r ->
    (forall i, f i = oro (f1 i) (f2 i)) ->
    Desc (Bin p msk m1 m2) r f.

(** A variant that also allows [Nil], or sets that do not
    cover the full given range, but are certainly contained in them.
    This is used to describe operations that may delete elements.
 *)

Inductive Desc0 : forall {a}, IntMap a -> range -> (N -> option a) -> Prop :=
  | Desc0Nil : forall {a} r (f : N -> option a), (forall i, f i = None) -> Desc0 Nil r f
  | Desc0NotNil :
      forall {a},
      forall m r f r' (f' : N -> option a),
      forall (HD : Desc m r f),
      forall (Hsubrange: isSubrange r r' = true)
      (Hf : forall i, f' i = f i),
      Desc0 m r' f'.

(** A variant that also allows [Nil] and does not reqiure a range. Used
    for the top-level specification.
 *)

Inductive Sem : forall {a}, IntMap a -> (N -> option a) -> Prop :=
  | SemNil : forall {a} (f : N -> option a), (forall i, f i = None) -> Sem Nil f
  | DescSem : forall {a} s r (f : N -> option a) (HD : Desc s r f), Sem s f.

(** The highest level: Just well-formedness.
 *)

Definition WF {a} (s : IntMap a) : Prop := exists f, Sem s f.

Ltac inversion_Desc HD1 :=
  inversion HD1;
  repeat match goal with [ H : existT ?f ?a ?s1 = existT ?f ?a ?s2 |- _ ] =>
                  apply Eqdep.EqdepTheory.inj_pair2 in H
  end;
  subst.

(** ** Lemmas related to well-formedness *)

(** All of these respect extensionality of [f] *)

Lemma Desc_change_f:
  forall {a} (s:IntMap a) r f f',
  Desc s r f -> (forall i, f' i = f i) -> Desc s r f'.
Proof.
  intros.
  induction H.
  * eapply DescTip; try eassumption.
    intro i. rewrite H0 H. reflexivity.
  * eapply DescBin; try eassumption.
    intro i. rewrite H0 H7. reflexivity.
Qed.

Lemma Sem_change_f:
  forall {a} (s:IntMap a) f f',
  Sem s f -> (forall i, f' i = f i) -> Sem s f'.
Proof.
  intros.
  destruct H.
  * apply SemNil.
    intro i. rewrite H0 H. reflexivity.
  * eapply DescSem. eapply Desc_change_f. eassumption.
    intro i. rewrite H0. reflexivity.
Qed.

Lemma Desc_Desc0:
  forall {a} (s:IntMap a) r f, Desc s r f -> Desc0 s r f.
Proof. intros.
  eapply Desc0NotNil.
  * eassumption.
  * apply isSubrange_refl.
  * intro. reflexivity.
Qed.

Lemma Desc0_Sem:
  forall {a} (s:IntMap a) r f, Desc0 s r f -> Sem s f.
Proof.
  intros.
  destruct H.
  * apply SemNil; eassumption.
  * eapply DescSem. eapply Desc_change_f. eassumption. assumption.
Qed.

Lemma Desc0_WF:
  forall {a} (s:IntMap a) r f, Desc0 s r f -> WF s.
Proof.
  intros. eexists. eapply Desc0_Sem. eassumption.
Qed.

Lemma Desc_outside:
 forall {a} {s : IntMap a} {r f i}, Desc s r f -> inRange i r = false -> f i = None.
Proof.
 intros ????? HD Houtside.
 induction HD;subst.
 * rewrite H.
   unfold inRange, singletonRange in *.
   simpl in Houtside.
   destruct (i =? k) eqn:IsI.
   inversion Houtside.
   auto.
 * rewrite H4; clear H4.
   rewrite IHHD1; last inRange_false.
   rewrite IHHD2; last inRange_false.
   reflexivity.
Qed.

Lemma Desc_inside:
 forall {a} {s : IntMap a} {r f i} {v}, Desc s r f -> f i = Some v -> inRange i r = true.
Proof.
 intros ?????? HD Hf.
 destruct (inRange i r) eqn:?; intuition.
 rewrite (Desc_outside HD) // in Hf.
Qed.

Lemma Desc0_outside:
  forall {a} {s : IntMap a} {r f i}, Desc0 s r f -> inRange i r = false -> f i = None.
Proof.
  intros.
  destruct H; auto.
  rewrite Hf.
  rewrite (Desc_outside HD) //; inRange_false.
Qed.

Lemma Desc0_subRange:
  forall {a} {s : IntMap a} {r r' f}, Desc0 s r f -> isSubrange r r' = true -> Desc0 s r' f.
Proof.
  intros.
  induction H.
  * apply Desc0Nil; assumption.
  * eapply Desc0NotNil; try eassumption.
    isSubrange_true.
Qed.

(** The [Desc] predicate only holds for non-empty sets. *)
Lemma Desc_some_f:
  forall {a} {s:IntMap a} {r f}, Desc s r f -> exists i v, f i = Some v.
Proof.
  intros ???? HD.
  induction HD; subst.
  +
    exists k. exists v.
    rewrite H.
    rewrite N.eqb_refl.
    auto.
  + destruct IHHD1  as [j [v1 ?]].
    exists j. exists v1.
    rewrite H4.
    rewrite H2.
    reflexivity.
Qed.

(** The [Desc] predicate is right_unique *)
Lemma Desc_unique_f:
  forall {a}{s:IntMap a}{r1 f1 r2 f2}, Desc s r1 f1 -> Desc s r2 f2 -> (forall i, f1 i = f2 i).
Proof.
  intros ?????? HD.
  revert r2 f2.
  induction HD; subst.
  + intros r2 f2 HD2 i.
    inversion_Desc HD2.
    rewrite H H5.
    reflexivity.
  + intros r3 f3 HD3 i.
    inversion_Desc HD3.
    rewrite H17 H4.
    erewrite IHHD1 by eassumption.
    erewrite IHHD2 by eassumption.
    reflexivity.
Qed.

Lemma DescBin' : forall {a} (s1:IntMap a) r1 f1 s2 r2 f2 p msk r f,
    Desc s1 r1 f1 ->
    Desc s2 r2 f2 ->
    (0 < rBits r)%N ->
    isSubrange r1 (halfRange r false) = true ->
    isSubrange r2 (halfRange r true) = true ->
    p = rPrefix r ->
    msk = rMask r ->
    (forall i, inRange i (halfRange r false) = true  -> f i = f1 i) ->
    (forall i, inRange i (halfRange r true)  = true  -> f i = f2 i) ->
    (forall i, inRange i r                   = false -> f i = None) ->
    Desc (Bin p msk s1 s2) r f.
Proof.
  intros.
  eapply DescBin; try eassumption.
  intro i.
  destruct (inRange i r) eqn:Hir.
  * destruct (inRange i (halfRange r false)) eqn: Hir1.
    + assert (Hir2 : inRange i (halfRange r true) = false).
      { eapply rangeDisjoint_inRange_false.
        eapply halves_disj; auto.
        assumption.
      }
      rewrite H6 //.
      rewrite (Desc_outside H0); last inRange_false.
      rewrite oro_None_r. reflexivity.
    + assert (Hir2 : inRange i (halfRange r true) = true).
      { rewrite halfRange_inRange_testbit // in Hir1.
        rewrite halfRange_inRange_testbit //.
        destruct (N.testbit _ _); simpl in *; congruence.
      }
      rewrite H7 //.
      rewrite (Desc_outside H); last inRange_false.
      rewrite oro_None_l //.
  * rewrite H8 //.
    rewrite (Desc_outside H) ; last inRange_false.
    rewrite (Desc_outside H0) ; last inRange_false.
    reflexivity.
Qed.

Ltac point_to_inRange :=
  lazymatch goal with
    | [ HD : Desc ?s ?r ?f, Hf : ?f ?i = Some ?v |- _ ]
      => apply (Desc_inside HD) in Hf
  end.

(**
 Like [solve_f_eq], but tries to solve the resulting bogus cases
 using reasoning about [inRange]. *)

Ltac solve_f_eq_disjoint :=
  solve_f_eq;
  repeat point_to_inRange;
  repeat saturate_inRange;
  try inRange_disjoint. (* Only try this, so that we see where we are stuck. *)

(** *** Uniqueness of representation *)

Lemma larger_f_imp:
  forall a (s1 : IntMap a) r1 f1 s2 r2 f2,
  (rBits r2 < rBits r1)%N ->
  Desc s1 r1 f1 -> Desc s2 r2 f2 ->
  (forall (i : N) v, f1 i = Some v -> f2 i = Some v) ->
  False.
Proof.
  intros ???? ??? Hsmaller HD1 HD2 Hf.
  destruct HD1.
  * subst. simpl in Hsmaller. Nomega.
  * subst.
    assert (isSubrange r2 (halfRange r false) = true).
      { destruct (Desc_some_f HD1_1) as [i [v Hi]].
        pose proof (Desc_inside HD1_1 Hi).
        specialize (H4 i).
        (* TODO: Why do we need Coq rewrite + by ? *)
        rewrite -> (Desc_outside HD1_2) in H4 by inRange_false.
        rewrite oro_None_r in H4.
        rewrite <- H4 in Hi; clear H4.
        apply Hf in Hi; clear Hf.
        apply (Desc_inside HD2) in Hi.
        apply inRange_both_smaller_subRange with (i := i).
        * inRange_true.
        * inRange_true.
        * rewrite rBits_halfRange. Nomega.
      }
    assert (isSubrange r2 (halfRange r true) = true).
      { destruct (Desc_some_f HD1_2) as [i [v Hi]].
        pose proof (Desc_inside HD1_2 Hi).
        specialize (H4 i).
        rewrite -> (Desc_outside HD1_1) in H4 by inRange_false.
        rewrite oro_None_l in H4.
        rewrite <- H4 in Hi; clear H4.
        apply Hf in Hi; clear Hf.
        apply (Desc_inside HD2) in Hi.
        apply inRange_both_smaller_subRange with (i := i).
        * inRange_true.
        * inRange_true.
        * rewrite rBits_halfRange. Nomega.
      }
      inRange_disjoint.
Qed.

Lemma Desc_unique:
  forall a (s1:IntMap a) r1 f1 s2 r2 f2,
  Desc s1 r1 f1 -> Desc s2 r2 f2 ->
  (forall i, f1 i = f2 i) ->
  s1 = s2.
Proof.
  intros ??????? HD1.
  revert s2 r2 f2.
  induction HD1.
  * intros s2 r2 f2 HD2 Hf.
    destruct HD2.
    + subst.
      destruct (N.eq_decidable k k0).
      ++ subst.
         specialize (H k0). rewrite Hf H1 in H.
         rewrite N.eqb_refl in H. inversion H.
         reflexivity.
      ++ specialize (H k0). rewrite Hf H1 in H.
         rewrite N.eqb_refl in H.
         destruct (N.eqb_neq k k0) as [h0 h1].
         rewrite N.eqb_sym in H.
         rewrite (h1 H0)  in H.
         inversion H.
    +
      exfalso. subst.
      eapply larger_f_imp with (r1 := r0) (r2 := singletonRange k).
      - simpl. auto.
      - eapply DescBin with (m1 := m1) (m2 := m2); try eassumption; reflexivity.
      - eapply DescTip; try eassumption; reflexivity.
      - intros i Hi. rewrite Hf. auto.
  * intros s3 r3 f3 HD3 Hf.
    destruct HD3.
    + exfalso. subst.
      eapply larger_f_imp with (r1 := r) (r2 := singletonRange k).
      - simpl. auto.
      - eapply DescBin with (m1 := m1) (m2 := m2); try eassumption; reflexivity.
      - eapply DescTip; try eassumption; reflexivity.
      - intros i Hi. rewrite <- Hf. auto.

    + subst.
      assert (r4 = r). {
        destruct (Desc_some_f HD3_1) as [i1 [v1 Hi1]].
        destruct (Desc_some_f HD3_2) as [i2 [v2 Hi2]].
        destruct (Desc_some_f HD1_1) as [i3 [v3 Hi3]].
        destruct (Desc_some_f HD1_2) as [i4 [v4 Hi4]].
        apply criss_cross with i1 i2 i3 i4; try assumption.
        * apply (Desc_inside HD3_1) in Hi1; inRange_true.
        * apply (Desc_inside HD3_2) in Hi2; inRange_true.
        * apply (Desc_inside HD1_1) in Hi3; inRange_true.
        * apply (Desc_inside HD1_2) in Hi4; inRange_true.
        * specialize (H10 i1); rewrite Hi1 in H10.
          rewrite oro_Some_l in H10.
          rewrite <- Hf in H10.
          specialize (H4 i1); rewrite H10 in H4; clear H10; symmetry in H4.
          apply oro_Some in H4.
          destruct H4.
          + apply (Desc_inside HD1_1) in H2.
            eapply inRange_isSubrange_true; [|eassumption].
            isSubrange_true.
          + apply (Desc_inside HD1_2) in H2.
            eapply inRange_isSubrange_true; [|eassumption].
            isSubrange_true.
        * specialize (H10 i2); rewrite Hi2 in H10;
          destruct (f0 i2) eqn:If0; simpl in H10;
          rewrite <- Hf in H10;
          specialize (H4 i2); rewrite H10 in H4; clear H10; symmetry in H4;
          apply oro_Some in H4; destruct H4.
          + apply (Desc_inside HD1_1) in H2.
            eapply inRange_isSubrange_true; [|eassumption].
            isSubrange_true.
          + apply (Desc_inside HD1_2) in H2.
            eapply inRange_isSubrange_true; [|eassumption].
            isSubrange_true.
          + apply (Desc_inside HD1_1) in H2.
            eapply inRange_isSubrange_true; [|eassumption].
            isSubrange_true.
          + apply (Desc_inside HD1_2) in H2.
            eapply inRange_isSubrange_true; [|eassumption].
            isSubrange_true.

        * specialize (H4 i3); rewrite Hi3 in H4.
          rewrite oro_Some_l in H4.
          rewrite -> Hf in H4.
          specialize (H10 i3); rewrite H4 in H10; clear H4; symmetry in H10.
          apply oro_Some in H10; destruct H10.
          + apply (Desc_inside HD3_1) in H2.
            eapply inRange_isSubrange_true; [|eassumption].
            isSubrange_true.
          + apply (Desc_inside HD3_2) in H2.
            eapply inRange_isSubrange_true; [|eassumption].
            isSubrange_true.
        * specialize (H4 i4); rewrite Hi4 in H4.
          destruct (f1 i4) eqn:Is4; simpl in H4;
          rewrite -> Hf in H4;
          specialize (H10 i4); rewrite H4 in H10; clear H4; symmetry in H10;
          apply oro_Some in H10; destruct H10.
          + apply (Desc_inside HD3_1) in H2;
            eapply inRange_isSubrange_true; [|eassumption];
            isSubrange_true.
          + apply (Desc_inside HD3_2) in H2;
            eapply inRange_isSubrange_true; [|eassumption];
            isSubrange_true.
          + apply (Desc_inside HD3_1) in H2.
            eapply inRange_isSubrange_true; [|eassumption].
            isSubrange_true.
          + apply (Desc_inside HD3_2) in H2.
            eapply inRange_isSubrange_true; [|eassumption].
            isSubrange_true.

      }
      subst.
      assert (IH_prem_1 : (forall i : N, f1 i = f0 i)). {
        intro i.
        specialize (H4 i). specialize (H10 i). specialize (Hf i).
        destruct (inRange i (halfRange r false)) eqn:?.
        -- rewrite -> (Desc_outside HD1_2) in H4 by inRange_false.
           rewrite oro_None_r in H4.
           rewrite <- H4; clear H4.

           rewrite -> (Desc_outside HD3_2) in H10 by inRange_false.
           rewrite oro_None_r in H10.
           rewrite <- H10; clear H10.

           assumption.
        -- rewrite (Desc_outside HD1_1) ; last inRange_false.
           rewrite (Desc_outside HD3_1) ; last inRange_false.
           reflexivity.
      }
      assert (IH_prem_2 : (forall i : N, f2 i = f3 i)). {
        intro i.
        specialize (H4 i). specialize (H10 i). specialize (Hf i).
        destruct (inRange i (halfRange r true)) eqn:?.
        -- rewrite -> (Desc_outside HD1_1) in H4 by inRange_false.
           rewrite oro_None_l in H4.
           rewrite <- H4; clear H4.

           rewrite -> (Desc_outside HD3_1) in H10 by inRange_false.
           rewrite oro_None_l in H10.
           rewrite <- H10; clear H10.

           assumption.
        -- rewrite (Desc_outside HD1_2) ; last inRange_false.
           rewrite (Desc_outside HD3_2) ; last inRange_false.
           reflexivity.
      }
      specialize (IHHD1_1 _ _ _ HD3_1 IH_prem_1).
      destruct IHHD1_1; subst.
      specialize (IHHD1_2 _ _ _ HD3_2 IH_prem_2).
      destruct IHHD1_2; subst.
      reflexivity.
Qed.

Lemma Sem_unique:
  forall a (s1:IntMap a) f1 s2 f2,
  Sem s1 f1 -> Sem s2 f2 ->
  (forall i, f1 i = f2 i) ->
  s1 = s2.
Proof.
  intros.
  destruct H, H0.
  * reflexivity.
  * exfalso.
    destruct (Desc_some_f HD) as [i [v Hi]].
    rewrite <- H1 in Hi.
    rewrite H in Hi.
    congruence.
  * exfalso.
    destruct (Desc_some_f HD) as [i [v Hi]].
    rewrite -> H1 in Hi.
    rewrite H in Hi.
    congruence.
  * eapply Desc_unique; eassumption.
Qed.

Theorem Sem_extensional {a} (s : IntMap a) (f1 f2 : N -> option a) :
  Sem s f1 ->
  Sem s f2 ->
  forall i, f1 i = f2 i.
Proof.
  intros S1 S2 k;
    inversion S1 as [a1 f1' E1 | a1 s1 r1 f1' D1];
    apply Eqdep.EqdepTheory.inj_pair2 in H0;
    apply Eqdep.EqdepTheory.inj_pair2 in H1;
    subst f1' s;
    inversion S2 as [a2 f2' E2 | a2 s2 r2 f2' D2];
    apply Eqdep.EqdepTheory.inj_pair2 in H1.
    subst f2';
    try subst s1; try subst s2.
  - now rewrite E1 E2.
  - subst.
    inversion D2.
  - subst.
    inversion D1.
  - apply Eqdep.EqdepTheory.inj_pair2 in H2.
    subst.
    eauto using Desc_unique_f.
Qed.

(** *** Verification of [nomatch] *)

Lemma nomatch_spec:
  forall i r,
  (0 < rBits r)%N ->
  IntMap.Internal.nomatch i (rPrefix r) (rMask r) =
  negb (inRange i r).
Proof.
  intros.
  destruct r as [p b]. simpl in *.
  unfold nomatch, zero, inRange.
  unfoldMethods.
  unfold mask, IntSet.Internal.maskW.
  f_equal.
  rewrite eq_iff_eq_true.
  rewrite !N.eqb_eq.
  rewrite <- N.pow_succ_r  by Nomega.
  replace (N.succ (b - 1)) with b by Nomega.
  rewrite N.sub_1_r.
  rewrite <- N.ones_equiv.
  rewrite -> N.ldiff_ones_r by nonneg.
  rewrite -> N_shiftl_inj by nonneg.
  reflexivity.
Qed.

Lemma match_nomatch: forall x p ms,
  match_ x p ms = negb (nomatch x p ms).
Proof.
  intros. unfold match_, nomatch. unfoldMethods.
  rewrite negb_involutive.
  reflexivity.
Qed.

(**
The IntMap code has a repeating pattern consisting of calls to [nomatch] and [zero].
The following two lemmas capture that pattern concisely.
*)

Lemma nomatch_zero:
  forall {a} i r (P : a -> Prop) left right otherwise,
  (0 < rBits r)%N ->
  (inRange i r = false -> P otherwise) ->
  (inRange i (halfRange r false) = true -> inRange i (halfRange r true) = false -> P left) ->
  (inRange i (halfRange r false) = false -> inRange i (halfRange r true) = true -> P right) ->
  P (if nomatch i (rPrefix r) (rMask r) then otherwise else
     if zero i (rMask r) then left else right).
Proof.
  intros.
  rewrite nomatch_spec //.
  rewrite if_negb.
  destruct (inRange i r) eqn:?.
  * rewrite zero_spec //.
    rewrite if_negb.
    destruct (N.testbit i (rBits r - 1)) eqn:Hbit.
    + apply H2.
      all: rewrite halfRange_inRange_testbit // Hbit //.
    + apply H1.
      all: rewrite halfRange_inRange_testbit // Hbit //.
  * apply H0; reflexivity.
Qed.

Lemma nomatch_zero_smaller:
  forall {a} r1 r (P : a -> Prop) left right otherwise,
  (rBits r1 < rBits r)%N ->
  (rangeDisjoint r1 r = true -> P otherwise) ->
  (isSubrange r1 (halfRange r false) = true  -> isSubrange r1 (halfRange r true) = false -> P left) ->
  (isSubrange r1 (halfRange r false) = false -> isSubrange r1 (halfRange r true) = true -> P right) ->
  P (if nomatch (rPrefix r1) (rPrefix r) (rMask r) then otherwise else
     if zero (rPrefix r1) (rMask r) then left else right).
Proof.
  intros ????????.
  assert (rBits r1 <= rBits r)%N by Nomega.
  assert (forall h, rBits r1 <= rBits (halfRange r h))%N
    by (intros; rewrite rBits_halfRange; Nomega).
  rewrite <- smaller_not_subrange_disjoint_iff; auto.
  repeat rewrite <- smaller_inRange_iff_subRange by auto.
  apply nomatch_zero.
  Nomega.
Qed.

(** *** Verification of [equal] *)

Lemma equal_spec a `{Base.Eq_ a} `{Base.EqExact a} :
  forall (s1 s2 : IntMap a), equal s1 s2 = true <-> s1 = s2.
Proof.
  induction s1; intro s2; destruct s2;
    try solve [simpl; intuition congruence].
  * simpl. unfoldMethods.
    rewrite !andb_true_iff.
    rewrite !N.eqb_eq.
    rewrite IHs1_1.
    rewrite IHs1_2.
    intuition congruence.
  * simpl.
    rewrite !andb_true_iff.
    rewrite <- (reflect_iff _ _ (Base.Eq_eq a0 a1)).
    rewrite !N.eqb_eq.
    intuition congruence.
Qed.

(** *** Verification of [nequal] *)

Lemma nequal_spec {a} `{Base.Eq_ a}`{ Base.EqLaws a} :
  forall (s1 s2:IntMap a), nequal s1 s2 = negb (equal s1 s2).
Proof.
  induction s1; intro s2; destruct s2;
    try solve [simpl; intuition congruence].
  * simpl. unfoldMethods.
    rewrite !negb_andb.
    rewrite IHs1_1.
    rewrite IHs1_2.
    reflexivity.
  * simpl.
    rewrite !negb_andb.
    rewrite (Base.Eq_inv k k0).
    rewrite (Base.Eq_inv a0 a1).
    rewrite !negb_involutive.
    auto.
Qed.

(** *** Verification of [singleton] *)

Lemma singleton_Desc:
  forall a k (v : a),
   Desc (singleton k v) (singletonRange k) (fun x => if x =? k then Some v else None).
Proof.
  intros.
  apply DescTip; try nonneg; try isBitMask.
Qed.

Lemma singleton_Sem:
  forall a k (v:a), Sem (singleton k v) (fun x => if x =? k then Some v else None).
Proof.
  intros.
  eapply DescSem.
  apply singleton_Desc; assumption.
Qed.

Lemma singleton_WF:
  forall a k (v:a), WF (singleton k v).
Proof. intros. eexists. apply singleton_Sem; auto. Qed.

(** *** Verification of [lookup] *)

Lemma lookup_Desc:
 forall {a}{s : IntMap a}{r f i}, Desc s r f -> lookup i s = f i.
Proof.
 intros ????? HD.
 induction HD; subst.
 * simpl.
   unfoldMethods.
   rewrite H.
   destruct (i =? k) eqn:Ei; simpl; auto.
 * rewrite H4. clear H4.
   simpl lookup.
   rewrite IHHD1 IHHD2. clear IHHD1 IHHD2.

   apply nomatch_zero; [auto|..]; intros.
   + rewrite (Desc_outside HD1) ; last inRange_false.
     rewrite (Desc_outside HD2) ; last inRange_false.
     reflexivity.
   + rewrite (Desc_outside HD2) ; last inRange_false.
     rewrite oro_None_r. reflexivity.
   + rewrite (Desc_outside HD1) ; last inRange_false.
     rewrite oro_None_l. reflexivity.
Qed.

Lemma lookup_Desc0:
  forall {a}{s:IntMap a} {r f i}, Desc0 s r f -> lookup i s = f i.
Proof.
  intros.
  destruct H; simpl; auto.
  rewrite Hf.
  eapply lookup_Desc; eauto.
Abort.

Lemma lookup_Sem:
  forall {a}{s:IntMap a}{f i}, Sem s f -> lookup i s = f i.
Proof.
  intros.
  destruct H.
  * rewrite H. reflexivity.
  * erewrite lookup_Desc; eauto.
Qed.

(** *** Verification of [isSubmapOf] *)

Lemma isSubmapOfBy_disjoint {a} (f : a -> a -> bool) :
  forall (s1 :IntMap a) r1 f1 s2 r2 f2,
  rangeDisjoint r1 r2 = true ->
  Desc s1 r1 f1 -> Desc s2 r2 f2 ->
  (forall (i : N) v1, f1 i = Some v1 -> exists v2, f2 i = Some v2 /\ (f v1 v2 = true)) <-> False.
Proof.
  intros ??? ??? Hdis HD1 HD2.
  intuition.
  destruct (Desc_some_f HD1) as [i [v Hi]].
  eapply rangeDisjoint_inRange_false_false with (i := i).
  ** eassumption.
  ** eapply Desc_inside; eassumption.
  ** eapply H in Hi.
     destruct Hi as [v2 [Hi EQ]].
     apply (Desc_inside HD2) in Hi.
     assumption.
Qed.

Lemma isSubmapOfBy_disjoint1 {a} :
  forall (s1 :IntMap a) r1 f1 (s2:IntMap a) r2 f2,
  rangeDisjoint r1 r2 = true ->
  Desc s1 r1 f1 -> Desc s2 r2 f2 ->
  forall (i : N) v1, f1 i = Some v1 -> f2 i = None.
Proof.
  intros ??? ??? Hdis HD1 HD2.
  intuition.
  eapply Desc_outside; eauto.
  apply not_true_is_false.
  unfold not.
  eapply rangeDisjoint_inRange_false_false with (i := i).
  ** eassumption.
  ** eapply Desc_inside; eassumption.
Qed.

Program Fixpoint isSubmapOfBy_Desc {a} (f : a -> a -> bool)
  (s1 :IntMap a) r1 f1 s2 r2 f2
  { measure (size_nat s1 + size_nat s2) } :
  Desc s1 r1 f1 ->
  Desc s2 r2 f2 ->
  isSubmapOfBy f s1 s2 = true <->
  (forall i v1, f1 i = Some v1 -> exists v2, f2 i = Some v2 /\ f v1 v2 = true) := _.
Next Obligation.
  revert isSubmapOfBy_Desc H H0.
  intros IH HD1 HD2.
  inversion_Desc HD1; inversion_Desc HD2.
  * (* Both are tips *)
    clear IH.
    unfold isSubmapOfBy.
    simpl; subst.
    unfoldMethods.
    destruct (k =? k0) eqn:h.
    + apply N.eqb_eq in h; subst.
      split.
      -- intros fh i v1 h0.
         rewrite H2 in h0.
         destruct (i =? k0) eqn:EQ; try discriminate.
         inversion h0; subst.
         exists v0. split; auto.
         rewrite H3. rewrite EQ. auto.
      -- intro h0.
         destruct (Desc_some_f HD1) as [i1 [v1 E]].
         destruct (h0 i1 v1 E) as [v2 [E2 F]].
         rewrite H2 in E.  rewrite H3 in E2.
         destruct (i1 =? k0) eqn:EQ; try discriminate.
         inversion E. inversion E2. subst.
         auto.
    + split. intro h1; discriminate.
      intro h1.
      destruct (Desc_some_f HD1) as [i1 [v1 E]].
      destruct (h1 i1 v1 E) as [v2 [E2 F]].
      rewrite H2 in E.  rewrite H3 in E2.
      destruct (i1 =? k0) eqn:EQ0; try discriminate.
      destruct (i1 =? k) eqn:EQ1; try discriminate.
      apply N.eqb_eq in EQ1.
      apply N.eqb_eq in EQ0.
      subst.
      rewrite N.eqb_refl in h.
      discriminate.
  * (* Tip left, Bin right *)
    unfold isSubmapOfBy.
    erewrite lookup_Desc; eauto.
    assert (K: f1 k = Some v).
    { rewrite H2. rewrite N.eqb_refl. auto. }
    rewrite H11.

    destruct (f0 k) eqn:F0; simpl;
      [| destruct (f3 k) eqn:F3; simpl].

Admitted.

(** *** Verification of [member] *)

Lemma member_Desc:
 forall {a}{s : IntMap a}{r f i}, Desc s r f -> member i s = ssrbool.isSome (f i).
Proof.
 intros ????? HD.
 induction HD; subst.
 * simpl.
   unfoldMethods.
   rewrite H.
   destruct (i =? k) eqn:Ei.
   - simpl. auto.
   - simpl. auto.
 * rewrite H4. clear H4.
   simpl member.
   rewrite IHHD1 IHHD2. clear IHHD1 IHHD2.

   apply nomatch_zero; [auto|..]; intros.
   + rewrite (Desc_outside HD1) ; last inRange_false.
     rewrite (Desc_outside HD2) ; last inRange_false.
     reflexivity.
   + rewrite (Desc_outside HD2) ; last inRange_false.
     rewrite oro_None_r. reflexivity.
   + rewrite (Desc_outside HD1) ; last inRange_false.
     rewrite oro_None_l. reflexivity.
Qed.

Lemma member_Desc0:
  forall {a}{s:IntMap a} {r f i}, Desc0 s r f -> member i s = ssrbool.isSome (f i).
Proof.
  intros.
  destruct H; simpl; auto.
  rewrite H. simpl. auto.
  eapply member_Desc; eauto.
Abort.

Lemma member_Sem:
  forall {a}{s:IntMap a}{f i}, Sem s f -> member i s = ssrbool.isSome (f i).
Proof.
  intros.
  destruct H.
  * rewrite H. reflexivity.
  * erewrite member_Desc; eauto.
Qed.

Lemma Desc_has_member:
  forall {a}{s:IntMap a}{r f}, Desc s r f -> exists i, member i s = true.
Proof.
  intros ???? HD.
  destruct (Desc_some_f HD) as [j [v ?]].
  exists j.
  rewrite (member_Desc HD).
  rewrite H. reflexivity.
Qed.

(** *** Verification of [notMember] *)

Lemma notMember_Sem:
  forall {a}{s:IntMap a}{f i}, Sem s f -> notMember i s = negb (ssrbool.isSome (f i)).
Proof.
  intros.
  change (negb (member i s) = negb (ssrbool.isSome (f i))).
  f_equal.
  apply member_Sem.
  assumption.
Qed.

(** *** Verification of [null] *)

Lemma null_Sem:
  forall {a}{s:IntMap a}{f}, Sem s f -> null s = true <-> (forall i, f i = None).
Proof.
  intros a s f HSem.
  destruct HSem.
  * intuition.
  * assert (null s = false) by (destruct HD; reflexivity).
    intuition try congruence.
    destruct (Desc_some_f HD) as [x [v ?]].
    specialize (H0 x).
    congruence.
Qed.

(** *** Verification of [empty] *)

Lemma empty_Sem {a} (f : N -> option a) : Sem empty f <-> forall i, f i = None.
Proof.
  split.
  - intro s.
    apply null_Sem in s.
    simpl in s. destruct s as [s _].
    apply s.
    auto.
  - now constructor.
Qed.

Lemma empty_WF {a} : WF (empty : IntMap a).
Proof. now exists (fun _ => None); constructor. Qed.
Hint Resolve empty_WF.

(** *** Verification of [insert] *)

Lemma disjoint_reorder a (s1 : IntMap a) r1 f1 s2 r2 f2 :
  Desc s1 r1 f1 ->
  Desc s2 r2 f2 ->
  rangeDisjoint r2 r1 = true ->
   forall i : N, oro (f1 i) (f2 i) = oro (f2 i) (f1 i).
Proof.
  intros h0 h1 h2 i.
  destruct (f1 i) eqn:F1; destruct (f2 i) eqn:F2; simpl; auto.
  - assert (h3 : f2 i = None).
    rewrite rangeDisjoint_sym in h2.
    eapply isSubmapOfBy_disjoint1; eauto.
    rewrite h3 in F2.
    discriminate.
Qed.

Lemma link_Desc:
    forall {a} p1' (s1 : IntMap a) r1 f1 p2' s2 r2 f2 r f,
    Desc s1 r1 f1 ->
    Desc s2 r2 f2 ->
    p1' = rPrefix r1 ->
    p2' = rPrefix r2 ->
    rangeDisjoint r1 r2 = true->
    r = commonRangeDisj r1 r2 ->
    (forall i, f i = oro (f1 i) (f2 i)) ->
  Desc (link p1' s1 p2' s2) r f.
Proof.
  intros; subst.
  unfold link.
  rewrite -> branchMask_spec. (* Uses the fact that IntSet.Internal.branchMask = branchMask *)
  rewrite mask_spec.
  rewrite -> zero_spec by (apply commonRangeDisj_rBits_pos; eapply Desc_rNonneg; eassumption).
  rewrite if_negb.
  match goal with [ |- context [N.testbit ?i ?b] ]  => destruct (N.testbit i b) eqn:Hbit end.
  * assert (Hbit2 : N.testbit (rPrefix r2) (rBits (commonRangeDisj r1 r2) - 1)%N = false).
    { apply not_true_is_false.
      rewrite <- Hbit.
      apply not_eq_sym.
      apply (commonRangeDisj_rBits_Different r1 r2);
          try (eapply Desc_rNonneg; eassumption); auto.
    }
    rewrite rangeDisjoint_sym in H3.
    rewrite -> commonRangeDisj_sym in * by (eapply Desc_rNonneg; eassumption).
    apply (DescBin _ _ _ _ _ _ _  _ _ _ f H0 H); auto.
    + apply commonRangeDisj_rBits_pos; (eapply Desc_rNonneg; eassumption).
    + rewrite <- Hbit2.
      apply isSubrange_halfRange_commonRangeDisj;
        try (eapply Desc_rNonneg; eassumption); auto.
    + rewrite <- Hbit at 1.
      rewrite -> commonRangeDisj_sym by (eapply Desc_rNonneg; eassumption).
      rewrite rangeDisjoint_sym in H3.
      apply isSubrange_halfRange_commonRangeDisj;
        try (eapply Desc_rNonneg; eassumption); auto.
    +
      intro i. erewrite disjoint_reorder; eauto.
      rewrite rangeDisjoint_sym.
      auto.
  * assert (Hbit2 : N.testbit (rPrefix r2) (rBits (commonRangeDisj r1 r2) - 1)%N = true).
    { apply not_false_iff_true.
      rewrite <- Hbit.
      apply not_eq_sym.
      apply commonRangeDisj_rBits_Different; try (eapply Desc_rNonneg; eassumption); auto.
    }
    apply (DescBin _ _ _ _ _ _ _ _ _ _ f H H0); auto.
    + apply commonRangeDisj_rBits_pos; (eapply Desc_rNonneg; eassumption).
    + rewrite <- Hbit.
      apply isSubrange_halfRange_commonRangeDisj;
        try (eapply Desc_rNonneg; eassumption); auto.
    + rewrite <- Hbit2 at 1.
      rewrite -> commonRangeDisj_sym by (eapply Desc_rNonneg; eassumption).
      rewrite rangeDisjoint_sym in H3.
      apply isSubrange_halfRange_commonRangeDisj;
        try (eapply Desc_rNonneg; eassumption); auto.
Qed.

Lemma disjoint_neq : forall x y, (x =? y) = false ->
  rangeDisjoint (singletonRange x) (singletonRange y) = true.
Proof.
       unfold singletonRange, rangeDisjoint. unfold isSubrange, rPrefix, inRange.
intros x y EE.
rewrite !N.shiftl_0_r.
rewrite !N.shiftr_0_r.
rewrite EE.
rewrite andb_false_l.
rewrite orb_false_l.
rewrite N.eqb_sym.
rewrite EE.
rewrite andb_false_l.
simpl. auto.
Qed.

Lemma insert_Nil_Desc a:
  forall e (v:a) r f,
  r = (singletonRange e) ->
  (forall i, f i = if (i =? e) then Some v else None) ->
  Desc (insert e v Nil) r f.
Proof.
  intros; subst.
  apply DescTip; try nonneg.
Qed.

Lemma rPrefix_singletonRange e : rPrefix (singletonRange e) = e.
Proof. unfold rPrefix, singletonRange. rewrite N.shiftl_0_r. auto. Qed.
Hint Rewrite rPrefix_singletonRange.

Lemma insert_Desc a:
  forall e v r1,
  forall (s2:IntMap a) r2 f2,
  forall r f,
  Desc s2 r2 f2 ->
  r1 = (singletonRange e) ->
  r = commonRange r1 r2 ->
  (forall i, f i = if (i =? e) then Some v else f2 i) ->
  Desc (insert e v s2) r f.
Proof.
  intros ???????? HD ?? Sf; subst.
  generalize dependent f.
  induction HD as [p2' bm2 r2 f2|s2 r2 f2 s3 r3 f3 p2' r]; subst; intros f' Hf.
  + simpl.
    unfoldMethods.
    pose (h0 := H e). clearbody h0.
    destruct (e =? bm2) eqn:EE.
    rewrite <- reflect_iff in EE; try eapply N.eqb_spec. subst.
    eapply DescTip.
    ++ intro i. specialize (Hf i). rewrite H in Hf.
       destruct (i =? bm2) eqn:EI; auto.
    ++ unfold singletonRange, commonRange, isSubrange, inRange, commonRangeDisj, rPrefix. simpl.
       rewrite andb_true_r.
       rewrite N.shiftl_0_r.
       rewrite N.eqb_refl. auto.
    ++ assert (h1 : rangeDisjoint (singletonRange e) (singletonRange bm2) = true).
         { eapply disjoint_neq; eauto. }
       eapply link_Desc with (f1 := fun i => if i =? e then Some v else None) (f2 := f); eauto.
       eapply DescTip; eauto.
       eapply DescTip; eauto.
       simpl. rewrite N.shiftl_0_r. auto.
       simpl. rewrite N.shiftl_0_r. auto.
       eapply disjoint_commonRange; eauto.
       intro i. rewrite Hf. unfold oro.
       destruct (i =? e); simpl; auto.
  + simpl.
    eapply nomatch_zero; auto.
    ++ intro RF.
       assert (h0: rangeDisjoint (singletonRange e) r0 = true). {
         unfold singletonRange, rangeDisjoint.
         unfold isSubrange. simpl. rewrite N.shiftl_0_r.
         rewrite RF.
         rewrite andb_false_l.
         rewrite orb_false_l.
         admit.
       }
       eapply link_Desc with (f1 := fun i => if i =? e then Some v else None); eauto.
       eapply DescTip; eauto.
       eapply DescBin; eauto.
       rewrite rPrefix_singletonRange; auto.
       eapply disjoint_commonRange; eauto.
       intro i. rewrite Hf. unfold oro. destruct (i =? e); simpl; auto.
    ++ intros R1 R2.
       eapply DescBin with (f1 := fun i => if i =? e then Some v else s3 i); eauto.
       admit.
       admit.
       admit.
       admit.
       admit.
       intro i. rewrite Hf.
       destruct (i =? e); simpl; auto.
    ++ intros R1 R2.
       admit.
Admitted.

Lemma insert_Sem:
  forall a e (v:a) s2 f2 f,
  Sem s2 f2 ->
  (forall i, f i = if (i =? e) then Some v else f2 i) ->
  Sem (insert e v s2) f.
Proof.
  intros.
  destruct H.
  * eapply DescSem. apply insert_Nil_Desc; auto.
    solve_f_eq.
  * eapply DescSem. eapply insert_Desc; eauto.
Qed.

Lemma insert_WF:
  forall a n (v:a) s, WF s -> WF (insert n v s).
Proof.
  intros.
  destruct H.
  eexists.
  eapply insert_Sem; eauto.
  intro i; reflexivity.
Qed.

(** * Specifying [restrictKeys] *)

(* We can extract the argument to [deferredFix] from the definition of [restrictKeys]. *)

Definition restrictKeys_f {a} :
  (IntMap a -> IntSet -> IntMap a) -> (IntMap a -> IntSet -> IntMap a).
Proof.
  let rhs := eval unfold restrictKeys in (@restrictKeys a) in
  match rhs with context[ deferredFix2 ?f ] => exact f end.
Defined.

Definition restrictKeys_body {a} := restrictKeys_f (@restrictKeys a).

Lemma restrictKeys_eq {a} (m : IntMap a) s :
  restrictKeys m s = restrictKeys_body m s.
Proof.
  enough (@restrictKeys a = restrictKeys_body) by congruence.
  apply deferredFix2_eq.
Qed.

Definition restrictBitMapToRange r bm :=
  let p := rPrefix r in
  let msk := rMask r in
    N.land (N.land bm (N.lxor (bitmapOf p - 1)%N (N.ones 64%N)))
           (N.lor (bitmapOf (N.lor p (N.lor msk (msk - 1))))
           (bitmapOf (N.lor p (N.lor msk (msk - 1))) - 1)%N).

Lemma bin_Desc0:
  forall a (m1 : IntMap a) r1 f1 m2 r2 f2 p msk r f,
    Desc0 m1 r1 f1 ->
    Desc0 m2 r2 f2 ->
    (0 < rBits r)%N ->
    isSubrange r1 (halfRange r false) = true ->
    isSubrange r2 (halfRange r true) = true ->
    p = rPrefix r ->
    msk = rMask r ->
    (forall i, f i = oro (f1 i) (f2 i)) ->
    Desc0 (bin p msk m1 m2) r f.
Admitted.

Ltac point_to_inRange_Map :=
  lazymatch goal with
    | [ HD : IntSetProofs.Desc ?s ?r ?f, Hf : ?f ?i = true |- _ ]
      => apply (IntSetProofs.Desc_inside HD) in Hf
    | [ H : bitmapInRange ?r ?bm ?i = true |- _ ]
      => apply bitmapInRange_inside in H
    | [ HD : Desc ?m ?r ?f, Hf : ?f ?i = Some _ |- _ ]
      => apply (Desc_inside HD) in Hf
  end.

Ltac solve_f_eq_disjoint_Map :=
  solve_f_eq;
  repeat point_to_inRange_Map;
  repeat saturate_inRange;
  try inRange_disjoint. (* Only try this, so that we see wher we are stuck. *)

Program Fixpoint restrictKeys_Desc
  a (m1 : IntMap a) r1 f1 s2 r2 f2 f
  { measure (size_nat m1 + Data.IntSet.Internal.size_nat s2) } :
  Desc m1 r1 f1 ->
  IntSetProofs.Desc s2 r2 f2 ->
  (forall i, f i = if f2 i then f1 i else None) ->
  Desc0 (restrictKeys m1 s2) r1 f
  := fun HD1 HD2 Hf => _.
Next Obligation.
  rewrite restrictKeys_eq.
  unfold restrictKeys_body, restrictKeys_f.
  unfoldMethods.

  destruct HD1.
  * (* m1 is a Tip *)
    subst.
    erewrite IntSetProofs.member_Desc by eassumption.
    destruct (f2 k) eqn: Hf2.
    + eapply Desc0NotNil; try (apply isSubrange_refl); try (intro; reflexivity).
      eapply DescTip; try reflexivity.
      intro i.
      rewrite Hf H; clear Hf H.
      destruct (N.eqb_spec i k).
      - subst. rewrite Hf2. reflexivity.
      - destruct (f2 i); reflexivity.
    + apply Desc0Nil.
      intro i.
      rewrite Hf H; clear Hf H.
      destruct (N.eqb_spec i k).
      - subst. rewrite Hf2. reflexivity.
      - destruct (f2 i); reflexivity.

  * (* m1 is a Bin *)
    inversion HD2.
    + (* s2 is a Tip *)
      clear restrictKeys_Desc. subst.
      set (m := Bin (rPrefix r) (rMask r) m1 m2) in *.
      admit.
    + (* s2 is also a Bin *)
      subst.
      set (m := Bin (rPrefix r) (rMask r) m1 m2) in *.
      set (s := IntSet.Internal.Bin (rPrefix r2) (rMask r2) s1 s0) in *.
      rewrite -> !shorter_spec by assumption.
      destruct (N.ltb_spec (rBits r2) (rBits r)).
      ++ (* s2 is smaller than m1 *)
        apply nomatch_zero_smaller; try assumption; intros.
        - (* s2 is disjoint of s1 *)
          apply Desc0Nil.
          solve_f_eq_disjoint_Map.

        - (* s2 is part of the left half of m1 *)
          eapply Desc0_subRange.
          eapply restrictKeys_Desc; clear restrictKeys_Desc; try eassumption.
          ** subst m s. simpl. omega.
          ** solve_f_eq_disjoint_Map.
          ** isSubrange_true; eapply Desc_rNonneg; eassumption.
        - (* s2 is part of the right half of m1 *)
          eapply Desc0_subRange.
          eapply restrictKeys_Desc; clear restrictKeys_Desc; try eassumption.
          ** subst m s. simpl. omega.
          ** solve_f_eq_disjoint_Map.
          ** isSubrange_true; eapply Desc_rNonneg; eassumption.

      ++ (* s2 is not smaller than m1 *)
        destruct (N.ltb_spec (rBits r) (rBits r2)).
        -- (* s2 is smaller than m1 *)
          apply nomatch_zero_smaller; try assumption; intros.
          - (* m1 is disjoint of s2 *)
            apply Desc0Nil.
            solve_f_eq_disjoint_Map.
          - (* s1 is part of the left half of s2 *)
            eapply Desc0_subRange.
            eapply restrictKeys_Desc; clear restrictKeys_Desc; try eassumption.
            ** subst m s. simpl. omega.
            ** eapply DescBin; try beassumption; reflexivity.
            ** solve_f_eq_disjoint_Map.
            ** isSubrange_true; eapply Desc_rNonneg; eassumption.

          - (* s1 is part of the right half of s2 *)

            eapply Desc0_subRange.
            eapply restrictKeys_Desc; clear restrictKeys_Desc; try eassumption.
            ** subst s m. simpl. omega.
            ** eapply DescBin; try beassumption; reflexivity.
            ** solve_f_eq_disjoint_Map.
            ** isSubrange_true; eapply Desc_rNonneg; eassumption.

        -- (* s1 and s2 are the same size *)
          apply same_size_compare; try Nomega; intros.
          - subst.
            eapply bin_Desc0; try assumption; try reflexivity.
            ** eapply restrictKeys_Desc.
               --- subst s m. simpl. omega.
               --- eassumption.
               --- eassumption.
               --- intro i. reflexivity.
            ** eapply restrictKeys_Desc.
               --- subst s m. simpl. omega.
               --- eassumption.
               --- eassumption.
               --- intro i. reflexivity.
            ** isSubrange_true; eapply Desc_rNonneg; eassumption.
            ** isSubrange_true; eapply Desc_rNonneg; eassumption.
            ** solve_f_eq_disjoint_Map.
          - apply Desc0Nil.
            solve_f_eq_disjoint_Map.
Admitted.

Lemma restrictKeys_Sem:
  forall a (m1 : IntMap a) f1 s2 f2,
  Sem m1 f1 ->
  IntSetProofs.Sem s2 f2 ->
  Sem (restrictKeys m1 s2) (fun i => if f2 i then f1 i else None).
Proof.
  intros.
  destruct H; [|destruct H0].
  * rewrite restrictKeys_eq.
    apply SemNil. solve_f_eq.
  * replace (restrictKeys s IntSet.Internal.Nil) with (@Nil a) by (rewrite restrictKeys_eq; destruct s; reflexivity).
    apply SemNil. solve_f_eq.
  * eapply Desc0_Sem. eapply restrictKeys_Desc; try eauto.
Qed.

Lemma restrictKeys_WF:
  forall a (m1 : IntMap a) s2, WF m1 -> IntSetProofs.WF s2 -> WF (restrictKeys m1 s2).
Proof.
  intros.
  destruct H, H0.
  eexists. apply restrictKeys_Sem; eassumption.
Qed.