Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Trivial.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.

Section ContextProperties.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {Gamma: ProofTheory L}
        {bSC: BasicSequentCalculus L Gamma}
        {minSC: MinimunSequentCalculus L Gamma}
        {ipSC: IntuitionisticPropositionalSequentCalculus L Gamma}
        {cpSC: ClassicalPropositionalSequentCalculus L Gamma}.

Lemma classical_derivable_spec: forall (Phi: context) (x: expr),
  Phi |-- x <-> ~ consistent (Union _ Phi (Singleton _ (~~ x))).
Proof.
  intros.
  unfold consistent.
  AddAxiomatization Gamma.
  fold (@consistent L Gamma (Phi;; ~~ x)).
  rewrite <- (double_negp x) at 1.
  unfold negp at 1.
  rewrite <- deduction_theorem.
  rewrite consistent_spec.
  tauto.
Qed.

Lemma MCS_nonelement_inconsistent: forall (Phi: context),
  maximal consistent Phi ->
  (forall x: expr, ~ Phi x <-> Phi |-- x --> FF).
Proof.
  intros.
  split; intros.
  + destruct H.
    specialize (H1 (Union _ Phi (Singleton _ x))).
    rewrite consistent_spec in H1.
    rewrite deduction_theorem in H1.
    assert (Included expr Phi (Union expr Phi (Singleton expr x))) by (intros ? ?; left; auto).
    assert (~ Included expr (Union expr Phi (Singleton expr x)) Phi) by (intros HH; specialize (HH x); apply H0, HH; right; constructor).
    tauto.
  + intro.
    pose proof derivable_assum Phi x H1.
    pose proof deduction_modus_ponens _ _ _ H2 H0.
    destruct H as [? _].
    rewrite consistent_spec in H; auto.
Qed.

Lemma maximal_consistent_orp_witnessed: forall (Phi: context),
  maximal consistent Phi -> orp_witnessed Phi.
Proof.
  intros.
  hnf; intros.
  rewrite MCS_element_derivable in H0 by auto.
  apply NNPP; intro.
  apply not_or_and in H1.
  destruct H1.
  rewrite MCS_nonelement_inconsistent in H1, H2 by eauto.
  destruct H as [? _]; rewrite consistent_spec in H.
  apply H.
  eapply deduction_modus_ponens; [exact H0 |].
  apply deduction_orp_elim'; auto.
Qed.

Lemma MCS_andp_iff: forall (Phi: context),
  maximal consistent Phi ->
  (forall x y: expr, Phi (x && y) <-> (Phi x /\ Phi y)).
Proof.
  intros.
  apply maximal_consistent_derivable_closed in H.
  apply DCS_andp_iff; auto.
Qed.

Lemma MCS_orp_iff: forall (Phi: context),
  maximal consistent Phi ->
  (forall x y: expr, Phi (x || y) <-> (Phi x \/ Phi y)).
Proof.
  intros.
  apply DCS_orp_iff; auto.
  + apply maximal_consistent_derivable_closed; auto.
  + apply maximal_consistent_orp_witnessed; auto.
Qed.

Lemma MCS_impp_iff: forall (Phi: context),
  maximal consistent Phi ->
  (forall x y: expr, Phi (x --> y) <-> (Phi x -> Phi y)).
Proof.
  intros.
  split; intros.
  + rewrite MCS_element_derivable in H0, H1 |- * by auto.
    apply (deduction_modus_ponens _ x y); auto.
  + pose proof derivable_excluded_middle Phi y.
    rewrite <- MCS_element_derivable in H1 by auto.
    rewrite MCS_orp_iff in H1 by auto.
    pose proof derivable_excluded_middle Phi x.
    rewrite <- MCS_element_derivable in H2 by auto.
    rewrite MCS_orp_iff in H2 by auto.
    destruct H1; [| destruct H2].
    - rewrite MCS_element_derivable in H1 |- * by auto.
      apply deduction_left_impp_intros; auto.
    - exfalso.
      apply H0 in H2.
      rewrite MCS_element_derivable in H1, H2 by auto.
      pose proof deduction_modus_ponens _ _ _ H2 H1.
      destruct H as [? _].
      rewrite consistent_spec in H; auto.
    - rewrite MCS_element_derivable in H2 |- * by auto.
      unfold negp in H2.
      rewrite <- deduction_theorem in H2 |- *.
      pose proof deduction_falsep_elim _ y H2.
      auto.
Qed.

Lemma MCS_negp_iff: forall (Phi: context),
  maximal consistent Phi ->
  (forall x: expr, Phi (~~ x) <-> ~ Phi x).
Proof.
  intros.
  unfold negp.
  rewrite MCS_impp_iff by auto.
  assert (~ Phi FF); [| tauto].
  pose proof proj1 H.
  rewrite consistent_spec, <- MCS_element_derivable in H0 by auto.
  auto.
Qed.

Lemma DDCS_MCS: forall (Phi: context),
  derivable_closed Phi ->
  orp_witnessed Phi ->
  consistent Phi ->
  maximal consistent Phi.
Proof.
  intros.
  split; auto.
  intros.
  unfold Included, Ensembles.In; intros.
  pose proof derivable_excluded_middle Phi x.
  apply H in H5.
  apply H0 in H5.
  destruct H5; auto.
  exfalso.
  apply H3 in H5; unfold Ensembles.In in H5.
  rewrite consistent_spec in H2.
  apply H2; clear H2.
  apply derivable_assum in H4.
  apply derivable_assum in H5.
  eapply deduction_modus_ponens.
  - apply H4.
  - apply H5.
Qed.

End ContextProperties.


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

(***
Modulus : 2^150 - 5
Base: 37.5
***)

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 37 + 1/2;
    bitwidth := 64;
    s := 2^150;
    c := [(1, 5)];
    carry_chains := Some [seq 0 (pred 4); [0; 1]]%nat;

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

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

    mul_code := None;

    square_code := None;

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

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


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


From Coq Require Export NArith List.
Import ListNotations.

#[global] Open Scope N.

Declare Custom Entry bingo.
Declare Custom Entry bingo1.

Record Input := { rand : list N ; boards : list (list (list N)) }.

Notation "'input' rand1 ',' .. ',' randn board1 .. boardn" :=
  {| rand := cons rand1 .. (cons randn nil) ..
  ;  boards := cons board1 .. (cons boardn nil) ..
  |}
  (at level 200, randn at level 0, board1 custom bingo, only parsing).

Notation "a b c d e" := [a; b; c; d; e]
  (in custom bingo at level 1, a custom bingo1, b custom bingo1, c custom bingo1, d custom bingo1, e custom bingo1).

Notation "a b c d e" := [a; b; c; d; e]
  (in custom bingo1 at level 1, a constr at level 0, b constr at level 0, c constr at level 0, d constr at level 0, e constr at level 0).

Definition example : Input := input
7,4,9,5,11,17,23,2,0,14,21,24,10,16,13,6,15,25,12,22,18,20,8,19,3,26,1

22 13 17 11  0
 8  2 23  4 24
21  9 14 16  7
 6 10  3 18  5
 1 12 20 15 19

 3 15  0  2 22
 9 18 13 17  5
19  8  7 25 23
20 11 10 24  4
14 21 16 12  6

14 21 17 24  4
10 16 15  9 19
18  8 23 26 20
22 11 13  6  5
 2  0 12  3  7
.

Definition Board := list (list (option N)).

Definition mkBoard : list (list N) -> Board := map (map Some).

Definition call (n : N) : Board -> Board :=
  map (map (fun x => match x with Some m => if N.eqb m n then None else x | None => x end)).

Fixpoint zip_with {A B C} (f : A -> B -> C) (xs : list A) (ys : list B) : list C :=
  match xs, ys with
  | x :: xs, y :: ys => f x y :: zip_with f xs ys
  | _, _ => nil
  end.

Fixpoint transpose {A} (xs : list (list A)) : list (list A) :=
  match xs with
  | x :: [] => map (fun y => cons y nil) x
  | x :: xs => zip_with cons x (transpose xs)
  | [] => []
  end.

Definition isNone {A} (x : option A) : bool :=
  match x with
  | None => true
  | Some _ => false
  end.

Definition cleared : list (option N) -> bool :=
  forallb isNone.

Definition winning (b : Board) : bool :=
  existsb cleared b || existsb cleared (transpose b).

Fixpoint fold_with {A B} (f : B -> B -> B) (y : B) (g : A -> B) (xs : list A) : B :=
  match xs with
  | [] => y
  | x :: xs => f (g x) (fold_with f y g xs)
  end.

Definition sum_with {A} : (A -> N) -> list A -> N := fold_with N.add 0%N.

Definition score : Board -> N :=
  sum_with (sum_with (fun x => match x with None => 0 | Some x => x end)).

Fixpoint bingo (rs : list N) (bs : list Board) : N * Board :=
  match rs with
  | [] => (0, [])  (* must not happen *)
  | r :: rs =>
    let bs := map (call r) bs in
    match find winning bs with
    | None => bingo rs bs
    | Some b => (r, b)
    end
  end.

Definition solve (xs : Input) : N :=
  let '(r, b) := bingo (rand xs) (map mkBoard (boards xs)) in
  r * score b.

(* Compute solve example. *)

Fixpoint unbingo (rs : list N) (bs : list Board) : N * Board :=
  match rs with
  | [] => (0, [])  (* must not happen *)
  | r :: rs =>
    let bs0 := map (call r) bs in
    let bs := filter (fun b => negb (winning b)) bs0 in
    match bs with
    | [] =>
      match bs0 with
      | b :: _ => (r, b)
      | _ => (0, [])  (* must not happen *)
      end
    | _ => unbingo rs bs
    end
  end.

Definition solve2 (xs : Input) : N :=
  let '(r, b) := unbingo (rand xs) (map mkBoard (boards xs)) in
  r * score b.

(* Compute solve2 example. *)

Definition solve12 (xs : Input) : N * N :=
  (solve xs, solve2 xs).


From stdpp Require Export sets gmap mapset.
From iris.algebra Require Export cmra.
From iris.algebra Require Import updates local_updates big_op.
From iris.prelude Require Import options.

(* The union CMRA *)
Section gset.
  Context `{Countable K}.
  Implicit Types X Y : gset K.

  Canonical Structure gsetO := discreteO (gset K).

  Local Instance gset_valid_instance : Valid (gset K) := λ _, True.
  Local Instance gset_unit_instance : Unit (gset K) := (∅ : gset K).
  Local Instance gset_op_instance : Op (gset K) := union.
  Local Instance gset_pcore_instance : PCore (gset K) := λ X, Some X.

  Lemma gset_op X Y : X ⋅ Y = X ∪ Y.
  Proof. done. Qed.
  Lemma gset_core X : core X = X.
  Proof. done. Qed.
  Lemma gset_included X Y : X ≼ Y ↔ X ⊆ Y.
  Proof.
    split.
    - intros [Z ->]. rewrite gset_op. set_solver.
    - intros (Z&->&?)%subseteq_disjoint_union_L. by exists Z.
  Qed.

  Lemma gset_ra_mixin : RAMixin (gset K).
  Proof.
    apply ra_total_mixin; apply _ || eauto; [].
    intros X. by rewrite gset_core idemp_L.
  Qed.
  Canonical Structure gsetR := discreteR (gset K) gset_ra_mixin.

  Global Instance gset_cmra_discrete : CmraDiscrete gsetR.
  Proof. apply discrete_cmra_discrete. Qed.

  Lemma gset_ucmra_mixin : UcmraMixin (gset K).
  Proof. split; [ done | | done ]. intros X. by rewrite gset_op left_id_L. Qed.
  Canonical Structure gsetUR := Ucmra (gset K) gset_ucmra_mixin.

  Lemma gset_opM X mY : X ⋅? mY = X ∪ default ∅ mY.
  Proof. destruct mY; by rewrite /= ?right_id_L. Qed.

  Lemma gset_update X Y : X ~~> Y.
  Proof. done. Qed.

  Lemma gset_local_update X Y X' : X ⊆ X' → (X,Y) ~l~> (X',X').
  Proof.
    intros (Z&->&?)%subseteq_disjoint_union_L.
    rewrite local_update_unital_discrete=> Z' _ /leibniz_equiv_iff->.
    split; [done|]. rewrite gset_op. set_solver.
  Qed.

  Global Instance gset_core_id X : CoreId X.
  Proof. by apply core_id_total; rewrite gset_core. Qed.

  Lemma big_opS_singletons X :
    ([^op set] x ∈ X, {[ x ]}) = X.
  Proof.
    induction X as [|x X Hx IH] using set_ind_L.
    - rewrite big_opS_empty. done.
    - unfold_leibniz. rewrite big_opS_insert // IH //.
  Qed.

  (** Add support [X ≼ Y] to [set_solver]. (We get support for [⋅] for free
  because it is definitionally equal to [∪]). *)
  Global Instance set_unfold_gset_included X Y Q :
    SetUnfold (X ⊆ Y) Q → SetUnfold (X ≼ Y) Q.
  Proof. intros [?]; constructor. by rewrite gset_included. Qed.
End gset.

Global Arguments gsetO _ {_ _}.
Global Arguments gsetR _ {_ _}.
Global Arguments gsetUR _ {_ _}.

(* The disjoint union CMRA *)
Inductive gset_disj K `{Countable K} :=
  | GSet : gset K → gset_disj K
  | GSetBot : gset_disj K.
Global Arguments GSet {_ _ _} _.
Global Arguments GSetBot {_ _ _}.

Section gset_disj.
  Context `{Countable K}.
  Local Arguments op _ _ !_ !_ /.
  Local Arguments cmra_op _ !_ !_ /.
  Local Arguments ucmra_op _ !_ !_ /.

  Global Instance GSet_inj : Inj (=@{gset K}) (=) GSet.
  Proof. intros ???. naive_solver. Qed.

  Canonical Structure gset_disjO := leibnizO (gset_disj K).

  Local Instance gset_disj_valid_instance : Valid (gset_disj K) := λ X,
    match X with GSet _ => True | GSetBot => False end.
  Local Instance gset_disj_unit_instance : Unit (gset_disj K) := GSet ∅.
  Local Instance gset_disj_op_instance : Op (gset_disj K) := λ X Y,
    match X, Y with
    | GSet X, GSet Y => if decide (X ## Y) then GSet (X ∪ Y) else GSetBot
    | _, _ => GSetBot
    end.
  Local Instance gset_disj_pcore_instance : PCore (gset_disj K) := λ _, Some ε.

  Ltac gset_disj_solve :=
    repeat (simpl || case_decide);
    first [apply (f_equal GSet)|done|exfalso]; set_solver by eauto.

  Lemma gset_disj_included X Y : GSet X ≼ GSet Y ↔ X ⊆ Y.
  Proof.
    split.
    - move=> [[Z|]]; simpl; try case_decide; set_solver.
    - intros (Z&->&?)%subseteq_disjoint_union_L.
      exists (GSet Z). gset_disj_solve.
  Qed.
  Lemma gset_disj_valid_inv_l X Y : ✓ (GSet X ⋅ Y) → ∃ Y', Y = GSet Y' ∧ X ## Y'.
  Proof. destruct Y; repeat (simpl || case_decide); by eauto. Qed.
  Lemma gset_disj_union X Y : X ## Y → GSet X ⋅ GSet Y = GSet (X ∪ Y).
  Proof. intros. by rewrite /= decide_True. Qed.
  Lemma gset_disj_valid_op X Y : ✓ (GSet X ⋅ GSet Y) ↔ X ## Y.
  Proof. simpl. case_decide; by split. Qed.

  Lemma gset_disj_ra_mixin : RAMixin (gset_disj K).
  Proof.
    apply ra_total_mixin; eauto.
    - intros [?|]; destruct 1; gset_disj_solve.
    - by constructor.
    - by destruct 1.
    - intros [X1|] [X2|] [X3|]; gset_disj_solve.
    - intros [X1|] [X2|]; gset_disj_solve.
    - intros [X|]; gset_disj_solve.
    - exists (GSet ∅); gset_disj_solve.
    - intros [X1|] [X2|]; gset_disj_solve.
  Qed.
  Canonical Structure gset_disjR := discreteR (gset_disj K) gset_disj_ra_mixin.

  Global Instance gset_disj_cmra_discrete : CmraDiscrete gset_disjR.
  Proof. apply discrete_cmra_discrete. Qed.

  Lemma gset_disj_ucmra_mixin : UcmraMixin (gset_disj K).
  Proof. split; try apply _ || done. intros [X|]; gset_disj_solve. Qed.
  Canonical Structure gset_disjUR := Ucmra (gset_disj K) gset_disj_ucmra_mixin.

  Local Arguments op _ _ _ _ : simpl never.

  Lemma gset_disj_alloc_updateP_strong P (Q : gset_disj K → Prop) X :
    (∀ Y, X ⊆ Y → ∃ j, j ∉ Y ∧ P j) →
    (∀ i, i ∉ X → P i → Q (GSet ({[i]} ∪ X))) →
    GSet X ~~>: Q.
  Proof.
    intros Hfresh HQ.
    apply cmra_discrete_updateP=> ? /gset_disj_valid_inv_l [Y [->?]].
    destruct (Hfresh (X ∪ Y)) as (i&?&?); first set_solver.
    exists (GSet ({[ i ]} ∪ X)); split.
    - apply HQ; set_solver by eauto.
    - apply gset_disj_valid_op. set_solver by eauto.
  Qed.
  Lemma gset_disj_alloc_updateP_strong' P X :
    (∀ Y, X ⊆ Y → ∃ j, j ∉ Y ∧ P j) →
    GSet X ~~>: λ Y, ∃ i, Y = GSet ({[ i ]} ∪ X) ∧ i ∉ X ∧ P i.
  Proof. eauto using gset_disj_alloc_updateP_strong. Qed.

  Lemma gset_disj_alloc_empty_updateP_strong P (Q : gset_disj K → Prop) :
    (∀ Y : gset K, ∃ j, j ∉ Y ∧ P j) →
    (∀ i, P i → Q (GSet {[i]})) → GSet ∅ ~~>: Q.
  Proof.
    intros. apply (gset_disj_alloc_updateP_strong P); eauto.
    intros i; rewrite right_id_L; auto.
  Qed.
  Lemma gset_disj_alloc_empty_updateP_strong' P :
    (∀ Y : gset K, ∃ j, j ∉ Y ∧ P j) →
    GSet ∅ ~~>: λ Y, ∃ i, Y = GSet {[ i ]} ∧ P i.
  Proof. eauto using gset_disj_alloc_empty_updateP_strong. Qed.

  Section fresh_updates.
    Local Set Default Proof Using "Type*".
    Context `{!Infinite K}.

    Lemma gset_disj_alloc_updateP (Q : gset_disj K → Prop) X :
      (∀ i, i ∉ X → Q (GSet ({[i]} ∪ X))) → GSet X ~~>: Q.
    Proof.
      intro; eapply gset_disj_alloc_updateP_strong with (λ _, True); eauto.
      intros Y ?; exists (fresh Y). split; [|done]. apply is_fresh.
    Qed.
    Lemma gset_disj_alloc_updateP' X :
      GSet X ~~>: λ Y, ∃ i, Y = GSet ({[ i ]} ∪ X) ∧ i ∉ X.
    Proof. eauto using gset_disj_alloc_updateP. Qed.

    Lemma gset_disj_alloc_empty_updateP (Q : gset_disj K → Prop) :
      (∀ i, Q (GSet {[i]})) → GSet ∅ ~~>: Q.
    Proof.
      intro. apply gset_disj_alloc_updateP. intros i; rewrite right_id_L; auto.
    Qed.
    Lemma gset_disj_alloc_empty_updateP' : GSet ∅ ~~>: λ Y, ∃ i, Y = GSet {[ i ]}.
    Proof. eauto using gset_disj_alloc_empty_updateP. Qed.
  End fresh_updates.

  Lemma gset_disj_dealloc_local_update X Y :
    (GSet X, GSet Y) ~l~> (GSet (X ∖ Y), GSet ∅).
  Proof.
    apply local_update_total_valid=> _ _ /gset_disj_included HYX.
    rewrite local_update_unital_discrete=> -[Xf|] _ /leibniz_equiv_iff //=.
    rewrite {1}/op /=. destruct (decide _) as [HXf|]; [intros[= ->]|done].
    by rewrite difference_union_distr_l_L
      difference_diag_L !left_id_L difference_disjoint_L.
  Qed.
  Lemma gset_disj_dealloc_empty_local_update X Z :
    (GSet Z ⋅ GSet X, GSet Z) ~l~> (GSet X, GSet ∅).
  Proof.
    apply local_update_total_valid=> /gset_disj_valid_op HZX _ _.
    assert (X = (Z ∪ X) ∖ Z) as HX by set_solver.
    rewrite gset_disj_union // {2}HX. apply gset_disj_dealloc_local_update.
  Qed.
  Lemma gset_disj_dealloc_op_local_update X Y Z :
    (GSet Z ⋅ GSet X, GSet Z ⋅ GSet Y) ~l~> (GSet X,GSet Y).
  Proof.
    rewrite -{2}(left_id ε _ (GSet Y)).
    apply op_local_update_frame, gset_disj_dealloc_empty_local_update.
  Qed.

  Lemma gset_disj_alloc_op_local_update X Y Z :
    Z ## X → (GSet X,GSet Y) ~l~> (GSet Z ⋅ GSet X, GSet Z ⋅ GSet Y).
  Proof.
    intros. apply op_local_update_discrete. by rewrite gset_disj_valid_op.
  Qed.
  Lemma gset_disj_alloc_local_update X Y Z :
    Z ## X → (GSet X,GSet Y) ~l~> (GSet (Z ∪ X), GSet (Z ∪ Y)).
  Proof.
    intros. apply local_update_total_valid=> _ _ /gset_disj_included ?.
    rewrite -!gset_disj_union //; last set_solver.
    auto using gset_disj_alloc_op_local_update.
  Qed.
  Lemma gset_disj_alloc_empty_local_update X Z :
    Z ## X → (GSet X, GSet ∅) ~l~> (GSet (Z ∪ X), GSet Z).
  Proof.
    intros. rewrite -{2}(right_id_L _ union Z).
    apply gset_disj_alloc_local_update; set_solver.
  Qed.

  (** Add some basic support for [GSet X = GSet Y], [GSet X ≼ GSet Y], and
  [✓ (GSet X ⋅ GSet Y)] to [set_solver]. There are probably more cases we could
  cover (e.g., involving [GSetBot], or nesting of [⋅]), but it is not clear
  these are useful in practice, nor how to handle them effectively. *)
  Global Instance set_unfold_gset_eq (X Y : gset K) Q :
    SetUnfold (X = Y) Q → SetUnfold (GSet X = GSet Y) Q.
  Proof. intros [?]; constructor. by rewrite (inj_iff _). Qed.
  Global Instance set_unfold_gset_disj_included (X Y : gset K) Q :
    SetUnfold (X ⊆ Y) Q → SetUnfold (GSet X ≼ GSet Y) Q.
  Proof. intros [?]; constructor. by rewrite gset_disj_included. Qed.
  Global Instance set_unfold_gset_disj_valid_op (X Y : gset K) Q :
    SetUnfold (X ## Y) Q → SetUnfold (✓ (GSet X ⋅ GSet Y)) Q.
  Proof. intros [?]; constructor. by rewrite gset_disj_valid_op. Qed.
End gset_disj.

Global Arguments gset_disjO _ {_ _}.
Global Arguments gset_disjR _ {_ _}.
Global Arguments gset_disjUR _ {_ _}.


(* A finite partial maps interface and implmentation in Coq.
   Largely copied from the Coq Std Lib, Msets
   - C.E. Sally, Aquinas Hobor *)

Require Import Utf8.
Require Export Bool Orders NArith SetoidList OrdersFacts.

Module Type Kvp (K : OrderedType).

 Section Vals.
 Variable val:Type.
 Notation kvp := (prod K.t val).
 Notation keq := K.eq.
 Notation klt := K.lt.

  Definition Kvpeq : relation kvp := λ a b,
    keq (fst a) (fst b) ∧ (snd a) = (snd b).

  Definition Kvplt : relation kvp := λ a b,
    klt (fst a) (fst b).

  Definition Pkeq : relation kvp :=  λ a b,
    keq  (fst a) (fst b).

 End Vals.
End Kvp.

(*******		     The functions on maps			*******)
Module Type Funs (K : OrderedType). (* The functions on maps *)
  Notation key := K.t.
  Notation klt := K.lt.
  Notation keq := K.eq.

  Parameter map_of : ∀ x : Type, Type. (* abstract type of maps *)

(* "binding" and "key-value pair" are used interchangably and have the obvious
   meaning. "key-value pair" just refers to the key and it's associated
   value, i.e. an abstract pair. It generally does not refer to Coq pairs,
   i.e. not of type [prod] *)

  Section Vals.
   Context {val : Type}.
   Notation mv := (map_of val).
   Notation kvp := (prod key val).

(*******			  Constructors				*******)

  Parameter empty : mv. (*gen*)
  (* the empty map *)

  Parameter singleton : key → val → mv.
  (* [singleton x y] creates a map with a single binding [x-y] *)

  Parameter add : key → val → mv → mv.
  (* [add x y m] adds the binding [x-y] to the map [m]. If [x] was already
     present, [y] shadows (replaces) the previously bound value *)

  Parameter update : key → val → mv → mv. (*gen*)
  (* If [x] is in [m], [update x y m] shadows the value previously bound to
     [x] with [y]; if [x] is not in [m], [m] itself is returned *)

  Parameter remove : key → mv → mv.
  (* [remove x m] deletes a binding of [x] (and the value that was bound to it)
     from [m]; returns [m] if [x] was not present. *)

  Parameter fromList : list kvp → mv.
  (* [fromList l] constructs a map from a list of key-value pairs. If the list
     has repeat keys, the binding later in the list is added to the map. *)

(*******			 Tests/Queries				*******)

  Parameter is_empty : mv → bool. (*gen*)
  (* returns true if its argument is empty and false otherwise *)

  Parameter mem : key → mv → bool. (*gen*)
  (* [mem x m] returns true if some value is bound to [x] in [m] *)

  Parameter cardinal : mv → nat. (*gen*)
  (* returns the number of bindings in the map *)

  Parameter find : key → mv → option val. (*gen*)
  (* [find x m] returns "Some" of the value bound to [x] if [x] is in [m] and
     "None" otherwise *)

  Context {val' val'' : Type}.
  Notation mv' := (map_of val').		Notation mv'' := (map_of val'').

  Parameter subset : mv → mv' → bool. (*gen*)
  (* [subset m m'] returns true if all the keys in [m] are in [m'] *)

  Parameter equal : (val → val' → bool) → mv → mv' → bool. (*gen*)
  (* [equal cmp m' m2] returns true if [m'] and [m2] have 1) the same keys wrt
     K.eq and 2) the same values modulo some comparison function [cmp] *)

  Parameter compare : mv → mv' → comparison. (*gen*)
  (* Total ordering between the domain (set of keys) of maps. If thought of as
     a decision procedure for equality (same keys), it is sound & complete;
     Yes := Eq, No := Lt, Gt. For subset, it is only complete (only "no"
     answers can be trusted). *)

  Parameter for_all : (key → val → bool) → mv → bool. (*gen*)
  (* [for_all P m] returns true if every binding the in the map satisfies [P] *)

  Parameter exists_ : (key → val → bool) → mv → bool. (*gen*)
  (* [exists_ P m] returns true if there exists a binding in the map satisfying
     [P] *)

(*******			 Map operators  			*******)

  Parameter union : mv → mv → mv.
  (* [union m m2] returns a map containing bindings where the keys are found
     in either [m] or [m2]. When both [m] & [m2] have a key in common, union
     is left-favouring: it returns the value from [m].*)

  Parameter inter : (key→val→val→val) → mv → mv → mv.
  (* [inter sl m m2] maps [x] to [sl x y z] iff [(x,y)] is in [m] and
     [(x,z)] is in [m2]. *)

  Parameter diff : mv → mv → mv.
  (* [diff m' m2] returns a map containing bindings where the keys are found in
     [m'] but not [m2]. Analogous to set difference, not symmetric difference *)

(* Dear Pierre, for union and intersection, we tried to generalize the types
   so that you could union a map of nats and a map of bools for exampl, but
   this proved to be extremely painful, in terms of the specs. We were also
   not exactly sure of the specs for them. In the interests of time, we
   prototyped these above functions first. We are not terribly happy with
   them; any comments/suggestions for improvements would be appreciated.

   The functions we would have liked to have are below. Are they too much?

  Parameter inter {X:Type} : (key → val → val' → X) → mv → mv' → map_of X.
  (* [inter comb m m'] returns a map containing keys that are in both [m] & [m'].
     A user supplied function, taking the key and both values determines the
     new value to be bound in the result *)

  Parameter union : (key→val→X)→(key→val'→X)→(key→val→val'→X)→mv→mv'→map_of X.
  (* [union left right pair m m'], returns a map containing bindings where the
     keys are found in either [m] or [m2]. If the key [x] is bound to [y] in
     only one of the maps, then [x] is bound to [left x y] in the result if
     [x] is in [m]. Alternatively, [x] is bound to [right x y] in the result,
     if [x] was in [m']. When [(x,y)] & [(x,z)] are in [m] & [m'] respectively,
     the value bound in the result is [sl x y z] *)
*)

(*******			 Map functions				*******)

  Parameter foldl : ∀ {A : Type}, (key → val → A → A) → mv → A → A. (*gen*)
  (* [fold f m acc] computes (f xN yN ... (f x2 y2 (f x1 y1 acc))...), where
     x1 y1 .. xN yN are the bindings of [m]. Takes the bindings in increasing
     order *)

  Parameter foldr : ∀ {A : Type}, (key → val → A → A) → mv → A → A. (*gen*)
  (* [fold f m acc] computes (f x1 y1 (f x2 y2 ... (f xN yN acc))...), where
     x1 y1 .. xN yN are the bindings of [m]. Takes the bindings in decreasing
     order *)

  Parameter filter : (key → val → bool) → mv → mv.
  (* [filter P m] is a map with all the bindings in [m] that satisfy [P]. *)

  Parameter partition : (key → val → bool) → mv → mv * mv.
  (* [partition P m] returns a pair of maps [(m', m2)], where [m'] is a map
     containing all key-value pairs that satisfy P, and [m2], the map containing
     the bindings that do not *)

  Parameter map : (val → val') → mv → mv'. (*gen*)
  (* [map f m] returns a map with same domain as [m], where the value [a] in
     each binding of [m] has been replaced by [f a] *)

  Parameter mapi : (key → val → val') → mv → mv'. (*gen*)
  (* Same as [map], but the function receives both key and value as arguments
     for each binding of the map *)
(*
  Parameter map2 : (option val → option val' → option val'') → mv → mv' → mv''.
  (* [map2 f m m'] creates a new map whose bindings belong to the ones of
     either m or m'. The presence and value for a key [k] is determined by
     [f e1 e2] where e1 and e2 are the (optional) bindings of k in m and m2. *)
*)

(*******		       Element selectors			*******)

  Parameter elements : mv → list kvp. (*gen*)
  (* Returns a list of bindings of the map sorted by keys. *)

  Parameter kelements : mv → list key. (*gen*)
  (* Returns a sorted list of keys of the map *)

  Parameter choose : mv → option kvp. (*gen*)
  (* Return one binding of the map, as [Some] of a pair of key and value.
     Returns None if the map is empty. Which element is chosen is unspecified.
     [Equal] sets could return different elements. *)

  Parameter min_elt : mv → option kvp. (*gen*)
  (* Returns the binding with the smallest key (with respect to the X.compare
     ordering), or None if the set is empty. *)

  Parameter max_elt : mv → option kvp. (*gen*)
  (* Returns the binding with the largest key (with respect to the X.compare
     ordering), or None if the set is empty. *)

  End Vals.

End Funs.

(*******		       The specifications			*******)
Module Type Maps (K:OrderedType).
  Include Funs K.  (* First, we get all the functions *)
  Include Kvp K.

(*******		  Some Predicate & Definitions			*******)
Section Preds1.
  Context {val : Type}.
  Notation mv := (map_of val).

  Parameter MapsTo : key → val → mv → Prop.
  (* [MapsTo k v m] is true when [v] is bound to [k] in [m]. i.e. the key-value
     pair [k-v] is in [m] *)
  Declare Instance Mt_compat : Proper (keq==>Logic.eq==>Logic.eq==>iff) MapsTo.

  Definition In k m := ∃v, MapsTo k v m.

End Preds1.
Section Preds2.
  Context {val val' : Type}.
  Notation mv := (map_of val).
  Notation mv' := (map_of val').

  Definition Empty       (m:mv)     := ∀ k v, ¬ MapsTo k v m.
  Definition Equal       (m1 m2:mv) := ∀ k v, MapsTo k v m1 ↔ MapsTo k v m2.
  Definition Restriction (m1 m2:mv) := ∀ k v, MapsTo k v m1 → MapsTo k v m2.
  Definition SameKeys    (m1 m2:mv) := ∀ k  , In k m1 ↔ In k m2.
  Definition Subset   (m:mv)(m':mv'):= ∀ k  , In k m → In k m'.
  Definition For_all (P:_→_→Prop) (m:mv) := ∀ k v, MapsTo k v m → P k v.
  Definition Exists  (P:_→_→Prop) (m:mv) := ∃ k v, MapsTo k v m ∧ P k v.
  Definition Equivb cmp (m:mv) (m':mv')  := (∀ x, In x m ↔ In x m') ∧
  (∀ x (v:val) (v':val'), MapsTo x v m → MapsTo x v' m' → cmp v v' = true).

  Parameter mkeq : relation (list key).
  Declare Instance mkeq_equiv : Equivalence mkeq.
  Parameter mklt : relation (list key).
  Declare Instance mklt_strorder : StrictOrder mklt.

End Preds2.

(*******			     Specs				*******)
Section Specs.
  Context {val val': Type}.
  Notation mv  := (map_of val).
  Notation mv' := (map_of val').
  Notation kvp := (prod key val).
  Notation kvpeq := (Kvpeq val).
  Notation kvplt := (Kvplt val).
  Notation pkeq := (Pkeq val).

  Notation "s [=] t"   := (Equal s t)       (at level 70, no associativity).
  Notation "s [|<=] t" := (Restriction s t) (at level 70, no associativity).
  Notation "s [<=] t"  := (Subset s t)      (at level 70, no associativity).

  Variable x a : key.
  Variable y b : val.
  Variable m m1 m2 : mv.

    (** Specification of [MapsTo] *)
      Parameter MapsTo_spec1 : keq a x → MapsTo a y m → MapsTo x y m.
      Parameter MapsTo_spec2 : MapsTo x b m → MapsTo x y m → b = y.

    (** Specification of [empty] *)
      Parameter empty_spec : Empty (@empty val).

    (** Specification of [add] *)
      Parameter add_spec1 : MapsTo x y (add x y m).
      Parameter add_spec2 : ¬keq a x → (MapsTo a b (add x y m) ↔ MapsTo a b m).

    (** Specification of [singleton] *)
      Parameter singleton_spec : MapsTo a b (singleton x y) ↔ kvpeq (a,b) (x,y).

    (** Specification of [update] *)
      Parameter update_spec1 : In x m → MapsTo x y (update x y m).
      Parameter update_spec2 : ¬In x m → (update x y m) [=] m.
      Parameter update_spec3: ¬keq a x → (MapsTo a b (update x y m) ↔ MapsTo a b m).

    (** Specification of [remove] *)
      Parameter remove_spec1 : keq a x → ¬In a (remove x m).
      Parameter remove_spec2 : ¬keq a x → MapsTo a b m →
                               MapsTo a b (remove x m).
      Parameter remove_spec3 : MapsTo a b (remove x m) → MapsTo a b m.

    (** Specification of [fromList] *)
    Variable lst : list kvp.
(*    is this spec needed?
      Parameter fromList_spec1 : In x (fromList lst) ↔ ∃y, InA pkeq (x,y) lst.
 *)
      Parameter fromList_spec2 : MapsTo x y (fromList lst) →
                                 InA kvpeq (x,y) lst.
      Parameter fromList_spec3 : NoDupA pkeq lst → InA kvpeq (x,y) lst →
                                 MapsTo x y (fromList lst).

    (** Specification of [is_empty] *)
      Parameter is_empty_spec : is_empty m = true ↔ Empty m.

    (** Specification of [mem] *)
      Parameter mem_spec : mem x m = true ↔ In x m.

    (** Specification of [cardinal] *)
      Parameter cardinal_spec : cardinal m = length (elements m).

    (** Specification of [find] *)
      Parameter find_spec : find x m = Some y ↔ MapsTo x y m.

  Variable m' : mv'.

    (** Specification of [subset] *)
      Parameter subset_spec : subset m m' = true ↔ m [<=] m'.
(*
    (** Specification of [equal] *)
    Variable cmp : val → val' → bool.
      Parameter equiv_spec : equiv cmp m m' = true ↔ Equivb cmp m m'.
*)
    (** Specification of [compare] *)
      Parameter compare_spec : CompSpec mkeq mklt
                              (kelements m1) (kelements m') (compare m1 m').

  Variable P : key → val → bool.
    (** Specification of [for_all] *)
    Notation compatb := (Proper (keq==>Logic.eq==>Logic.eq)) (only parsing).
    Notation P' := (λ x y, P x y = true).
      Parameter for_all_spec : compatb P → (for_all P m = true ↔ For_all P' m).

    (** Specification of [exists_] *)
      Parameter exists__spec : compatb P → (exists_ P m = true ↔ Exists  P' m).

  Variable sl : key → val → val → val.
    Notation compatbb := (Proper (keq==>Logic.eq==>Logic.eq==>Logic.eq)).

    (** Specification of [union] *)
      Parameter union_spec1 : MapsTo x y (union m m2) →
                              MapsTo x y m ∨ MapsTo x y m2.
      Parameter union_spec2 : MapsTo x y m ∨ (¬In x m ∧ MapsTo x y m2) →
                              MapsTo x y (union m m2).

    (** Specification of [inter] *)
      Parameter inter_spec : compatbb sl →
                           ((∃ y b, MapsTo x (sl x y b) (inter sl m m2)) ↔
                             In x m ∧ In x m2).
      Parameter inter_spec1 : MapsTo x (sl x y b) (inter sl m m2) →
                              In x m ∧ In x m2.
      Parameter inter_spec2 : compatbb sl →
                              MapsTo x y m ∧ MapsTo x b m2 →
                              MapsTo x (sl x y b) (inter sl m m2).

    (** Specification of [diff] *)
      Parameter diff_spec : MapsTo x y (diff m m2) ↔
                            MapsTo x y m ∧ ¬In x m2.

    (** Specification of [foldl] *)
      Notation func := (compose flip prod_curry).
      (*"flipped uncurry", not "function"*)
      Parameter foldl_spec : ∀ {X : Type} f (sd : X),
                foldl f m sd = fold_left (func f) (elements m) sd.

    (** Specification of [foldr] *)
      Notation unc := prod_curry.
      Parameter foldr_spec : ∀ {X : Type} f (sd : X),
                foldr f m sd = fold_right (unc f) sd (elements m).

    (** Specification of [filter] *)
      Parameter filter_spec : compatb P →
               (MapsTo x y (filter P m) ↔ MapsTo x y m ∧ P x y = true).

    (** Specification of [partition] *)
      Notation nP := (λ x y, negb (P x y)).
      Parameter partition_spec : compatb P → let (x,y) := partition P m in
                x [=] filter P m ∧ y [=] filter nP m.
      Parameter partition_spec1 : compatb P →
                fst (partition P m) [=] filter P m.
      Parameter partition_spec2 : compatb P →
                snd (partition P m) [=] filter nP m.

  Variable f  :       val → val'.
  Variable f' : key → val → val'.
    (** Specification of [map] *)
      Parameter map_spec1 : MapsTo x y m → MapsTo x (f y) (map f m).
      Parameter map_spec2 : In x (map f m) → In x m.

    (** Specification of [mapi] *)
      Parameter mapi_spec1 : compatb f' →
                             MapsTo x y m → MapsTo x (f' x y) (mapi f' m).
      Parameter mapi_spec2 : In x (mapi f' m) → In x m.

    (** Specification of [elements] *)
      Parameter elements_spec1 : InA kvpeq (x,y) (elements m) ↔ MapsTo x y m.
      Parameter elements_spec2 : Sorted kvplt (elements m).
      Parameter elements_spec3 : NoDupA kvpeq (elements m).

    (** Specification of [kelements] *)
      Parameter kelements_spec1 : InA keq x  (kelements m) ↔ In x m.
      Parameter kelements_spec2 : Sorted klt (kelements m).
      Parameter kelements_spec3 : NoDupA keq (kelements m).

    (** Specification of [choose] *)
    Variable kv1 kv2 : kvp.
      Parameter choose_spec1 : choose m = Some (x,y) → MapsTo x y m.
      Parameter choose_spec2 : choose m = None → Empty m.

(*    should we make [choose] select some kind of principal element, or let
      it take a random element?
      Parameter choose_spec3 : choose m = Some kv1 → choose m2 = Some kv2 →
                               m [=] m2 → kvpeq kv1 kv2.
*)
    (** Specification of [min_elt] *)
      Parameter min_elt_spec1 : min_elt m = Some (x,y) → MapsTo x y m.
      Parameter min_elt_spec2 : min_elt m = Some (x,y) →
                                   ∀ a, In a m → ¬klt a x.
      Parameter min_elt_spec3 : min_elt m = None → Empty m.

    (** Specification of [max_elt] *)
      Parameter max_elt_spec1 : max_elt m = Some (x,y) → MapsTo x y m.
      Parameter max_elt_spec2 : max_elt m = Some (x,y) →
                                   ∀ a, In a m → ¬klt x a.
      Parameter max_elt_spec3 : max_elt m = None → Empty m.

  End Specs.

End Maps.

(*   A specification for maps well formed in the underlying implementation    *)

Module Type RawMaps (K:OrderedType). (* this is the analog of Maps *)
  Include Funs K. (* First, we get all the functions *)
  Include Kvp K.

(*******		  Some Predicate & Definitions			*******)
Section Preds1.
  Context {val : Type}.
  Notation mv := (map_of val).

  Parameter MapsTo : key → val → mv → Prop.
  (* [MapsTo k v m] is true when [v] is bound to [k] in [m]. i.e. the key-value
     pair [k-v] is in [m] *)
  Declare Instance Mt_compat : Proper (keq==>Logic.eq==>Logic.eq==>iff) MapsTo.

  Definition In k m := ∃v, MapsTo k v m.

End Preds1.
Section Preds2.
  Context {val val' : Type}.
  Notation mv := (map_of val).
  Notation mv' := (map_of val').

  Definition Empty       (m:mv)     := ∀ k v, ¬ MapsTo k v m.
  Definition Equal       (m1 m2:mv) := ∀ k v, MapsTo k v m1 ↔ MapsTo k v m2.
  Definition Restriction (m1 m2:mv) := ∀ k v, MapsTo k v m1 → MapsTo k v m2.
  Definition SameKeys    (m1 m2:mv) := ∀ k  , In k m1 ↔ In k m2.
  Definition Subset   (m:mv)(m':mv'):= ∀ k  , In k m → In k m'.
  Definition For_all (P:_→_→Prop) (m:mv) := ∀ k v, MapsTo k v m → P k v.
  Definition Exists  (P:_→_→Prop) (m:mv) := ∃ k v, MapsTo k v m ∧ P k v.
  Definition Equivb cmp (m:mv) (m':mv')  := (∀x, In x m ↔ In x m') ∧
  (∀x (v:val) (v':val'), MapsTo x v m → MapsTo x v' m' → cmp v v' = true).

  Parameter IsOk : mv → Prop.
  Class Ok (m:mv) : Prop := ok : IsOk m.

  Parameter isok : mv → bool.
  Declare Instance isok_Ok s `(isok s = true) : Ok s | 10.

  Parameter mkeq : relation (list key).
  Declare Instance mkeq_equiv : Equivalence mkeq.
  Parameter mklt : relation (list key).
  Declare Instance mklt_strorder : StrictOrder mklt.

End Preds2.

  Declare Instance empty_ok v : Ok (@empty v).
  Declare Instance singleton_ok v x y : Ok (@singleton v x y).
  Declare Instance add_ok v x y m `{@Ok v m} : Ok (add x y m).
  Declare Instance update_ok v x y m `{@Ok v m}: Ok (update x y m).
  Declare Instance remove_ok v x m `{@Ok v m} : Ok (remove x m).
  Declare Instance fromList_ok val (l:list (key*val)) : Ok (fromList l).
  Declare Instance union_ok v m m2 `{@Ok v m, @Ok v m2} : Ok (union m m2).
  Declare Instance inter_ok v sl m m2 `{@Ok v m, @Ok v m2} : Ok (inter sl m m2).
  Declare Instance diff_ok v m m2 `{@Ok v m, @Ok v m2}: Ok (diff m m2).
  Declare Instance map_ok v v' (f:v→v') m `{@Ok v m}: Ok (map f m).
  Declare Instance mapi_ok v v' (f:key→v→v') m `{@Ok v m}: Ok (mapi f m).
  Declare Instance filter_ok v (P:key→v→bool) m `{@Ok v m} : Ok (filter P m).
  Declare Instance partition_ok1 v P m `{@Ok v m} : Ok (fst (partition P m)).
  Declare Instance partition_ok2 v P m `{@Ok v m} : Ok (snd (partition P m)).

(*******			     Specs				*******)
Section Specs.
  Context {val val' : Type}.
  Notation mv    := (map_of val).
  Notation mv'   := (map_of val').
  Notation kvp   := (prod key val).
  Notation kvpeq := (Kvpeq val).
  Notation kvplt := (Kvplt val).
  Notation Ok    := (@Ok val).
  Notation Ok'   := RawMaps.Ok.

  Notation "s [=] t"   := (Equal s t)       (at level 70, no associativity).
  Notation "s [|<=] t" := (Restriction s t) (at level 70, no associativity).
  Notation "s [<=] t"  := (Subset s t)      (at level 70, no associativity).

  Variable a x  : key.
  Variable b y  : val.
  Variable m m2 : mv.
  Notation compatb := (Proper (keq==>Logic.eq==>Logic.eq)) (only parsing).

  Parameter MapsTo_spec1 : ∀ `{Ok m}, keq a x → MapsTo a y m → MapsTo x y m.
  Parameter MapsTo_spec2 : ∀ `{Ok m}, MapsTo x b m → MapsTo x y m → b = y.

  Parameter empty_spec : Empty (@empty val).

  Parameter singleton_spec : MapsTo a b (singleton x y) ↔ kvpeq (a,b) (x,y).

  Parameter add_spec1 : ∀ `{Ok m}, MapsTo x y (add x y m).
  Parameter add_spec2 : ∀ `{Ok m}, ¬keq a x →
                        (MapsTo a b (add x y m) ↔ MapsTo a b m).

  Parameter update_spec1 : ∀ `{Ok m},  In x m → MapsTo x y (update x y m).
  Parameter update_spec2 : ∀ `{Ok m}, ¬In x m → (update x y m) [=] m.
  Parameter update_spec3 : ∀ `{Ok m}, ¬keq a x →
                        (MapsTo a b (update x y m) ↔ MapsTo a b m).

  Parameter remove_spec1 : ∀ `{Ok m}, keq a x → ¬In a (remove x m).
  Parameter remove_spec2 : ∀ `{Ok m}, ¬keq a x → MapsTo a b m →
                           MapsTo a b (remove x m).
  Parameter remove_spec3 : ∀ `{Ok m}, MapsTo a b (remove x m) → MapsTo a b m.

  Variable lst : list kvp.
  Notation pkeq := (fun x y => keq (fst x) (fst y)).
(*
  Parameter fromList_spec1 : In x (fromList lst) ↔ ∃ y, InA pkeq (x,y) lst.
 *)
  Parameter fromList_spec2 : MapsTo x y (fromList lst) → InA kvpeq (x,y) lst.
  Parameter fromList_spec3 : NoDupA pkeq lst → InA kvpeq (x,y) lst →
                             MapsTo x y (fromList lst).

  Parameter is_empty_spec : ∀ `{Ok m}, is_empty m = true ↔ Empty m.

  Parameter mem_spec : ∀ `{Ok m}, mem x m = true ↔ In x m.

  Parameter cardinal_spec : ∀ `{Ok m}, cardinal m = length (elements m).

  Parameter find_spec : ∀ `{Ok m}, find x m = Some y ↔ MapsTo x y m.

  Variable m'  : mv'.
  Variable cmp : val → val' → bool.
  Parameter subset_spec : ∀ `{Ok m, Ok' m'}, subset m m' = true ↔ m[<=]m'.
(*
  Parameter equiv_spec : equiv cmp m m' = true ↔ Equivb cmp m m'.
*)
  Parameter compare_spec : ∀ `{Ok m, Ok' m'},
                           CompSpec mkeq mklt
                          (kelements m) (kelements m') (compare m m').

  Variable P  : key → val → bool.
  Notation P' := (λ x y, P x y = true).
  Notation nP := (λ x y, negb (P x y)).
  Parameter for_all_spec : ∀ `{Ok m}, compatb P →
                          (for_all P m = true ↔ For_all P' m).

  Parameter exists__spec : ∀ `{Ok m}, compatb P →
                          (exists_ P m = true ↔ Exists  P' m).

  Variable sl : key → val → val → val.
  Notation compatbb := (Proper (keq==>Logic.eq==>Logic.eq==>Logic.eq)).
  Parameter union_spec1 : ∀ `{Ok m, Ok m2}, MapsTo x y (union m m2) →
                          MapsTo x y m ∨ MapsTo x y m2.
  Parameter union_spec2 : ∀ `{Ok m, Ok m2},
                          MapsTo x y m ∨ (¬In x m ∧ MapsTo x y m2) →
                          MapsTo x y (union m m2).

  Parameter inter_spec : ∀ `{Ok m, Ok m2}, compatbb sl →
                       ((∃ y b, MapsTo x (sl x y b) (inter sl m m2)) ↔
                         In x m ∧ In x m2).
  Parameter inter_spec1 : ∀ `{Ok m, Ok m2},
                          MapsTo x (sl x y b) (inter sl m m2) →
                          In x m ∧ In x m2.
  Parameter inter_spec2 : ∀ `{Ok m, Ok m2}, compatbb sl →
                          MapsTo x y m ∧ MapsTo x b m2 →
                          MapsTo x (sl x y b) (inter sl m m2).

  Parameter diff_spec : ∀ `{Ok m, Ok m2}, MapsTo x y (diff m m2) ↔
                            MapsTo x y m ∧ ¬In x m2.

  (*"flipped uncurry", not "function"*)
  Notation func := (compose flip prod_curry).
  Parameter foldl_spec : ∀ {X : Type} f (sd : X) `{Ok m},
            foldl f m sd = fold_left (func f) (elements m) sd.

  Notation unc := prod_curry.
  Parameter foldr_spec : ∀ {X : Type} f (sd : X) `{Ok m},
            foldr f m sd = fold_right (unc f) sd (elements m).

  Parameter filter_spec : ∀ `{Ok m}, compatb P →
           (MapsTo x y (filter P m) ↔ MapsTo x y m ∧ P x y = true).

  Parameter partition_spec : let (x,y) := partition P m in compatb P →
            x [=] filter P m ∧ y [=] filter nP m.
  Parameter partition_spec1 : compatb P → fst (partition P m) [=] filter  P m.
  Parameter partition_spec2 : compatb P → snd (partition P m) [=] filter nP m.

  Variable f  :       val → val'.
  Variable f' : key → val → val'.
  Parameter map_spec1 : ∀ `{Ok m}, MapsTo x y m → MapsTo x (f y) (map f m).
  Parameter map_spec2 : ∀ `{Ok m}, In x (map f m) → In x m.

  Parameter mapi_spec1 : ∀ `{Ok m}, compatb f' →
                         MapsTo x y m → MapsTo x (f' x y) (mapi f' m).
  Parameter mapi_spec2 : ∀ `{Ok m}, In x (mapi f' m) → In x m.

  Parameter elements_spec1 : ∀ `{Ok m}, InA kvpeq (x,y) (elements m) ↔
                             MapsTo x y m.
  Parameter elements_spec2 : ∀ `{Ok m}, Sorted kvplt (elements m).
  Parameter elements_spec3 : ∀ `{Ok m}, NoDupA kvpeq (elements m).

  Parameter kelements_spec1 : ∀ `{Ok m}, InA keq x (kelements m) ↔ In x m.
  Parameter kelements_spec2 : ∀ `{Ok m}, Sorted klt (kelements m).
  Parameter kelements_spec3 : ∀ `{Ok m}, NoDupA keq (kelements m).

(*  Variable kv1 kv2 : kvp. *)
  Parameter choose_spec1 : ∀ `{Ok m}, choose m = Some (x,y) → MapsTo x y m.
  Parameter choose_spec2 : ∀ `{Ok m}, choose m = None → Empty m.
(*  Parameter choose_spec3 : ∀ `{Ok m, Ok m2}, choose m = Some kv1 →
                           choose m2 = Some kv2 → m [=] m2 → kvpeq kv1 kv2. *)

  Parameter min_elt_spec1 : ∀ `{Ok m}, min_elt m = Some (x,y) → MapsTo x y m.
  Parameter min_elt_spec2 : ∀ `{Ok m}, min_elt m = Some (x,y) →
                                ∀ a, In a m → ¬klt a x.
  Parameter min_elt_spec3 : ∀ `{Ok m}, min_elt m = None → Empty m.

  Parameter max_elt_spec1 : ∀ `{Ok m}, max_elt m = Some (x,y) → MapsTo x y m.
  Parameter max_elt_spec2 : ∀ `{Ok m}, max_elt m = Some (x,y) →
                                ∀ a, In a m → ¬klt x a.
  Parameter max_elt_spec3 : ∀ `{Ok m}, max_elt m = None → Empty m.

 End Specs.

End RawMaps.

(***  Functor to bring well-formed specification to vanilla specification  ***)
Module Raw2Maps (K:OrderedType)(M:RawMaps K) <: Maps K.
Notation key := K.t.
Notation keq := K.eq.				Notation klt := K.lt.

  (** We avoid creating induction principles for the Record *)
  Local Unset Elimination Schemes.
  Local Unset Case Analysis Schemes.

  Record t_ (typ : Type) := Mkt {v :> M.map_of typ ; is_ok : M.Ok v}.
  Definition map_of := t_.
  Arguments Mkt {typ} v {is_ok}.
  Arguments v {typ} t.
  Hint Resolve is_ok : typeclass_instances.

Section Preds1.
  Context {val val':Type}.
  Notation wm := (map_of val). (* well formed map of val *)

  Definition MapsTo x y (m:wm) := M.MapsTo x y m.(v).
  Instance Mt_compat : Proper (K.eq==>Logic.eq==>Logic.eq==>iff) MapsTo.
  Proof with auto.
    cbv; intros. apply M.Mt_compat... rewrite H1...
  Qed.

  Definition In x (m:wm) := M.In x m.(v).

End Preds1.
Section Preds2.
  Context {val val':Type}.
  Notation wm := (map_of val). (* well formed map of val *)
  Notation w' := (map_of val').
  Notation kvp := (prod key val).

  Definition Empty       (m:wm)     := M.Empty m.
  Definition Equal       (m1 m2:wm) := M.Equal m1 m2.
  Definition Restriction (m1 m2:wm) := M.Restriction m1 m2.
  Definition SameKeys    (m1 m2:w') := M.SameKeys m1 m2.
  Definition Subset   (m:wm)(m':w') := M.Subset m m'.
  Definition For_all (P:_→_→Prop) (m:wm) := M.For_all P m.
  Definition Exists  (P:_→_→Prop) (m:wm) := M.Exists P m.
  Definition Equivb cmp (m:wm) (m':w')  := M.Equivb cmp m m'.
  Definition Kvpeq := M.Kvpeq val.
  Definition Kvplt := M.Kvplt val.
  Definition Pkeq := M.Pkeq val.

  Definition mkeq : relation (list key) := M.mkeq.
  Instance mkeq_equiv : Equivalence mkeq.
  Proof.
    generalize M.mkeq_equiv.
    unfold mkeq. firstorder.
  Qed.

  Definition mklt : relation (list key) := M.mklt.
  Instance mklt_strorder: StrictOrder mklt.
  Proof.
    generalize M.mklt_strorder.
    unfold mklt. firstorder.
  Qed.

(*
  Definition Restriction (m1 m2:wm) := ∀ k v, MapsTo k v m1 → MapsTo k v m2.
  Definition SameKeys (m:wm)(m':w'):= ∀ k  , In k m ↔ In k m'.
  Definition Subset   (m:wm)(m':w'):= ∀ k  , In k m → In k m'.
  Definition For_all (P:_→_→Prop) (m:wm) := ∀ k v, MapsTo k v m → P k v.
  Definition Exists  (P:_→_→Prop) (m:wm) := ∃ k v, MapsTo k v m ∧ P k v.
  Definition Equivb cmp (m:wm) (m':w')  := (∀x, In x m ↔ In x m') ∧
  (∀x (v:val) (v':val'), MapsTo x v m → MapsTo x v' m' → cmp v v' = true).
  Definition Kvp_eq := @M.Kvp_eq val.
  Definition Kvp_lt := @M.Kvp_lt val.
*)

  Definition empty : wm               := Mkt M.empty.
  Definition singleton x y : wm       := Mkt (M.singleton x y).
  Definition add x y m : wm           := Mkt (M.add x y m.(v)).
  Definition is_empty (m:wm)          := M.is_empty m.(v).
  Definition mem x (m:wm)             := M.mem x m.(v).
  Definition cardinal (m:wm)          := M.cardinal m.(v).
  Definition update x y m : wm        := Mkt (M.update x y m.(v)).
  Definition remove x m : wm          := Mkt (M.remove x m.(v)).
  Definition fromList l : wm          := Mkt (M.fromList l).
  Definition find x (m:wm)            := M.find x m.(v).
  Definition subset (m:wm) (m':w')    := M.subset m.(v) m'.(v).
  Definition equal cmp (m:wm) (m2:w') := M.equal cmp m.(v) m2.(v).
  Definition compare (m:wm) (m':w')   := M.compare m.(v) m'.(v).
  Definition for_all P (m:wm)         := M.for_all P m.(v).
  Definition exists_ P (m:wm)         := M.exists_ P m.(v).
  Definition union (m m2:wm)          := Mkt (M.union m.(v) m2.(v)).
  Definition inter sl (m m2:wm)       := Mkt (M.inter sl m.(v) m2.(v)).
  Definition diff (m m2:wm)           := Mkt (M.diff m.(v) m2.(v)).
  Definition foldl {A} f m sd         := @M.foldl val A f m.(v) sd.
  Definition foldr {A} f m sd         := @M.foldr val A f m.(v) sd.
  Definition filter P (m:wm)          := Mkt (M.filter P m.(v)).
  Definition partition P (m:wm)       := let x := M.partition P m.(v) in
                                        (Mkt (fst x), Mkt (snd x)).
  Definition map  (f:val→val')     m  := Mkt (M.map  f m.(v)).
  Definition mapi (f:key→val→val') m  := Mkt (M.mapi f m.(v)).
  Definition elements (m:wm)          := M.elements m.(v).
  Definition kelements (m:wm)         := M.kelements m.(v).
  Definition choose (m:wm)            := M.choose m.(v).
  Definition min_elt (m:wm)           := M.min_elt m.(v).
  Definition max_elt (m:wm)           := M.max_elt m.(v).

End Preds2.

Section Vals.
 Context {val val':Type}.
 Notation mv := (map_of val).
 Notation mv' := (map_of val').
 Notation kvp := (prod key val).

 Variable x a     : key.
 Variable y b     : val.
 Variable m m1 m2 : mv.
 Variable kv1 kv2 : kvp.
 Variable m'      : mv'.
 Variable P       : key → val → bool.
 Variable lst     : list kvp.
 Variable cmp     : val → val' → bool.
 Variable sl      : key → val → val → val.
 Variable f       :       val → val'.
 Variable f'      : key → val → val'.
 Notation "s [=] t"   := (Equal s t)       (at level 70, no associativity).
 Notation "s [|<=] t" := (Restriction s t) (at level 70, no associativity).
 Notation "s [<=] t"  := (Subset s t)      (at level 70, no associativity).
 Notation compatb := (Proper (keq==>Logic.eq==>Logic.eq)) (only parsing).
 Notation compatbb := (Proper (keq==>Logic.eq==>Logic.eq==>Logic.eq)).

Lemma MapsTo_spec1 : keq a x → MapsTo a y m → MapsTo x y m.
Proof. refine (@M.MapsTo_spec1 _ _ _ _ _ _). Qed.
Lemma MapsTo_spec2 : MapsTo x b m → MapsTo x y m → b = y.
Proof. refine (@M.MapsTo_spec2 _ _ _ _ _ _). Qed.
Lemma empty_spec : Empty (@empty val).
Proof. refine M.empty_spec. Qed.
Lemma add_spec1 : MapsTo x y (add x y m).
Proof. refine (@M.add_spec1 _ _ _ _ _). Qed.
Lemma add_spec2 : ¬keq a x → (MapsTo a b (add x y m) ↔ MapsTo a b m).
Proof. refine (@M.add_spec2 _ _ _ _ _ _ _). Qed.
Lemma singleton_spec : MapsTo a b (singleton x y) ↔ Kvpeq (a,b)(x,y).
Proof. refine (@M.singleton_spec _ _ _ _ _). Qed.
Lemma update_spec1 : In x m → MapsTo x y (update x y m).
Proof. refine (@M.update_spec1 _ _ _ _ _). Qed.
Lemma update_spec2 : ¬In x m → (update x y m) [=] m.
Proof. refine (@M.update_spec2 _ _ _ _ _). Qed.
Lemma update_spec3 : ¬keq a x → (MapsTo a b (update x y m) ↔ MapsTo a b m).
Proof. refine (@M.update_spec3 _ _ _ _ _ _ _). Qed.
Lemma remove_spec1 : keq a x → ¬In a (remove x m).
Proof. refine (@M.remove_spec1 _ _ _ _ _). Qed.
Lemma remove_spec2 : ¬keq a x → MapsTo a b m → MapsTo a b (remove x m).
Proof. refine (@M.remove_spec2 _ _ _ _ _ _). Qed.
Lemma remove_spec3 : MapsTo a b (remove x m) → MapsTo a b m.
Proof. refine (@M.remove_spec3 _ _ _ _ _ _). Qed. (*
Lemma fromList_spec1 : In x (fromList lst) ↔ ∃ y, InA pkeq (x,y) lst.
Proof. refine (@M.fromList_spec1 _ _ _). Qed. *)
Lemma fromList_spec2 : MapsTo x y (fromList lst) → InA Kvpeq (x,y) lst.
Proof. refine (@M.fromList_spec2 _ _ _ _). Qed.
Lemma fromList_spec3 : NoDupA Pkeq lst → InA Kvpeq (x,y) lst →
                       MapsTo x y (fromList lst).
Proof. refine (@M.fromList_spec3 _ _ _ _). Qed.
Lemma is_empty_spec : is_empty m = true ↔ Empty m.
Proof. refine (@M.is_empty_spec _ _ _). Qed.
Lemma mem_spec : mem x m = true ↔ In x m.
Proof. refine (@M.mem_spec _ _ _ _). Qed.
Lemma cardinal_spec : cardinal m = length (elements m).
Proof. refine (@M.cardinal_spec _ _ _). Qed.
Lemma find_spec : find x m = Some y ↔ MapsTo x y m.
Proof. refine (@M.find_spec _ _ _ _ _). Qed.
Lemma subset_spec : subset (m:mv) (m':mv') = true ↔ m [<=] m'.
Proof. refine (@M.subset_spec _ _ _ _ _ _). Qed. (*
Lemma equiv_spec : equiv cmp m m' = true ↔ Equivb cmp m m'.
Proof. refine (@M.equiv_spec _ _ _ _ _). Qed. *)
Lemma compare_spec : CompSpec mkeq mklt
                     (kelements m) (kelements m') (compare m m').
Proof. refine (@M.compare_spec _ _ _ _ _ _). Qed.
  Notation P' := (λ x y, P x y = true).
Lemma for_all_spec : compatb P → (for_all P m = true ↔ For_all P' m).
Proof. refine (@M.for_all_spec val _ _ _). Qed.
Lemma exists__spec : compatb P → (exists_ P m = true ↔ Exists  P' m).
Proof. refine (@M.exists__spec val _ _ _). Qed.
Lemma union_spec1 : MapsTo x y (union m m2) → MapsTo x y m ∨ MapsTo x y m2.
Proof. refine (@M.union_spec1 _ _ _ _ _ _ _). Qed.
Lemma union_spec2 : MapsTo x y m ∨ (¬In x m ∧ MapsTo x y m2) →
                    MapsTo x y (union m m2).
Proof. refine (@M.union_spec2 _ _ _ _ _ _ _). Qed.
Lemma inter_spec : compatbb sl →
                 ((∃ y b, MapsTo x (sl x y b) (inter sl m m2)) ↔
                   In x m ∧ In x m2).
Proof. refine (@M.inter_spec _ _ _ _ _ _ _). Qed.
Lemma inter_spec1 : MapsTo x (sl x y b) (inter sl m m2) →
                    In x m ∧ In x m2.
Proof. refine (@M.inter_spec1 _ _ _ _ _ _ _ _ _). Qed.
Lemma inter_spec2 : compatbb sl →
                    MapsTo x y m ∧ MapsTo x b m2 →
                    MapsTo x (sl x y b) (inter sl m m2).
Proof. refine (@M.inter_spec2 _ _ _ _ _ _ _ _ _). Qed.
Lemma diff_spec : MapsTo x y (diff m m2) ↔ MapsTo x y m ∧ ¬In x m2.
Proof. refine (@M.diff_spec _ _ _ _ _ _ _). Qed.
  Notation func := (compose flip prod_curry).
Lemma foldl_spec : ∀ {X : Type} f (sd : X),
  foldl f m sd = fold_left (func f) (elements m) sd.
Proof. intros. refine (@M.foldl_spec _ _ _ _ _ _). Qed.
  Notation unc := prod_curry.
Lemma foldr_spec : ∀ {X : Type} f (sd : X),
  foldr f m sd = fold_right (unc f) sd (elements m).
Proof. intros. refine (@M.foldr_spec _ _ _ _ _ _). Qed.
Lemma filter_spec : compatb P →
  (MapsTo x y (filter P m) ↔ MapsTo x y m ∧ P x y = true).
Proof. refine (@M.filter_spec _ _ _ _ _ _). Qed.
  Notation nP := (λ x y, negb (P x y)).
Lemma partition_spec1 : compatb P → fst (partition P m) [=] filter P m.
Proof. refine (@M.partition_spec1 _ _ _). Qed.
Lemma partition_spec2 : compatb P → snd (partition P m) [=] filter nP m.
Proof. refine (@M.partition_spec2 _ _ _). Qed.
Lemma partition_spec : let (x,y) := partition P m in compatb P →
  x [=] filter P m ∧ y [=] filter nP m.
Proof. intro H. generalize (partition_spec1 H),
(partition_spec2 H) ; simpl; intros. split; auto. Qed.
Lemma map_spec1 : MapsTo x y m → MapsTo x (f y) (map f m).
Proof. refine (@M.map_spec1 _ _ _ _ _ _ _). Qed.
Lemma map_spec2 : In x (map f m) → In x m.
Proof. refine (@M.map_spec2 val val' _ _ _ _). Qed.
Lemma mapi_spec1 : compatb f' → MapsTo x y m → MapsTo x (f' x y) (mapi f' m).
Proof. refine (@M.mapi_spec1 val val' _ _ _ _ _). Qed.
Lemma mapi_spec2 : In x (mapi f' m) → In x m.
Proof. refine (@M.mapi_spec2 val val' _ _ _ _). Qed.
Lemma elements_spec1 : InA Kvpeq (x,y) (elements m) ↔ MapsTo x y m.
Proof. refine (@M.elements_spec1 _ _ _ _ _). Qed.
Lemma elements_spec2 : Sorted Kvplt (elements m).
Proof. refine (@M.elements_spec2 _ _ _). Qed.
Lemma elements_spec3 : NoDupA Kvpeq (elements m).
Proof. refine (@M.elements_spec3 _ _ _). Qed.
Lemma kelements_spec1 : InA keq x (kelements m) ↔ In x m.
Proof. refine (@M.kelements_spec1 _ _ _ _). Qed.
Lemma kelements_spec2 : Sorted klt (kelements m).
Proof. refine (@M.kelements_spec2 _ _ _). Qed.
Lemma kelements_spec3 : NoDupA keq (kelements m).
Proof. refine (@M.kelements_spec3 _ _ _). Qed.
Lemma choose_spec1 : choose m = Some (x,y) → MapsTo x y m.
Proof. refine (@M.choose_spec1 _ _ _ _ _). Qed.
Lemma choose_spec2 : choose m = None → Empty m.
Proof. refine (@M.choose_spec2 _ _ _). Qed. (*
Lemma choose_spec3 : choose m = Some kv1 → choose m2 = Some kv2 →
m [=] m2 → Kvp_eq kv1 kv2.
Proof. refine (@M.choose_spec3 _ _ _ _ _ _ _). Qed. *)
Lemma min_elt_spec1 : min_elt m = Some (x,y) → MapsTo x y m.
Proof. refine (@M.min_elt_spec1 _ _ _ _ _). Qed.
Lemma min_elt_spec2 : min_elt m = Some (x,y) → ∀ a, In a m → ¬klt a x.
Proof. refine (@M.min_elt_spec2 _ _ _ _ _). Qed.
Lemma min_elt_spec3 : min_elt m = None → Empty m.
Proof. refine (@M.min_elt_spec3 _ _ _). Qed.
Lemma max_elt_spec1 : max_elt m = Some (x,y) → MapsTo x y m.
Proof. refine (@M.max_elt_spec1 _ _ _ _ _). Qed.
Lemma max_elt_spec2 : max_elt m = Some (x,y) → ∀ a, In a m → ¬klt x a.
Proof. refine (@M.max_elt_spec2 _ _ _ _ _). Qed.
Lemma max_elt_spec3 : max_elt m = None → Empty m.
Proof. refine (@M.max_elt_spec3 _ _ _). Qed.

  End Vals.

End Raw2Maps.

Module KvpRelations (K:OrderedType).
  Include Kvp K.
(*  Notation key := K.t.
  Notation kvp := (prod key val).
*)
  Instance Kvpeq_compat (val:Type) :
  Proper ((Kvpeq val)==>(Kvpeq val)==>iff) (Kvplt val).
  Proof with auto.
    intros (?,?) (?,?) (A,?) (?,?)
    (?,?) (B,?). split; cbv in *;
    rewrite A,B...
  Qed.

  Instance Pkeq_compat (val:Type) :
  Proper ((Pkeq val)==>(Pkeq val)==> iff) (Kvplt val).
  Proof with auto.
  unfold Kvplt. intros (a,w) (b,x) H (c,y) (d,z) H0;
  red in H, H0; simpl in *. rewrite H, H0; split...
  Qed.

  Instance Kvpeq_refl (val:Type) : Reflexive (Kvpeq val).
  Proof with auto. split... reflexivity... Qed.
  Hint Immediate Kvpeq_refl.

  Instance Kvpeq_symm (val:Type) : Symmetric (Kvpeq val).
  Proof. intros x y (H,H0). split; auto.
  symmetry; auto. Qed. Hint Immediate Kvpeq_symm.

  Instance Kvpeq_trans (val:Type) : Transitive (Kvpeq val).
  Proof.
    intros x y z (H,H0) (H1,H2). split;
    [transitivity (fst y) |
     transitivity (snd y) ]; auto.
  Qed. Hint Resolve Kvpeq_trans.

  Instance Kvpeq_equiv (val:Type) : Equivalence (Kvpeq val).
  Proof. split; auto. Qed.

  Instance Pkeq_refl (val:Type) : Reflexive (Pkeq val).
  Proof with auto. intros (x,y). red. reflexivity...
  Qed. Hint Immediate Pkeq_refl.

  Instance Pkeq_symm (val:Type) : Symmetric (Pkeq val).
  Proof. unfold Pkeq. intros x y H.
  symmetry; auto. Qed. Hint Immediate Pkeq_symm.

  Instance Pkeq_trans (val:Type) : Transitive (Pkeq val).
  Proof.
    unfold Pkeq. intros x y z H H1.
    transitivity (fst y); auto.
  Qed. Hint Resolve Pkeq_trans.

  Instance Pkeq_equiv (val:Type) : Equivalence (Pkeq val).
  Proof. split; auto. Qed.

  Instance Kvplt_irrefl (val:Type) : Irreflexive (Kvplt val).
  Proof with auto.
    intros (x,y) H.
    apply (StrictOrder_Irreflexive x)...
  Qed. Hint Resolve Kvplt_irrefl.

  Instance Kvplt_trans (val:Type) : Transitive (Kvplt val).
  Proof.
    intros (?,?) (x,?) (?,?); cbv.
    transitivity x; auto.
  Qed. Hint Resolve Kvplt_trans.

  Instance Kvplt_strord (val:Type) : StrictOrder (Kvplt val).
  Proof. split; auto. Qed.

Hint Immediate Kvpeq_equiv Pkeq_equiv Kvplt_strord.
(*
  End Vals.

Hint Immediate Kvpeq_refl Kvpeq_symm
Kvpeq_trans Kvpeq_equiv Pkeq_refl
Pkeq_symm Pkeq_trans Pkeq_equiv
Kvplt_irrefl Kvplt_trans Kvplt_strord.
*)
End KvpRelations.

Module MakeListOrdering (O:OrderedType).
 Module MO:=OrderedTypeFacts O.
 Local Notation key := O.t.
 Local Notation keq := O.eq.
 Local Notation klt := O.lt.
 Local Notation t := (list key).
 Local Notation In := (InA keq).

(*
Definition eq m m' := ∀ x:key, In x m ↔ In x m'.
*)
Definition eq := eqlistA keq.
Hint Unfold eq.
Hint Constructors eqlistA.

Instance eq_equiv : Equivalence eq.
Proof with auto.
  split.
  - intros x. reflexivity.
  - intros x y H. symmetry...
  - intros x y z H H'. transitivity y...
Qed.

Inductive lt_list : t → t → Prop :=
  | lt_nil : ∀ x s, lt_list nil (x :: s)
  | lt_cons_lt : ∀ x y s s', klt x y → lt_list (x :: s) (y :: s')
  | lt_cons_eq : ∀ x y s s', keq x y → lt_list s s' →
      lt_list (x :: s) (y :: s').
Hint Constructors lt_list.

Definition lt := lt_list.
Hint Unfold lt.

Instance lt_strorder : StrictOrder lt.
Proof with auto.
  split.
  - assert (∀ s s', s=s' → ¬lt s s').
    { intros x y H. induction 1; inversion H;
      subst... apply (MO.lt_irrefl H0)... }
    intro s. apply H...
  - intros x y z H. revert z. elim H; intros.
    + inversion_clear H0...
    + inversion_clear H1; constructor 2.
      * transitivity y0...
      * rewrite <- H2...
    + inversion_clear H3.
      * constructor 2. rewrite H0...
      * unfold lt in H2. constructor 3...
        rewrite H0...
Qed.

Instance lt_compat' :
  Proper (eq==>eq==>iff) lt.
Proof with auto.
  apply proper_sym_impl_iff_2; auto with *.
  intros a b E1 x y E2 H.
  revert b E1 y E2. induction H; intros;
  inversion_clear E1; inversion_clear E2...
  - constructor 2. MO.order.
  - constructor 3; [|apply IHlt_list]...
    transitivity y; [transitivity x;
   [symmetry|]|]...
Qed.

Lemma eq_cons l1 l2 x y :
 keq x y → eq l1 l2 → eq (x :: l1) (y :: l2).
Proof.
  unfold eq; intros Exy E12.
  constructor 2;[MO.order|auto].
Qed.
Hint Resolve eq_cons.

Lemma cons_CompSpec : forall c x1 x2 l1 l2, keq x1 x2 →
 CompSpec eq lt l1 l2 c → CompSpec eq lt (x1::l1) (x2::l2) c.
Proof.
  destruct c; simpl; inversion_clear 2; auto with relations.
Qed.

End MakeListOrdering.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(** printing [!] %\ensuremath{\hat{\ }}% #^# *)
(** printing {!} %\ensuremath{\hat{\ }}% #^# *)

Require Export CoRN.transc.Exponential.

Opaque Expon.

(**
* Arbitrary Real Powers

** Powers of Real Numbers

We now define
$x^y=e^{y\times\log(x)}$#xy=ey*log(x)#, whenever
[x [>] 0], inspired by the rules for manipulating these expressions.
*)

Definition power x y (Hx : [0] [<] x) := Exp (y[*]Log x Hx).

Notation "x [!] y [//] Hy" := (power x y Hy) (at level 20).

(**
This definition yields a well defined, strongly extensional function
which extends the algebraic exponentiation to an integer power and
still has all the good properties of that operation; when [x [=] e] it
coincides with the exponential function.
*)

Lemma power_wd : forall x x' y y' Hx Hx', x [=] x' -> y [=] y' -> x[!]y[//]Hx [=] x'[!]y'[//]Hx'.
Proof.
 intros.
 unfold power in |- *; algebra.
Qed.

Lemma power_strext : forall x x' y y' Hx Hx', x[!]y[//]Hx [#] x'[!]y'[//]Hx' -> x [#] x' or y [#] y'.
Proof.
 intros.
 cut (Log x Hx [#] Log x' Hx' or y [#] y'). intro H0.
  elim H0; intro H1; [ left | right ]; auto; exact (Log_strext _ _ _ _ H1).
 apply bin_op_strext_unfolded with (cr_mult (c:=IR)).
 astepl (y[*]Log x Hx); astepr (y'[*]Log x' Hx').
 apply Exp_strext; auto.
Qed.

Lemma power_plus : forall x y z Hx, x[!]y[+]z[//]Hx [=] x[!]y[//]Hx[*]x[!]z[//]Hx.
Proof.
 intros.
 unfold power in |- *.
 Step_final (Exp (y[*]Log x Hx[+]z[*]Log x Hx)).
Qed.

Lemma power_inv : forall x y Hx Hxy, x[!] [--]y[//]Hx [=] ([1][/] x[!]y[//]Hx[//]Hxy).
Proof.
 intros; unfold power in |- *.
 rstepr ([1][/] _[//]Exp_ap_zero (y[*]Log x Hx)).
 Step_final (Exp [--] (y[*]Log x Hx)).
Qed.

#[global]
Hint Resolve power_wd power_plus power_inv: algebra.

Lemma power_minus : forall x y z Hx Hxz, x[!]y[-]z[//]Hx [=] (x[!]y[//]Hx[/] x[!]z[//]Hx[//]Hxz).
Proof.
 intros.
 unfold cg_minus in |- *.
 astepl (x[!]y[//]Hx[*]x[!][--]z[//]Hx).
 rstepr (x[!]y[//]Hx[*] ([1][/] _[//]Hxz)).
 algebra.
Qed.

Lemma power_nat : forall x n Hx, x[!]nring n[//]Hx [=] x[^]n.
Proof.
 intros; unfold power in |- *.
 induction  n as [| n Hrecn].
  simpl in |- *; astepr (Exp [0]); simpl in |- *; algebra.
 simpl in |- *.
 astepr (Exp (nring n[*]Log x Hx) [*]Exp (Log x Hx)).
 astepr (Exp (nring n[*]Log x Hx[+]Log x Hx)).
 simpl in |- *; rational.
Qed.

#[global]
Hint Resolve power_minus power_nat: algebra.

Lemma power_zero : forall (x : IR) Hx, x[!][0][//]Hx [=] [1].
Proof.
 intros.
 astepl (x[!]nring 0[//]Hx).
 Step_final (x[^]0).
Qed.

Lemma power_one : forall (x : IR) Hx, x[!][1][//]Hx [=] x.
Proof.
 intros.
 astepr (x[^]1).
 astepr (x[!]nring 1[//]Hx).
 simpl in |- *; algebra.
Qed.

Lemma one_power : forall (x : IR) H, [1][!]x[//]H [=] [1].
Proof.
 intros x H.
 unfold power.
 astepl  (Exp (x[*][0])).
 rstepl (Exp ([0])).
 algebra.
Qed.

#[global]
Hint Resolve power_zero power_one one_power: algebra.

Opaque nexp_op.

Lemma power_int : forall x z Hx Hx', x[!]zring z[//]Hx [=] (x[//]Hx') [^^] (z).
Proof.
 intros; induction  z as [| p| p].
   simpl in |- *.
   Step_final (x[!][0][//]Hx).
  simpl in |- *.
  Step_final (x[!]nring (nat_of_P p) [//]Hx).
 simpl in |- *.
 astepl (x[!][--] (nring (nat_of_P p)) [//]Hx).
 astepl ([1][/] x[!]nring (nat_of_P p) [//]Hx[//]Exp_ap_zero _).
 Step_final ([1][/] x[^]nat_of_P p[//]nexp_resp_ap_zero _ Hx').
Qed.

#[global]
Hint Resolve power_int: algebra.

Lemma Exp_power : forall (x : IR) He, E[!]x[//]He [=] Exp x.
Proof.
 intros; unfold power in |- *.
 Step_final (Exp (x[*][1])).
Qed.

Lemma mult_power : forall x y z Hx Hy Hxy, (x[*]y) [!]z[//]Hxy [=] x[!]z[//]Hx[*]y[!]z[//]Hy.
Proof.
 intros; unfold power in |- *.
 astepr (Exp (z[*]Log _ Hx[+]z[*]Log _ Hy)).
 Step_final (Exp (z[*] (Log _ Hx[+]Log _ Hy))).
Qed.

Lemma recip_power : forall x y Hx Hx' Hx'' Hxy, ([1][/] x[//]Hx') [!]y[//]Hx'' [=] ([1][/] x[!]y[//]Hx[//]Hxy).
Proof.
 intros; unfold power in |- *.
 rstepr ([1][/] _[//]Exp_ap_zero (y[*]Log x Hx)).
 astepr (Exp [--] (y[*]Log _ Hx)).
 Step_final (Exp (y[*][--] (Log _ Hx))).
Qed.

#[global]
Hint Resolve Exp_power mult_power recip_power: algebra.

Lemma div_power : forall x y z Hx Hy Hy' Hxy Hyz,
 (x[/] y[//]Hy') [!]z[//]Hxy [=] (x[!]z[//]Hx[/] y[!]z[//]Hy[//]Hyz).
Proof.
 intros.
 apply eq_transitive_unfolded with ((x[*] ([1][/] _[//]Hy')) [!]z[//]
   mult_resp_pos _ _ _ Hx (recip_resp_pos _ _ Hy' Hy)).
  apply power_wd; rational.
 rstepr (x[!]z[//]Hx[*] ([1][/] _[//]Hyz)).
 Step_final (x[!]z[//]Hx[*]_[!]z[//]recip_resp_pos _ _ Hy' Hy).
Qed.

#[global]
Hint Resolve div_power: algebra.

Lemma power_ap_zero : forall (x y : IR) Hx, x[!]y[//]Hx [#] [0].
Proof.
 intros; unfold power in |- *.
 apply Exp_ap_zero.
Qed.

Lemma power_mult : forall x y z Hx Hxy, x[!]y[*]z[//]Hx [=] (x[!]y[//]Hx) [!]z[//]Hxy.
Proof.
 intros; unfold power in |- *.
 apply Exp_wd.
 astepl (z[*]y[*]Log x Hx).
 astepl (z[*] (y[*]Log x Hx)).
 algebra.
Qed.

Lemma power_pos : forall (x y : IR) Hx, [0] [<] x[!]y[//]Hx.
Proof.
 intros; unfold power in |- *.
 apply Exp_pos.
Qed.

#[global]
Hint Resolve power_mult: algebra.

Lemma power_recip : forall x q Hx (Hx' : [0] [<=] x) Hq (Hq' : 0 < q),
 x[!][1][/] nring q[//]Hq[//]Hx [=] NRoot Hx' Hq'.
Proof.
 intros.
 apply NRoot_unique.
   apply less_leEq; apply power_pos.
  apply power_pos.
 astepr (x[!][1][//]Hx).
 astepl (_[!]nring q[//]power_pos _ ([1][/] _[//]Hq) Hx).
 Step_final (x[!] ([1][/] _[//]Hq) [*]nring q[//]Hx).
Qed.

#[global]
Hint Resolve power_recip: algebra.

Lemma power_div : forall x p q Hx (Hx' : [0] [<=] x) Hq (Hq' : 0 < q),
 x[!]nring p[/] nring q[//]Hq[//]Hx [=] (NRoot Hx' Hq') [^]p.
Proof.
 intros.
 apply eq_transitive_unfolded with (x[!] ([1][/] _[//]Hq) [*]nring p[//]Hx).
  apply power_wd; rational.
 astepr (NRoot Hx' Hq'[!]nring p[//]NRoot_pos _ Hx' _ Hq' Hx).
 Step_final ((x[!][1][/] _[//]Hq[//]Hx) [!]nring p[//]power_pos _ _ _).
Qed.

#[global]
Hint Resolve power_div: algebra.

Lemma real_power_resp_leEq_rht : forall x y p Hx Hy,
 [0][<=] p -> x[<=]y -> x[!]p[//]Hx [<=] y[!]p[//]Hy.
Proof.
 intros x y p Hp Hx Hy H.
 unfold power.
 apply Exp_resp_leEq.
 apply mult_resp_leEq_lft; try assumption.
 apply Log_resp_leEq.
 assumption.
Qed.

Lemma real_power_resp_less_rht : forall x y p Hx Hy,
 [0][<] p -> x[<]y -> x[!]p[//]Hx [<] y[!]p[//]Hy.
Proof.
 intros x y p Hp Hx Hy H.
 unfold power.
 apply Exp_resp_less.
 apply mult_resp_less_lft; try assumption.
 apply Log_resp_less.
 assumption.
Qed.

Lemma real_power_resp_leEq_lft : forall x p q Hx Hx',
 [1][<=]x -> p[<=]q -> x[!]p[//]Hx [<=] x[!]q[//]Hx'.
Proof.
 intros x p q Hx Hx' Hx0 H.
 unfold power.
 apply Exp_resp_leEq.
 stepr (q[*]Log x Hx); [| now csetoid_rewrite (Log_wd x x Hx Hx' (eq_reflexive IR x)); apply eq_reflexive].
 apply mult_resp_leEq_rht; try assumption.
 apply Zero_leEq_Log.
 assumption.
Qed.

Lemma real_power_resp_less_lft : forall x p q Hx Hx',
 [1][<]x -> p[<]q -> x[!]p[//]Hx [<] x[!]q[//]Hx'.
Proof.
 intros x p q Hx Hx' Hx0 H.
 unfold power.
 apply Exp_resp_less.
 stepr (q[*]Log x Hx); [| now csetoid_rewrite (Log_wd x x Hx Hx' (eq_reflexive IR x)); apply eq_reflexive].
 apply mult_resp_less; try assumption.
 apply Zero_less_Log.
 assumption.
Qed.

Lemma real_power_resp_leEq_both : forall x y p q Hx Hy',
 [1][<=]x -> [0] [<=] p -> x[<=]y -> p[<=]q ->
 x[!]p[//]Hx [<=] y[!]q[//]Hy'.
Proof.
 intros x y p q Hx Hy Hx0 Hp H0 H1.
 apply leEq_transitive with (y[!]p[//]Hy).
  apply real_power_resp_leEq_rht; assumption.
 apply real_power_resp_leEq_lft; try assumption.
 apply leEq_transitive with x; assumption.
Qed.

Lemma real_power_resp_less_both : forall x y p q Hx Hy',
 [1][<]x -> [0] [<] p -> x[<]y -> p[<]q ->
 x[!]p[//]Hx [<] y[!]q[//]Hy'.
Proof.
 intros x y p q Hx Hy Hx0 Hp H0 H1.
 apply less_transitive_unfolded with (y[!]p[//]Hy).
  apply real_power_resp_less_rht; assumption.
 apply real_power_resp_less_lft; try assumption.
 apply less_transitive_unfolded with x; assumption.
Qed.

Section Power_Function.

(**
** Power Function

This operation on real numbers gives birth to an analogous operation
on partial functions which preserves continuity.

%\begin{convention}% Let [F, G : PartIR].
%\end{convention}%
*)

Variable J : interval.
Variables F G : PartIR.

Definition FPower := Expon[o]G{*} (Logarithm[o]F).

Lemma FPower_domain : forall x, Dom F x -> Dom G x ->
 (forall Hx, [0] [<] F x Hx) -> Dom FPower x.
Proof.
 intros x H H0 H1.
 simpl in |- *.
 cut (Conj (Dom G) (fun y : IR => {Hx : _ | [0] [<] Part F y Hx}) x). intro H2.
  exists H2; split.
 split; auto.
 exists H; auto.
Qed.

Lemma Continuous_power : positive_fun J F ->
 Continuous J F -> Continuous J G -> Continuous J FPower.
Proof.
 intros H H0 H1.
 unfold FPower in |- *.
 apply Continuous_comp with realline.
   3: apply Continuous_Exp.
  2: apply Continuous_mult; [ apply H1 | apply Continuous_comp with (openl [0]); auto ].
   3: apply Continuous_Log.
  apply maps_compacts_into_strict_imp_weak; apply Continuous_imp_maps_compacts_into.
  apply Continuous_mult; auto.
  apply Continuous_comp with (openl [0]); auto.
   2: apply Continuous_Log.
  apply maps_compacts_into_strict_imp_weak; apply positive_imp_maps_compacts_into; auto.
 apply maps_compacts_into_strict_imp_weak; apply positive_imp_maps_compacts_into; auto.
Qed.

End Power_Function.

Notation "F {!} G" := (FPower F G) (at level 20).

Section More_on_Power_Function.

Opaque Expon Logarithm.

(** From global continuity we can obviously get local continuity: *)

Lemma continuous_I_power : forall F G a b Hab, Continuous_I Hab F ->
 Continuous_I Hab G -> positive_fun (compact a b Hab) F -> Continuous_I Hab (F{!}G).
Proof.
 intros.
 apply (Int_Continuous (clcr a b) Hab).
 apply Continuous_power.
   auto.
  apply Continuous_Int with Hab Hab; auto.
 apply Continuous_Int with Hab Hab; auto.
Qed.

(** The rule for differentiation is a must. *)

Lemma Derivative_power : forall (J : interval) pJ F F' G G', positive_fun J F ->
 Derivative J pJ F F' -> Derivative J pJ G G' ->
 Derivative J pJ (F{!}G) (G{*} (F{!} (G{-} [-C-][1]) {*}F') {+}F{!}G{*} (G'{*} (Logarithm[o]F))).
Proof.
 intros J pJ F F' G G' H H0 H1.
 unfold FPower in |- *.
 assert (H2 : Derivative (openl [0]) I Logarithm {1/}FId).
  apply Derivative_Log.
 assert (H3 : Derivative realline I Expon Expon).
  apply Derivative_Exp.
 elim H; intros incF H'.
 elim H'; intros c H4 H5; clear incF H'.
 Derivative_Help.
  apply eq_imp_Feq.
    apply included_FMult.
     apply included_FComp.
      intros x H6.
      repeat split.
       apply (Derivative_imp_inc _ _ _ _ H1); auto.
      simpl in |- *.
      exists (Derivative_imp_inc _ _ _ _ H0 _ H6).
      apply Log_domain; apply less_leEq_trans with c; auto.
     intros; apply Exp_domain.
    intros x H6; simpl in |- *; repeat split.
        apply (Derivative_imp_inc _ _ _ _ H1); auto.
       exists (Derivative_imp_inc _ _ _ _ H0 _ H6).
       repeat split.
       intros; simpl in |- *.
       apply Greater_imp_ap; apply less_leEq_trans with c; auto.
      apply (Derivative_imp_inc' _ _ _ _ H0); auto.
     apply (Derivative_imp_inc' _ _ _ _ H1); auto.
    exists (Derivative_imp_inc _ _ _ _ H0 _ H6).
    intros; apply Log_domain; apply less_leEq_trans with c; auto.
   apply included_FPlus.
    apply included_FMult.
     Included.
    apply included_FMult.
     apply included_FComp.
      apply included_FMult.
       Included.
      apply included_FComp.
       Included.
      intros; apply Log_domain; apply less_leEq_trans with c; auto.
     intros; apply Exp_domain.
    Included.
   apply included_FMult.
    apply included_FComp.
     apply included_FMult.
      Included.
     apply included_FComp.
      Included.
     intros; apply Log_domain; apply less_leEq_trans with c; auto.
    intros; apply Exp_domain.
   apply included_FMult.
    Included.
   apply included_FComp.
    Included.
   intros; apply Log_domain; apply less_leEq_trans with c; auto.
  intros.
  astepl (Part _ _ (ProjIR1 Hx) [*]Part _ _ (ProjIR2 Hx)).
  elim Hx; intros Hx1 Hx2; clear Hx.
  astepl (Part _ _ Hx1[*]Part _ _ Hx2).
  astepl (Part _ _ (ProjT2 Hx1) [*]Part _ _ Hx2).
  elim Hx1; clear Hx1; intros Hx1 Hx3.
  astepl (Part _ (Part _ _ Hx1) Hx3[*]Part _ _ Hx2).
  generalize Hx3; clear Hx3.
  elim Hx1; intros Hx4 Hx5.
  intro; astepl (Part _ (Part _ _ (ProjIR1 (Hx4, Hx5)) [*]
    Part _ _ (ProjIR2 (Hx4, Hx5))) Hx3[*] Part _ _ Hx2).
  cut (Dom Expon (Part _ _ Hx4[*]Part _ _ Hx5)). intro H7.
   2: apply dom_wd with (x := Part _ _ (ProjIR1 (Hx4, Hx5)) [*]
     Part _ _ (ProjIR2 (Hx4, Hx5))); algebra.
  astepl (Part _ (Part _ _ Hx4[*]Part _ _ Hx5) H7[*]Part _ _ Hx2).
  clear Hx3; rename H7 into Hx3.
  astepl (Part _ (Part _ _ Hx4[*]Part _ _ (ProjT2 Hx5)) Hx3[*]Part _ _ Hx2).
  generalize Hx3; clear Hx3.
  elim Hx5; intros Hx6 Hx7.
  intro; astepl (Part _ (Part _ _ Hx4[*]Part _ _ Hx7) Hx3[*]Part _ _ Hx2).
  set (A := Part _ (Part _ _ Hx4[*]Part _ _ Hx7) Hx3) in *.
  astepl (A[*] (Part _ _ (ProjIR1 Hx2) [+]Part _ _ (ProjIR2 Hx2))).
  elim Hx2; intros Hx8 Hx9.
  astepl (A[*] (Part _ _ Hx8[+]Part _ _ Hx9)).
  astepl (A[*] (Part _ _ (ProjIR1 Hx8) [*]Part _ _ (ProjIR2 Hx8) [+]Part _ _ Hx9)).
  elim Hx8; intros Hx10 Hx11.
  astepl (A[*] (Part _ _ Hx10[*]Part _ _ Hx11[+]Part _ _ Hx9)).
  astepl (A[*] (Part _ _ Hx10[*]Part _ _ Hx11[+] Part _ _ (ProjIR1 Hx9) [*]Part _ _ (ProjIR2 Hx9))).
  elim Hx9; intros Hx12 Hx13.
  astepl (A[*] (Part _ _ Hx10[*]Part _ _ Hx11[+]Part _ _ Hx12[*]Part _ _ Hx13)).
  astepl (A[*] (Part _ _ Hx10[*] (Part _ _ (ProjIR1 Hx11) [*]Part _ _ (ProjIR2 Hx11)) [+]
    Part _ _ Hx12[*]Part _ _ Hx13)).
  elim Hx11; intros Hx14 Hx15.
  apply eq_transitive_unfolded with (A[*] (Part _ _ Hx10[*] (Part _ _ Hx14[*]Part _ _ Hx15) [+]
    Part _ _ Hx12[*]Part _ _ Hx13)).
   apply mult_wd; algebra.
  astepl (A[*] (Part _ _ Hx10[*] (Part _ _ Hx14[*]Part _ _ Hx15) [+]
    Part _ _ Hx12[*]Part _ _ (ProjT2 Hx13))).
  elim Hx13; intros Hx16 Hx17.
  astepl (A[*] (Part _ _ Hx10[*] (Part _ _ Hx14[*]Part _ _ Hx15) [+] Part _ _ Hx12[*]Part _ _ Hx17)).
  astepl (A[*] (Part _ _ Hx10[*] (Part _ _ (ProjT2 Hx14) [*]Part _ _ Hx15) [+]
    Part _ _ Hx12[*]Part _ _ Hx17)).
  elim Hx14; intros Hx18 Hx19.
  astepl (A[*] (Part _ _ Hx10[*] (Part _ _ Hx19[*]Part _ _ Hx15) [+] Part _ _ Hx12[*]Part _ _ Hx17)).
  elim Hx19; intros Hx20 Hx21.
  assert (H7 : Dom G x). auto.
   assert (H8 : Dom F x). auto.
   cut ([0] [<] Part _ _ H8). intro H9.
   assert (H10 : Part _ _ H8 [#] [0]). apply Greater_imp_ap; auto.
    assert (H11 : Dom F' x). auto.
    assert (H12 : Dom G' x). auto.
    apply eq_transitive_unfolded with (Exp (Part _ _ H7[*]Log _ H9) [*]
      (Part _ _ H7[*] (([1][/] _[//]H10) [*]Part _ _ H11) [+] Part _ _ H12[*]Log _ H9)).
    unfold A, Log in |- *; simpl in |- *.
    repeat first  [apply mult_wd | apply pfwdef | apply bin_op_wd_unfolded]; try reflexivity.
   clear Hx21 Hx20 Hx19 Hx18 Hx17 Hx16 Hx15 Hx14 Hx13 Hx12 Hx11 Hx10 Hx9 Hx8 A
     Hx3 Hx7 Hx6 Hx5 Hx4 Hx1 Hx2.
   astepr (Part _ _ (ProjIR1 Hx') [+]Part _ _ (ProjIR2 Hx')).
   elim Hx'; clear Hx'; intros Hx1 Hx2.
   astepr (Part _ _ Hx1[+]Part _ _ Hx2).
   astepr (Part _ _ Hx1[+]Part _ _ (ProjIR1 Hx2) [*]Part _ _ (ProjIR2 Hx2)).
   elim Hx2; clear Hx2; intros Hx2 Hx3.
   astepr (Part _ _ Hx1[+]Part _ _ Hx2[*]Part _ _ Hx3).
   astepr (Part _ _ Hx1[+] Part _ _ Hx2[*] (Part _ _ (ProjIR1 Hx3) [*]Part _ _ (ProjIR2 Hx3))).
   elim Hx3; clear Hx3; intros Hx3 Hx4.
   astepr (Part _ _ Hx1[+]Part _ _ Hx2[*] (Part _ _ H12[*]Part _ _ Hx4)); clear Hx3.
   astepr (Part _ _ Hx1[+]Part _ _ Hx2[*] (Part _ _ H12[*]Part _ _ (ProjT2 Hx4))).
   elim Hx4; clear Hx4; intros Hx3 Hx4.
   astepr (Part _ _ Hx1[+]Part _ _ Hx2[*] (Part _ _ H12[*]Part _ _ Hx4)).
   apply eq_transitive_unfolded with (Part _ _ Hx1[+]Part _ _ Hx2[*] (Part _ _ H12[*]Log _ H9)).
    2: unfold Log in |- *; apply bin_op_wd_unfolded; algebra.
   clear Hx3 Hx4.
   astepr (Part _ _ Hx1[+]Part _ _ (ProjT2 Hx2) [*] (Part _ _ H12[*]Log _ H9)).
   elim Hx2; clear Hx2; intros Hx2 Hx3.
   astepr (Part _ _ Hx1[+]Part _ _ Hx3[*] (Part _ _ H12[*]Log _ H9)).
   generalize Hx3; clear Hx3.
   elim Hx2; clear Hx2; intros Hx4 Hx5 Hx3.
   assert (H13 : Dom Expon (Part _ _ Hx4[*]Part _ _ Hx5)). apply Exp_domain.
    astepr (Part _ _ Hx1[+] Part _ (Part _ _ (ProjIR1 (Hx4, Hx5)) [*]
      Part _ _ (ProjIR2 (Hx4, Hx5))) Hx3[*] (Part _ _ H12[*]Log _ H9)).
   apply eq_transitive_unfolded with (Part _ _ Hx1[+]Part _ _ H13[*] (Part _ _ H12[*]Log _ H9)).
    2: apply bin_op_wd_unfolded; algebra.
   generalize H13; clear H13 Hx3.
   elim Hx5; clear Hx5; intros Hx5 Hx6 Hx3.
   astepr (Part _ _ Hx1[+] Part _ (Part _ _ Hx4[*]Part _ _ Hx6) Hx3[*] (Part _ _ H12[*]Log _ H9)).
   apply eq_transitive_unfolded with
     (Part _ _ Hx1[+]Exp (Part _ _ H7[*]Log _ H9) [*] (Part _ _ H12[*]Log _ H9)).
    2: apply bin_op_wd_unfolded; [ algebra | unfold Log in |- *; simpl in |- * ].
    2: apply bin_op_wd_unfolded; algebra.
   eapply eq_transitive_unfolded.
    apply ring_dist_unfolded.
   apply bin_op_wd_unfolded.
    2: apply eq_reflexive_unfolded.
   clear Hx3 Hx6 Hx5 Hx4.
   astepr (Part _ _ (ProjIR1 Hx1) [*]Part _ _ (ProjIR2 Hx1)).
   elim Hx1; clear Hx1; intros Hx1 Hx2.
   astepr (Part _ _ Hx1[*]Part _ _ Hx2).
   astepr (Part _ _ H7[*] (Part _ _ (ProjIR1 Hx2) [*]Part _ _ (ProjIR2 Hx2))).
   elim Hx2; clear Hx2 Hx1; intros Hx1 Hx2.
   astepr (Part _ _ H7[*] (Part _ _ Hx1[*]Part _ _ H11)).
   astepr (Part _ _ H7[*] (Part _ _ (ProjT2 Hx1) [*]Part _ _ H11)).
   elim Hx1; clear Hx1 Hx2; intros Hx1 Hx2.
   astepr (Part _ _ H7[*] (Part _ _ Hx2[*]Part _ _ H11)).
   apply eq_transitive_unfolded with (Part _ _ H7[*] (Exp (Part _ _ Hx1) [*]Part _ _ H11)).
    2: simpl in |- *; algebra.
   clear Hx2.
   apply eq_transitive_unfolded with (Part _ _ H7[*]
     (Exp (Part _ _ (ProjIR1 Hx1) [*]Part _ _ (ProjIR2 Hx1)) [*]Part _ _ H11)).
    2: apply mult_wdr; algebra.
   elim Hx1; clear Hx1; intros Hx1 Hx2.
   apply eq_transitive_unfolded
     with (Part _ _ H7[*] (Exp (Part _ _ Hx1[*]Part _ _ Hx2) [*]Part _ _ H11)).
    2: apply mult_wdr; algebra.
   apply eq_transitive_unfolded
     with (Part _ _ H7[*] (Exp ((Part _ _ H7[-][1]) [*]Log _ H9) [*]Part _ _ H11)).
    2: unfold Log in |- *; simpl in |- *.
    2: apply mult_wdr; apply mult_wd; algebra.
   clear Hx1 Hx2.
   rstepl ((Exp (Part _ _ H7[*]Log _ H9) [/] _[//]H10) [*] (Part _ _ H7[*]Part _ _ H11)).
   rstepr (Exp ((Part _ _ H7[-][1]) [*]Log _ H9) [*] (Part _ _ H7[*]Part _ _ H11)).
   apply mult_wdl.
   apply eq_transitive_unfolded with (Exp (Part _ _ H7[*]Log _ H9[-]Log _ H9)).
    2: apply Exp_wd; rational.
   astepr (Exp (G x H7[*]Log _ H9) [/] _[//]Exp_ap_zero (Log _ H9)).
   algebra.
  Transparent Logarithm.
  astepr (Part _ _ Hx16); auto.
 Opaque Logarithm.
 apply Derivative_comp with realline I; Deriv.
  apply Continuous_imp_maps_compacts_into.
  apply Continuous_mult.
   apply Derivative_imp_Continuous with pJ G'; auto.
  apply Continuous_comp with (openl [0]).
    apply maps_compacts_into_strict_imp_weak; apply positive_imp_maps_compacts_into; auto.
    apply Derivative_imp_Continuous with pJ F'; auto.
   apply Derivative_imp_Continuous with pJ F'; auto.
  apply Continuous_Log.
 apply Derivative_mult.
  auto.
 apply Derivative_comp with (openl [0]) I; Deriv.
 apply positive_imp_maps_compacts_into; auto.
 apply Derivative_imp_Continuous with pJ F'; auto.
Qed.

Lemma Diffble_power : forall (J : interval) pJ F G, positive_fun J F ->
 Diffble J pJ F -> Diffble J pJ G -> Diffble J pJ (F{!}G).
Proof.
 intros J pJ F G H H0 H1.
 set (F1 := Deriv _ _ _ H0) in *.
 set (G1 := Deriv _ _ _ H1) in *.
 eapply Derivative_imp_Diffble.
 apply Derivative_power with (F' := F1) (G' := G1).
   auto.
  unfold F1 in |- *; apply Deriv_lemma.
 unfold G1 in |- *; apply Deriv_lemma.
Qed.

End More_on_Power_Function.

#[global]
Hint Resolve Derivative_power: derivate.


From Paco Require Export paconotation.
From Paco Require Import pacotac_internal paconotation_internal.
Set Implicit Arguments.
Set Primitive Projections.

(** ** Predicates of Arity 1
*)

Section Arg1_def.

Variable T0 : Type.
Variable gf : rel1 T0 -> rel1 T0.
Arguments gf : clear implicits.

Inductive _paco (paco: rel1 T0 -> rel1 T0) ( r: rel1 T0) x0 : Prop :=
| paco_pfold pco
    (LE : pco <1= (paco r \1/ r))
    (SIM: gf pco x0)
.

CoInductive paco r x0 : Prop := paco_go { paco_observe: _paco paco r x0 }.

Definition upaco( r: rel1 T0) := paco r \1/ r.

End Arg1_def.

Arguments paco [ T0 ] gf r x0.
Arguments upaco [ T0 ] gf r x0.
Hint Unfold upaco.

(* Less than or equal - internal use only *)
Notation "p <_paco_1= q" :=
  (forall _paco_x0 (PR: p _paco_x0 : Prop), q _paco_x0 : Prop)
  (at level 50, no associativity).

(* coinduction automation - internal use only *)
Ltac paco_cofix_auto :=
  let CIH := fresh "CIH" in cofix CIH; repeat intro;
  match goal with [H: _ |- _] => apply paco_observe in H; destruct H as [] end; do 2 econstructor;
  try (match goal with [H: _|-_] => apply H end); intros;
  lazymatch goal with [PR: _ |- _] => match goal with [H: _ |- _] => apply H in PR end end;
  repeat match goal with [ H : _ \/ _ |- _] => destruct H end; first [eauto; fail|eauto 10].

Definition monotone T0 (gf: rel1 T0 -> rel1 T0) :=
  forall x0 r r' (IN: gf r x0) (LE: r <1= r'), gf r' x0.

Definition _monotone T0 (gf: rel1 T0 -> rel1 T0) :=
  forall r r'(LE: r <1= r'), gf r <1== gf r'.

Lemma monotone_eq T0 (gf: rel1 T0 -> rel1 T0) :
  monotone gf <-> _monotone gf.
Proof. unfold monotone, _monotone, le1. split; eauto. Qed.

Lemma paco_mon_gen T0 gf gf' r r' x
    (PR: @paco T0 gf r x)
    (LEgf: gf <2= gf')
    (LEr: r <1= r'):
  paco gf' r' x.
Proof.
  revert x PR. cofix CIH.
  intros. apply paco_observe in PR. destruct PR as [].
  do 2 econstructor.
  - intros. specialize (LE x0 PR). destruct LE.
    + left. apply CIH, H.
    + right. apply LEr, H.
  - apply LEgf, SIM.
Qed.

Section Arg1.

Variable T0 : Type.
Variable gf : rel1 T0 -> rel1 T0.
Arguments gf : clear implicits.

Theorem paco_acc: forall
  l r (OBG: forall rr (INC: r <1= rr) (CIH: l <1= rr), l <1= paco gf rr),
  l <1= paco gf r.
Proof.
  intros; assert (SIM: paco gf (r \1/ l) x0) by eauto.
  clear PR; repeat (try left; do 2 paco_revert; paco_cofix_auto).
Qed.

Theorem paco_mon: monotone (paco gf).
Proof. paco_cofix_auto; repeat (left; do 2 paco_revert; paco_cofix_auto). Qed.

Theorem paco_mult_strong: forall r,
  paco gf (upaco gf r) <1= paco gf r.
Proof. paco_cofix_auto; repeat (left; do 2 paco_revert; paco_cofix_auto). Qed.

Corollary paco_mult: forall r,
  paco gf (paco gf r) <1= paco gf r.
Proof. intros; eapply paco_mult_strong, paco_mon; eauto. Qed.

Theorem paco_fold: forall r,
  gf (upaco gf r) <1= paco gf r.
Proof. intros; do 2 econstructor; [ |eauto]; eauto. Qed.

Theorem paco_unfold: forall (MON: monotone gf) r,
  paco gf r <1= gf (upaco gf r).
Proof. unfold monotone; intros; apply paco_observe in PR; destruct PR as []; eauto. Qed.

Theorem _paco_acc: forall
  l r (OBG: forall rr (INC: r <1== rr) (CIH: l <1== rr), l <1== paco gf rr),
  l <1== paco gf r.
Proof. unfold le1. eapply paco_acc. Qed.

Theorem _paco_mon: _monotone (paco gf).
Proof. apply monotone_eq. eapply paco_mon. Qed.

Theorem _paco_mult_strong: forall r,
  paco gf (upaco gf r) <1== paco gf r.
Proof. unfold le1. eapply paco_mult_strong. Qed.

Theorem _paco_fold: forall r,
  gf (upaco gf r) <1== paco gf r.
Proof. unfold le1. eapply paco_fold. Qed.

Theorem _paco_unfold: forall (MON: _monotone gf) r,
  paco gf r <1== gf (upaco gf r).
Proof.
  unfold le1. intro.
  eapply paco_unfold; apply monotone_eq; eauto.
Qed.

End Arg1.

Hint Unfold monotone.
Hint Resolve paco_fold.

Arguments paco_mon_gen        [ T0 ] gf gf' r r' x PR LEgf LEr.
Arguments paco_acc            [ T0 ] gf l r OBG x0 PR.
Arguments paco_mon            [ T0 ] gf x0 r r' IN LE.
Arguments paco_mult_strong    [ T0 ] gf r x0 PR.
Arguments paco_mult           [ T0 ] gf r x0 PR.
Arguments paco_fold           [ T0 ] gf r x0 PR.
Arguments paco_unfold         [ T0 ] gf MON r x0 PR.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(* Notation management revised in December 2002 *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*  PlusQ.v                                                                 *)
(*                                                                          *)
(*  Basic properties of the addition on rational numbers                    *)
(*                                                                          *)
(*                                                                          *)
(*  Samuel Boutin                                                           *)
(*  Coq V5.10                                                               *)
(*  June  1995                                                              *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                               PlusQ.v                                    *)
(****************************************************************************)

Require Import AC.
Require Import HS.
Require Import quotient.
Require Import subset.
Require Import intnumbers.
Require Import rational_defs.

Section plusQ.

Require Import productSyntax.

Open Scope RAT_scope.

Lemma plusQ_sym : forall n m : Q, n + m = m + n.

intro n; pattern n in |- *; apply (Closure_prop Q_typ Q_rel n).
intro x.
intro m; pattern m in |- *; apply (Closure_prop Q_typ Q_rel m).
intro y.
unfold plusQ in |- *.
rewrite (Reduce Q_typ Q_rel (Q -> Q) plusQ_X Compat_plusQ_X x).
rewrite (Reduce Q_typ Q_rel (Q -> Q) plusQ_X Compat_plusQ_X y).
unfold plusQ_X in |- *; simpl in |- *.
repeat rewrite Reduce.
unfold plusQ_XX in |- *.
unfold plusQ_XXX in |- *.
apply (From_R_to_L Q_typ Q_rel).
red in |- *; simpl in |- *.
repeat rewrite Out_In.
repeat rewrite distribZ_l.
AZm.
repeat elim (multZ_sym (y .2)).
ACZa.
Qed.

Lemma plusQ_assoc_l : forall n m p : Q, n + (m + p) = n + m + p.

intro n; pattern n in |- *; apply (Closure_prop Q_typ Q_rel n).
intro x.
intro m; pattern m in |- *; apply (Closure_prop Q_typ Q_rel m).
intro y.
intro p; pattern p in |- *; apply (Closure_prop Q_typ Q_rel p).
intro z.
unfold plusQ in |- *.
rewrite (Reduce Q_typ Q_rel (Q -> Q) plusQ_X Compat_plusQ_X x).
rewrite (Reduce Q_typ Q_rel (Q -> Q) plusQ_X Compat_plusQ_X y).
unfold plusQ_X in |- *; simpl in |- *.
repeat rewrite (Reduce Q_typ Q_rel Q).
unfold plusQ_XX in |- *.
repeat rewrite (Reduce Q_typ Q_rel Q).
rewrite
 (Reduce Q_typ Q_rel (Q -> Q)
    (fun x0 : Q_typ =>
     lift Q_typ Q_rel Q (fun y0 : Q_typ => |(plusQ_XXX x0 y0) |q)
       (Compat_plusQ_XX x0)) Compat_plusQ_X (plusQ_XXX x y))
 .
repeat rewrite (Reduce Q_typ Q_rel Q).
unfold plusQ_XXX in |- *.
apply (From_R_to_L Q_typ Q_rel).
red in |- *; simpl in |- *.
pattern (%- (%+ ((y .2 * z .2)%INT) (plusQ_XXX_prelim y z))) at 1 in |- *.
repeat rewrite Out_In.
repeat rewrite distribZ_l.
AZm.
AZa.
HSZa.
rewrite (multZ_permute (z .2)).
HSZa.
ACZm.
Qed.

Lemma plusQ_assoc_r : forall n m p : Q, n + m + p = n + (m + p).

intros.
apply sym_equal.
apply plusQ_assoc_l.
Qed.

Lemma plusQ_permute : forall n m p : Q, n + (m + p) = m + (n + p).

intros.
rewrite plusQ_assoc_l.
rewrite plusQ_assoc_l.
rewrite (plusQ_sym m n).
reflexivity.
Qed.

Axiom plusQ_plus_l : forall n m p : Q, n + m = n + p -> m = p.

(*
Lemma plusQ_plus_l : forall n m p : Q, n + m = n + p -> m = p.

intro n; pattern n; apply (Closure_prop Q_typ Q_rel n).
intro x.
intro m; pattern m; apply (Closure_prop Q_typ Q_rel m).
intro y.
intro p; pattern p; apply (Closure_prop Q_typ Q_rel p).
intro z.
unfold plusQ.
rewrite -> (Reduce Q_typ Q_rel (Q->Q) plusQ_X Compat_plusQ_X x).
unfold plusQ_X.
repeat rewrite -> Reduce.
unfold plusQ_XX.
repeat rewrite -> Reduce.
unfold plusQ_XXX;simpl.
intro HH.

unfold Q_rel; simpl.
apply (From_R_to_L Q_typ Q_rel).
red;simpl.

(* fail from here *)
apply (simpl_plus_l a2).
apply (simpl_plus_l a1).
rewrite (plus_permute a2).
rewrite plus_assoc_l.
rewrite H'.
ACNa.
apply (From_L_to_R Q_typ Q_rel).
exact HH.
Qed.
*)

End plusQ.