(* subsetconst.v

   Copyright (C) 2017, Cong Sun

   This is an implementation of the subset construction algorithm
   to convert a NFA to a DFA. It is used in our reasearch paper
   when the replacement of action \tau may introduce nondeterministic
   transitions in the result. This implementation is not quite efficient
   yet and need further improvement.

   This program 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 3 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.
*)

Require Export IA.
Require Export NewStates.

Definition subset_construction (a:IA) : IA :=
  let init:= IAutomaton.get_init a in
  let states:=IAutomaton.get_states a in
  let trs:= NewSSet.subset_const
    (NewSSet.add init NewSSet.empty)
    (NewSSet.add init NewSSet.empty)
    (IAutomaton.get_actions a)
    (NewSSet.power_states ( NewSSet.convertSSet2NewSSet states) )
    (TSet.elements (IAutomaton.get_trans a)) (SSet.cardinal states) in
  constr_ia (TSet.getStatesByTrans trs) (init)
  (IAutomaton.get_AI a) (IAutomaton.get_AO a) (IAutomaton.get_AH a) trs.


From trace_program_logic.heap_lang.examples Require Import yesno.
From iris.proofmode Require Import tactics.
From trace_program_logic.program_logic Require Export weakestpre.
From trace_program_logic.fairness Require Import fairness fair_termination fairness_finiteness.
From trace_program_logic.prelude Require Export finitary quantifiers sigma classical_instances.
From trace_program_logic.heap_lang Require Export lang lifting tactics.
From trace_program_logic.heap_lang Require Import notation.

From stdpp Require Import finite.

Section product_of_orders.
  Variables (A B : Type) (leA : relation A) (leB : relation B).
  Context `{HlAtrans: Transitive _ leA}.

  Lemma prod_trans :
     transitive _ leA ->
     transitive _ leB ->
     transitive _ (prod_relation leA leB).
   Proof.
     intros tA tB [x1 y1] [x2 y2] [x3 y3] H.
     inversion H; subst; clear H.
     intros H.
     inversion H; subst; clear H.
     split; eauto.
   Qed.

   Theorem wf_prod :
     well_founded leA ->
     well_founded leB ->
     well_founded (prod_relation leA leB).
   Proof.
     intros wfA wfB [x y]. generalize dependent y.
     induction (wfA x) as [x _ IHx]; clear wfA.
     intros y.
     induction (wfB y) as [y _ IHy]; clear wfB.
     constructor.
     intros [x' y'] H.
     now inversion H; subst; clear H; eauto.
   Qed.

   Theorem wf_prod_strict :
     well_founded (strict leA) ->
     well_founded (strict leB) ->
     well_founded (strict (prod_relation leA leB)).
   Proof.
     intros wfA wfB [x y]. generalize dependent y.
     induction (wfA x) as [x _ IHx]; clear wfA.
     intros y.
     generalize dependent x.
     induction (wfB y) as [y _ IHy]; clear wfB.
     intros x IH.
     constructor.
     intros [x' y'] H.
     inversion H as [[??] [?|?]%Classical_Prop.not_and_or]; subst; clear H; first by apply IH.
     apply IHy; first done. intros ???. eapply IH, strict_transitive_l =>//.
   Qed.

  Global Instance prod_relation_antisym :
    AntiSymm eq leA → AntiSymm eq leB → AntiSymm eq (prod_relation leA leB).
  Proof.
    intros ??[??] [??] [??] [??].
    f_equal; firstorder eauto.
  Qed.

  Global Instance prod_relation_preorder :
    PreOrder leA → PreOrder leB → PreOrder (prod_relation leA leB).
  Proof. firstorder eauto. Qed.

  Global Instance prod_relation_partialorder :
    PartialOrder leA → PartialOrder leB → PartialOrder (prod_relation leA leB).
  Proof.
    intros. split; first (firstorder eauto).
    typeclasses eauto.
  Qed.
End product_of_orders.

Section unstrict_order.
  Context {A B : Type}.
  Variables (lt : relation A).

  Definition unstrict x y :=
    x = y ∨ lt x y.
End unstrict_order.

Definition the_order (s1 s2: the_model): Prop :=
  match s1, s2 with
  | (N1, B1, yf1, nf1), (N2, B2, yf2, nf2) =>
    prod_relation
      (unstrict (lexprod _ _ (strict Nat.le) (strict bool_le)))
      (prod_relation bool_le bool_le)
      (N1, B1, (yf1, nf1))
      (N2, B2, (yf2, nf2))
  end.

Ltac inv_lexs :=
  repeat match goal with
    [ H: lexprod _ _ _ _ _ _ |- _ ] => inversion H; clear H; simplify_eq
         end.

Instance the_order_po: PartialOrder the_order.
Proof.
  constructor.
  - constructor.
    + intros x. destruct x as [[[??]?]?]. simpl.
      unfold prod_relation. simpl. split; last done.
      by econstructor.
    + intros [[[??]?]?] [[[??]?]?] [[[??]?]?]. simpl.
      unfold prod_relation. simpl. intros (Hlex1&?&?) (Hlex2&?&?). split; last first.
      * split; etransitivity =>//.
      * inversion Hlex1; inversion Hlex2; simplify_eq;
          try (econstructor 1; try (etransitivity; done); inv_lexs; f_equal; done);
          try (econstructor 2; try done).
        inv_lexs.
        ** econstructor. by etransitivity.
        ** econstructor 1 =>//.
        ** econstructor => //.
        ** econstructor 2. by etransitivity.
  -  intros [[[??]?]?] [[[??]?]?]. simpl.
      unfold prod_relation. simpl. intros (Hlex1&?&?) (Hlex2&?&?).
      do 3 f_equal; try (by eapply anti_symm =>//).
     + inversion Hlex1; inversion Hlex2; simplify_eq; try (eapply anti_symm =>//; done);
         inv_lexs; eauto. exfalso; eapply (strict_anti_symm (R := strict Nat.le)) =>//; eapply _.
     + inversion Hlex1; inversion Hlex2; simplify_eq; try (eapply anti_symm =>//; done);
       inv_lexs; eauto; try by eapply anti_symm;
         exfalso; eapply (strict_anti_symm (R := strict Nat.le)); eauto.
       exfalso; eapply (strict_anti_symm (R := strict bool_le)); eauto.
     + eapply anti_symm =>//; apply _.
     + eapply anti_symm =>//; apply _.
       Unshelve. all: exact eq.
Qed.

Definition the_decreasing_role (s: the_model): YN :=
  match s with
  | (0%nat, false, true, false) => Y
  | (0%nat, true, false, true) => No
  | (1%nat, false, true, false) => Y
  | (_, true, _, _) => Y
  | (_, false, _, _) => No
  end.

Instance eq_antisymm A: Antisymmetric A eq eq.
Proof. by intros ??. Qed.

Definition same: the_model -> (nat * bool * (bool * bool)) :=
  λ '(N, B, yf, nf), (N, B, (yf, nf)).

Lemma strict_unstrict {A} (R: relation A):
  forall x y, strict (unstrict R) x y -> R x y.
Proof.
  unfold strict, unstrict.
  intros x y.
  intros [[?|?] [Hneq HnR]%Classical_Prop.not_or_and] =>//.
Qed.

Lemma wf_bool_le: wf (strict bool_le).
Proof.
  intros b. destruct b; constructor; intros b' h; destruct b'; inversion h as [h1 h2];
              [done| | inversion h1| done]. clear h1 h2.
  constructor; intros b' h'; inversion h' as [h1 h2]; destruct b'; [inversion h1 | exfalso; eauto].
Qed.

Instance lex_trans `{Transitive A R1, Transitive B R2}: Transitive (lexprod A B R1 R2).
Proof.
  intros [x x'] [y y'] [z z'] Ha Hb.
  inversion Ha; inversion Hb; simplify_eq.
  - constructor 1. etransitivity =>//.
  - by constructor 1.
  - by constructor 1.
  - constructor 2. etransitivity =>//.
Qed.

Instance test1 `{Transitive A R}: Transitive (unstrict R).
Proof.
  intros x y z [?|?] [?|?]; simplify_eq; ((left; done) || right; eauto).
Qed.

Lemma the_model_almost_wf:
  wf (strict $
    prod_relation
      (unstrict (lexprod _ _ (strict Nat.le) (strict bool_le)))
      (prod_relation bool_le bool_le)).
Proof.
  apply wf_prod_strict.
  - apply _.
  - assert (H: wf (lexprod nat bool (strict Nat.le) (strict bool_le))).
    + apply wf_lexprod; last apply wf_bool_le.
      eapply (wf_projected _ id); last apply Nat.lt_wf_0.
      intros ??[??]. simpl. lia.
    + eapply (wf_projected _ id); last exact H.
      intros ???. apply strict_unstrict => //.
  - apply wf_prod_strict; eauto using wf_bool_le.
    apply _.
Qed.

Program Instance the_model_terminates: FairTerminatingModel the_model :=
  {|
  ftm_leq := the_order;
  ftm_decreasing_role := the_decreasing_role;
  |}.
Next Obligation.
  eapply (wf_projected _ same); last exact the_model_almost_wf.
  intros [[[? ?] ?] ?] [[[? ?] ? ]?] ?. eauto.
Qed.
Next Obligation.
  intros [[[N B] yf] nf] Hex.
  destruct B.
  - split.
    + simpl. destruct yf.
      * do 2 (destruct N; try set_solver).
      * destruct Hex as [ρ' [s' Hex]].
        inversion Hex; subst. set_solver.
    + intros [[[N' B'] yf'] nf'] Htrans.
      inversion Htrans; simplify_eq; rewrite strict_spec_alt; (split; [| try done; do 2 (destruct N'; eauto)]);
       (constructor; [simpl; eauto; unfold unstrict; (try by left) |]).
      { right. constructor 2. constructor; eauto. constructor. }
      all: simpl; by constructor.
  - split.
    + simpl. destruct nf.
      * destruct N; simpl; destruct yf; try set_solver; destruct N; set_solver.
      * destruct Hex as [ρ' [s' Hex]].
        inversion Hex; subst. destruct N; try set_solver.
        destruct N; try set_solver. lia.
    + intros [[[N' B'] yf'] nf'] Htrans.
      inversion Htrans; simplify_eq; rewrite strict_spec_alt; (split; [| try done; do 2 (destruct N'; eauto)]);
       (constructor ; [simpl; eauto; unfold unstrict; (try by left) |]).
      all: simpl; try by constructor.
      all: right; constructor 1; split; lia.
Qed.
Next Obligation.
  intros [[[N B] yf] nf]  [[[N' B'] yf'] nf'] ρ Htrans Hnex.
  inversion Htrans ; simplify_eq; eauto; simpl in *;
    try (destruct N'; eauto); try lia; (try (destruct N'; done)); try done.
  - destruct yf'; done.
  - destruct B'; try done. destruct nf'; done.
  - have ?: N' = 0%nat by lia. subst. destruct B' =>//.
    destruct nf'=>//.
  - destruct B' =>//; destruct yf' =>//.
Qed.
Next Obligation.
  intros [[[N B] yf] nf] ρ [[[N' B'] yf'] nf'] Htrans.
  destruct ρ; last by inversion Htrans.
  inversion Htrans; simplify_eq; simpl.
  all: constructor; [((left; done) || right; (constructor 1; constructor; done) || (try constructor 2)); simpl | simpl; try reflexivity].
  - constructor. constructor. eauto.
  - constructor 1; split; lia.
  - constructor 1; split; lia.
  - constructor. constructor. eauto. done.
  - constructor; done.
Qed.

(* The model is finitely branching *)
Definition steppable '(n, w, yf, nf): list ((nat * bool * bool * bool) * option YN) :=
  n' ← [n; (n-1)%nat];
  w' ← [w; negb w];
  yf' ← [yf; negb yf];
  nf' ← [nf; negb nf];
  ℓ ← [Some Y; Some No];
  mret ((n', w', yf', nf'), ℓ).

Instance proof_irrel_trans s x:
  ProofIrrel ((let '(s', ℓ) := x in yntrans s ℓ s'): Prop).
Proof. apply make_proof_irrel. Qed.

Lemma model_finitary s:
  Finite { '(s', ℓ) | yntrans s ℓ s'}.
Proof.
  assert (H: forall A (y x: A) xs, (y = x ∨ y ∈ xs) -> y ∈ x::xs) by set_solver.
  eapply (in_list_finite (steppable s)).
  intros [[[n w] yf] nf] Htrans.
  inversion Htrans; try (repeat (rewrite ?Nat.sub_0_r; simpl;
    eapply H; try (by left); right); done).
Qed.

Theorem yesno_terminates
        (N : nat)
        (HN: N > 0)
        (extr : extrace)
        (Hvex : extrace_valid extr)
        (Hexfirst : (trfirst extr).1 = [start #N]):
  (∀ tid, fair_ex tid extr) -> terminating_trace extr.
Proof.
  assert (heapGpreS yesnoΣ the_model) as HPreG.
  { apply _. }
  eapply (simulation_adequacy_terminate_ftm (Mdl := the_model) yesnoΣ NotStuck _ (N, true, true, true)) =>//.
  - eapply valid_state_evolution_finitary_fairness.
    intros ?. simpl. apply (model_finitary s1).
  - set_solver.
  - intros ?. iStartProof. iIntros "!> Hm Hf !>". simpl.
    iApply (start_spec _ _ 45 with "[Hm Hf]"); eauto.
    + lia.
    + iSplitL "Hm"; eauto. iSplit; last done.
      assert ({[Y := 45%nat; No := 45%nat]} = gset_to_gmap 45 {[Y; No]}) as <-; last done.
      rewrite -leibniz_equiv_iff. intros ρ.
      destruct (gset_to_gmap 45 {[Y; No]} !! ρ) as [f|] eqn:Heq.
      * apply lookup_gset_to_gmap_Some in Heq as [Heq ->].
        destruct (decide (ρ = Y)) as [-> |].
        ** rewrite lookup_insert //.
        ** rewrite lookup_insert_ne //. assert (ρ = No) as -> by set_solver.
           rewrite lookup_insert //.
      * apply lookup_gset_to_gmap_None in Heq.
        repeat (rewrite lookup_insert_ne //; last set_solver).
Qed.


(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
From HB Require Import structures.
Require Import Reals.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import boolp classical_sets Rstruct.
From mathcomp Require Import finmap.
Require Import Reals_ext classical_sets_ext Rbigop ssrR fdist fsdist.
Require Import convex.

(******************************************************************************)
(*       Semi-complete semilattice structures and non-empty convex sets       *)
(*                                                                            *)
(* neset T              == the type of non-empty sets over T                  *)
(* x%:ne                == try to infer whether x : set T is neset T          *)
(*                         (NB: worth moving to a dedicated file?)            *)
(* x <| p |>: Y         == (fun y => x <| p |> y) @` Y                        *)
(* X :<| p |>: Y        == \bigcup_(x in X) (x <| p |>: Y)                    *)
(*                                                                            *)
(* semiLattType         == type of (finitary) semilattice                     *)
(* semiCompSemiLattType == type of semicomplete semilattice, or infinitary    *)
(*                         semilattice which may come without a bottom        *)
(*                         element, provides an infinitary operator           *)
(*                         |_| : neset T -> T with the following axioms       *)
(*                         (inherits from semiLattice):                       *)
(*          1. |_| [set x] = x                                                *)
(*          2. |_| (\bigcup_(i in s) f i) = |_| (|_| @` (f @` s))             *)
(*          3. x [+] y = |_| [set x; y]                                       *)
(* {Biglub_morph U -> V} == Homomorphism between semicomplete semilattices    *)
(*                                                                            *)
(* semiLattConvType == semilattice convex space: This structure is a          *)
(*     combination of convex space and semilattice structures with the        *)
(*     distributive law of convex operation over lattice operation. This is   *)
(*     the algebra carried by the interface of combined choice monads, which  *)
(*     is described by MonadAltProb in monae. Although semilattice convex     *)
(*     space is what precisely corresponds to MonadAltProb, we prefer the     *)
(*     easiness of its completion (semicomplete semilattice convex space, the *)
(*     next module after this one) when defining our instance of MonadAltProb *)
(*     in monae (gcm_model.v, altprob_model.v).                               *)
(* semiCompSemiLattConvType == Semicomplete semilattice convex space: a       *)
(*     combination of convex space and semicomplete semilattice structures    *)
(*     with the distributive law of convex operation over lattice operation;  *)
(*     this is the algebra carried by the combined choice monad, which is     *)
(*     described in monae (files gcm_model.v and altprob_model.v),            *)
(*     extends semiCompSemiLattType and convType with the following axiom:    *)
(*          3. x <| p |> |_| I = |_| ((fun y => x <| p |> y) @` I)            *)
(*                                                                            *)
(* {Biglub_affine U -> V} == Homomorphism between semicomplete semilattice    *)
(*                           convex spaces                                    *)
(*                                                                            *)
(* necset T             == the type of non-empty convex sets over T, the      *)
(*                         object part of the third adjunction that appears   *)
(*                         in the definition of the combined choice monad     *)
(* structures on necset:                                                      *)
(* - convex space structure on necset (necset_convType A, instance of         *)
(*   convType) with elements of type necset A and with operator               *)
(*   X <| p |> Y = {x<|p|>y | x \in X, y \in Y}                               *)
(*   Notation: {necset A}                                                     *)
(* - semicomplete semilattice structure on necset, instance of                *)
(*   semiCompSemiLattType with elements of type necset A and with operator    *)
(*   |_| X = hull (bigsetU X idfun)                                           *)
(* - the combined structure on necset, instance of semiCompSemiLattConvType   *)
(*   with elements of type necset A                                           *)
(*                                                                            *)
(* necset_join, necset_bind == elementary definition of the multiplication    *)
(*                             and bind operations of the combined choice     *)
(*                             monad                                          *)
(*                                                                            *)
(* Section technical_corollaries == proofs of some subtle lemmas in the       *)
(*                                  literature                                *)
(******************************************************************************)

Declare Scope latt_scope.

Reserved Notation "x %:ne" (at level 0, format "x %:ne").
Reserved Notation "x <| p |>: Y" (format "x  <| p |>:  Y", at level 49).
Reserved Notation "X :<| p |>: Y" (format "X  :<| p |>:  Y", at level 49).
Reserved Notation "x [+] y" (format "x  [+]  y", at level 50).
Reserved Notation "'|_|' f" (at level 36, f at level 36, format "|_|  f").
Reserved Notation "{ 'necset' T }" (at level 0, format "{ 'necset'  T }").
Reserved Notation "{ 'Biglub_morph' T '->' R }"
  (at level 36, T, R at next level, format "{ 'Biglub_morph'  T  '->'  R }").
Reserved Notation "{ 'Biglub_affine' T '->' R }"
  (at level 36, T, R at next level, format "{ 'Biglub_affine'  T  '->'  R }").

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope reals_ext_scope.
Local Open Scope fdist_scope.
Local Open Scope convex_scope.

Module NESet.
Local Open Scope classical_set_scope.
Record mixin_of (T : Type) (X : set T) := Mixin {_ : X != set0 }.
Record t (T : Type) : Type := Pack { car : set T ; class : mixin_of car }.
Module Exports.
Notation neset := t.
Notation "s %:ne" := (@Pack _ s (class _)).
Coercion car : neset >-> set.
End Exports.
End NESet.
Export NESet.Exports.

Section neset_canonical.
Variable A : Type.
Canonical neset_predType :=
  Eval hnf in PredType (fun t : neset A => (fun x => x \in (t : set _))).
Canonical neset_eqType := Equality.Pack (@gen_eqMixin (neset A)).
Canonical neset_choiceType := choice_of_Type (neset A).
End neset_canonical.

Section NESet_interface.
Variables (A : Type).
Lemma neset_neq0 (a : neset A) : a != set0 :> set _.
Proof. by case: a => [? []]. Qed.
Lemma neset_ext (a b : neset A) : a = b :> set _ -> a = b.
Proof.
move: a b => -[a Ha] -[b Hb] /= ?; subst a.
congr NESet.Pack; exact/Prop_irrelevance.
Qed.
End NESet_interface.

Section neset_lemmas.
Local Open Scope classical_set_scope.

Lemma set1_neq0 A (a : A) : [set a] != set0.
Proof. by apply/set0P; exists a. Qed.

Definition neset_repr A (X : neset A) : A.
Proof.
case: X => X [] /set0P /boolp.constructive_indefinite_description [x _]; exact x.
Defined.

Lemma repr_in_neset A (X : neset A) : (X : set A) (neset_repr X).
Proof. by case: X => X [] X0 /=; case: cid. Qed.

Global Opaque neset_repr.
Local Hint Resolve repr_in_neset : core.

Lemma image_const A B (X : neset A) (b : B) : (fun _ => b) @` X = [set b].
Proof.
rewrite eqEsubset; split=> b'; [by case => ? _ -> | by move=> ?; eexists].
Qed.

Lemma neset_bigsetU_neq0 A B (X : neset A) (F : A -> neset B) :
  \bigcup_(i in X) F i != set0.
Proof. by apply/bigcup_set0P; eexists; split => //; eexists. Qed.

Lemma neset_image_neq0 A B (f : A -> B) (X : neset A) : f @` X != set0.
Proof. apply/set0P; eexists; exact/imageP. Qed.

Lemma neset_setU_neq0 A (X Y : neset A) : X `|` Y != set0.
Proof. by apply/set0P; eexists; left. Qed.

Canonical neset1 {A} (a : A) :=
  @NESet.Pack A [set a] (NESet.Mixin (set1_neq0 a)).
Canonical bignesetU {A} I (S : neset I) (F : I -> neset A) :=
  NESet.Pack (NESet.Mixin (neset_bigsetU_neq0 S F)).
Canonical image_neset {A B} (f : A -> B) (X : neset A) :=
  NESet.Pack (NESet.Mixin (neset_image_neq0 f X)).
Canonical nesetU {T} (X Y : neset T) :=
  NESet.Pack (NESet.Mixin (neset_setU_neq0 X Y)).

Lemma neset_hull_neq0 (T : convType) (F : neset T) : hull F != set0.
Proof. by rewrite hull_eq0 neset_neq0. Qed.

Canonical neset_hull (T : convType) (F : neset T) :=
  NESet.Pack (NESet.Mixin (neset_hull_neq0 F)).

End neset_lemmas.
Local Hint Resolve repr_in_neset : core.
Arguments image_neset : simpl never.

Section conv_set_def.
Local Open Scope classical_set_scope.
Local Open Scope R_scope.
Variable L : convType.
(*
The three definitions below work more or less the same way,
although the lemmas are not sufficiently provided in classical_sets.v
to switch between these views.
Definition conv_pt_set (p : prob) (x : L) (Y : set L) :=
[set z | exists y, Y y /\ z = x <| p |> y].
Definition conv_pt_set (p : prob) (x : L) (Y : set L) :=
  \bigcup_(y in Y) [set x <| p |> y].
Definition conv_pt_set (p : prob) (x : L) (Y : set L) :=
  (fun y => x <| p |> y) @` Y.
*)
Definition conv_pt_set (p : prob) (x : L) (Y : set L) :=
  locked (fun y => x <| p |> y) @` Y.
Local Notation "x <| p |>: Y" := (conv_pt_set p x Y).

Lemma conv_pt_setE p x Y : x <| p |>: Y = (fun y => x <| p |> y) @` Y.
Proof. by rewrite /conv_pt_set; unlock. Qed.

Definition conv_set p (X Y : set L) := \bigcup_(x in X) (x <| p |>: Y).
Local Notation "X :<| p |>: Y" := (conv_set p X Y).
End conv_set_def.

Notation "x <| p |>: Y" := (conv_pt_set p x Y) : convex_scope.
Notation "X :<| p |>: Y" := (conv_set p X Y) : convex_scope.

Section conv_set_lemmas.
Local Open Scope classical_set_scope.
Local Open Scope R_scope.
Variables A : convType.

Lemma conv_setE p (X Y : set A) :
  X :<| p |>: Y = \bigcup_(x in X) (x <| p |>: Y).
Proof. by []. Qed.

Lemma conv_in_conv_pt_set p (Y : set A) x y :
  Y y -> (x <| p |>: Y) (x <| p |> y).
Proof. by move=> ?; rewrite conv_pt_setE; exists y. Qed.

Lemma conv_in_conv_set p (X Y : set A) x y :
  X x -> Y y -> (X :<| p |>: Y) (x <| p |> y).
Proof. by move=> *; exists x=> //; rewrite conv_pt_setE; exists y. Qed.

Lemma conv_in_conv_set' p (X Y : set A) u :
 (X :<| p |>: Y) u -> exists x y, X x /\ Y y /\ u = x <| p |> y.
Proof.
by case=> x ?; rewrite conv_pt_setE=> -[] y ? <-; exists x, y.
Qed.

Lemma convC_set p (X Y : set A) : X :<| p |>: Y = Y :<| p.~%:pr |>: X.
Proof.
by rewrite eqEsubset; split=> u; case=> x Xx;
  rewrite conv_pt_setE => -[] y Yy <-;
  exists y => //; rewrite conv_pt_setE; exists x => //; rewrite -convC.
Qed.

Lemma convA_pt_set p q x (Y Z : set A) :
  x <|p|>: (Y :<|q|>: Z) = (x <|[r_of p, q]|>: Y) :<|[s_of p, q]|>: Z.
Proof.
rewrite eqEsubset; split=> u; rewrite conv_pt_setE.
- case=> yz [] y Yy; rewrite conv_pt_setE=> -[] z Zz <- <-.
  by rewrite convA; apply conv_in_conv_set=> //; apply conv_in_conv_pt_set.
- case=> xy [] y Yy <-; rewrite conv_pt_setE; case=> z Zz <-.
  by rewrite -convA; apply conv_in_conv_pt_set=> //; apply conv_in_conv_set.
Qed.

Lemma convA_set p q (X Y Z : set A) :
  X :<|p|>: (Y :<|q|>: Z) = (X :<|[r_of p, q]|>: Y) :<|[s_of p, q]|>: Z.
Proof.
rewrite eqEsubset; split=> u.
- by case=> x Xx; rewrite convA_pt_set=> -[] xy xYxy; exists xy=> //; exists x.
- by case=> xy -[] x Xx xYxy; exists x=> //; rewrite convA_pt_set; exists xy.
Qed.

Lemma conv_cset1 (p : prob) (x y : A) :
  [set x] :<|p|>: [set y] = [set x <|p|> y].
Proof.
rewrite eqEsubset; split=> [u|u ->]; last exact: conv_in_conv_set.
by case/conv_in_conv_set'=> x' [] y' [] -> [] -> ->.
Qed.

Lemma conv1_pt_set x (Y : neset A) : x <| 1%:pr |>: Y = [set x].
Proof.
rewrite eqEsubset;split => u; rewrite conv_pt_setE.
- by case => y _; rewrite conv1.
- by move=> ->; eexists => //; rewrite conv1.
Qed.

Lemma conv0_pt_set x (Y : set A) : x <| 0%:pr |>: Y = Y.
Proof.
rewrite eqEsubset; split => u; rewrite conv_pt_setE.
- by case=> y Yy <-; rewrite conv0.
- by move=> Yu; exists u=> //; rewrite conv0.
Qed.

Lemma conv1_set X (Y : neset A) : X :<| 1%:pr |>: Y = X.
Proof.
transitivity (\bigcup_(x in X) [set x]); last by rewrite bigcup_imset1 image_id.
by apply :eq_bigcupr => x; rewrite conv1_pt_set.
Qed.

Lemma conv0_set (X : neset A) Y : X :<| 0%:pr |>: Y = Y.
Proof.
rewrite convC_set /= (_ : 0.~%:pr = 1%:pr) ?conv1_set //.
by apply val_inj; rewrite /= onem0.
Qed.

Definition probset := @setT prob.

Definition natset := @setT nat.

Definition oplus_conv_set (X Y : set A) :=
  \bigcup_(p in probset) (X :<| p |>: Y).

Lemma conv_in_oplus_conv_set p (X Y : set A) x y :
  X x -> Y y -> (oplus_conv_set X Y) (x <|p|> y).
Proof. by move=> *; exists p=> //; exact: conv_in_conv_set. Qed.

Fixpoint iter_conv_set (X : set A) (n : nat) :=
  match n with
  | O => X
  | S n' => oplus_conv_set X (iter_conv_set X n')
  end.

Lemma iter0_conv_set (X : set A) : iter_conv_set X 0 = X.
Proof. by []. Qed.

Lemma iterS_conv_set (X : set A) (n : nat) :
  iter_conv_set X (S n) = oplus_conv_set X (iter_conv_set X n).
Proof. by []. Qed.

Lemma probset_neq0 : probset != set0.
Proof. by apply/set0P; exists 0%:pr. Qed.

Lemma natset_neq0 : natset != set0.
Proof. by apply/set0P; exists O. Qed.

Lemma conv_pt_set_neq0 p (x : A) (Y : neset A) : x <| p |>: Y != set0.
Proof. exact: neset_image_neq0. Qed.

Lemma conv_set_neq0 p (X Y : neset A) : X :<| p |>: Y != set0.
Proof. by rewrite neset_neq0. Qed.

Lemma oplus_conv_set_neq0 (X Y : neset A) : oplus_conv_set X Y != set0.
Proof. apply/set0P; eexists; exists 1%:pr => //; by rewrite conv1_set. Qed.

Fixpoint iter_conv_set_neq0 (X : neset A) (n : nat) :
  iter_conv_set X n != set0 :=
  if n is n'.+1 then
    oplus_conv_set_neq0 X (NESet.Pack (NESet.Mixin (iter_conv_set_neq0 X n')))
  else neset_neq0 X.

Canonical probset_neset := NESet.Pack (NESet.Mixin probset_neq0).
Canonical natset_neset := NESet.Pack (NESet.Mixin natset_neq0).
Canonical conv_pt_set_neset (p : prob) (x : A) (Y : neset A) :=
  NESet.Pack (NESet.Mixin (conv_pt_set_neq0 p x Y)).
Canonical conv_set_neset (p : prob) (X Y : neset A) :=
  NESet.Pack (NESet.Mixin (conv_set_neq0 p X Y)).
Canonical oplus_conv_set_neset (X Y : neset A) :=
  NESet.Pack (NESet.Mixin (oplus_conv_set_neq0 X Y)).
Canonical iter_conv_set_neset (X : neset A) (n : nat) :=
  NESet.Pack (NESet.Mixin (iter_conv_set_neq0 X n)).

Lemma conv_pt_cset_is_convex (p : prob) (x : A) (Y : {convex_set A}) :
  is_convex_set (conv_pt_set p x Y).
Proof.
apply/asboolP=> u v q.
rewrite conv_pt_setE /= => -[y0 Yy0 <-] [y1 Yy1 <-].
rewrite -convDr; apply/imageP.
by move/asboolP: (convex_setP Y); apply.
Qed.

Canonical conv_pt_cset (p : prob) (x : A) (Y : {convex_set A}) :=
  CSet.Pack (CSet.Mixin (conv_pt_cset_is_convex p x Y)).

Lemma conv_cset_is_convex (p : prob) (X Y : {convex_set A}) :
  is_convex_set (conv_set p X Y).
Proof.
apply/asboolP=> u v q.
case/conv_in_conv_set'=> x0 [] y0 [] ? [] ? ->.
case/conv_in_conv_set'=> x1 [] y1 [] ? [] ? ->.
by rewrite convACA; apply/conv_in_conv_set;
 [move/asboolP: (convex_setP X); apply | move/asboolP: (convex_setP Y); apply].
Qed.

Canonical conv_cset (p : prob) (X Y : {convex_set A}) :=
  CSet.Pack (CSet.Mixin (conv_cset_is_convex p X Y)).

Lemma oplus_conv_cset_is_convex (X Y : {convex_set A}) :
  is_convex_set (oplus_conv_set X Y).
Proof.
apply/asboolP=> u v p.
case=> q _ [] xu Xxu; rewrite conv_pt_setE=> -[] yu Yyu <-.
case=> r _ [] xv Xxv; rewrite conv_pt_setE=> -[] yv Yyv <-.
apply (prob_trichotomy' p); rewrite ?conv0 ?conv1;
  [exact: conv_in_oplus_conv_set | exact: conv_in_oplus_conv_set | move=> op].
apply (prob_trichotomy' q) => [| |oq].
- rewrite conv0 (convC r) convA convC; apply conv_in_oplus_conv_set=> //.
  by move/asboolP: (convex_setP Y); apply.
- rewrite conv1 convA; apply conv_in_oplus_conv_set=> //.
  by move/asboolP: (convex_setP X); apply.
- apply (prob_trichotomy' r) => [| |or].
  + rewrite conv0 -convA' ?oprob_neq1 //; apply conv_in_oplus_conv_set=> //.
    by move/asboolP: (convex_setP Y); apply.
  + rewrite conv1 convC convA; apply conv_in_oplus_conv_set=> //.
    by move/asboolP: (convex_setP X); apply.
  + case: (convACA' xu yu xv yv oq op or)=> q' [] p' [] r' ->.
    by apply conv_in_oplus_conv_set; [move/asboolP: (convex_setP X); apply |
                                      move/asboolP: (convex_setP Y); apply].
Qed.

Canonical oplus_conv_cset (X Y : {convex_set A}) :=
  CSet.Pack (CSet.Mixin (oplus_conv_cset_is_convex X Y)).

Fixpoint iter_conv_cset_is_convex (X : {convex_set A}) (n : nat) :
  is_convex_set (iter_conv_set X n) :=
  match n with
  | 0 => convex_setP X
  | n'.+1 => oplus_conv_cset_is_convex
               X (CSet.Pack (CSet.Mixin (iter_conv_cset_is_convex X n')))
  end.

Canonical iter_conv_cset (X : {convex_set A}) (n : nat) :=
  CSet.Pack (CSet.Mixin (iter_conv_cset_is_convex X n)).

Lemma conv_pt_set_monotone (p : prob) (x : A) (Y Y' : set A) :
  Y `<=` Y' -> x <| p |>: Y `<=` x <| p |>: Y'.
Proof. by move=> YY' u [] y /YY' Y'y <-; exists y. Qed.

Lemma conv_set_monotone (p : prob) (X Y Y' : set A) :
  Y `<=` Y' -> X :<| p |>: Y `<=` X :<| p |>: Y'.
Proof. by move/conv_pt_set_monotone=> YY' u [] x Xx /YY' HY'; exists x. Qed.

Lemma oplus_conv_set_monotone (X Y Y' : set A) :
  Y `<=` Y' -> oplus_conv_set X Y `<=` oplus_conv_set X Y'.
Proof. by move/conv_set_monotone=> YY' u [] p _ /YY' HY'; exists p. Qed.

Lemma iter_monotone_conv_set (X : neset A) (m : nat) :
  forall n, (m <= n)%N -> iter_conv_set X m `<=` iter_conv_set X n.
Proof.
elim: m => [n _|m IHm].
- case: n => // n.
  rewrite iter0_conv_set iterS_conv_set.
  by exists 1%:pr => //; rewrite conv1_set.
- case => // n /(IHm _) mn.
  rewrite iterS_conv_set=> a [] p _ H.
  exists p => //.
  by move: (@conv_set_monotone p X _ _ mn) => /(_ a); apply.
Qed.

Lemma iter_bigcup_conv_set (X : neset A) (n : nat) :
  iter_conv_set X n `<=` \bigcup_(i in natset) iter_conv_set X i.
Proof. by move=> a H; exists n. Qed.

Lemma iter_conv_set_superset (X : neset A) n : X `<=` iter_conv_set X n .
Proof.
move=> x Xx; elim: n => // n IHn; rewrite iterS_conv_set.
by exists 1%:pr => //; rewrite conv1_set.
Qed.

Lemma Convn_iter_conv_set (n : nat) :
  forall (g : 'I_n -> A) (d : {fdist 'I_n}) (X : set A),
    g @` setT `<=` X -> iter_conv_set X n (<|>_d g).
Proof.
elim: n => [g d|n IHn g d X]; first by have := fdistI0_False d.
have [/eqP ->|Xneq0 gX] := boolP (X == set0).
  by move=> /(_ (g ord0)) H; exfalso; apply/H/imageP.
set X' := NESet.Pack (NESet.Mixin Xneq0).
have gXi : forall i : 'I_n.+1, X (g i).
  by move=> i; move/subset_image : gX; apply.
have [/eqP d01|d0n1] := boolP (d ord0 == 1).
- suff : X (<|>_d g) by move/(@iter_conv_set_superset X' n.+1 (<|>_d g)).
  by rewrite (Convn_proj g d01); exact/gX/imageP.
- rewrite ConvnIE //; exists (probfdist d ord0) => //; exists (g ord0) => //.
  rewrite conv_pt_setE.
  exists (<|>_(fdist_del d0n1) (fun x : 'I_n => g (fdist_del_idx ord0 x))) => //.
  by apply IHn => u [] i _ <-; exact/gX/imageP.
Qed.

Lemma oplus_convC_set (X Y : set A) : oplus_conv_set X Y = oplus_conv_set Y X.
Proof.
suff H : forall X' Y', oplus_conv_set X' Y' `<=` oplus_conv_set Y' X'
  by rewrite eqEsubset; split => // /H.
by move=> {X} {Y} X Y u [] p _; rewrite convC_set => H; exists p.~%:pr.
Qed.

Lemma convmm_cset (p : prob) (X : {convex_set A}) : X :<| p |>: X = X.
Proof.
rewrite eqEsubset; split=> [x /conv_in_conv_set'[] | x ?].
- by move=> x0 [] x1 [] ? [] ? ->; move/asboolP : (convex_setP X); apply.
- by rewrite -(convmm p x); apply conv_in_conv_set.
Qed.

Lemma oplus_convmm_cset (X : {convex_set A}) : oplus_conv_set X X = X.
Proof.
rewrite eqEsubset; split => [x [p _]|x Xx].
- by rewrite convmm_cset.
- by exists 0%:pr => //; rewrite convmm_cset.
Qed.

Lemma oplus_convmm_set_hull (X : set A) :
  oplus_conv_set (hull X) (hull X) = hull X.
Proof. by rewrite oplus_convmm_cset. Qed.

Lemma hull_iter_conv_set (X : set A) :
  hull X = \bigcup_(i in natset) iter_conv_set X i.
Proof.
rewrite eqEsubset; split.
  by move=> x [] n [] g [] d [] gX ->; exists n => //; apply Convn_iter_conv_set.
apply bigsubsetU.
elim => [_|n IHn _]; first exact/subset_hull.
have H : iter_conv_set X n.+1 `<=` oplus_conv_set X (hull X).
  exact/oplus_conv_set_monotone/IHn.
apply (subset_trans H); rewrite oplus_convC_set.
have : oplus_conv_set (hull X) X `<=` oplus_conv_set (hull X) (hull X).
  exact/oplus_conv_set_monotone/subset_hull.
by move/subset_trans; apply; rewrite oplus_convmm_set_hull.
Qed.

(* tensorial strength for hull and conv_set *)
Lemma hull_conv_set_strr (p : prob) (X Y : set A) :
  hull (X :<| p |>: hull Y) = hull (X :<| p |>: Y).
Proof.
apply hull_eqEsubset=> u.
- case=> x Xx; rewrite conv_pt_setE=> -[] y [] n [] g [] d [] gY yg <-.
  exists n, (fun i => x <|p|> g i), d; rewrite -ConvnDr yg; split=> //.
  by move=> v [] i _ <-; exists x=> //; apply/conv_in_conv_pt_set/gY/imageP.
- case=> x Xx [] y Yy <-; apply/subset_hull.
  by exists x=> //; exists y=> //; exact/subset_hull.
Qed.

End conv_set_lemmas.

Local Open Scope classical_set_scope.
Lemma affine_image_conv_set (A B : convType) (f : {affine A -> B}) p
    (X Y : set A) :
  f @` (X :<| p |>: Y) =  f @` X :<| p |>: f @` Y.
Proof.
rewrite eqEsubset; split=> [u [v]|u].
- move=> /conv_in_conv_set' [] x [] y [] Xx [] Yy ->; rewrite affine_conv=> <-.
  by apply conv_in_conv_set; apply imageP.
- case/conv_in_conv_set'=> x [] y [] [] x0 Xx0 <- [] [] y0 Yy0 <- ->.
  by rewrite -affine_conv; apply/imageP/conv_in_conv_set.
Qed.
Local Close Scope classical_set_scope.

(* (saikawa) I am aware that ssreflect/order.v has definitions of porder and
   lattice. For now, I write down the following definition of semilattice
   independently of the two, as it seems hard to insert a new layer in the
   mathcomp hierarchy. *)
HB.mixin Record isSemiLattice (T : Type) := {
  slchoice : Choice.class_of T ;
  lub : T -> T -> T ;
  lubC : commutative lub;
  lubA : associative lub;
  lubxx : idempotent lub }.

#[short(type=semiLattType)]
HB.structure Definition SemiLattice := { T & isSemiLattice T }.

Canonical semilattice_eqType (T : semiLattType) := EqType T slchoice.
Canonical semilattice_choiceType (T : semiLattType) := ChoiceType T slchoice.
Coercion semilattice_choiceType : semiLattType >-> choiceType.

Notation "x [+] y" := (lub x y) : latt_scope.

Local Open Scope latt_scope.

Section semilattice_lemmas.
Variable L : semiLattType.
Local Notation lub := (@lub L).

Lemma lubAC : right_commutative lub.
Proof. by move=> x y z; rewrite -!lubA [X in _ [+] X]lubC. Qed.

Lemma lubCA : left_commutative lub.
Proof. by move=> x y z; rewrite !lubA [X in X [+] _]lubC. Qed.

Lemma lubACA : interchange lub lub.
Proof. by move=> x y z t; rewrite !lubA [X in X [+] _]lubAC. Qed.

Lemma lubKU (y x : L) : x [+] (x [+] y) = x [+] y.
Proof. by rewrite lubA lubxx. Qed.

Lemma lubUK (y x : L) : (x [+] y) [+] y = x [+] y.
Proof. by rewrite -lubA lubxx. Qed.

Lemma lubKUC (y x : L) : x [+] (y [+] x) = x [+] y.
Proof. by rewrite lubC lubUK lubC. Qed.

Lemma lubUKC (y x : L) : y [+] x [+] y = x [+] y.
Proof. by rewrite lubAC lubC lubxx. Qed.

End semilattice_lemmas.

HB.mixin Record isSemiCompSemiLatt T of isSemiLattice T := {
  scslchoice : Choice.class_of T ;
  biglub : neset T -> T ;
  (* [Reiterman] p.326, axiom 3 *)
  biglub1 : forall x : T, biglub [set x]%:ne = x ;
  biglub_bignesetU : forall I (s : neset I) (f : I -> neset T),
    biglub (\bigcup_(i in s) f i)%:ne = biglub (biglub @` (f @` s))%:ne ;
  lubE : forall x y, x [+] y = biglub [set x; y]%:ne }.

#[short(type=semiCompSemiLattType)]
HB.structure Definition SemiCompSemiLatt :=
  { T of @isSemiCompSemiLatt T & isSemiLattice T }.

Canonical semicompsemilatt_eqType (T : semiCompSemiLattType) :=
  EqType T scslchoice.
Canonical semicompsemilatt_choiceType (T : semiCompSemiLattType) :=
  ChoiceType T scslchoice.

Notation "|_| f" := (biglub f) : latt_scope.
Local Open Scope latt_scope.

Section semicompsemilatt_lemmas.
Local Open Scope classical_set_scope.
Variable L : semiCompSemiLattType.

(*
[Reiterman]
- Commentationes Mathematicae Universitatis Carolinae
- Jan Reiterman
- On locally small based algebraic theories
- https://dml.cz/bitstream/handle/10338.dmlcz/106455/CommentatMathUnivCarol_027-1986-2_12.pdf
*)

(* NB: bigsetU (bigsetI too) is the bind operator for the powerset monad *)

Lemma biglub_bigcup (I : Type) (S : neset I) (F : I -> neset L) :
  |_| (\bigcup_(i in S) F i)%:ne = |_| (biglub @` (F @` S))%:ne.
Proof. by rewrite biglub_bignesetU. Qed.

Lemma nesetU_bigcup T (I J : neset T) :
  (I `|` J)%:ne = (\bigcup_(i in [set I; J]) idfun i)%:ne.
Proof.
apply/neset_ext => /=; rewrite eqEsubset; split => x.
  by case=> Hx; [exists I => //; left | exists J => //; right].
by case=> K [] -> Hx; [left | right].
Qed.

Lemma biglub_setU (I J : neset L) :
  |_| (I `|` J)%:ne = |_| [set |_| I; |_| J]%:ne.
Proof.
rewrite nesetU_bigcup biglub_bignesetU; congr (|_| _%:ne); apply/neset_ext => /=.
by rewrite image_id /= image_setU !image_set1.
Qed.

(* NB: [Reiterman] p.326, axiom 1 is trivial, since our |_| operator receives
   a set but not a sequence. *)

(* [Reiterman] p.326, axiom 2 *)
Lemma biglub_flatten (F : neset (neset L)) :
  |_| (biglub @` F)%:ne = |_| (\bigcup_(i in F) idfun i)%:ne.
Proof.
rewrite biglub_bignesetU; congr (|_| _%:ne); apply/neset_ext => /=.
by rewrite image_id.
Qed.

Let lub_binary (x y : L) := |_| [set x; y]%:ne.

Let lub_binaryC : commutative lub_binary.
Proof. by move=> x y; rewrite /lub_binary -!lubE lubC. Qed.

Let lub_binaryA : associative lub_binary.
Proof. by move=> x y z; rewrite /lub_binary -!lubE lubA. Qed.

Let lub_binaryxx : idempotent lub_binary.
Proof. by move=> x; rewrite /lub_binary -lubE lubxx. Qed.

End semicompsemilatt_lemmas.

Definition biglubmorph (U V : semiCompSemiLattType) (f : U -> V) :=
  forall (X : neset U), f (|_| X) = |_| (f @` X)%:ne.

HB.mixin Record isBiglubMorph (U V : semiCompSemiLattType) (f : U -> V) := {
  biglub_morph : biglubmorph f }.

HB.structure Definition BiglubMorph (U V : semiCompSemiLattType) :=
  {f of isBiglubMorph U V f}.

Notation "{ 'Biglub_morph' T '->' R }" :=
  (BiglubMorph.type T R) : convex_scope.

Section biglub_morph.
Variables (L M : semiCompSemiLattType).

Local Open Scope classical_set_scope.
Local Open Scope latt_scope.

Definition lub_morph (f : L -> M) :=
  forall (x y : L), f (x [+] y) = f x [+] f y.

Lemma biglub_lub_morph (f : {Biglub_morph L -> M}) : lub_morph f.
Proof.
move=> x y; rewrite !lubE biglub_morph.
congr (|_| _%:ne); apply/neset_ext => /=.
by rewrite image_setU !image_set1.
Qed.

End biglub_morph.

Local Open Scope convex_scope.
Local Open Scope latt_scope.
Local Open Scope classical_set_scope.

HB.mixin Record isSemiLattConv L of ConvexSpace L & SemiLattice L := {
  lubDr : forall (p : prob) (x y z : L),
    conv p x (y [+] z) = (conv p x y) [+] (conv p x z) }.

#[short(type=semiLattConvType)]
HB.structure Definition SemiLattConv :=
  {L of isSemiLattConv L & ConvexSpace L & SemiLattice L}.

(* Homomorphism between semilattice convex spaces *)
(* TODO: define LubAffine for semiLattConvType *)

Section semilattconvtype_lemmas.
Local Open Scope latt_scope.
Local Open Scope convex_scope.

Variable L : semiLattConvType.

Lemma lubDl p : left_distributive (fun x y => x <|p|> y) (@lub L).
Proof. by move=> x y z; rewrite convC lubDr -(convC _ x z) -(convC _ y z). Qed.

(*
  The proof of the next lemma is essentially based on the canonical order
  structure induced by semilattice structure: x <= y is defined to be
  x [+] y = y.
  Immediately from the definition,
    x [+] y  <=  x [+] y [+] x <|p|> y and
    x [+] y [+] x <|p|> y  <=  x [+] y [+] x <|p|> y [+] y <|p|> x holds.
  Now that x [+] y [+] x <|p|> y [+] y <|p|> x can be rewritten into x [+] y
  by distributivity, we can conclude x [+] y = x [+] y [+] x <|p|> y by
  antisymmmetry. This proof might be a motivation to base our semilattice over
  ssreflect.order.POrder.
 *)
Lemma lub_absorbs_conv (x y : L) p : x [+] y = x [+] y [+] x <|p|> y.
Proof.
have H : x [+] y = (x [+] y [+] x <|p|> y) [+] y <|p|> x.
  rewrite -[in LHS](convmm p (x [+] y)) lubDl 2!lubDr 2!convmm lubCA lubC.
  by rewrite (lubAC x).
rewrite {1}H.
have {2}<- : x [+] y [+] (x [+] y [+] x <|p|> y) = x [+] y [+] x <|p|> y
   by rewrite lubA lubxx.
rewrite [in RHS]lubC.
have <- : x [+] y [+] x <|p|> y [+] (x [+] y [+] x <|p|> y [+] y <|p|> x) =
    x [+] y [+] x <|p|> y [+] y <|p|> x
  by rewrite lubA lubxx.
by rewrite -H.
Qed.

(* The next lemma corresponds to biglub_hull.
   In order to type check its statement,
   we need some bigop-like machinery for semilattice,
   which is unfortunately only a semigroup and not a monoid *)
Local Notation "\lub_ ( i < n ) F" := False
         (at level 41, F at level 41, i, n at level 50,
          format "'[' \lub_ ( i  <  n ) '/  '  F ']'").
Fail Lemma lub_absorbs_convn (n : nat) (d : {fdist 'I_n}) (f : 'I_n -> L) :
  \lub_(i < n) f i = (\lub_(i < n) f i) [+] (<|>_d f).
End semilattconvtype_lemmas.

HB.mixin Record isSemiCompSemiLattConv L of SemiCompSemiLatt L &
                                            ConvexSpace L := {
  biglubDr : forall (p : prob) (x : L) (I : neset L),
    conv p x (|_| I) = |_| ((conv p x) @` I)%:ne
}.

#[short(type=semiCompSemiLattConvType)]
HB.structure Definition SemiCompSemiLattConv :=
  { L of isSemiCompSemiLattConv L & SemiCompSemiLatt L & ConvexSpace L &
         isSemiLattConv L}.

HB.structure Definition BiglubAffine (U V : semiCompSemiLattConvType) :=
  {f of isAffine U V f & isBiglubMorph U V f}.

Notation "{ 'Biglub_affine'  T '->'  R }" :=
  (BiglubAffine.type T R) : convex_scope.

Section biglub_affine_functor_laws.

Variables (R S T : semiCompSemiLattConvType)
  (f : {Biglub_affine S -> T}) (g : {Biglub_affine R -> S}).

Let biglubmorph_idfun : biglubmorph (@idfun R).
Proof.
by move=> x; congr (|_| _); apply neset_ext; rewrite /= image_id.
Qed.

HB.instance Definition _ := isBiglubMorph.Build _ _ _ biglubmorph_idfun.

Let biglubmorph_comp : biglubmorph (f \o g).
Proof.
move=> x; cbn; rewrite !biglub_morph.
by congr (|_| _); apply neset_ext => /=; rewrite image_comp.
Qed.

HB.instance Definition _ := isBiglubMorph.Build _ _ _ biglubmorph_comp.

End biglub_affine_functor_laws.

Section semicompsemilattconvtype_lemmas.
Local Open Scope latt_scope.
Local Open Scope convex_scope.
Local Open Scope classical_set_scope.

Variable L : semiCompSemiLattConvType.

Lemma biglubDl (p : prob) (X : neset L) (y : L) :
  |_| X <|p|> y = |_| ((fun x => x <|p|> y) @` X)%:ne.
Proof.
rewrite convC biglubDr; congr (|_| _); apply/neset_ext/eq_imagel=> x ?.
by rewrite -convC.
Qed.

Lemma biglub_conv_pt_setE p x (Y : neset L) :
  |_| (x <| p |>: Y)%:ne = |_| ((conv p x) @` Y)%:ne.
Proof.
by congr (|_| _%:ne); apply/neset_ext => /=; rewrite conv_pt_setE.
Qed.

Lemma biglub_conv_pt_setD p x (Y : neset L) :
  |_| (x <| p |>: Y)%:ne = x <|p|> |_| Y.
Proof. by rewrite biglub_conv_pt_setE -biglubDr. Qed.

Lemma biglub_conv_setE p (X Y : neset L) :
  |_| (X :<| p |>: Y)%:ne = |_| ((fun x => x <|p|> |_| Y) @` X)%:ne.
Proof.
transitivity (|_| (\bigcup_(x in X) (x <| p |>: Y))%:ne).
  by congr (|_| _%:ne); apply neset_ext.
rewrite biglub_bigcup //; congr (|_| _%:ne); apply neset_ext => /=.
rewrite image_comp; congr image; apply funext => x /=.
by rewrite biglub_conv_pt_setD.
Qed.

Lemma biglub_conv_setD p (X Y : neset L) :
  |_| (X :<| p |>: Y)%:ne = |_| X <|p|> |_| Y.
Proof. by rewrite biglub_conv_setE biglubDl. Qed.

Lemma biglub_oplus_conv_setE (X Y : neset L) :
  |_| (oplus_conv_set X Y)%:ne =
  |_| ((fun p => |_| X <|p|> |_| Y) @` probset)%:ne.
Proof.
transitivity (|_| (\bigcup_(p in probset_neset) (X :<| p |>: Y))%:ne).
  by congr (|_| _%:ne); apply/neset_ext.
rewrite biglub_bigcup //; congr (|_| _%:ne); apply/neset_ext => /=.
rewrite image_comp; congr image; apply funext => p /=.
by rewrite biglub_conv_setD.
Qed.

Lemma biglub_iter_conv_set (X : neset L) (n : nat) :
  |_| (iter_conv_set X n)%:ne = |_| X.
Proof.
elim: n => [|n IHn /=]; first by congr (|_| _); apply/neset_ext.
rewrite (biglub_oplus_conv_setE _ (iter_conv_set X n)%:ne).
transitivity (|_| [set |_| X]%:ne); last by rewrite biglub1.
congr (|_| _%:ne); apply/neset_ext => /=.
transitivity ((fun _ => |_| X) @` probset); last by rewrite image_const.
by congr image; apply funext=> p; rewrite IHn convmm.
Qed.

Lemma biglub_hull (X : neset L) : |_| (hull X)%:ne = |_| X.
Proof.
transitivity (|_| (\bigcup_(i in natset) iter_conv_set X i)%:ne);
  first by congr (|_| _); apply neset_ext; rewrite /= hull_iter_conv_set.
rewrite biglub_bignesetU /= -[in RHS](biglub1 (|_| X)).
transitivity (|_| ((fun _ => |_| X) @` natset)%:ne); last first.
  by congr (|_| _); apply/neset_ext/image_const.
congr (|_| _%:ne); apply/neset_ext => /=.
rewrite image_comp; congr image; apply funext => n /=.
by rewrite biglub_iter_conv_set.
Qed.

Let lubDr p : right_distributive (fun x y => x <|p|> y) (@lub L).
Proof.
move=> x y z; rewrite !lubE biglubDr.
congr (|_| _%:ne); apply/neset_ext => /=.
by rewrite image_setU !image_set1.
Qed.

(* NB: was in the doc before *)
(* biglubDr_semiLattConvType == Semicomplete semilattice convex space is a    *)
(*                              semilattice convex space                      *)
(* NB: not needed?
HB.instance Definition _ (*biglubDr_semiLattConvType*) := @isSemiLattConv.Build
  L lubDr.
*)

End semicompsemilattconvtype_lemmas.

Module NECSet.
Section def.
Variable A : convType.
Record class_of (X : set A) : Type := Class {
  base : CSet.mixin_of X ; mixin : NESet.mixin_of X }.
Record t : Type := Pack { car : set A ; class : class_of car }.
Definition baseType (M : t) := CSet.Pack (base (class M)).
Definition mixinType (M : t) := NESet.Pack (mixin (class M)).
End def.
Module Exports.
Notation necset := t.
Canonical baseType.
Canonical mixinType.
Coercion baseType : necset >-> convex_set.
Coercion mixinType : necset >-> neset.
Coercion car : necset >-> set.
End Exports.
End NECSet.
Export NECSet.Exports.

Section necset_canonical.
Variable (A : convType).
Canonical necset_predType :=
  Eval hnf in PredType (fun t : necset A => (fun x => x \in (t : set _))).
Canonical necset_eqType := Equality.Pack (@gen_eqMixin (necset A)).
Canonical necset_choiceType := choice_of_Type (necset A).
End necset_canonical.

Section necset_lemmas.
Variable A : convType.

Lemma necset_ext (a b : necset A) : a = b :> set _ -> a = b.
Proof.
move: a b => -[a Ha] -[b Hb] /= ?; subst a.
congr NECSet.Pack; exact/Prop_irrelevance.
Qed.

(* TODO: does the Canonical make sense? *)
Canonical neset_hull_necset (T : convType) (F : neset T) :=
  NECSet.Pack (NECSet.Class (CSet.Mixin (hull_is_convex F))
                            (NESet.Mixin (neset_hull_neq0 F))).

(* TODO: does the Canonical make sense? *)
Canonical necset1 (T : convType) (x : T) := Eval hnf in
  @NECSet.Pack _ [set x] (NECSet.Class (CSet.Mixin (is_convex_set1 x))
                                       (NESet.Mixin (set1_neq0 x))).
End necset_lemmas.

Module necset_convType.
Section def.
Variable A : convType.

Definition conv p (X Y : necset A) : necset A := locked
  (NECSet.Pack (NECSet.Class (CSet.Mixin (conv_cset_is_convex p X Y))
                             (NESet.Mixin (conv_set_neq0 p X Y)))).

Lemma convE p (X Y : necset A) : conv p X Y = conv_set p X Y :> set A.
Proof. by rewrite /conv; unlock. Qed.

Lemma conv1 X Y : conv 1%:pr X Y = X.
Proof. by apply necset_ext; rewrite convE conv1_set. Qed.

Lemma convmm p X : conv p X X = X.
Proof. by apply necset_ext; rewrite convE convmm_cset. Qed.

Lemma convC p X Y : conv p X Y = conv p.~%:pr Y X.
Proof. by apply necset_ext; rewrite !convE convC_set. Qed.

Lemma convA p q X Y Z :
  conv p X (conv q Y Z) = conv [s_of p, q] (conv [r_of p, q] X Y) Z.
Proof. by apply necset_ext; rewrite !convE convA_set. Qed.

End def.

Section lemmas.
Local Open Scope classical_set_scope.
Variable A : convType.

(* This lemma is now trivial since we redefined conv directly by conv_set;
   now kept just for compatibility. *)
Lemma conv_conv_set p X Y : conv p X Y = X :<| p |>: Y :> set A.
Proof. by rewrite convE. Qed.

End lemmas.
End necset_convType.

HB.instance Definition necset_convType (A : convType) :=
  @isConvexSpace.Build (necset A) (Choice.class _)
                       (@necset_convType.conv A)
                       (@necset_convType.conv1 A)
                       (@necset_convType.convmm A)
                       (@necset_convType.convC A)
                       (@necset_convType.convA A).

Definition Necset_to_convType (A : convType) :=
  fun phT : phant (Choice.sort A) => necset A.
Local Notation "{ 'necset' T }" := (Necset_to_convType (Phant T)).

Module necset_semiCompSemiLattType.
Section def.
Local Open Scope classical_set_scope.
Variable (A : convType).

Definition pre_op (X : neset {necset A}) : {convex_set A} :=
  CSet.Pack (CSet.Mixin (hull_is_convex (\bigcup_(i in X) idfun i)%:ne)).

Lemma pre_op_neq0 X : pre_op X != set0 :> set _.
Proof. by rewrite hull_eq0 neset_neq0. Qed.

Definition biglub_necset (X : neset (necset A)) : necset A :=
  NECSet.Pack (NECSet.Class
    (CSet.Mixin (hull_is_convex (\bigcup_(i in X) idfun i)%:ne))
    (NESet.Mixin (pre_op_neq0 X))).

Lemma biglub_necset1 x : biglub_necset [set x]%:ne = x.
Proof. by apply necset_ext => /=; rewrite bigcup_set1 hull_cset. Qed.

Lemma biglub_necset_bigsetU (I : Type) (S : neset I) (F : I -> neset (necset A)) :
  biglub_necset (bignesetU S F) = biglub_necset (biglub_necset @` (F @` S))%:ne.
Proof.
apply necset_ext => /=.
apply: hull_eqEsubset => a.
- case => x [] i Si Fix xa.
  exists 1, (fun _ => a), (fdist1 ord0).
  split; last by rewrite ConvnI1E.
  move=> a0 [] zero _ <-.
  exists (biglub_necset (F i)); first by do 2 apply imageP.
  by apply/subset_hull; exists x.
- case => x [] u [] i Si Fiu <-.
  case => n [] g [] d [] /= gx ag.
  exists n, g, d; split => //.
  apply: (subset_trans gx).
  move => a0 [] x0 ux0 x0a0.
  exists x0 => //; exists i => //.
  by rewrite Fiu.
Qed.

Let lub_ (x y : necset A) : necset A := biglub_necset [set x; y]%:ne.

Let lub_E (x y : necset A) : lub_ x y = neset_hull_necset (x `|` y)%:ne.
Proof. by apply necset_ext; rewrite /= bigcup_setU !bigcup_set1. Qed.

Let lub_C : commutative lub_.
Proof.
by move=> x y; congr biglub_necset; apply neset_ext; rewrite /= setUC.
Qed.

Let lub_A : associative lub_.
Proof.
by move=> x y z; rewrite !lub_E; apply necset_ext => /=; exact: hullUA.
Qed.

Let lub_xx : idempotent lub_.
Proof.
by move=> x; rewrite lub_E; apply necset_ext => /=; rewrite setUid hull_cset.
Qed.

#[export]
HB.instance Definition _ := @isSemiLattice.Build (necset A) (Choice.class _)
  lub_ lub_C lub_A lub_xx.

Let lub_E' : forall x y, lub_ x y = biglub_necset [set x; y]%:ne.
Proof. by []. Qed.

#[export]
HB.instance Definition _ (*necset_semiCompSemiLattType*) :=
  @isSemiCompSemiLatt.Build (necset A) (Choice.class _)
    biglub_necset biglub_necset1 biglub_necset_bigsetU lub_E'.

End def.
End necset_semiCompSemiLattType.

HB.export necset_semiCompSemiLattType.

Module necset_semiCompSemiLattConvType.
Section def.
Variable A : convType.
Let L := necset A.

Let biglubDr' (p : prob) (X : L) (I : neset L) :
  necset_convType.conv p X (|_| I) = |_| ((necset_convType.conv p X) @` I)%:ne.
Proof.
apply necset_ext => /=.
rewrite -hull_cset necset_convType.conv_conv_set /= hull_conv_set_strr.
congr hull; rewrite eqEsubset; split=> u /=.
- case=> x Xx [] y []Y IY Yy <-.
  exists (necset_convType.conv p X Y); first by exists Y.
  rewrite necset_convType.conv_conv_set.
  by exists x=> //; exists y.
- case=> _ [] Y IY <-; rewrite necset_convType.convE.
  rewrite convC_set [in X in _ -> X]convC_set.
  by case=> y Yy yXu; exists y=> //; exists Y.
Qed.

Let lubDr' (p : prob) (x y z : L) :
  x <|p|> (y [+] z) = (x <|p|> y) [+] (x <|p|> z).
Proof.
rewrite /conv /=; rewrite lubE biglubDr' lubE; congr (|_| _).
by apply/neset_ext => /=; rewrite image_setU !image_set1.
Qed.

#[export]
HB.instance Definition _ := @isSemiLattConv.Build (necset A) lubDr'.

#[export]
HB.instance Definition _ := @isSemiCompSemiLattConv.Build (necset A) biglubDr'.
End def.

End necset_semiCompSemiLattConvType.
HB.export necset_semiCompSemiLattConvType.

Definition Necset_to_semiCompSemiLattConvType (A : convType) :=
  fun phT : phant (Choice.sort A) => [the semiCompSemiLattConvType of necset A].
Notation "{ 'necset' T }" :=
  (Necset_to_semiCompSemiLattConvType (Phant T)) : convex_scope.

Module necset_join.
Section def.
Local Open Scope classical_set_scope.
Local Open Scope proba_scope.
Definition F (T : Type) := {necset {dist (choice_of_Type T)}}.
Variable T : Type.

Definition L := [the convType of F T].

Definition FFT := F (F T).

Definition F1join0' (X : FFT) : set L := (@Convn_of_fsdist L) @` X.

Lemma F1join0'_convex X : is_convex_set (F1join0' X).
Proof.
apply/asboolP=> x y p [] dx Xdx <-{x} [] dy Xdy <-{y}.
exists (dx <|p|>dy); first by move/asboolP: (convex_setP X); apply.
by rewrite Convn_of_fsdist_affine.
Qed.

Lemma F1join0'_neq0 X : (F1join0' X) != set0.
Proof.
apply/set0P.
case/set0P: (neset_neq0 X) => x Xx.
by exists (Convn_of_fsdist (x : {dist (F T)})), x.
Qed.

Definition L' := necset L.

Definition F1join0 : FFT -> L' := fun X => NECSet.Pack (NECSet.Class
  (CSet.Mixin (F1join0'_convex X)) (NESet.Mixin (F1join0'_neq0 X))).

Definition join1' (X : L')
    : convex_set [the convType of {dist (choice_of_Type T)}] :=
  CSet.Pack (CSet.Mixin (hull_is_convex
    (\bigcup_(i in X) if i \in X then (i : set _) else cset0 _))).

Lemma join1'_neq0 (X : L') : join1' X != set0 :> set _.
Proof.
rewrite hull_eq0 set0P.
case/set0P: (neset_neq0 X) => y.
case/set0P: (neset_neq0 y) => x yx sy.
exists x; exists y => //.
rewrite -in_setE in sy.
by rewrite sy.
Qed.

Definition join1 : L' -> L := fun X =>
  NECSet.Pack (NECSet.Class (CSet.Mixin (hull_is_convex _))
                            (NESet.Mixin (join1'_neq0 X))).
Definition join : FFT -> L := join1 \o F1join0.
End def.
Module Exports.
Definition necset_join := Eval hnf in join.
End Exports.
End necset_join.
Export necset_join.Exports.

Section necset_bind.
Local Open Scope classical_set_scope.
Local Open Scope proba_scope.
Local Open Scope R_scope.
Local Notation M := (necset_join.F).

Section ret.
Variable a : Type.
Definition necset_ret (x : a) : M a := necset1 (fsdist1 (x : choice_of_Type a)).
End ret.

Section fmap.
Variables (a b : Type) (f : a -> b).

Let necset_fmap' (ma : M a) :=
  (fsdistmap (f : choice_of_Type a -> choice_of_Type b)) @` ma.

Lemma necset_fmap'_convex ma : is_convex_set (necset_fmap' ma).
Proof.
apply/asboolP=> x y p [] dx madx <-{x} [] dy mady <-{y}.
exists (dx <| p |> dy); last by rewrite affine_conv.
by move/asboolP: (convex_setP ma); apply.
Qed.

Lemma necset_fmap'_neq0 ma : (necset_fmap' ma) != set0.
Proof.
case/set0P : (neset_neq0 ma) => x max; apply/set0P.
by exists (fsdistmap (f : choice_of_Type a -> choice_of_Type b) x), x.
Qed.

Definition necset_fmap : M a -> M b := fun ma =>
  NECSet.Pack (NECSet.Class (CSet.Mixin (necset_fmap'_convex ma))
                            (NESet.Mixin (necset_fmap'_neq0 ma))).
End fmap.

Section bind.
Variables a b : Type.
Definition necset_bind (ma : M a) (f : a -> M b) : M b :=
  necset_join (necset_fmap f ma).
End bind.
End necset_bind.

Section technical_corollaries.
Variable L : semiCompSemiLattConvType.

Corollary Varacca_Winskel_Lemma_5_6 (Y Z : neset L) :
  hull Y = hull Z -> |_| Y = |_| Z.
Proof.
move=> H; rewrite -[in LHS]biglub_hull -[in RHS]biglub_hull.
by congr (|_| _); apply neset_ext.
Qed.

Corollary Beaulieu_technical_equality (x y : L):
  x [+] y = |_| ((fun p => x <| p |> y) @` probset)%:ne.
Proof.
rewrite lubE -[in LHS]biglub_hull; congr (|_| _); apply neset_ext => /=.
rewrite eqEsubset; split=> i /=.
- have /set0P x0 := set1_neq0 x.
  have /set0P y0 := set1_neq0 y.
  move/(@hull_setU _ _ (necset1 x) (necset1 y) x0 y0).
  by move=> [a /asboolP ->] [b /asboolP ->] [p ->]; exists p.
- by case=> p ? <-; exact/mem_hull_setU.
Qed.

End technical_corollaries.


From fae_gtlc_mu.cast_calculus Require Export types lang consistency.
From fae_gtlc_mu Require Export prelude.
From Coq Require Import List.

Reserved Notation "Γ ⊢ₜ e : τ" (at level 74, e, τ at next level).

(** Typing derivations *)
Inductive typed (Γ : list type) : expr → type → Prop :=
  | Var_typed x τ (pτ : Closed τ) : (Γ !! x = Some τ) → Γ ⊢ₜ Var x : τ
  | Unit_typed : Γ ⊢ₜ Unit : TUnit
  | Pair_typed e1 e2 τ1 τ2 :
     Γ ⊢ₜ e1 : τ1 → Γ ⊢ₜ e2 : τ2 → Γ ⊢ₜ Pair e1 e2 : TProd τ1 τ2
  | Fst_typed e τ1 τ2 : Γ ⊢ₜ e : TProd τ1 τ2 → Γ ⊢ₜ Fst e : τ1
  | Snd_typed e τ1 τ2 : Γ ⊢ₜ e : TProd τ1 τ2 → Γ ⊢ₜ Snd e : τ2
  | InjL_typed e τ1 τ2 (pτ2 : Closed τ2) : Γ ⊢ₜ e : τ1 → Γ ⊢ₜ InjL e : TSum τ1 τ2
  | InjR_typed e τ1 (pτ1 : Closed τ1) τ2 : Γ ⊢ₜ e : τ2 → Γ ⊢ₜ InjR e : TSum τ1 τ2
  | Case_typed e0 e1 e2 τ1 τ2 ρ :
     Γ ⊢ₜ e0 : TSum τ1 τ2 → τ1 :: Γ ⊢ₜ e1 : ρ → τ2 :: Γ ⊢ₜ e2 : ρ →
     Γ ⊢ₜ Case e0 e1 e2 : ρ
  | Lam_typed e τ1 (pτ1 : Closed τ1) τ2 : τ1 :: Γ ⊢ₜ e : τ2 → Γ ⊢ₜ Lam e : TArrow τ1 τ2
  | App_typed e1 e2 τ1 τ2 : Γ ⊢ₜ e1 : TArrow τ1 τ2 → Γ ⊢ₜ e2 : τ1 → Γ ⊢ₜ App e1 e2 : τ2
  | Fold_typed e τ : Γ ⊢ₜ e : τ.[TRec τ/] → Γ ⊢ₜ Fold e : TRec τ
  | Unfold_typed e τ : Γ ⊢ₜ e : TRec τ → Γ ⊢ₜ Unfold e : τ.[TRec τ/]
  (* typing for CAST *)
  | Cast_typed e τi τf (pτf : Closed τf) (pC : consistency_open τi τf) :
      Γ ⊢ₜ e : τi →
      Γ ⊢ₜ Cast e τi τf : τf
  (* typing for BLAME *)
  | CastError_typed τ : Closed τ → Γ ⊢ₜ CastError : τ
where "Γ ⊢ₜ e : τ" := (typed Γ e τ).

From fae_gtlc_mu.cast_calculus Require Export types_lemmas.

(* Our typing derivations are defined such that for any τ, if something is well-typed of type τ, τ is closed (i.e. τ does not contain free variables). *)
Lemma typed_closed {Γ} {e} {τ} : Γ ⊢ₜ e : τ → Closed τ.
Proof.
  intro d. induction d.
  - auto.
  - apply TUnit_Closed.
  - by apply TProd_closed.
  - by eapply TProd_closed1.
  - by eapply TProd_closed2.
  - by eapply TSum_closed.
  - by eapply TSum_closed.
  - auto.
  - by apply TArrow_closed.
  - by eapply TArrow_closed2.
  - by apply closed_Fold_typed_help.
  - by apply TRec_closed_unfold.
  - auto.
  - auto.
Qed.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Rlimit.
Require Export Cbase.
Require Import Ctacfield.
Require Import Cnorm.
Require Import Cprop_base.
Require Import Rsequence.
Require Import Csequence.
Require Import Csequence_facts.
Require Import Cfunctions.

Open Scope C_scope.

(** Definition of the distance in C *)

Definition C_dist a b := Cnorm (a - b).

Lemma C_dist_pos : forall a b, C_dist a b >= 0.
Proof.
intros ; unfold C_dist ; apply Rle_ge ; apply Cnorm_pos.
Qed.

Lemma C_dist_sym : forall a b, C_dist a b = C_dist b a.
Proof.
intros ; unfold C_dist ; rewrite Cnorm_minus_sym ; reflexivity.
Qed.

Lemma C_dist_refl : forall a b, C_dist a b = 0%R <-> a = b.
Proof.
intros a b ; split ; intro H.
 assert (M := Cnorm_0 _ H) ; apply Cminus_diag_uniq ; assumption.
 unfold C_dist ; subst ; unfold Cminus ; rewrite Cadd_opp_r ; apply Cnorm_C0.
Qed.

Lemma C_dist_tri : forall a b c, C_dist a b <= C_dist a c + C_dist c b.
Proof.
intros ; unfold C_dist ; replace (a - b) with ((a - c) + (c - b)) by field ;
 apply Cnorm_triang.
Qed.

Lemma C_dist_plus : forall a b c d, C_dist (a + c) (b + d) <= C_dist a b + C_dist c d.
Proof.
intros a b c d ; unfold C_dist ; replace (a + c - (b+d)) with ((a-b) + (c-d)) by ring ;
 apply Cnorm_triang.
Qed.

Lemma C_dist_eq : forall a b, a = b -> C_dist a b = 0%R.
Proof.
intros ; apply (proj2 (C_dist_refl _ _)) ; assumption.
Qed.

(** C metric space *)

Definition C_met : Metric_Space :=
 Build_Metric_Space C C_dist C_dist_pos C_dist_sym C_dist_refl C_dist_tri.

Definition limit1_in (f:C->C) (D:C -> Prop) (l z:C) : Prop :=
  limit_in C_met C_met f D z l.

Definition Boule (c : C) (r : posreal) (x : C) := dist C_met c x < r.

Definition CVN_r (fn : nat -> C -> C) (r : posreal) := {An : nat -> C &
	{l : R |
	Rseq_cv (fun n : nat => sum_f_R0 (fun k : nat => Cnorm (An k)) n) l /\
	(forall (n : nat) (y : C), Boule 0 r y -> Cnorm (fn n y) <= Cnorm (An n))}}.

(*********)
Definition D_x (D:C -> Prop) (y x:C) : Prop := D x /\ y <> x.

Definition Dgf (Df Dg:C -> Prop) (f:C->C) (z:C) := Df z /\ Dg (f z).

Definition adhDa (D:C -> Prop) (a:C) : Prop := forall alp:R, alp > 0 ->
  exists x, D x /\ C_dist x a < alp.

(** Compatibility of limit with operators *)

(*********)
Lemma single_limit : forall f D l l' x,
	adhDa D x -> limit1_in f D l x -> limit1_in f D l' x ->
	l = l'.
Proof.
unfold limit1_in, limit_in ; intros f D l l' x HD Hl Hl' ;
 cut (forall eps:R, eps > 0 -> dist C_met l l' < eps).
 simpl ; unfold C_dist ; intro Hforall.
 apply Cseq_cv_unique with (fun _ => l).
 apply Cseq_cst_cv.
 intros eps eps_pos ; exists 0%nat ; intros n n_lb ; apply Hforall ; assumption.
 intros eps eps_pos ; assert (eps_2_pos : eps / 2 > 0) by fourier ;
 destruct (Hl (eps / 2)%R eps_2_pos) as (alpha1, [alpha1_pos Halpha1]) ;
 destruct (Hl' (eps / 2)%R eps_2_pos) as (alpha2, [alpha2_pos Halpha2]) ;
 assert (alpha'_pos : Rmin alpha1 alpha2 > 0) by (apply Rmin_pos ; assumption) ;
 destruct (HD (Rmin alpha1 alpha2)%R alpha'_pos) as (x', [Dx' Hx']) ;  clear Hl Hl' HD.
 apply Rle_lt_trans with (Cnorm (l - (f x')) + Cnorm (f x' - l'))%R.
 simpl ; unfold C_dist.
 replace (Cnorm (l - l')) with (Cnorm ((l - f x') + (f x' - l')))
 by (apply Cnorm_eq_compat ; field) ; apply Cnorm_triang.
 apply Rlt_le_trans with (eps / 2 + eps / 2)%R ; [| right ; field] ;
 apply Rlt_trans with (Cnorm (l - f x') + eps / 2)%R.
 apply Rplus_lt_compat_l ; simpl in Halpha2 ; apply Halpha2 ; split ;
 [| apply Rlt_le_trans with (Rmin alpha1 alpha2) ; [| apply Rmin_r]] ; assumption.
 apply Rplus_lt_compat_r ; simpl in Halpha1 ; rewrite Cnorm_minus_sym ;
 apply Halpha1 ; split ; [| apply Rlt_le_trans with (Rmin alpha1 alpha2) ;
 [| apply Rmin_l]] ; assumption.
Qed.

(*********)
Lemma limit_plus : forall (f g:C -> C) (D:C -> Prop) (l l' z:C),
    limit1_in f D l z ->
    limit1_in g D l' z -> limit1_in (fun x:C => f x + g x) D (l + l') z.
Proof.
  intros; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *;
    intros; elim (H (eps * / 2)%R (eps2_Rgt_R0 eps H1));
      elim (H0 (eps * / 2)%R (eps2_Rgt_R0 eps H1)); simpl in |- *;
        clear H H0; intros; elim H; elim H0; clear H H0; intros;
          split with (Rmin x0 x); split.
  apply Rmin_Rgt_r ; split ; assumption.
  intros; elim H4; clear H4; intros;
    cut (C_dist (f x1) l + C_dist (g x1) l' < eps).
  cut (C_dist (f x1 + g x1) (l + l') <= C_dist (f x1) l + C_dist (g x1) l').
  apply Rle_lt_trans.
  apply C_dist_plus.
  elim (Rmin_Rgt_l x0 x (C_dist x1 z) H5); clear H5; intros.
  generalize (H3 x1 (conj H4 H6)); generalize (H0 x1 (conj H4 H5)); intros;
    replace eps with (eps * / 2 + eps * / 2)%R.
  apply Rplus_lt_compat ; assumption.
  apply eps2.
Qed.

(*********)
Lemma limit_opp : forall (f:C -> C) (D:C -> Prop) (l x0:C),
    limit1_in f D l x0 -> limit1_in (fun x:C => - f x) D (- l) x0.
Proof.
  unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
    elim (H eps H0); clear H; intros; elim H; clear H;
      intros; split with x; split; auto; intros; generalize (H1 x1 H2);
        clear H1; intro; unfold C_dist in |- *; unfold Cminus in |- *;
          rewrite (Copp_involutive l); rewrite (Cadd_comm (- f x1) l);
            fold (l - f x1) in |- *; fold (C_dist l (f x1)) in |- *;
              rewrite C_dist_sym; assumption.
Qed.

(*********)
Lemma limit_minus : forall (f g:C -> C) (D:C -> Prop) (l l' x0:C),
    limit1_in f D l x0 ->
    limit1_in g D l' x0 -> limit1_in (fun x:C => f x - g x) D (l - l') x0.
Proof.
  intros; unfold Cminus in |- *; generalize (limit_opp g D l' x0 H0); intro;
    exact (limit_plus f (fun x:C => - g x) D l (- l') x0 H H1).
Qed.

(*********)
Lemma limit_free : forall (f:C -> C) (D:C -> Prop) (x x0:C),
    limit1_in (fun h:C => f x) D (f x) x0.
Proof.
  unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
    split with eps; split; auto; intros; elim (C_dist_refl (f x) (f x));
      intros a b; rewrite (b (refl_equal (f x))); unfold Rgt in H;
        assumption.
Qed.

(*********)
Lemma limit_mul : forall (f g:C -> C) (D:C -> Prop) (l l' x0:C),
    limit1_in f D l x0 ->
    limit1_in g D l' x0 -> limit1_in (fun x:C => f x * g x) D (l * l') x0.
Proof.
  intros f g D l l' z Hf Hg eps eps_pos.
      elim (Hf (Rmin 1 (eps * mul_factor (Cnorm l) (Cnorm l')))
             (mul_factor_gt_f eps (Cnorm l) (Cnorm l') eps_pos)) ;
      elim (Hg (eps * mul_factor (Cnorm l) (Cnorm l'))%R
             (mul_factor_gt eps (Cnorm l) (Cnorm l') eps_pos)) ;
      clear Hf Hg ; simpl ; intros x Hf y Hg ; elim Hf ; elim Hg ;
      clear Hf Hg ; intros y_pos Hx x_pos Hy ; split with (Rmin y x) ;
      split ; [apply Rmin_Rgt_r ; split ; assumption |].
  intros z' [Dz' Hz'] ; unfold C_dist ;  replace (f z' * g z' - l * l') with
      (f z' * (g z' - l') + l' * (f z' - l)).
  cut (Cnorm (f z' * (g z' - l')) + Cnorm (l' * (f z' - l)) < eps).
  cut
    (Cnorm (f z' * (g z' - l') + l' * (f z' - l)) <=
      Cnorm (f z' * (g z' - l')) + Cnorm (l' * (f z' - l))).
  apply Rle_lt_trans.
  apply Cnorm_triang.
  repeat (rewrite Cnorm_Cmult) ;
    cut ((1 + Cnorm l) * (eps * mul_factor (Cnorm l) (Cnorm l'))
          + Cnorm l' * (eps * mul_factor (Cnorm l) (Cnorm l')) <= eps).
  cut (Cnorm (f z') * Cnorm (g z' - l') + Cnorm l' * Cnorm (f z' - l) <
      (1 + Cnorm l) * (eps * mul_factor (Cnorm l) (Cnorm l'))
      + Cnorm l' * (eps * mul_factor (Cnorm l) (Cnorm l'))).
  apply Rlt_le_trans.
  elim (Rmin_Rgt_l y x (C_dist z' z) Hz'); intros Hx2 Hy2.
  apply Rplus_lt_le_compat.
  apply Rmult_ge_0_gt_0_lt_compat.
  apply Rle_ge ; apply Cnorm_pos.
  rewrite Rplus_comm ; unfold Rgt in |- *; apply Rle_lt_0_plus_1;
    apply Cnorm_pos.
  apply Rplus_lt_reg_r with (- Cnorm l)%R.
  rewrite <- Rplus_assoc ; rewrite (Rplus_comm (- Cnorm l) 1).
  rewrite (Rplus_assoc 1 (- Cnorm l) (Cnorm l)) ; rewrite Rplus_opp_l ;
  rewrite (proj1 (Rplus_ne 1)) ; rewrite (Rplus_comm (- Cnorm l) (Cnorm (f z'))) ;
  cut (Cnorm (f z' - l) < 1) ; cut (Cnorm (f z') - Cnorm l <= Cnorm (f z' - l)).
  apply Rle_lt_trans.
  apply Cnorm_triang_rev_l.
  intros _ ; apply Rlt_le_trans with (Rmin 1 (eps * mul_factor (Cnorm l) (Cnorm l'))) ;
  [apply Hx ; split ; assumption | apply Rmin_l].
  apply Cnorm_triang_rev_l.
  apply Hy ; split ; assumption.
  apply Rmult_le_compat.
  apply Cnorm_pos.
  apply Cnorm_pos.
  right ; trivial.
  apply Rlt_le ; apply Rlt_le_trans with (Rmin 1 (eps * mul_factor (Cnorm l) (Cnorm l'))) ;
  [apply Hx | apply Rmin_r] ; split ; assumption.
  rewrite (Rmult_comm (1 + Cnorm l) (eps * mul_factor (Cnorm l) (Cnorm l')));
  rewrite (Rmult_comm (Cnorm l') (eps * mul_factor (Cnorm l) (Cnorm l')));
  rewrite <- (Rmult_plus_distr_l (eps * mul_factor (Cnorm l) (Cnorm l'))
       (1 + Cnorm l) (Cnorm l')) ;
  rewrite (Rmult_assoc eps (mul_factor (Cnorm l) (Cnorm l')) (1 + Cnorm l + Cnorm l'));
  rewrite (Rplus_assoc 1 (Cnorm l) (Cnorm l')).
  unfold mul_factor ; right.
  repeat rewrite Rabs_Cnorm.
  rewrite Rinv_l.
  field.
  apply Rgt_not_eq.
  rewrite Rplus_comm ; apply Rle_lt_0_plus_1 ; apply Rplus_le_le_0_compat ;
  apply Cnorm_pos.
  field.
Qed.

Lemma limit_inv : forall f D l z,
    limit1_in f D l z -> l <> 0 -> limit1_in (fun x => / f x) D (/ l) z.
Proof.
intros f D l z Hf l_neq ; intros eps eps_pos ; elim (Hf ((Cnorm l) / 2)%R).
 intros delta1 [delta1_pos Hdelta1] ; elim (Hf (eps * (Rsqr (Cnorm l) / 2))%R).
 intros delta2 [delta2_pos Hdelta2] ; exists (Rmin delta1 delta2) ; split.
 unfold Rmin ; case (Rle_dec delta1 delta2); intro H ; assumption.
 intro x ; generalize (Hdelta2 x); clear Hdelta2 ; intro Hdelta2 ;
 generalize (Hdelta1 x); clear Hdelta1 ; intro Hdelta1 ; simpl in x.
 intros [Dx xz_bd] ; cut (D x /\ Cnorm (x - z) < delta1).
  cut (D x /\ Cnorm (x - z) < delta2).
  intros H2 H1 ; generalize (Hdelta1 H1) ; clear Hdelta1 ; intro Hdelta1 ;
  generalize (Hdelta2 H2) ; clear Hdelta2 ; intro Hdelta2.
  simpl in * ; unfold C_dist in * ; generalize (Cnorm_triang_rev_l l (f x)) ; intro H ;
  rewrite Cnorm_minus_sym in Hdelta1 ; generalize
  (Rle_lt_trans (Cnorm l - Cnorm (f x)) (Cnorm (l - f x)) (Cnorm l / 2) H Hdelta1) ;
  intro H'.
  generalize (Rplus_lt_compat_l (Cnorm (f x) - Cnorm l / 2) (Cnorm l - Cnorm (f x))
                (Cnorm l / 2) H');
  replace (Cnorm (f x) - Cnorm l / 2 + (Cnorm l - Cnorm (f x)))%R with
                (Cnorm l / 2)%R by field.
  unfold Rminus ; rewrite Rplus_assoc ; rewrite Rplus_opp_l ;
    rewrite Rplus_0_r ; intro H'' ; cut (f x <> 0).
  intro fx_neq ; replace (/ f x - / l) with ((l - f x) * / (l * f x)).
  rewrite Cnorm_Cmult; rewrite Cnorm_inv.
  cut (/ Cnorm (l * f x) < 2 / Rsqr (Cnorm l)).
  intro H3; rewrite Cnorm_minus_sym in Hdelta2; cut (0 <= / Cnorm (l * f x)).
  intro H4 ; generalize
      (Rmult_le_0_lt_compat (Cnorm (l - f x)) (eps * (Rsqr (Cnorm l) / 2))
      (/ Cnorm (l * f x)) (2 / Rsqr (Cnorm l)) (Cnorm_pos ((l - f x))) H4 Hdelta2 H3);
      replace (eps * (Rsqr (Cnorm l) / 2) * (2 / Rsqr (Cnorm l)))%R with eps.
  trivial.
  field ; unfold Rsqr.
  apply Rmult_integral_contrapositive_currified ; apply Cnorm_no_R0 ; assumption.
  left ; apply Rinv_0_lt_compat ; apply Cnorm_pos_lt ;
  apply Cmult_integral_contrapositive_currified ; assumption.
 rewrite Cmult_comm; rewrite Cnorm_Cmult ; rewrite Rinv_mult_distr.
 unfold Rsqr, Rdiv ; rewrite Rinv_mult_distr ; repeat rewrite <- Rmult_assoc.
 apply Rmult_lt_compat_r.
 apply Rinv_0_lt_compat; apply Cnorm_pos_lt; assumption.
 apply Rmult_lt_reg_l with (Cnorm (f x) * Cnorm l * / 2)%R.
 repeat apply Rmult_lt_0_compat ; [| | fourier] ; apply Cnorm_pos_lt; assumption.
 rewrite Rmult_comm ; repeat rewrite <- Rmult_assoc ; rewrite Rinv_l.
 rewrite Rmult_1_l ; repeat rewrite Rmult_assoc ;
 replace (Cnorm l * (/ 2 * (2 * / Cnorm l)))%R with 1%R.
 rewrite Rmult_1_r ; assumption.
 field ; apply Cnorm_no_R0 ; assumption.
 apply Cnorm_no_R0 ; assumption.
 apply Cnorm_no_R0 ; assumption.
 apply Cnorm_no_R0 ; assumption.
 apply Cnorm_no_R0 ; assumption.
 apply Cnorm_no_R0 ; assumption.
 apply Cmult_integral_contrapositive_currified ; assumption.
 field ; split ; assumption.
 apply Cnorm_gt_not_eq ; apply Rlt_gt ; apply Rle_lt_trans with (Cnorm l / 2)%R ;
 [assert (Temp := Cnorm_pos l) ; fourier | assumption].
 split ; [| apply Rlt_le_trans with (Rmin delta1 delta2) ; [| apply Rmin_r]] ; assumption.
 split ; [| apply Rlt_le_trans with (Rmin delta1 delta2) ; [| apply Rmin_l]] ; assumption.
 unfold Rdiv ; repeat apply Rmult_lt_0_compat ; intuition ;
 apply Cnorm_pos_lt ; assumption.
 unfold Rdiv ; repeat apply Rmult_lt_0_compat ; intuition ;
 apply Cnorm_pos_lt ; assumption.
Qed.

Lemma limit_comp : forall f g Df Dg l l' z,
    limit1_in f Df l z -> limit1_in g Dg l' l -> limit1_in (fun z => g (f z)) (Dgf Df Dg f) l' z.
Proof.
  unfold limit1_in, limit_in, Dgf in |- *; simpl in |- *.
  intros f g Df Dg l l' x0 Hf Hg eps eps_pos.
  elim (Hg eps eps_pos).
  intros alpg lg.
  elim (Hf alpg).
  2: tauto.
  intros alpf lf.
  exists alpf.
  intuition.
Qed.


Require Import Coqlib.
Require Import Maps.
Require Import SetoidList.
Require Import Axioms.
Require Import ClassesAndNotations.
Require Import Libs.
Set Implicit Arguments.

(*Definition decidable (P:Prop) := {P} + {~P}.
Definition decidable1 (A:Type) (P:A -> Prop) := forall a, decidable (P a).
Definition decidable2 (A:Type) (P:A -> A -> Prop) := forall a1 a2, decidable (P a1 a2).
Definition semi_decidable (P:Prop) := {P} + {True}.
Definition semi_decidable1 (A:Type) (P:A -> Prop) := forall a, semi_decidable (P a).
Definition semi_decidable2 (A:Type) (P:A -> A -> Prop) := forall a1 a2, semi_decidable (P a1 a2).
*)

Module Type ISET (X:EQUALITY_TYPE).
  Definition elt := X.t.
  Definition eq_elt (t1 t2 : elt) := t1 = t2.
(*  Definition eq_elt := @Logic.eq elt.
  Variable deq_elt: forall e1 e2: elt, decidable (e1 = e2).
  Notation "x =? y" := (deq_elt x y) (at level 70, no associativity).*)
  Variable t:Type.
  Variable empty: t.

  Variable mem: elt -> t -> bool.
  Definition In x s : Prop :=
    mem x s = true.

  Declare Instance EqA_t : EqA t.

  Declare Instance EqASDec_t : EqASDec t.

  Notation "s [<=] t" :=
    (forall x : elt, In x s -> In x t) (at level 70, no associativity).

  Definition included s t := s [<=] t.

  Hypothesis mem_1 : forall x s, In x s -> mem x s = true.
  Hypothesis mem_2 : forall x s, mem x s = true -> In x s.

  Variable add: elt -> t -> t.
(*  Variable remove_force: elt -> t -> t.*)
  Variable remove: elt -> t -> t.
  Hypothesis  mempty:
    forall x, ~ In x empty.

  Hypothesis mas:
    forall x s, In x (add x s).
  Hypothesis add_1:
    forall x s, In x (add x s).
  Hypothesis mao:
    forall x y s, x <> y -> mem x (add y s) = mem x s.
  Hypothesis add_2: forall y s, s [<=] add y s.
  Hypothesis add_3:
    forall x y s, x <> y -> In y (add x s) -> In y s.
  Hypothesis add_iff :
    forall x y s,
      In y (add x s) <-> x = y \/ In y s.
  Hypothesis not_mem_iff :forall x s,  ~In x s <-> mem x s = false.
  Hypothesis maspec:
    forall x y s,
      mem x (add y s) = if x == y then true else mem x s.

  Hypothesis maident:
    forall x s, In x s -> add x s = s.

  Hypothesis rempty: forall x, remove x empty = empty.
(*  Hypothesis rfempty: forall x, remove_force x empty = empty.*)
  Hypothesis mrs:
    forall x s, mem x (remove x s) = false.
  Hypothesis mro:
    forall x y s, x <> y -> mem x (remove y s) = mem x s.
(*  Hypothesis mrfs:
    forall x s, mem x (remove_force x s) = false.
  Hypothesis mrfo:
    forall x y s, x <> y -> mem x (remove_force y s) = mem x s.
  Hypothesis mrfspec:
    forall x y s,
      mem x (remove_force y s) = if x == y then false else mem x s.*)
  Hypothesis mrspec:
    forall x y s,
      mem x (remove y s) = if x == y then false else mem x s.
  Hypothesis remove_1 : forall x s, ~ In x (remove x s).
  Hypothesis remove_2 : forall x y s, x <> y -> In y s -> In y (remove x s).
  Hypothesis remove_3 : forall x s, remove x s [<=] s.

  (* extensional equality *)
  Definition exteq s1 s2 : Prop := s1 ≡ s2.

  Variable bempty: t -> bool.

  Hypothesis bempty_correct: forall s, bempty s = true -> (forall x, ~In x s).

  Definition beq s t := s ≡? t.

  Variable elements: t -> list elt.
  Hypothesis elements_correct:
    forall s x, In x s -> List.In x (elements s).
  Hypothesis elements_1 : forall x s, In x s -> InA eq_elt x (elements s).
  Hypothesis elements_complete:
    forall s x, List.In x (elements s) -> In x s.
  Hypothesis elements_2 :
    forall x s,
      InA eq_elt x (elements s) -> In x s.

  Hypothesis elements_norepet:
  forall s, list_norepet (elements s).

  Variable fold: forall (A: Type), (elt -> A -> A) -> t -> A -> A.

  Hypothesis fold_spec:
    forall (A:Type) (f : elt -> A -> A) s (a : A),
      fold f s a =
        List.fold_left (fun a x => f x a) (elements s) a.
  Definition fold_1 := fold_spec.
  Variable union: t -> t -> t.

  Parameter union_1 : forall s s' x, In x (union s s') -> In x s \/ In x s'.
  Parameter union_2 : forall s s' x, In x s -> In x (union s s').
  Parameter union_3 : forall s s' x, In x s' -> In x (union s s').

  Hypothesis included_trans: forall s2 s1 s3,
    s1 [<=] s2 -> s2 [<=] s3 -> s1 [<=] s3.

  Hypothesis subset_add_2 : forall x s1 s2, s1 [<=] s2 -> s1 [<=] (add x s2).

  Hypothesis subset_refl: forall s, s [<=] s.

  Definition for_all f s := List.forallb f (elements s).
  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.

  Hypothesis for_all_1 : forall f s,
    For_all (fun x => f x = true) s -> for_all f s = true.

  Hypothesis for_all_2 :
    forall f s,
      for_all f s = true -> For_all (fun x => f x = true) s.

End ISET.

Module PSet <: ISET(PosEqDec).
  Definition elt := positive.
  Definition eq_elt (t1 t2: elt) := t1 = t2.

  Definition t := PTree.t unit.
  Implicit Types x y: positive.
  Implicit Types s: t.

  Definition empty:t := PTree.empty unit.
  Definition mem x s :=
    match PTree.get x s with
      | None => false
      | Some _ => true
    end.

  Definition In x s : Prop :=
    mem x s = true.
  Instance EqA_t : EqA t := {
    eqA := fun s t => (forall x : elt, In x s <-> In x t)}.
  Proof.
    prove_equiv; unfold In; intros; try tauto; dintuition.
    edestruct H; eauto. edestruct H; eauto.
    assert (mem x0 y = true). edestruct H; eauto.
    edestruct H0; eauto.
    assert (mem x0 y = true). edestruct H0; eauto.
    edestruct H; eauto.
  Defined.

  Notation "s [<=] t" := (forall x : elt, In x s -> In x t) (at level 70, no associativity).

  Definition included s t := s [<=] t.

  Lemma mem_1 : forall x s, In x s -> mem x s = true. Proof. auto. Qed.
  Lemma mem_2 : forall x s, mem x s = true -> In x s.  Proof. auto. Qed.

  Definition add x s : t:=
    if mem x s then s else
    PTree.set x tt s.

  Definition remove_force x s : t :=
    PTree.remove_force x s.

  Definition remove x s :=
    if mem x s then remove_force x s else s.

  Hint Unfold In empty mem add remove: pset.
  Hint Rewrite PTree.gempty PTree.gss PTree.gso PTree.grs PTree.gro
    PTree.bempty_correct PTree.elements_complete
    using (auto; congruence): ptree.

  Ltac solve_simpl:=
    repeat match goal with
             | |- context[add ?x ?s] =>
               unfold add; case_eq (mem x s); intro MEM
             | |- _ => intro
           end;
    unfold In, mem, add, remove, remove_force, empty in *; simpl in *;
    autorewrite with ptree in *; simpl in *; auto; try congruence.

  Theorem mempty:
    forall x, ~ In x empty.
  Proof.
    solve_simpl.
  Qed.

  Theorem mempty_false:
    forall x, mem x empty = false.
  Proof.
    solve_simpl.
  Qed.

  Theorem mas:
    forall x s, In x (add x s).
  Proof.
    solve_simpl.
  Qed.

  Definition add_1 := mas.

  Theorem mao:
    forall x y s, x <> y -> mem x (add y s) = mem x s.
  Proof.
    solve_simpl.
  Qed.

  Theorem add_2:
    forall y s, s [<=] add y s.
  Proof.
    solve_simpl.
    dest x == y. subst. rewrite H in MEM. inv MEM.
    solve_simpl.
  Qed.
  Theorem add_3:
    forall x y s, x <> y -> In y (add x s) -> In y s.
  Proof.
    solve_simpl.
  Qed.

  Theorem add_iff :
    forall x y s,
      In y (add x s) <-> x = y \/ In y s.
  Proof.
    intros x y s. split; intro.
    destruct (x == y).
    auto.
    right. eapply add_3; eauto.
    destruct H. subst. apply mas.
    apply add_2; auto.
  Qed.

  Lemma not_mem_iff :forall x s,  ~In x s <-> mem x s = false.
  Proof.
    intros. unfold In. split; intro H;
    destruct (mem x s); congruence.
  Qed.

  Hint Resolve mempty mas mao: pset.

  Theorem maspec:
    forall x y s,
      mem x (add y s) = if x == y then true else mem x s.
  Proof.
    intros x y s.
    destruct (x == y); subst; auto with pset. apply mas.
  Qed.

  Theorem maident:
    forall x s, In x s -> add x s = s.
  Proof.
    solve_simpl.
  Qed.

  Lemma rfempty: forall x, remove_force x empty = empty.
  Proof.
    unfold remove_force; intros. unfold empty.
    unfold PTree.remove_force, PTree.empty.
    destruct x; reflexivity.
  Qed.

  Lemma rempty: forall x, remove x empty = empty.
  Proof.
    unfold remove. intro x. rewrite mempty_false. reflexivity.
  Qed.

  Theorem mrfs:
    forall x s, mem x (remove_force x s) = false.
  Proof.
    unfold remove_force. unfold mem.
    intros x s. rewrite PTree.remove_force_same.
    solve_simpl.
  Qed.

  Theorem mrs:
    forall x s, mem x (remove x s) = false.
  Proof.
    unfold remove. intros x s.
    case_eq (mem x s); intro MEM; try congruence.
    apply mrfs.
  Qed.

  Theorem mrfo:
    forall x y s, x <> y -> mem x (remove_force y s) = mem x s.
  Proof.
    intros x y s H. unfold remove_force, mem.
    rewrite PTree.remove_force_same.
    solve_simpl.
  Qed.

  Theorem mro:
    forall x y s, x <> y -> mem x (remove y s) = mem x s.
  Proof.
    unfold remove; intros.
    case_eq (mem y s); intro MEM; auto.
    apply mrfo. auto.
  Qed.

  Hint Resolve maspec maident rempty mrs mro mrfo mrfs: pset.
  Lemma mrfspec:
    forall x y s,
      mem x (remove_force y s) = if x == y then false else mem x s.
  Proof.
    intros.
    destruct (x == y); subst; auto with pset.
  Qed.

  Theorem mrspec:
    forall x y s,
      mem x (remove y s) = if x == y then false else mem x s.
  Proof.
    intros.
    destruct (x == y); subst; auto with pset.
  Qed.

  Lemma remove_1 : forall x s, ~ In x (remove x s).
  Proof.
    intros x s. unfold In. rewrite mrs. auto.
  Qed.

  Lemma remove_2 : forall x y s, x <> y -> In y s -> In y (remove x s).
  Proof.
    unfold In.
    intros x y s H H0. rewrite mro; auto.
  Qed.

  Lemma remove_3 : forall x s, remove x s [<=] s.
  Proof.
    unfold In.
    intros x s y H.
    erewrite mro in H; eauto.
    intro. subst.
    rewrite mrs in H. inv H.

  Qed.

  (* extensional equality *)

  Definition exteq s1 s2 : Prop := s1 ≡ s2.

  Definition bempty s := PTree.bempty s.

  Lemma bempty_correct: forall s, bempty s = true ->
    (forall x, ~In x s).
  Proof.
    solve_simpl.
  Qed.

  Section EQDEC.
    Instance EqA_unit: EqA unit :=
    {eqA := @Logic.eq _}.

    Instance EqADec_unit: EqADec unit.
    Proof.
      constructor.
      intros.
      left. unfold eqA. simpl. destruct x; destruct y; auto.
    Defined.

    Global Instance EqASDec_t : EqASDec t.
    Proof.
      constructor.
      intros x y.

      dest x ≡? y.
      left.
      unfold eqA in *. simpl in *.
      intros x0.
      unfold PTree.exteq in EQ. specialize (EQ x0).
      unfold In, mem.
      split;
      destruct (x ! x0); destruct (y ! x0); auto.
      right; auto.
    Defined.

    Definition beq s1 s2 := s1 ≡? s2.

    (*  Definition const_true (_ _:X.t) := true.
       Definition beq_t_ : t_ -> t_ -> bool := PTree.beq const_true.
       Definition beq_aux t1 t2 := beq_t_ t1.(m) t2.(m).*)

(*  Lemma beq_aux_correct:
    forall s1 s2, beq_aux s1 s2 = true -> exteq s1 s2.
  Proof.
    unfold beq_aux, exteq, beq_t_, In, mem.
    intros s1 s2 HBEQ.
    destruct s1 as [s1 CORR1].
    destruct s2 as [s2 CORR2].
    simpl in *.
    intros x.
    pose proof (@PTree.beq_correct elt (fun _ _ => True) const_true) as BC.
    unfold PTree.exteq in BC.
    assert (forall x y : elt, const_true x y = true -> True) as TRIV by auto.
    specialize (BC TRIV s1 s2 HBEQ (X.index x)). clear TRIV.
    case_eq (s1 ! (X.index x)); case_eq (s2 ! (X.index x)); intros; rewrite H in *;
      rewrite H0 in *; tauto.
  Qed.

  Lemma beq: semi_decidable2 exteq.
  Proof. unfold semi_decidable2, semi_decidable.
    intros t1 t2.
    case_eq (beq_aux t1 t2); intro BEQ.
    left. apply beq_aux_correct. trivial.
    right. apply I.
  Qed.
*)

  Definition elements s:= List.map fst (PTree.elements s).

  Theorem elements_correct:
    forall s x, In x s -> List.In x (elements s).
  Proof.
    unfold elements.
    unfold In, mem.
    intros s x IN.
    assert (s ! x = Some tt).
    destruct (s ! x). destruct u; reflexivity. inv IN.
    pose proof (PTree.elements_correct _ _ H).
    replace x with (fst (x, tt)); auto.
    apply List.in_map. auto.
  Qed.

  Theorem elements_complete:
    forall s x, List.In x (elements s) -> In x s.
  Proof.
    unfold elements.
    unfold In, mem.
    intros s x IN.
    replace x with (fst (x, tt)) in IN by auto.
    rewrite PTree.elements_complete with (v := tt). reflexivity.
    rewrite List.in_map_iff in IN.
    destruct IN as [[a b] [? ?]].
    destruct b. simpl in H. subst. auto.
  Qed.

  Theorem elements_norepet:
    forall s, list_norepet (elements s).
  Proof.
    unfold elements. apply PTree.elements_keys_norepet.
  Qed.

  Lemma elements_1 :  forall x s, In x s -> InA eq_elt x (elements s).
  Proof.
    intros x s H. apply In_InA. unfold eq_elt. dintuition congruence.

    apply elements_correct. auto.
  Qed.

  Lemma elements_2 :
    forall x s,
      InA eq_elt x (elements s) -> In x s.
  Proof.
    unfold eq_elt.
    intros x s H. apply elements_complete.
    rewrite InA_alt in H.
    destruct H as [j [? ?]].
    subst. auto.
  Qed.

  Definition f_union :=
    fun (oa ob: option unit) =>
      match oa, ob with
        | None,  None => None
        | Some x, _
        | None, Some x=> Some x
      end.

  Program Definition union (m1 m2: t) :=
    PTree.combine_eqdec f_union m1 m2.

  Lemma union_1 : forall s s' x, In x (union s s') -> In x s \/ In x s'.
  Proof.
    assert (f_union None None = None) as fNNN by reflexivity.
    unfold union, In, mem.
    intros s s' x H.
    pose proof (PTree.gcombine_eqdec f_union fNNN s s' x).
    destruct ((PTree.combine_eqdec f_union s s') ! x); try congruence.
    destruct (s ! x); destruct (s' ! x); simpl in H0; auto.
  Qed.

  Lemma union_2 : forall s s' x, In x s -> In x (union s s').
  Proof.
    assert (f_union None None = None) as fNNN by reflexivity.
    unfold union, In, mem.
    intros s s' x H.
    pose proof (PTree.gcombine_eqdec f_union fNNN s s' x).
    destruct ((PTree.combine_eqdec f_union s s') ! x); try congruence.
    destruct (s ! x); destruct (s' ! x); simpl in H0; auto.
  Qed.
  Lemma union_3 : forall s s' x, In x s' -> In x (union s s').
  Proof.
    assert (f_union None None = None) as fNNN by reflexivity.
    unfold union, In, mem.
    intros s s' x H.
    pose proof (PTree.gcombine_eqdec f_union fNNN s s' x).
    destruct ((PTree.combine_eqdec f_union s s') ! x); try congruence.
    destruct (s ! x); destruct (s' ! x); simpl in H0; auto.
  Qed.

  End EQDEC.

  (*Proof.
     apply PTree.elements_keys_norepet.
     Qed.*)

  Definition fold (A:Type) (f : elt -> A -> A) s (a : A) :=
    PTree.fold (fun a' x _ => f x a') s a.

  Theorem fold_spec:
    forall (A:Type) (f : elt -> A -> A) s (a : A),
      fold f s a =
        List.fold_left (fun a x => f x a) (elements s) a.
  Proof.
    intros. unfold fold, elements.
    rewrite PTree.fold_spec. unfold elt in *.
    remember (@PTree.elements unit s) as elts. clear Heqelts.
    generalize dependent a.
    induction elts; intros; simpl; auto.
  Qed.

  Definition fold_1 := fold_spec.

  Lemma included_trans: forall s2 s1 s3,
    s1 [<=] s2 -> s2 [<=] s3 -> s1 [<=] s3.
  Proof.
    unfold In. auto.
  Qed.

  Lemma subset_add_2 : forall x s1 s2,  s1 [<=] s2 -> s1 [<=] (add x s2).
  Proof.
    unfold included, In.
    intros x s1 s2 H.
    intros i0 H0.
    dest i0 == x; subst.
    apply mas.
    rewrite mao; auto.
  Qed.

  Lemma subset_refl: forall s, s [<=] s.
  Proof. auto. Qed.

  Definition for_all f s := List.forallb f (elements s).
  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.

  Lemma for_all_1 : forall f s,
    For_all (fun x => f x = true) s -> for_all f s = true.
  Proof.
    unfold for_all, For_all.
    intros f s FORALL.
    rewrite forallb_forall.
    intros x IN. apply elements_complete in IN. auto.
  Qed.

  Lemma for_all_2 :
    forall f s,
      for_all f s = true -> For_all (fun x => f x = true) s.
    unfold for_all, For_all.
    intros f s FORALL.
    rewrite forallb_forall in FORALL.
    intros x IN. apply elements_correct in IN. auto.
  Qed.

End PSet.
(*
Module Indexed_Pos <: INDEXED_TYPE.
  Definition t := positive.
  Definition index (p:t) := p.
  Lemma index_inj
    : forall (x y: t), index x = index y -> x = y.
  Proof. auto. Qed.
  Definition eq := peq.
End Indexed_Pos.

Module PSet := ISet(Indexed_Pos).

Module PosPair (IS:ISET) <: ISET with Definition elt := (positive * IS.elt)%type.
  Definition elt := (positive * IS.elt)%type.
  Definition eq_elt := @Logic.eq elt.
  Lemma deq_elt: forall e1 e2: elt, decidable (e1 = e2).
  Proof.
    intros. unfold decidable.
    decide equality.
    apply IS.deq_elt.
    apply peq.
  Qed.

  Notation "x == y" := (deq_elt x y) (at level 70, no associativity).

  Definition t := (PTree.t IS.t).

  Implicit Types x y: elt.
  Implicit Types s: t.

  Definition empty: t := PTree.empty _.

  Definition mem (x: elt) (s:t) :=
    match PTree.get (fst x) s with
      | None => false
      | Some s' => IS.mem (snd x) s'
    end.

  Definition In x s : Prop :=
    mem x s = true.

  Notation "s [=] t" := (forall x : elt, In x s <-> In x t) (at level 70, no associativity).
  Notation "s [<=] t" := (forall x : elt, In x s -> In x t) (at level 70, no associativity).

  Definition included s t := s [<=] t.

  Lemma mem_1 : forall x s, In x s -> mem x s = true. Proof. auto. Qed.
  Lemma mem_2 : forall x s, mem x s = true -> In x s. Proof. auto. Qed.

  Definition add (x:elt) (s:t) :=
    match PTree.get (fst x) s with
      | None => PTree.set (fst x) (IS.add (snd x) IS.empty) s
      | Some s' =>
        if IS.mem (snd x) s' then s else
          PTree.set (fst x) (IS.add (snd x) s') s
    end.

  Definition remove x s :=
    match PTree.get (fst x) s with
      | None => s
      | Some s' =>
        if IS.mem (snd x) s' then
          let s'' := IS.remove (snd x) s' in
          if IS.bempty s'' then
            PTree.remove (fst x)  s
          else
            PTree.set (fst x) s'' s
        else
          s
    end.

  Hint Unfold In empty mem add remove: pset.
  Hint Rewrite PTree.gempty PTree.gss PTree.gso PTree.grs PTree.gro PTree.grfs PTree.grfo
    PTree.bempty_correct PTree.elements_complete
    using (auto; congruence): ptree.

  Ltac solve_simpl:=
    repeat match goal with
             | |- context[add ?x ?s] =>
               unfold add; case_eq (mem x s); intro MEM
             | |- _ => intro
           end;
    unfold In, mem, add, remove, empty in *; simpl in *;
    autorewrite with ptree in *; simpl in *;
      eauto using IS.mempty, IS.mas, IS.add_1, IS.mao, IS.add_2, IS.add_3; try congruence.

  Lemma mempty:
    forall x, ~ In x empty.
  Proof.
    solve_simpl.
  Qed.

  Axiom mas:
    forall x s, In x (add x s).

  Axiom add_1:
    forall x s, In x (add x s).
  Axiom mao:
    forall x y s, x <> y -> mem x (add y s) = mem x s.
  Axiom add_2: forall y s, s [<=] add y s.
  Axiom add_3:
    forall x y s, x <> y -> In y (add x s) -> In y s.
  Axiom add_iff :
    forall x y s,
      In y (add x s) <-> x = y \/ In y s.
  Axiom not_mem_iff :forall x s,  ~In x s <-> mem x s = false.
  Axiom maspec:
    forall x y s,
      mem x (add y s) = if x == y then true else mem x s.

  Axiom maident:
    forall x s, In x s -> add x s = s.

  Axiom rempty: forall x, remove x empty = empty.
(*  Axiom rfempty: forall x, remove_force x empty = empty.*)
  Axiom mrs:
    forall x s, mem x (remove x s) = false.

  Axiom mro:
    forall x y s, x <> y -> mem x (remove y s) = mem x s.
(*  Axiom mrfs:
    forall x s, mem x (remove_force x s) = false.
  Axiom mrfo:
    forall x y s, x <> y -> mem x (remove_force y s) = mem x s.
  Axiom mrfspec:
    forall x y s,
      mem x (remove_force y s) = if x == y then false else mem x s.*)
  Axiom mrspec:
    forall x y s,
      mem x (remove y s) = if x == y then false else mem x s.
  Axiom remove_1 : forall x s, ~ In x (remove x s).
  Axiom remove_2 : forall x y s, x <> y -> In y s -> In y (remove x s).
  Axiom remove_3 : forall x s, remove x s [<=] s.

  (* extensional equality *)
  Definition exteq s1 s2 : Prop := s1 [=] s2.

  Definition bempty s := PTree.bempty s.

  Axiom bempty_correct: forall s, bempty s = true -> (forall x, ~In x s).

  Definition beq_b s1 s2 :=
    PTree.beq IS.beq s1 s2.

  Lemma beq: semi_decidable2 exteq.
  Proof.
    unfold semi_decidable2.
    intros s1 s2. case_eq (beq_b s1 s2); intro BEQ.
    unfold beq_b in BEQ.
    assert (forall ss1 ss2, (if IS.beq ss1 ss2 then true else false) = true -> IS.exteq ss1 ss2).
    intros ss1 ss2 H. destruct (IS.beq ss1 ss2). auto. inv H.
    pose proof (PTree.beq_correct IS.exteq _ H _ _ BEQ) as BEQ_CORR.

    unfold PTree.exteq in BEQ_CORR.

    left. unfold exteq. unfold In. unfold mem. intros [a b]. simpl.
    specialize (BEQ_CORR a). unfold IS.exteq in BEQ_CORR. unfold IS.In in BEQ_CORR.
    destruct (s1 ! a); destruct (s2!a); auto; try solve [inv BEQ_CORR]. dintuition.
    right; auto.
  Qed.

  Notation "s [?=] t" := (beq s t) (at level 70, no associativity).

  Definition elements s :=
    List.fold_right
      (fun pss l =>
        let '(p, ss) := pss in
        (List.map (fun e => (p, e)) (IS.elements ss)) ++ l) nil (PTree.elements s).

  Axiom elements_correct:
    forall s x, In x s -> List.In x (elements s).
  Axiom elements_1 : forall x s, In x s -> InA eq_elt x (elements s).
  Axiom elements_complete:
    forall s x, List.In x (elements s) -> In x s.
  Axiom elements_2 :
    forall x s,
      InA eq_elt x (elements s) -> In x s.

  Axiom elements_norepet:
  forall s, list_norepet (elements s).

  Definition fold (A:Type) (f: elt -> A -> A) s a :=
    PTree.fold (fun acc p ss =>
      IS.fold (fun e acc' => f (p, e) acc') ss acc) s a.

  Axiom fold_spec:
    forall (A:Type) (f : elt -> A -> A) s (a : A),
      fold f s a =
        List.fold_left (fun a x => f x a) (elements s) a.
  Definition fold_1 := fold_spec.

  Definition union s1 s2 :=
    PTree.combine_eq_dec IS.exteq IS.beq
    (fun oss1 oss2 =>
      match oss1, oss2 with
        | None, None => None
        | Some ss, None
        | None, Some ss => Some ss
        | Some ss1, Some ss2 => Some (IS.union ss1 ss2)
      end) s1 s2.

  Axiom included_trans: forall s2 s1 s3,
    s1 [<=] s2 -> s2 [<=] s3 -> s1 [<=] s3.

  Axiom subset_add_2 : forall x s1 s2, s1 [<=] s2 -> s1 [<=] (add x s2).

  Axiom subset_refl: forall s, s [<=] s.

  Definition for_all f s := List.forallb f (elements s).
  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.

  Axiom for_all_1 : forall f s,
    For_all (fun x => f x = true) s -> for_all f s = true.

  Axiom for_all_2 :
    forall f s,
      for_all f s = true -> For_all (fun x => f x = true) s.

End PosPair.

(*Module IndexedPair (IT1:INDEXED_TYPE)(IT2:INDEXED_TYPE).
  Definition t := (IT1.t * IT2.t)%type.
  Fixpoint prep_concat p1 p2 :=
    match p1 with
      | xH => xO (xO p2)
      | (xO p1') => xO (xI (prep_concat p1' p2))
      | (xI p1') => xI (prep_concat p1' p2)
    end.
  Definition index (p:t) :=
    let '(x1, x2) := p in
    prep_concat (IT2.index x2) (IT1.index x1).

  Lemma eq: forall (p1 p2:t), {p1 = p2}+{p1 <> p2}.
  Proof.
    intros. decide equality. apply IT2.eq. apply IT1.eq.
  Qed.

  Lemma prep_concat_correct: forall i1 j1 i2 j2,
    prep_concat i1 j1 = prep_concat i2 j2 ->
    i1 = i2 /\ j1 = j2.
  Proof.
    induction i1; simpl; intros j1 i2 j2 HEQ.
    destruct i2; simpl in HEQ; try congruence.
    inv HEQ.  destruct (IHi1 _ _ _ H0). split; congruence.
    destruct i2; simpl in HEQ; try congruence.
    inv HEQ.  destruct (IHi1 _ _ _ H0). split; congruence.
    destruct i2; simpl in HEQ; try congruence.
    inv HEQ. split; congruence.
  Qed.

  Lemma index_inj:
    forall p1 p2, index p1 = index p2 -> p1 = p2.
  Proof.
    intros [x1 y1] [x2 y2] HEQ.
    unfold index in HEQ.
    pose proof (prep_concat_correct _ _ _ _ HEQ).
    destruct H. apply IT2.index_inj in H. apply IT1.index_inj in H0.
    congruence.
  Qed.
End IndexedPair.*)*)