From Coq Require Import QArith.
From Coq.micromega Require Import OrderedRing RingMicromega.
From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint.
From mathcomp.zify Require Import ssrZ zify.

Import Order.TTheory GRing.Theory Num.Theory.

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

Local Open Scope ring_scope.

Implicit Types (R : ringType) (F : fieldType).

(* Some basic facts about `Decimal.uint` and `Hexadecimal.uint`               *)

Fixpoint N_of_uint_acc (d : Decimal.uint) (acc : N) : N :=
  match d with
  | Decimal.Nil => acc
  | Decimal.D0 d => N_of_uint_acc d (acc * 10)
  | Decimal.D1 d => N_of_uint_acc d (acc * 10 + 1)
  | Decimal.D2 d => N_of_uint_acc d (acc * 10 + 2)
  | Decimal.D3 d => N_of_uint_acc d (acc * 10 + 3)
  | Decimal.D4 d => N_of_uint_acc d (acc * 10 + 4)
  | Decimal.D5 d => N_of_uint_acc d (acc * 10 + 5)
  | Decimal.D6 d => N_of_uint_acc d (acc * 10 + 6)
  | Decimal.D7 d => N_of_uint_acc d (acc * 10 + 7)
  | Decimal.D8 d => N_of_uint_acc d (acc * 10 + 8)
  | Decimal.D9 d => N_of_uint_acc d (acc * 10 + 9)
  end.

Lemma N_of_uint_accE (d : Decimal.uint) (acc : positive) :
  N.pos (Pos.of_uint_acc d acc) = N_of_uint_acc d (N.pos acc).
Proof.
by elim: d acc => // d IHd acc; rewrite IHd 1?Pos.add_comm Pos.mul_comm.
Qed.

Definition N_of_uint : Decimal.uint -> N := N_of_uint_acc ^~ 0%num.

Lemma N_of_uintE : N.of_uint =1 N_of_uint.
Proof.
rewrite /N.of_uint /Pos.of_uint /N_of_uint /=.
by elim => //= d _; rewrite N_of_uint_accE.
Qed.

Lemma uint_N_nat (d : Decimal.uint) : nat_of_N (N.of_uint d) = Nat.of_uint d.
Proof.
rewrite N_of_uintE /N_of_uint /Nat.of_uint.
have ->: 0%N = nat_of_N 0%num by [].
by elim: d 0%num => //= d IHd acc; rewrite IHd Nat.tail_mul_spec;
  congr Nat.of_uint_acc; lia.
Qed.

Fixpoint N_of_hex_uint_acc (d : Hexadecimal.uint) (acc : N) : N :=
  match d with
  | Hexadecimal.Nil => acc
  | Hexadecimal.D0 d => N_of_hex_uint_acc d (acc * 16)
  | Hexadecimal.D1 d => N_of_hex_uint_acc d (acc * 16 + 1)
  | Hexadecimal.D2 d => N_of_hex_uint_acc d (acc * 16 + 2)
  | Hexadecimal.D3 d => N_of_hex_uint_acc d (acc * 16 + 3)
  | Hexadecimal.D4 d => N_of_hex_uint_acc d (acc * 16 + 4)
  | Hexadecimal.D5 d => N_of_hex_uint_acc d (acc * 16 + 5)
  | Hexadecimal.D6 d => N_of_hex_uint_acc d (acc * 16 + 6)
  | Hexadecimal.D7 d => N_of_hex_uint_acc d (acc * 16 + 7)
  | Hexadecimal.D8 d => N_of_hex_uint_acc d (acc * 16 + 8)
  | Hexadecimal.D9 d => N_of_hex_uint_acc d (acc * 16 + 9)
  | Hexadecimal.Da d => N_of_hex_uint_acc d (acc * 16 + 10)
  | Hexadecimal.Db d => N_of_hex_uint_acc d (acc * 16 + 11)
  | Hexadecimal.Dc d => N_of_hex_uint_acc d (acc * 16 + 12)
  | Hexadecimal.Dd d => N_of_hex_uint_acc d (acc * 16 + 13)
  | Hexadecimal.De d => N_of_hex_uint_acc d (acc * 16 + 14)
  | Hexadecimal.Df d => N_of_hex_uint_acc d (acc * 16 + 15)
  end.

Lemma N_of_hex_uint_accE (d : Hexadecimal.uint) (acc : positive) :
  N.pos (Pos.of_hex_uint_acc d acc) = N_of_hex_uint_acc d (N.pos acc).
Proof.
by elim: d acc => // d IHd acc; rewrite IHd 1?Pos.add_comm Pos.mul_comm.
Qed.

Definition N_of_hex_uint : Hexadecimal.uint -> N := N_of_hex_uint_acc ^~ 0%num.

Lemma N_of_hex_uintE : N.of_hex_uint =1 N_of_hex_uint.
Proof.
rewrite /N.of_hex_uint /Pos.of_hex_uint /N_of_hex_uint /=.
by elim => //= d _; rewrite N_of_hex_uint_accE.
Qed.

Lemma hex_uint_N_nat (d : Hexadecimal.uint) :
  nat_of_N (N.of_hex_uint d) = Nat.of_hex_uint d.
Proof.
rewrite N_of_hex_uintE /N_of_hex_uint /Nat.of_hex_uint.
have ->: 0%N = nat_of_N 0%num by [].
by elim: d 0%num => //= d IHd acc; rewrite IHd Nat.tail_mul_spec;
  congr Nat.of_hex_uint_acc; lia.
Qed.

(* In reified syntax trees, constants must be represented by binary integers  *)
(* `N` and `Z`. For the fine-grained control of conversion, we provide        *)
(* immediately expanding versions of `N -> nat`, `Z -> int`, and `N -> Z`     *)
(* conversions.                                                               *)

Definition addn_expand := Eval compute in addn.

Fixpoint nat_of_pos_rec_expand (p : positive) (a : nat) : nat :=
  match p with
  | p0~1 => addn_expand a (nat_of_pos_rec_expand p0 (addn_expand a a))
  | p0~0 => nat_of_pos_rec_expand p0 (addn_expand a a)
  | 1 => a
  end%positive.

Definition nat_of_pos_expand (p : positive) : nat := nat_of_pos_rec_expand p 1.

Definition nat_of_N_expand (n : N) : nat :=
  if n is N.pos p then nat_of_pos_expand p else 0%N.

Definition int_of_Z_expand (n : Z) : int :=
  match n with
  | Z0 => Posz 0
  | Zpos p => Posz (nat_of_pos_expand p)
  | Zneg p => Negz (nat_of_pos_expand p).-1
  end.

Definition Z_of_N_expand (n : N) : Z :=
  match n with
  | N0 => Z0
  | N.pos p => Z.pos p
  end.

Lemma nat_of_N_expandE : nat_of_N_expand = nat_of_N. Proof. by []. Qed.
Lemma int_of_Z_expandE : int_of_Z_expand = int_of_Z. Proof. by []. Qed.
Lemma Z_of_N_expandE : Z_of_N_expand = Z.of_N. Proof. by []. Qed.

(* Data types for reifying `nat` and `int` constants, including large ones    *)
(* that uses `Number.uint`                                                    *)

Variant large_nat := large_nat_N of N | large_nat_uint of Number.uint.

Definition nat_of_large_nat (n : large_nat) : nat :=
  match n with
  | large_nat_N n => nat_of_N_expand n
  | large_nat_uint n => Nat.of_num_uint n
  end.

Definition N_of_large_nat (n : large_nat) : N :=
  match n with
  | large_nat_N n => n
  | large_nat_uint n => N.of_num_uint n
  end.

Lemma large_nat_N_nat (n : large_nat) :
  nat_of_N (N_of_large_nat n) = nat_of_large_nat n.
Proof.
case: n => [n|[d|d]] /=; first by rewrite nat_of_N_expandE; lia.
  by rewrite uint_N_nat.
by rewrite hex_uint_N_nat.
Qed.

Definition Z_of_large_nat (n : large_nat) : Z :=
  match n with
  | large_nat_N n => Z.of_N n
  | large_nat_uint n => Z.of_num_uint n
  end.

Lemma large_nat_Z_int (n : large_nat) :
  int_of_Z (Z_of_large_nat n) = nat_of_large_nat n.
Proof.
rewrite -large_nat_N_nat; case: n => [n|[d|d]] //=; first lia.
  by rewrite /Z.of_uint /N.of_uint; lia.
by rewrite /Z.of_hex_uint /N.of_hex_uint; lia.
Qed.

Variant large_int :=
  | large_int_Z of Z
  | large_int_Pos of Number.uint
  | large_int_Neg of Number.uint.

Definition int_of_large_int (n : large_int) : int :=
  match n with
  | large_int_Z n => int_of_Z_expand n
  | large_int_Pos n => Posz (Nat.of_num_uint n)
  | large_int_Neg n => Negz (Nat.of_num_uint n)
  end.

Definition Z_of_large_int (n : large_int) : Z :=
  match n with
  | large_int_Z n => n
  | large_int_Pos n => Z.of_num_uint n
  | large_int_Neg n => - (Z.succ (Z.of_num_uint n))
  end.

Lemma large_int_Z_int (n : large_int) :
  int_of_Z (Z_of_large_int n) = int_of_large_int n.
Proof.
by case: n => [n|[d|d]|[d|d]] //=; rewrite -(uint_N_nat, hex_uint_N_nat);
  rewrite /Z.of_uint /N.of_uint /Z.of_hex_uint /N.of_hex_uint; lia.
Qed.

(* Embedding of rational numbers `Q` in a generic `unitRingType`              *)

Definition R_of_Q {R : unitRingType} (x : Q) : R :=
  (int_of_Z (Qnum x))%:~R / (Pos.to_nat (Qden x))%:R.

Lemma R_of_Q0 (R : unitRingType) : R_of_Q 0 = 0 :> R.
Proof. by rewrite /R_of_Q mul0r. Qed.

Lemma R_of_Q1 (R : unitRingType) : R_of_Q 1 = 1 :> R.
Proof. by rewrite /R_of_Q divr1. Qed.

Lemma R_of_Q_add (F : numFieldType) x y :
  R_of_Q (x + y) = R_of_Q x + R_of_Q y :> F.
Proof.
rewrite /R_of_Q /= addf_div ?pnatr_eq0; try lia.
by rewrite !pmulrn -!intrM -!intrD; congr (_%:~R / _%:~R); lia.
Qed.

Lemma R_of_Q_opp (R : unitRingType) x : R_of_Q (- x) = - R_of_Q x :> R.
Proof. by rewrite /R_of_Q !rmorphN mulNr. Qed.

Lemma R_of_Q_sub (F : numFieldType) x y :
  R_of_Q (x - y) = R_of_Q x - R_of_Q y :> F.
Proof. by rewrite R_of_Q_add R_of_Q_opp. Qed.

Lemma R_of_Q_mul (F : fieldType) x y :
  R_of_Q (x * y) = R_of_Q x * R_of_Q y :> F.
Proof.
by rewrite /R_of_Q /= mulrACA -invfM -intrM -natrM; congr (_%:~R / _%:R); lia.
Qed.

Lemma R_of_Q_inv (F : numFieldType) x : R_of_Q (/ x) = (R_of_Q x)^-1 :> F.
Proof.
case: x => [[|n|n] d]; rewrite /R_of_Q ?mul0r ?invr0 //= invf_div //=.
apply/eqP; rewrite eqr_div ?pnatr_eq0 ?intr_eq0; try lia.
rewrite -intrM -natrM pmulrn; apply/eqP; congr _%:~R.
by rewrite !NegzE mulrNN !prednK; lia. (* FIXME *)
Qed.

Lemma R_of_Q_invZ (R : unitRingType) x :
  R_of_Q (/ (x # 1)) = (int_of_Z x)%:~R^-1 :> R.
Proof.
case: x => [|n|n]; rewrite /R_of_Q ?mul0r ?invr0 ?mul1r ?mulN1r ?invrN //=.
by congr (- _%:R^-1); lia.
Qed.

(* Some instances required to adapt `ring`, `field`, and `lra` tactics to     *)
(* MathComp                                                                   *)

Lemma RZ R : ring_morph 0 1 +%R *%R (fun x y : R => x - y) -%R eq
                        0 1 Z.add Z.mul Z.sub Z.opp Z.eqb
                        (fun n => (int_of_Z n)%:~R).
Proof.
split=> //= [x y | x y | x y | x | x y /Z.eqb_eq -> //].
- by rewrite !rmorphD.
- by rewrite !rmorphB.
- by rewrite !rmorphM.
- by rewrite !rmorphN.
Qed.

Lemma PN R : @power_theory R 1 *%R eq N id (fun x n => x ^+ nat_of_N n).
Proof.
split => r [] //=; elim=> //= p <-.
- by rewrite Pos2Nat.inj_xI ?exprS -exprD addnn -mul2n.
- by rewrite Pos2Nat.inj_xO ?exprS -exprD addnn -mul2n.
Qed.

Lemma RR (R : comRingType) :
  @ring_theory R 0 1 +%R *%R (fun x y => x - y) -%R eq.
Proof.
exact/mk_rt/subrr/(fun _ _ => erefl)/mulrDl/mulrA/mulrC/mul1r/addrA/addrC/add0r.
Qed.

Lemma RF F : @field_theory F 0 1 +%R *%R (fun x y => x - y) -%R
                           (fun x y => x / y) GRing.inv eq.
Proof.
by split=> // [||x /eqP]; [exact: RR | exact/eqP/oner_neq0 | exact: mulVf].
Qed.

Section RealDomain.

Variable R : realDomainType.

Lemma Rsor : @SOR R 0 1 +%R *%R (fun x y => x - y) -%R eq Order.le Order.lt.
Proof.
apply: mk_SOR_theory.
- exact: RelationClasses.eq_equivalence.
- by move=> x _ <- y _ <-.
- by move=> x _ <- y _ <-.
- by move=> x _ <-.
- by move=> x _ <- y _ <-.
- by move=> x _ <- y _ <-.
- exact: RR.
- by [].
- by move=> x y xley ylex; apply: le_anti; rewrite xley ylex.
- by move=> x y z; apply: le_trans.
- move=> x y; rewrite lt_neqAle; split.
  + by move=> /andP[/eqP yneqx ->]; split.
  + by move=> [-> /eqP ->].
- move=> x y; case: (ltgtP x y) => [xlty|yltx|<-].
  + by left.
  + by right; right.
  + by right; left.
- by move=> x y z; rewrite ler_add2l.
- exact: mulr_gt0.
- by apply/eqP; rewrite eq_sym oner_neq0.
Qed.

Lemma Rpower : power_theory 1 *%R eq nat_of_N (@GRing.exp R).
Proof.
apply: mkpow_th => x n; case: n => [//|p]; elim: p => [p|p|//] /= IHp.
- by rewrite Pos2Nat.inj_xI exprS multE mulnC exprM expr2 IHp.
- by rewrite Pos2Nat.inj_xO multE mulnC exprM expr2 IHp.
Qed.

Lemma RSORaddon :
  @SORaddon R 0 1 +%R *%R (fun x y => x - y) -%R eq (fun x y => x <= y) (* ring elements *)
  Z Z0 (Zpos 1) Z.add Z.mul Z.sub Z.opp Z.eqb Z.leb (* coefficients *)
  (fun n => (int_of_Z n)%:~R) nat nat_of_N (@GRing.exp R).
Proof.
apply: mk_SOR_addon.
- exact: RZ.
- exact: Rpower.
- by move=> x y ? /intr_inj; lia.
- by move=> x y; rewrite ler_int; lia.
Qed.

End RealDomain.

Section RealField.

Variable F : realFieldType.

Lemma R_of_Q_eq x y : Qeq_bool x y = (R_of_Q x == R_of_Q y :> F).
Proof.
rewrite /Qeq_bool /R_of_Q /= eqr_div ?pnatr_eq0; try lia.
rewrite !pmulrn -!intrM eqr_int -!/(int_of_Z (Z.pos _)) -!rmorphM /=.
by rewrite (can_eq int_of_ZK); apply/idP/eqP => /Zeq_is_eq_bool.
Qed.

Lemma R_of_Q_le x y : Qle_bool x y = (R_of_Q x <= R_of_Q y :> F).
Proof.
rewrite /Qle_bool /R_of_Q /=.
rewrite ler_pdivr_mulr ?ltr0n; last lia.
rewrite mulrAC ler_pdivl_mulr ?ltr0n; last lia.
rewrite !pmulrn -!intrM ler_int; lia.
Qed.

Lemma FQ : ring_morph 0 1 +%R *%R (fun x y : F => x - y) -%R eq
                      0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool R_of_Q.
Proof.
apply: mkmorph.
- exact: R_of_Q0.
- exact: R_of_Q1.
- exact: R_of_Q_add.
- exact: R_of_Q_sub.
- exact: R_of_Q_mul.
- exact: R_of_Q_opp.
- by move=> x y; rewrite R_of_Q_eq => /eqP.
Qed.

Lemma FSORaddon :
  @SORaddon F 0 1 +%R *%R (fun x y => x - y) -%R eq (fun x y => x <= y) (* ring elements *)
  Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool Qle_bool (* coefficients *)
  R_of_Q nat nat_of_N (@GRing.exp F).
Proof.
apply: mk_SOR_addon.
- exact: FQ.
- exact: Rpower.
- by move=> x y; rewrite R_of_Q_eq => /eqP.
- by move=> x y; rewrite R_of_Q_le.
Qed.

End RealField.


(************* Syntax of Turing machines with lists ***************)

Definition HTape2: Set := list Sym.

Inductive Tape2: Set := pair2: HTape2 -> HTape2 -> Tape2.

Definition read2 (t:Tape2): Sym :=
           match t with (pair2 l r) =>
           match r with nil => B
                      | cons b r' => b
           end end.

Definition is_value2 (T:Spec) (t:Tape2) (q:State) :=
           tr T q (read2 t) = None.

(****************** INDUCTIVE Semantics *********************)

Inductive bf2: Spec -> Tape2 -> State -> Tape2 -> State -> Prop :=

(* HALT move *)

   bfH2: forall T:Spec, forall q:State,
        forall t:Tape2,
        (is_value2 T t q) ->
        (bf2 T t q t q)

(* RIGHT moves *)

 | bfRc: forall T:Spec, forall p q i:State,
        forall l r:HTape2, forall t:Tape2, forall b:Sym,
        (tr T p (read2 (pair2 l (cons b r)))) = (Some (i, R)) ->
        (bf2 T (pair2 (cons b l) r) i t q) ->
        (bf2 T (pair2 l (cons b r)) p t q)

 | bfRn: forall T:Spec, forall p q i:State,
        forall l:HTape2, forall t:Tape2,
        (tr T p (read2 (pair2 l nil))) = (Some (i, R)) ->
        (bf2 T (pair2 (cons B l) nil) i t q) ->
        (bf2 T (pair2 l nil) p t q)

(* LEFT moves *)

 | bfLc: forall T:Spec, forall p q i:State,
        forall l r:HTape2, forall t:Tape2, forall b:Sym,
        (tr T p (read2 (pair2 (cons b l) r))) = (Some (i, L)) ->
        (bf2 T (pair2 l (cons b r)) i t q) ->
        (bf2 T (pair2 (cons b l) r) p t q)

 | bfLn: forall T:Spec, forall p q i:State,
        forall r:HTape2, forall t:Tape2,
        (tr T p (read2 (pair2 nil r))) = (Some (i, L)) ->
        (bf2 T (pair2 nil (cons B r)) i t q) ->
        (bf2 T (pair2 nil r) p t q)

(* WRITE moves *)

 | bfWc: forall T:Spec, forall p q i:State,
        forall l r:HTape2, forall t:Tape2, forall a b:Sym,
        (tr T p (read2 (pair2 l (cons b r)))) = (Some (i, (W a))) ->
        (bf2 T (pair2 l (cons a r)) i t q) ->
        (bf2 T (pair2 l (cons b r)) p t q)

 | bfWn: forall T:Spec, forall p q i:State,
        forall l:HTape2, forall t:Tape2, forall a:Sym,
        (tr T p (read2 (pair2 l nil))) = (Some (i, (W a))) ->
        (bf2 T (pair2 l (cons a nil)) i t q) ->
        (bf2 T (pair2 l nil) p t q).

(****************** COINDUCTIVE Semantics *********************)

CoInductive bi2: Spec -> Tape2 -> State -> Prop :=

(* RIGHT moves *)

   biRc: forall T:Spec, forall p q:State,
        forall l r:HTape2, forall b:Sym,
        (tr T p (read2 (pair2 l (cons b r)))) = (Some (q, R)) ->
        (bi2 T (pair2 (cons b l) r) q) ->
        (bi2 T (pair2 l (cons b r)) p)

 | biRn: forall T:Spec, forall p q:State,
        forall l:HTape2,
        (tr T p (read2 (pair2 l nil))) = (Some (q, R)) ->
        (bi2 T (pair2 (cons B l) nil) q) ->
        (bi2 T (pair2 l nil) p)

(* LEFT moves *)

 | biLc: forall T:Spec, forall p q:State,
        forall l r:HTape2, forall b:Sym,
        (tr T p (read2 (pair2 (cons b l) r))) = (Some (q, L)) ->
        (bi2 T (pair2 l (cons b r)) q) ->
        (bi2 T (pair2 (cons b l) r) p)

 | biLn: forall T:Spec, forall p q:State,
        forall r:HTape2,
        (tr T p (read2 (pair2 nil r))) = (Some (q, L)) ->
        (bi2 T (pair2 nil (cons B r)) q) ->
        (bi2 T (pair2 nil r) p)

(* WRITE moves *)

 | biWc: forall T:Spec, forall p q:State,
        forall l r:HTape2, forall a b:Sym,
        (tr T p (read2 (pair2 l (cons b r)))) = (Some (q, (W a))) ->
        (bi2 T (pair2 l (cons a r)) q) ->
        (bi2 T (pair2 l (cons b r)) p)

 | biWn: forall T:Spec, forall p q:State,
        forall l:HTape2, forall a:Sym,
        (tr T p (read2 (pair2 l nil))) = (Some (q, (W a))) ->
        (bi2 T (pair2 l (cons a nil)) q) ->
        (bi2 T (pair2 l nil) p).


Require Import Setoid.
From ZFC Require Import Sets Axioms Cartesian Omega.
(*
Inductive Ens : Type :=
    sup : forall A : Type, (A -> Ens) -> Ens.

Definition EQ : Ens -> Ens -> Prop.
Proof.
simple induction 1; intros A f eq1.
simple induction 1; intros B g eq2.
apply and.
exact (forall x : A, exists y : B, eq1 x (g y)).
exact (forall y : B, exists x : A, eq1 x (g y)).
Defined.

Definition Vide:Ens := sup False (fun k=>match k with end).
*)
Definition S1 := sup unit (fun k=>match k with | _ => Vide end).
Definition S2 := sup bool (fun k=>match k with | _ => Vide end).

Definition id {T} := fun x : T => x.

Lemma exists_bijection (A B:Type):
A = B -> exists f, exists g, forall (x:A) (y:B),
 f x = y -> g y = x.
Proof.
 intro H; subst.
 exists id.
 exists id.
 intros. subst.
 reflexivity.
Defined.

Lemma unit_neq_bool: (bool:Type) = (unit:Type) -> False.
Proof.
intro Heq.
destruct (exists_bijection bool unit Heq) as [f [g Hfg]].
destruct (f true) eqn: Hft.
destruct (f false) eqn: Hff.
pose proof (Hfg _ _ Hft) as Hgtt.
pose proof ( Hfg _ _ Hff) as Hgtf.
rewrite Hgtf in Hgtt.
inversion Hgtt.
Defined.

Theorem uneb : S1 <> S2.
Proof.
intro H.
unfold S1,S2 in H.
inversion H.
symmetry in H1.
exact (unit_neq_bool H1).
Defined.

Theorem axExt : forall x y : Ens,
   EQ x y <-> forall z, (IN z x <-> IN z y).
Proof.
intros.
split.
+ intros.
  split.
  - apply IN_sound_right. exact H.
  - apply IN_sound_right. apply EQ_sym. exact H.
+ induction x as [A f], y as [B g].
  intro K.
  simpl in * |- *.
  split.
  - intro x.
    apply K.
    exists x.
    apply EQ_refl.
  - intro y.
    assert (Q:EXType B (fun y0 : B => EQ (g y) (g y0))).
    * exists y.
      apply EQ_refl.
    * destruct (proj2 (K (g y)) Q).
      exists x.
      apply EQ_sym.
      exact H0.
Defined.

Theorem ESS : EQ S1 S2.
Proof.
apply axExt.
simpl.
intro z.
split.
+ intro a.
  exists true.
  destruct a.
  exact H.
+ intro a.
  exists tt.
  destruct a.
  exact H.
Defined.
(* We have: S1<>S2, but (EQ S1 S2).
c1 extracts S1 from the pair.
c2 extracts S2 from the pair.
*)

Definition EQC (A B:Ens -> Prop) := forall z:Ens, A z <-> B z.

(*Definition Comp : Ens -> (Ens -> Prop) -> Ens.*)
Definition Comp_not_sound_right : exists x c1 c2 (H:EQC c1 c2),
~ (EQ (Comp x c1) (Comp x c2)).
Proof.
exists (Paire S1 S2).
(* Надо некорректно определить класс *)
Check fun x:Ens=> x = S1.

exists (fun x=> EQ x S1).
exists (fun x=> EQ x S2).
(*unshelve eapply ex_intro. firstorder.
intros H.
rewrite -> axExt in H.*)

(* almost
exists (Sing S1).
exists (fun x=>EQ x S1).
exists (fun x=>EQ x S2).
unshelve eapply ex_intro.
+ unfold EQC. intro z. split.
  - intro u. apply (EQ_tran _ _ _ u ESS).
  - intro u. refine (EQ_tran _ _ _ u _). apply EQ_sym. exact ESS.
+ intro H.*)
Abort.

Section sou.
Context (c1 c2 : Ens->Prop).
Context (c1_sou : forall x y, EQ x y -> (c1 x <-> c1 y)).
Context (c2_sou : forall x y, EQ x y -> (c2 x <-> c2 y)).
Definition Comp_sound_right : forall x (H:EQC c1 c2),
 (EQ (Comp x c1) (Comp x c2)).
Proof.
intros.
apply axExt.
intro z. split.
+ intro q.
  unshelve eapply IN_P_Comp.  (* c2 := (fun w=>S1=w) *)
  { unfold EQC in H.
    intros w1 w2 H0 H1.
    eapply c2_sou.
    apply EQ_sym. exact H1.
    exact H0. }
  { pose (m:= Comp_INC x c1).
    unfold INC in m.
    apply m. exact q. }
  {
    eapply IN_Comp_P in q.
    eapply H. exact q.
    intros w1 w2 H0 H1.
    eapply c1_sou. apply EQ_sym. exact H1. exact H0.
  }
+ intro q.
  unshelve eapply IN_P_Comp.
  { unfold EQC in H.
    intros w1 w2 H0 H1.
    eapply c1_sou.
    apply EQ_sym. exact H1.
    exact H0. }
  { pose (m:= Comp_INC x c2).
    unfold INC in m.
    apply m. exact q. }
  {
    eapply IN_Comp_P in q.
    eapply H. exact q.
    intros w1 w2 H0 H1.
    eapply c2_sou. apply EQ_sym. exact H1. exact H0.
  }
Defined.
End sou.

(*=====================END========================*)

(* The following is a mistake... *)
Definition Comp_not_sound_left : exists x1 x2 (H:EQ x1 x2) c,
~ (EQ (Comp x1 c) (Comp x2 c)).
Proof.
exists (Sing S1).
exists (Sing S2).
unshelve eapply ex_intro.
 apply Sing_sound; exact ESS.
exists (fun w=>S1=w).
intro Y.
rewrite axExt in Y.
pose (ys := Y S1).
destruct ys.
assert (Q:IN S1 (Comp (Sing S1) (fun w : Ens => S1 = w))).
eapply IN_P_Comp.
(* Nothing can be done *)
(*exists (Paire S1 S2).
exists (Paire S1 S2).
unshelve eapply ex_intro.
apply EQ_refl.*)
Abort.
(*___________________________________________________*)

(** INTERESTING

Module ClassicalEns.
Import Classical_Prop.
Import Classical_Pred_Type.
(*
Definition ce :  False.
remember (classic False).
clear Heqo.
destruct o.
pose (Q:=classic False).
destruct Q.
Theorem or_elim (A B C:Prop): (A->C) ->(B->C)->((A\/B)->C).
intros.
destruct H1.
or
*)

(*N z x*)
Check Comp Omega.
Print Comp.
(*
Definition Comp : Ens -> (Ens -> Prop) -> Ens.
simple induction 1; intros A f fr P.
apply (sup (sig A (fun x => P (f x)))).
simple induction 1; intros x p; exact (f x).
Defined.
*)
(* Тут должен быть пример функции, дающей разные значения на
   на двух неравных, экстенсионально равных множествах.
   Определим два типа с нулём элементов.
*)

Inductive VI : bool -> Set :=
| c1 : VI true
.

Theorem theyneq : VI true <> VI false.
Proof.
intros H.
(*pose (x2:=c2 : VI true).*)
pose (x1:=c1 : VI true).
replace (VI true) with (VI false) in x1.
inversion x1.
Defined.

Inductive Va:Set :=.
Inductive Vb:Set :=.

Definition ce : Ens->Prop.

(*___________________________________________________*)
(*
exists S1.
exists S2.
exists ESS.
unshelve eapply ex_intro.
intro e.

assert (J: IN e S1). admit.
simpl in J. destruct J as [j1 j2].

exact (e=S1).
auto with zfc.

unfold EQ.

auto.
eq
False
I:True
  unit
  bool*)
**)


Require Import rt.util.all.
Require Import rt.model.basic.task rt.model.basic.job rt.model.basic.schedule
               rt.model.basic.task_arrival rt.model.basic.interference
               rt.model.basic.priority rt.model.basic.platform.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module PlatformFP.

  Import Job SporadicTaskset Schedule ScheduleOfSporadicTask SporadicTaskset SporadicTaskArrival Interference Priority Platform.

  Section Lemmas.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    Context {Job: eqType}.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Consider any job arrival sequence ... *)
    Context {arr_seq: arrival_sequence Job}.

    (* ... and any schedule of this arrival sequence. *)
    Context {num_cpus: nat}.
    Variable sched: schedule num_cpus arr_seq.

    (* Assume that all jobs have valid parameters. *)
    Hypothesis H_valid_job_parameters:
      forall (j: JobIn arr_seq),
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

    Section JobInvariantAsTaskInvariant.

      (* Assume any work-conserving priority-based scheduler. *)
      Variable higher_eq_priority: FP_policy sporadic_task.
      Hypothesis H_work_conserving: work_conserving job_cost sched.
      Hypothesis H_enforces_JLDP_policy:
        enforces_FP_policy job_cost job_task sched higher_eq_priority.

      (* Consider any task set ts ... *)
      Variable ts: taskset_of sporadic_task.

      (* ... that has no duplicate tasks ... *)
      Hypothesis H_ts_is_a_set: uniq ts.
      (* ... and such that all jobs come from the taskset. *)
      Hypothesis H_all_jobs_from_taskset:
        forall (j: JobIn arr_seq), job_task j \in ts.

      (* Suppose that jobs are sequential, ...*)
      Hypothesis H_sequential_jobs: sequential_jobs sched.
      (* ... jobs must arrive to execute, ... *)
      Hypothesis H_completed_jobs_dont_execute:
        completed_jobs_dont_execute job_cost sched.
      (* ... and jobs do not execute after completion. *)
      Hypothesis H_jobs_must_arrive_to_execute:
        jobs_must_arrive_to_execute sched.

      (* Assume that jobs arrive sporadically. *)
      Hypothesis H_sporadic_tasks:
        sporadic_task_model task_period arr_seq job_task.

      (* Consider a valid task tsk, ...*)
      Variable tsk: sporadic_task.
      Hypothesis H_valid_task: is_valid_sporadic_task task_cost task_period task_deadline tsk.

      (*... whose job j ... *)
      Variable j: JobIn arr_seq.
      Variable H_job_of_tsk: job_task j = tsk.

      (*... is backlogged at time t <= job_arrival j + task_period tsk. *)
      Variable t: time.
      Hypothesis H_j_backlogged: backlogged job_cost sched j t.
      Hypothesis H_t_before_period: t < job_arrival j + task_period tsk.

      Let can_interfere_with_tsk := fp_can_interfere_with higher_eq_priority tsk.

      (* Assume that any jobs of higher-priority tasks complete by their period. *)
      Hypothesis H_all_previous_jobs_completed :
        forall (j_other: JobIn arr_seq) tsk_other,
          job_task j_other = tsk_other ->
          can_interfere_with_tsk tsk_other ->
          completed job_cost sched j_other (job_arrival j_other + task_period tsk_other).

      (* Assume that any jobs of tsk prior to j complete by their period. *)
      Hypothesis H_all_previous_jobs_of_tsk_completed :
        forall j0 : JobIn arr_seq,
          job_task j0 = tsk ->
          job_arrival j0 < job_arrival j ->
          completed job_cost sched j0 (job_arrival j0 + task_period tsk).

      Definition scheduled_task_with_higher_eq_priority (tsk tsk_other: sporadic_task) :=
        task_is_scheduled job_task sched tsk_other t &&
        can_interfere_with_tsk tsk_other.

      (* Then, there can be at most one pending job of higher-priority tasks at time t. *)
      Lemma platform_fp_no_multiple_jobs_of_interfering_tasks :
          forall j1 j2,
            pending job_cost sched j1 t ->
            pending job_cost sched j2 t ->
            job_task j1 = job_task j2 ->
            can_interfere_with_tsk (job_task j1) ->
            j1 = j2.
      Proof.
        unfold sporadic_task_model in *.
        rename H_sporadic_tasks into SPO, H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_all_previous_jobs_completed into PREV.
        intros j1 j2 PENDING1 PENDING2 SAMEtsk INTERF.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: PENDING1 PENDING2 => /andP [ARRIVED1 /negP NOTCOMP1] /andP [ARRIVED2 /negP NOTCOMP2].
        destruct (leqP (job_arrival j1) (job_arrival j2)) as [BEFORE1 | BEFORE2].
        {
          specialize (SPO j1 j2 DIFF SAMEtsk BEFORE1).
          exploit (PREV j1 (job_task j1)); [by done | by apply INTERF | intros COMP1].
          apply NOTCOMP1.
          apply completion_monotonic with (t0 := job_arrival j1 + task_period (job_task j1));
            try (by done).
          by apply leq_trans with (n := job_arrival j2).
        }
        {
          apply ltnW in BEFORE2.
          exploit (SPO j2 j1); [by red; ins; subst j2 | by rewrite SAMEtsk | by done | intro SPO' ].
          exploit (PREV j2 (job_task j2));
            [by done | by rewrite -SAMEtsk | intro COMP2 ].
          apply NOTCOMP2.
          apply completion_monotonic with (t0 := job_arrival j2 + task_period (job_task j2));
            try (by done).
          by apply leq_trans with (n := job_arrival j1).
        }
      Qed.

      (* Also, there can be at most one pending job of tsk at time t. *)
      Lemma platform_fp_no_multiple_jobs_of_tsk :
          forall j',
            pending job_cost sched j' t ->
            job_task j' = tsk ->
            j' = j.
      Proof.
        unfold sporadic_task_model in *.
        rename H_sporadic_tasks into SPO,
               H_valid_task into PARAMS,
               H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_all_previous_jobs_completed into PREV,
               H_j_backlogged into BACK, H_job_of_tsk into JOBtsk.
        intros j' PENDING' SAMEtsk.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: BACK PENDING' => /andP [/andP [ARRIVED /negP NOTCOMP] NOTSCHED]
                               /andP [ARRIVED' /negP NOTCOMP'].
        destruct (leqP (job_arrival j') (job_arrival j)) as [BEFORE | BEFORE'].
        {
          exploit (SPO j' j DIFF); [by rewrite JOBtsk | by done | intro SPO'].
          apply NOTCOMP'.
          apply completion_monotonic with (t0 := job_arrival j' + task_period tsk); try (by done);
            first by apply leq_trans with (n := job_arrival j); [by rewrite -SAMEtsk | by done].
          {
            apply PREVtsk; first by done.
            apply leq_trans with (n := job_arrival j' + task_period tsk); last by rewrite -SAMEtsk.
            rewrite -addn1; apply leq_add; first by done.
            by unfold is_valid_sporadic_task in *; des.
          }
        }
        {
          unfold has_arrived in *.
          rewrite leqNgt in ARRIVED'; move: ARRIVED' => /negP BUG; apply BUG.
          apply leq_trans with (n := job_arrival j + task_period tsk); first by done.
          by rewrite -JOBtsk; apply SPO;
            [by red; ins; subst j' | by rewrite SAMEtsk | by apply ltnW].
        }
      Qed.

      (* Therefore, all processors are busy with tasks other than tsk. *)
      Lemma platform_fp_cpus_busy_with_interfering_tasks :
        count (scheduled_task_with_higher_eq_priority tsk) ts = num_cpus.
      Proof.
        have UNIQ := platform_fp_no_multiple_jobs_of_interfering_tasks.
        have UNIQ' := platform_fp_no_multiple_jobs_of_tsk.
        rename H_all_jobs_from_taskset into FROMTS,
               H_sequential_jobs into SEQUENTIAL,
               H_work_conserving into WORK,
               H_enforces_JLDP_policy into PRIO,
               H_j_backlogged into BACK,
               H_job_of_tsk into JOBtsk,
               H_sporadic_tasks into SPO,
               H_valid_job_parameters into JOBPARAMS,
               H_valid_task into TASKPARAMS,
               H_all_previous_jobs_completed into PREV,
               H_completed_jobs_dont_execute into COMP,
               H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_jobs_must_arrive_to_execute into ARRIVE.
        apply work_conserving_eq_work_conserving_count in WORK.
        unfold valid_sporadic_job, valid_realtime_job,
               enforces_FP_policy, enforces_JLDP_policy, FP_to_JLDP,
               task_precedence_constraints, completed_jobs_dont_execute,
               sporadic_task_model, is_valid_sporadic_task,
               jobs_of_same_task_dont_execute_in_parallel,
               sequential_jobs,
               can_interfere_with_tsk in *.
        apply/eqP; rewrite eqn_leq; apply/andP; split.
        {
          apply leq_trans with (n := count (fun x => task_is_scheduled job_task sched x t) ts);
            first by apply sub_count; red; move => x /andP [SCHED _].
          unfold task_is_scheduled.
          apply count_exists; first by done.
          {
            intros cpu x1 x2 SCHED1 SCHED2.
            unfold task_scheduled_on in *.
            destruct (sched cpu t); last by done.
            move: SCHED1 SCHED2 => /eqP SCHED1 /eqP SCHED2.
            by rewrite -SCHED1 -SCHED2.
          }
        }
        {
          rewrite -(WORK j t) // -count_predT.
          apply leq_trans with (n := count (fun j: JobIn arr_seq =>
            scheduled_task_with_higher_eq_priority tsk (job_task j)) (jobs_scheduled_at sched t));
            last first.
          {
            rewrite -count_map.
            apply leq_trans with (n := count predT [seq x <- (map (fun (j: JobIn arr_seq) => job_task j) (jobs_scheduled_at sched t)) | scheduled_task_with_higher_eq_priority tsk x]);
              first  by rewrite count_filter; apply sub_count; red; ins.
            apply leq_trans with (n := count predT [seq x <- ts | scheduled_task_with_higher_eq_priority tsk x]);
              last by rewrite count_predT size_filter.
            apply count_sub_uniqr;
              last first.
            {
              red; intros tsk' IN'.
              rewrite mem_filter in IN'; move: IN' => /andP [SCHED IN'].
              rewrite mem_filter; apply/andP; split; first by done.
              by move: IN' => /mapP [j' _] ->; apply FROMTS.
            }
            {
              rewrite filter_map.
              rewrite map_inj_in_uniq; first by apply filter_uniq, scheduled_jobs_uniq.
              red; intros j1 j2 SCHED1 SCHED2 SAMEtsk.
              rewrite 2!mem_filter in SCHED1 SCHED2.
              move: SCHED1 SCHED2 => /andP [/andP [_ HP1] SCHED1] /andP [/andP [_ HP2] SCHED2].
              rewrite 2!mem_scheduled_jobs_eq_scheduled in SCHED1 SCHED2.
              apply scheduled_implies_pending with (job_cost0 := job_cost) in SCHED1; try (by done).
              apply scheduled_implies_pending with (job_cost0 := job_cost) in SCHED2; try (by done).
              by apply UNIQ.
            }
          }
          {
            apply sub_in_count; intros j' SCHED' _.
            rewrite mem_scheduled_jobs_eq_scheduled in SCHED'.
            apply/andP; split.
            {
              move: SCHED' => /existsP [cpu /eqP SCHED'].
              by apply/existsP; exists cpu; rewrite /task_scheduled_on SCHED' eq_refl.
            }
            apply/andP; split; first by rewrite -JOBtsk; apply PRIO with (t := t).
            {
              apply/eqP; red; intro SAMEtsk.
              generalize SCHED'; intro PENDING'.
              apply scheduled_implies_pending with (job_cost0 := job_cost) in PENDING'; try (by done).
              specialize (UNIQ' j' PENDING' SAMEtsk); subst j'.
              by move: BACK => /andP [_ NOTSCHED]; rewrite SCHED' in NOTSCHED.
            }
          }
        }
      Qed.

    End JobInvariantAsTaskInvariant.

  End Lemmas.

End PlatformFP.


(*
(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 Lia.
Require Import Rsequence_def.
Require Import Rsequence_facts.
Require Import Rsequence_cv_facts.
Require Import Rsequence_usual_facts.
Require Import Rtactic.
Require Import MyRIneq.

Require Import Cprop_base.
Require Import Csequence.
Require Import Csequence_facts.
Require Import Cpser_def Cpser_base_facts Cpser_facts.
Require Import Cseries.
Require Import Cseries_facts.
Require Import Cdefinitions.
Require Import Canalysis_def.

Open Scope C_scope.

(** * Definition and manipulation of the general term of the power serie of the exponential *)

Definition exp_seq (n : nat) := / INC (fact n).

Lemma exp_seq_neq : forall n : nat, exp_seq n <> 0.
Proof.
intro n ; unfold exp_seq ; apply Cinv_neq_0_compat ;
 apply not_0_INC ; apply fact_neq_0.
Qed.

Lemma Cdiv_exp_seq_simpl : forall n, (exp_seq (S n)) / (exp_seq n) = / INC (S n).
Proof.
intros n ; unfold exp_seq.
 replace (fact (S n))%nat with ((S n) * fact n)%nat by reflexivity ;
 unfold Cdiv ; rewrite mult_INC, Cinv_involutive ;
 [rewrite Cinv_mult_distr ;
  [rewrite Cmult_assoc, Cinv_l, Cmult_1_r ;
   [reflexivity |] | |] |] ;
   apply not_0_INC ; auto ;  apply fact_neq_0.
Qed.

Lemma Deriv_exp_seq_simpl : forall n, An_deriv exp_seq n = exp_seq n.
Proof.
intro n ; unfold exp_seq, An_deriv, Cseq_shift, Cseq_mult.
 replace (fact (S n))%nat with ((S n) * fact n)%nat by reflexivity.
 rewrite mult_INC, Cinv_mult_distr, <- Cmult_assoc, Cinv_r, Cmult_1_l ;
 [reflexivity | | |] ; replace C0 with (INC O) by reflexivity ; apply not_INC ;
 try apply fact_neq_0 ; intuition.
Qed.

(** * This power serie has a radius of convergence that is infinite *)

Lemma exp_infinite_cv_radius : infinite_cv_radius exp_seq.
Proof.
intros r.
 pose (M := (/ (Rabs r + 1))%R) ; assert (M_pos : 0 < M).
  unfold M ; apply Rinv_0_lt_compat ;
  apply Rplus_le_lt_0_compat ; [apply Rabs_pos | apply Rlt_0_1].
 apply (Cpser_alembert_prelim2 exp_seq M M_pos exp_seq_neq).

assert (t : (1 > 0)%nat) by constructor ;
 assert (H := Rseq_poly_cv 1 t) ;
 assert (H2 := Rseq_cv_pos_infty_shift_compat_reciprocal _ H) ;
 assert (H3 := Rseq_cv_pos_infty_inv_compat _ H2) ;
 clear t H H2 ; destruct (H3 _ M_pos) as [N HN] ; exists N ;
 intros n.
 rewrite Cdiv_exp_seq_simpl, <- IRC_INR_INC, <- Cinv_IRC_Rinv.
 rewrite Cnorm_IRC_Rabs.
 apply Rle_trans with (R_dist ((/ Rseq_shift (Rseq_poly 1))%Rseq (N + n)%nat) 0).
 right ; unfold R_dist, Rseq_shift, Rseq_poly, pow ; apply Rabs_eq_compat ;
 rewrite Rminus_0_r, <- (Rmult_1_r (INR (S (N + n)))) ; reflexivity.
 left ; apply HN ; intuition.
 apply not_0_INR ; intuition.

unfold M ; rewrite Rinv_involutive ; [| apply Rgt_not_eq ; apply Rplus_le_lt_0_compat ;
 [apply Rabs_pos | apply Rlt_0_1]] ; intuition.
Qed.

Definition Cexp (z : C) := sum  _ exp_infinite_cv_radius z.

Definition Deriv_Cexp (z : C) := sum_derive _ exp_infinite_cv_radius z.

(** * The exponential is its own derivative *)

Lemma Cexp_eq_Deriv_Cexp : forall z, Cexp z = Deriv_Cexp z.
Proof.
intro z.
 assert (T1 := sum_sums _ exp_infinite_cv_radius z) ;
 assert (T2 := sum_derive_sums _ exp_infinite_cv_radius z).
 symmetry ; eapply Cpser_unique_extentionality.
 apply Deriv_exp_seq_simpl.
 apply T2.
 apply T1.
Qed.

Lemma derivable_pt_lim_Cexp : forall z, derivable_pt_lim Cexp z (Cexp z).
Proof.
intro z ; rewrite Cexp_eq_Deriv_Cexp ;
 apply derivable_pt_lim_sum.
Qed.

(** ** Euler's Formula*)

Lemma Cexp_exp_compat : forall a : R, Cexp a =  exp a.
Proof.
intros a ; unfold exp, Cexp ; destruct (exist_exp a) as (l, H).
 pose (l1 := sum exp_seq exp_infinite_cv_radius (a +i  0)) ;
 assert (H1 := sum_sums _ exp_infinite_cv_radius (a +i 0)) ;
 replace (sum exp_seq exp_infinite_cv_radius (a +i  0)) with l1 in * by reflexivity.
rewrite <- Ceq ; simpl.

split.
apply (Rseq_cv_unique (sum_f_R0 (fun j : nat => (/ INR (fact j) * a ^ j)%R))).
  apply Rseq_cv_eq_compat with (fun n => Cre (sum_f_C0 (fun j : nat => / INC (fact j) * (a +i  0) ^ j) n)).
   intro n ; induction n.
  simpl ; field.
  rewrite sum_f_C0_simpl, tech5, <- Cre_add_compat, IHn ;
  apply Rplus_eq_compat_l.
  rewrite Cre_mul, Cpow_Cim_0, Cpow_Cre_0, Rmult_0_r, Rminus_0_r.
  rewrite INC_inv_Cre_INR ; [reflexivity | apply fact_neq_0].
 apply (Cseq_Rseq_Rseq_equiv _ _) ; apply Pser_Cseqcv_link ; unfold exp_seq in H1 ; apply H1.
 apply H.

 apply (Rseq_cv_unique (fun n => Cim (sum_f_C0 (fun j : nat => / INC (fact j) * (a +i  0) ^ j) n))).
  apply (Cseq_Rseq_Rseq_equiv _ _) ; apply Pser_Cseqcv_link ; unfold exp_seq in H1 ; apply H1.
  apply (Rseq_cv_eq_compat R0) ; [| apply Rseq_constant_cv].
  intro n ; induction n ; unfold Rseq_constant in *.
  simpl ; field.
  rewrite sum_f_C0_simpl, <- Cim_add_compat, <- IHn, Cim_mul, Cpow_Cim_0,
  Cpow_Cre_0, INC_inv_Cim_INR ; [ring | apply fact_neq_0].
Qed.

Lemma Cre_Cpow_2 : forall (a : R) (n : nat), Cre ((0 +i a) ^ (2 * n)) = ((-1) ^ n * a ^ (2*n))%R.
Proof.
intros a n ; induction n.
 simpl ; ring.
 replace (2 * S n)%nat with (S (S (2 * n))) by intuition.
 do 2 rewrite Cpow_S, Cre_mul ; rewrite IHn.
 rewrite Cim_mul.
 replace (Cre (0 +i a)) with R0 by reflexivity.
 repeat rewrite IHn ; simpl ; ring.
Qed.

Lemma Cim_Cpow_2 : forall (a : R) (n : nat), Cim ((0 +i a) ^ (2 * n)) = R0.
Proof.
intros a n ; induction n.
 simpl ; ring.
 replace (2 * S n)%nat with (S (S (2 * n))) by intuition.
 do 2 rewrite Cpow_S, Cim_mul ; rewrite IHn.
 rewrite Cre_mul.
 replace (Cre (0 +i a)) with R0 by reflexivity.
 repeat rewrite IHn ; ring.
Qed.

Lemma Cre_Cpow_S2 : forall (a : R) (p : nat), Cre ((0 +i  a) ^ S (2 * p)) = R0.
Proof.
intros a n ; induction n.
 simpl ; ring.
 replace (2 * S n)%nat with (S (S (2 * n))) by intuition.
 do 2 rewrite Cpow_S, Cre_mul ; rewrite IHn.
 rewrite Cim_mul.
 replace (Cre (0 +i a)) with R0 by reflexivity.
 repeat rewrite IHn ; ring.
Qed.

Lemma Cim_Cpow_S2 : forall (a : R) (n : nat), Cim ((0 +i a) ^ (S (2 * n))) = ((-1) ^ n * a ^ S (2*n))%R.
Proof.
intros a n ; induction n.
 simpl ; ring.
 replace (2 * S n)%nat with (S (S (2 * n))) by intuition.
 do 2 rewrite Cpow_S, Cim_mul ; rewrite IHn.
 rewrite Cre_mul.
 replace (Cre (0 +i a)) with R0 by reflexivity.
 repeat rewrite IHn ; simpl ; ring.
Qed.

Lemma Cexp_trigo_compat : forall a, Cexp (0 +i a) = cos a +i sin a.
Proof.
intros a ; rewrite <- Ceq ; split ; simpl ;
 pose (l := sum _ exp_infinite_cv_radius (0 +i  a)) ;
 replace (Cexp (0 +i  a)) with l by reflexivity.
 unfold cos ; destruct (exist_cos (Rsqr a)) as (l', Hl') ; unfold cos_in, cos_n in Hl'.
 apply Rseq_cv_unique with (fun N => Cre (sum_f_C0 (gt_pser exp_seq (0 +i a)) N)).
 apply (Cseq_Rseq_Rseq_equiv _ _) ; apply Pser_Cseqcv_link ; apply sum_sums.
 intros eps eps_pos ; destruct (Hl' _ eps_pos) as [N HN] ; exists (2 * N)%nat ;
 intros n n_lb ; unfold R_dist.

 destruct (n_modulo_2 n) as [H|H] ; destruct H as [p Hp] ; rewrite Hp.
 replace (Cre (sum_f_C0 (gt_pser exp_seq (0 +i  a)) (2 * p))) with
  (sum_f_R0 (fun i : nat => ((-1) ^ i / INR (fact (2 * i)) * a² ^ i)%R) p).
 apply HN ; lia.

clear ; induction p.
 simpl ; field.
 replace (2 * S p)%nat with (S (S (2 * p)))%nat by intuition.
 do 2 rewrite sum_f_C0_simpl ; rewrite tech5 ; do 2 rewrite<- Cre_add_compat ;
 rewrite <- IHp, Rplus_assoc ; apply Rplus_eq_compat_l.
 replace ((-1) ^ S p / INR (fact (2 * S p)) * a² ^ S p)%R
 with (Cre (gt_pser exp_seq (0 +i  a) (S (S (2 * p))))).
 replace (Cre (gt_pser exp_seq (0 +i  a) (S (2 * p))))%R with R0.
 symmetry ; apply Rplus_0_l.
 unfold_gt ; unfold exp_seq ; rewrite Cre_mul.
 replace (S (S (2 * p))) with (2 * S p)%nat by intuition.
 rewrite Cim_inv_INC, Rmult_0_l, Cre_Cpow_S2 ; ring.
 unfold_gt ; unfold exp_seq ; rewrite Cre_mul.
 replace (S (S (2 * p))) with (2 * S p)%nat by intuition.
 rewrite Cre_Cpow_2, Cim_Cpow_2, INC_inv_Cre_INR.
 unfold Rsqr ; rewrite pow_mult, Rmult_0_r, Rminus_0_r.
 rewrite Rmult_comm ; unfold Rdiv ; do 2 rewrite Rmult_assoc ;
 apply Rmult_eq_compat_l.
 rewrite Rmult_comm ; simpl (pow a (S (S O))) ;
 rewrite Rmult_1_r ; reflexivity.
 apply fact_neq_0.

 replace (Cre (sum_f_C0 (gt_pser exp_seq (0 +i  a)) (S (2 * p)))) with
  (sum_f_R0 (fun i : nat => ((-1) ^ i / INR (fact (2 * i)) * a² ^ i)%R) p).
 apply HN ; lia.

clear ; induction p.
 simpl ; field.
 replace (2 * S p)%nat with (S (S (2 * p)))%nat by intuition.
 do 2 rewrite sum_f_C0_simpl ; rewrite tech5 ; do 2 rewrite<- Cre_add_compat ;
 rewrite <- IHp, Rplus_assoc ; apply Rplus_eq_compat_l.
 replace ((-1) ^ S p / INR (fact (2 * S p)) * a² ^ S p)%R
 with (Cre (gt_pser exp_seq (0 +i  a) (S (S (2 * p))))).
 replace (Cre (gt_pser exp_seq (0 +i  a) (S (S (S (2 * p))))))%R with R0.
 symmetry ; apply Rplus_0_r.
 unfold_gt ; unfold exp_seq ; rewrite Cre_mul.
 replace (S (S (2 * p))) with (2 * S p)%nat by intuition.
 rewrite Cim_inv_INC, Rmult_0_l, Cre_Cpow_S2 ; ring.
 unfold_gt ; unfold exp_seq ; rewrite Cre_mul.
 replace (S (S (2 * p))) with (2 * S p)%nat by intuition.
 rewrite Cre_Cpow_2, Cim_Cpow_2, INC_inv_Cre_INR.
 unfold Rsqr ; rewrite pow_mult, Rmult_0_r, Rminus_0_r.
 rewrite Rmult_comm ; unfold Rdiv ; do 2 rewrite Rmult_assoc ;
 apply Rmult_eq_compat_l.
 rewrite Rmult_comm ; simpl (pow a (S (S O))) ;
 rewrite Rmult_1_r ; reflexivity.
 apply fact_neq_0.

 unfold sin ; destruct (exist_sin (Rsqr a)) as (l', Hl') ; unfold sin_in, sin_n in Hl'.
 apply Rseq_cv_unique with (fun N => Cim (sum_f_C0 (gt_pser exp_seq (0 +i a)) N)).
 apply (Cseq_Rseq_Rseq_equiv _ _) ; apply Pser_Cseqcv_link ; apply sum_sums.
 intros eps eps_pos ; destruct (Req_dec a 0) as [a_eq | a_neq].
 exists O ; intros n n_lb ; unfold R_dist, gt_pser ; rewrite a_eq, Rmult_0_l.
 apply Rle_lt_trans with (Rabs (0 - 0)) ;
  [| rewrite Rminus_0_r, Rabs_R0 ; assumption].
 right ; apply Rabs_eq_compat ; apply Rminus_eq_compat ; [| reflexivity].
 induction n.
 simpl ; field.
 rewrite sum_f_C0_simpl, <- Cim_add_compat, IHn, Rplus_0_l ;
 unfold gt_pser ; replace (0 +i 0) with C0 by reflexivity.
 unfold Cseq_mult ; rewrite C0_pow, Cmult_0_r ; simpl ; intuition.
 intuition.

pose (eps' := (eps / Rabs a)%R) ; assert (eps'_pos : 0 < eps').
 unfold eps', Rdiv ; apply Rlt_mult_inv_pos ; [| apply Rabs_pos_lt] ; assumption.
destruct (Hl' _ eps'_pos) as [N HN] ; exists (S (2 * N))%nat ;
 intros n n_lb ; unfold R_dist.

 destruct (n_modulo_2 n) as [H|H] ; destruct H as [p Hp] ; rewrite Hp.
 destruct p.
 apply False_ind ; clear -n_lb Hp ; lia.
 replace (Cim (sum_f_C0 (gt_pser exp_seq (0 +i  a)) (2 * S p))) with
  (a * sum_f_R0 (fun i : nat => ((-1) ^ i / INR (fact (2 * i + 1)) * a² ^ i)%R) p)%R.
  rewrite <- Rmult_minus_distr_l, Rabs_mult ; apply Rlt_le_trans with (Rabs a * eps')%R.
  apply Rmult_lt_compat_l ; [apply Rabs_pos_lt ; assumption|] ; apply HN ; lia.
  unfold eps' ; right ; field ; apply Rabs_no_R0 ; assumption.
  rewrite scal_sum.
  clear ; induction p.
  simpl ; field.

 replace (2 * S (S p))%nat with (S (S (2 * S p))) by intuition.
 rewrite tech5 ; do 2 rewrite sum_f_C0_simpl, <- Cim_add_compat.
 rewrite IHp, Rplus_assoc ; apply Rplus_eq_compat_l.
 replace (Cim (gt_pser exp_seq (0 +i  a) (S (S (2 * S p)))))%R with R0.
 unfold_gt ; unfold exp_seq.
 rewrite Cim_mul, Cre_Cpow_S2, Cim_Cpow_S2, Rmult_0_l, Rplus_0_r,
 Rplus_0_r.
 unfold Rsqr.
 rewrite INC_inv_Cre_INR.
 replace (a ^ S (2 * S p))%R with (a * (a ^ 2) ^ (S p))%R.
 replace (2 * S p + 1)%nat with (S (2 * S p)) by intuition.
 rewrite (Rmult_comm (/ INR (fact (S (2 * S p)))) _) ; unfold Rdiv ;
 repeat rewrite Rmult_assoc ; apply Rmult_eq_compat_l.
 rewrite Rmult_comm, <- Rmult_assoc ; apply Rmult_eq_compat_r.
 rewrite Rmult_comm ; apply Rmult_eq_compat_l.
 simpl ; repeat rewrite Rmult_1_r ; reflexivity.
 rewrite <- pow_mult ; simpl ; reflexivity.
 apply fact_neq_0.
unfold_gt ; unfold exp_seq ; rewrite Cim_mul ;
replace ( S (S (2 * S p))) with (2 * (S (S p)))%nat by intuition ;
rewrite Cim_Cpow_2, INC_inv_Cim_INR.
do 2 rewrite Rmult_0_r ; ring.
apply fact_neq_0.

 replace (Cim (sum_f_C0 (gt_pser exp_seq (0 +i  a)) (S (2 * p)))) with
  (a * sum_f_R0 (fun i : nat => ((-1) ^ i / INR (fact (2 * i + 1)) * a² ^ i)%R) p)%R.
  rewrite <- Rmult_minus_distr_l, Rabs_mult ; apply Rlt_le_trans with (Rabs a * eps')%R.
  apply Rmult_lt_compat_l ; [apply Rabs_pos_lt ; assumption|] ; apply HN ; lia.
  unfold eps' ; right ; field ; apply Rabs_no_R0 ; assumption.
  rewrite scal_sum.
  clear ; induction p.
  simpl ; field.

 replace (2 * (S p))%nat with (S (S (2 * p))) by intuition.
 rewrite tech5 ; do 2 rewrite sum_f_C0_simpl, <- Cim_add_compat.
 rewrite IHp, Rplus_assoc ; apply Rplus_eq_compat_l.
 replace (Cim (gt_pser exp_seq (0 +i  a) (S (S (2 * p)))))%R with R0.
 unfold_gt ; unfold exp_seq.
 replace (S (S (S (2 * p)))) with (S (2 * (S p))) by intuition.
 rewrite Cim_mul, Cre_Cpow_S2, Cim_Cpow_S2, Rmult_0_l,
 Rplus_0_l, Rplus_0_r.
 unfold Rsqr.
 rewrite INC_inv_Cre_INR.
 replace (a ^ S (2 * S p))%R with (a * (a ^ 2) ^ (S p))%R.
 replace (2 * S p + 1)%nat with (S (2 * S p)) by intuition.
 rewrite (Rmult_comm (/ INR (fact (S (2 * S p)))) _) ; unfold Rdiv ;
 repeat rewrite Rmult_assoc ; apply Rmult_eq_compat_l.
 rewrite Rmult_comm, <- Rmult_assoc ; apply Rmult_eq_compat_r.
 rewrite Rmult_comm ; apply Rmult_eq_compat_l.
 simpl ; repeat rewrite Rmult_1_r ; reflexivity.
 rewrite <- pow_mult ; simpl ; reflexivity.
 apply fact_neq_0.
unfold_gt ; unfold exp_seq ; rewrite Cim_mul ;
replace (S (S (2 * p))) with (2 * (S p))%nat by intuition ;
rewrite Cim_Cpow_2, INC_inv_Cim_INR.
do 2 rewrite Rmult_0_r ; ring.
apply fact_neq_0.
Qed.

Lemma Cexp_abs_cv : forall z, {l | Cser_abs_cv (gt_pser exp_seq z) l}.
Proof.
intro z ; assert (z_bd : Cnorm z < Cnorm z + 1) by intuition ;
 destruct (Cpser_abel2_prelim _ _ (exp_infinite_cv_radius (Cnorm z + 1)%R) _ z_bd) as [l Hl].
 unfold Cpser_norm in Hl.
 exists (Cre l) ; unfold Cser_abs_cv.
apply Rseq_cv_eq_compat with
      (fun n => Cre (sum_f_C0 (fun n : nat => Cnorm (gt_pser exp_seq z n)) n)).
intro n ; rewrite <- sum_f_C0_Cre_compat ; simpl ; reflexivity.
apply Cseq_cv_re_compat.
auto.
Qed.

Lemma binomial_diag : forall n, Binomial.C n n = 1%R.
Proof.
intros n.
unfold Binomial.C.
rewrite minus_diag.
simpl.
field.
INR_solve; apply fact_neq_0.
Qed.

Lemma binomial_zero : forall n, Binomial.C n 0 = 1%R.
Proof.
intros n.
unfold Binomial.C.
simpl.
rewrite <- minus_n_O.
field.
INR_solve; apply fact_neq_0.
Qed.

Open Scope C_scope.

Lemma binomial_sum : forall (x y:C) n,
  (x + y) ^ n = sum_f_C0 (fun p => IRC (Binomial.C n p) * x ^ p * y ^ (n - p)) n.
Proof.
intros x y n.
induction n.
 unfold Binomial.C; simpl.
 rewrite <- Ceq; simpl; split; field.

 destruct n.
  unfold Binomial.C; simpl.
  rewrite <- Ceq; simpl; split; field.

  rewrite sum_f_C0_simpl.
  rewrite <- sum_f_C0_reindex.

  rewrite Csum_eq_compat with _ (fun k =>
    Binomial.C (S n)    k  * x ^ S k * y ^ (S (S n) - S k) +
    Binomial.C (S n) (S k) * x ^ S k * y ^ (S (S n) - S k)) _.
   rewrite sum_f_C0_add_compat.
   rewrite Cpow_S.
   rewrite IHn.
   rewrite Cmult_add_distr_l.
   do 2 (rewrite Cmult_comm; rewrite sum_f_C0_mult).
   assert (AP:forall a b c d e f, a = d + f -> b = c + e -> a + b = c + (d + e) + f)
     by (intros; subst; ring); apply AP; clear AP.
    rewrite sum_f_C0_simpl.
    repeat rewrite binomial_diag.
    repeat rewrite minus_diag.
    apply Cadd_eq_compat.
     apply Csum_eq_compat_weak; intro; simpl; ring.
     simpl; ring.

    rewrite <- sum_f_C0_reindex.
    apply Cadd_eq_compat.
     simpl; repeat rewrite binomial_zero; ring.
     apply Csum_eq_compat; intros j Hj.
     rewrite <- minus_Sn_m with (S n) _; [|lia].
     simpl; ring.

   intros j Hj.
   repeat rewrite <- Cmult_add_distr_r.
   rewrite <- Binomial.pascal; [|lia].
   rewrite Cadd_IRC_Rplus; trivial.
Qed.

Lemma Cexp_add : forall a b, Cexp (a + b) = (Cexp a * Cexp b)%C.
Proof.
intros a b.
unfold Cexp.
pose (gt_pser exp_seq) as tg.
apply Cser_cv_unique with (tg (a + b)).
apply sum_sums.
destruct (Cexp_abs_cv a) as [lna Hlna].
 eapply Cser_cv_eq_compat.
  2:eapply (Ccauchy_product (tg a) (tg b)) ; try apply sum_sums.

  intro n; simpl.
  unfold tg, exp_seq ; unfold_gt.
  rewrite binomial_sum.
  rewrite sum_f_C0_mult.
  apply Csum_eq_compat_weak; intros p.
  unfold Binomial.C.
  rewrite Cdiv_IRC_Rdiv.
   repeat rewrite Cmult_IRC_Rmult.
   repeat rewrite IRC_INR_INC.
   field; repeat split; replace C0 with (INC O)%C by trivial;
     apply not_INC; apply fact_neq_0.
  apply Rmult_integral_contrapositive.
   INR_solve; apply fact_neq_0.
apply Hlna.
Qed.

Lemma Cexp_0 : Cexp C0 = C1.
Proof.
replace C0 with (IRC (IZR 0)) by auto.
rewrite Cexp_exp_compat ; rewrite exp_0 ; auto.
Qed.

Lemma Cexp_mult : forall a n, Cexp (INC n * a) = (Cexp a) ^ n.
Proof.
intros a n ; induction n.
simpl ; rewrite Cmult_0_l ; apply Cexp_0.
rewrite S_INC, Cpow_S, Cmult_add_distr_r,
 Cmult_1_l, Cexp_add, IHn ; ring.
Qed.


(* Check or-patterns *)

Definition g x :=
  match x with ((((1 as x),_) | (_,x)), (_,(2 as y))|(y,_)) => (x,y) end.

Check (refl_equal _ : g ((1,2),(3,4)) = (1,3)).

Check (refl_equal _ : g ((1,4),(3,2)) = (1,2)).

Fixpoint max (n m:nat) {struct m} : nat :=
  match  n, m with
  | S n', S m' => S (max n' m')
  | 0, p | p, 0 => p
  end.

(* Check bug #1477 *)

Inductive I : Set :=
  | A : nat -> nat -> I
  | B : nat -> nat -> I.

Definition foo (x:I) : nat :=
  match x with
    | A a b | B b a => S b
  end.


Require Import Setoid Morphisms.
From mathcomp Require Import all_ssreflect.
From GraphTheory Require Import edone preliminaries bij.
From GraphTheory Require Import setoid_bigop structures mgraph pttdom mgraph2.
From GraphTheory Require Import rewriting reduction open_confluence transfer.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

(** * Completeness of the 2pdom axioms *)

Section s.
Variable A: Type.
Notation term := (pttdom.term A).
Notation nterm := (pttdom.nterm A).
Notation test := (test [the pttdom of term]).
Notation tgraph2 := (graph2 test term).
Notation graph := (graph unit (flat A)).
Notation graph2 := (graph2 unit (flat A)).
Notation step := (@step [the pttdom of term]).
Notation steps := (@steps [the pttdom of term]).

(* local confluence of the additive, packaged system (Proposition 8.1) *)
Proposition local_confluence G G' H H':
    step G G' -> step H H' -> G ≃2p H ->
    exists F, steps G' F /\ steps H' F.
Proof.
  (* by transferring local confluence of open steps *)
  move => GG HH [GH].
  apply ostep_of in GG as [U [[sGU] [UG']]].
  apply ostep_of in HH as [V [[sHV] [VH']]].
  apply oiso_of in GH.
  destruct (ostep_iso sGU GH) as [W [sHW UW]].
  destruct (fun HF => local_confluence HF sHV sHW) as [T [sVT sWT]]. by apply GH.
  have gT: is_graph T. by eapply osteps_graph, sWT; apply UW.
  have gU: is_graph U. by apply UW.
  have gV: is_graph V. by apply VH'.
  have gW: is_graph W. by apply UW.
  apply (steps_of gV gT) in sVT.
  apply (steps_of gW gT) in sWT.
  exists (pack T); split.
  - transitivity (pack W)=>//. apply iso_step.
    etransitivity. apply openK. apply iso_of_oiso.
    eapply oiso2_trans. apply oiso2_sym. eassumption. assumption.
  - transitivity (pack V)=>//. apply iso_step.
    etransitivity. apply openK. apply iso_of_oiso.
    by apply oiso2_sym.
Qed.

Definition measure (G: tgraph2) := #|vertex G| + #|edge G|.

Lemma step_decreases G H: step G H -> measure H < measure G.
Proof.
  rewrite /measure.
  case; intros=>/=; by rewrite ?card_option ?card_sum ?card_unit ?card_void ?addSnnS ?addnS ?addn0.
Qed.

Lemma iso_stagnates (G H : tgraph2) : G ≃2p H -> measure H = measure G.
Proof. case. move=>[l _]. by rewrite /measure (card_bij (iso_v l)) (card_bij (iso_e l)). Qed.

(* confluence, via appropriate variant of Newman's lemma  *)
Proposition confluence F: forall G H, steps F G -> steps F H -> exists F', steps G F' /\ steps H F'.
Proof.
  induction F as [F_ IH] using (well_founded_induction_type (Wf_nat.well_founded_ltof _ measure)).
  move=> G H S.
  move: G H S IH => _ H [F G FG|F__ F0 G' G FF0 FG GG] IH FH.
  - exists H; split=>//. by rewrite -(inhabits FG: _ ≃2p _).
  - move: H FH IH FF0=> _ [F H FH|F F1 H' H FF1 FH HH] IH FF0.
      exists G; split=>//. rewrite -(inhabits FH: _ ≃2p _).  eauto using cons_step.
    destruct (local_confluence FG FH) as [M[GM HM]]. by rewrite -(inhabits FF0: _ ≃2p _).
    destruct (fun D => IH G' D _ _ GG GM) as [L[GL ML]].
     rewrite /Wf_nat.ltof -(iso_stagnates (inhabits FF0)). apply /ltP. by apply step_decreases.
    have HL: steps H' L by transitivity M.
    destruct (fun D => IH H' D _ _ HL HH) as [R[LR HR]].
     rewrite /Wf_nat.ltof -(iso_stagnates (inhabits FF1)). apply /ltP. by apply step_decreases.
     exists R. split=>//. by transitivity L.
Qed.

(* graphs of normal forms are in normal form (i.e., can't reduce) *)
Lemma normal_steps s: forall H : tgraph2 , steps (tgraph_of_nterm s) H -> tgraph_of_nterm s ≃2p H.
Proof.
  suff E: forall G H, steps G H -> G ≃2p tgraph_of_nterm s -> G ≃2p H.
    by intros; apply E=>//; reflexivity.
  destruct 1 as [G H I|G' G H H' I S _]=>//L.
  - exfalso. setoid_rewrite (inhabits I: _ ≃2p _) in L.
    clear -S L. destruct L as [[L Li Lo]]. generalize (card_bij (iso_e L)).
    destruct s; destruct S; simpl in *; (try by rewrite !card_option ?card_sum ?card_unit ?card_void); rewrite /unl in Li, Lo; move=>_.
    * generalize (card_bij (iso_v L)). rewrite card_sum !card_unit addnC.
      have H: 0 < #|G|. apply /card_gt0P. by exists input.
      revert H. case #|G|; discriminate.
    * revert Li Lo.
      suff E: input=output :>G by congruence.
      apply/(card_le1_eqP (A := predT)) => //.
      apply iso_v, card_bij in L. rewrite !card_sum !card_unit addnC in L.
        by injection L=>->.
    * have E: forall y, L (inr tt) <> L (inl y) by intros y H; generalize (bij_injective (f:=L) H).
      case_eq (L (inr tt)); case.
       generalize (E input). simpl in *. congruence.
       generalize (E output). simpl in *. congruence.
    * generalize (endpoint_iso L false None). generalize (endpoint_iso L true None).
      have H: L.e None = None by case (L.e None)=>//; repeat case.
      rewrite H. case L.d; simpl; congruence.
Qed.

(* isomorphisms on graphs of normal forms give back equations *)
Lemma normal_iso (s t: nterm):
  tgraph_of_nterm s ≃2p tgraph_of_nterm t ->
  term_of_nterm s ≡ term_of_nterm t.
Proof.
  case s=>[a|a u b];
  case t=>[c|c v d]=>/=; move=> [[h hi ho]].
  - symmetry. by apply (vlabel_iso h tt).
  - exfalso.
    generalize (bijK' h (inl tt)). generalize (bijK' h (inr tt)).
    case (h^-1 (inr tt)). case (h^-1 (inl tt)). congruence.
  - exfalso.
    generalize (bijK h (inl tt)). generalize (bijK h (inr tt)).
    case (h (inr tt)). case (h (inl tt)). congruence.
  - generalize (vlabel_iso h (inl tt)).
    generalize (vlabel_iso h (inr tt)).
    simpl in *.
    rewrite hi ho /=.
    generalize (elabel_iso h None).
    generalize (endpoint_iso h (h.d None) None).
    have H: h.e None = None by case (h.e None)=>//; repeat case. rewrite H.
    case (iso_d h None)=>/=. by rewrite hi.
    intros. symmetry. apply dot_eqv=>//. apply dot_eqv=>//.
Qed.

(* transferring isomorphisms on letter-labeled graphs to term-labeled graphs *)
Lemma tgraph_graph (u: term):
  tgraph_of_term u ≃2
  relabel2 (fun _ => 1%CM) (fun x : flat A => pttdom.tm_var x) (graph_of_term u).
Proof.
  have ? : 1%CM ≡ (1 ⊗ 1)%CM by move => M; rewrite monU.
  induction u=>/=.
  - etransitivity. apply (dot_iso2 IHu1 IHu2). symmetry. apply relabel2_dot => //.
  - etransitivity. apply (par_iso2 IHu1 IHu2). symmetry. apply relabel2_par=>//.
  - etransitivity. apply (cnv_iso2 IHu). symmetry. apply relabel2_cnv=>//.
  - etransitivity. apply (dom_iso2 IHu). symmetry. apply relabel2_dom=>//.
  - symmetry. apply relabel2_one=>//.
  - symmetry. apply relabel2_var=>//.
Qed.

(* Lemma 5.3 *)
Lemma tgraph_graph_iso (u v: term):
  graph_of_term u ≃2p graph_of_term v -> tgraph_of_term u ≃2p tgraph_of_term v.
Proof.
  intros [h]. exists.
  etransitivity. apply tgraph_graph.
  etransitivity. 2: symmetry; apply tgraph_graph.
  apply relabel2_iso=>//.
  case=>//=??/=->//.
Qed.

(** main completeness theorem *)
Theorem completeness (u v: term): graph_of_term u ≃2p graph_of_term v -> u ≡ v.
Proof.
  move=>/tgraph_graph_iso h.
  pose proof (reduce u) as H.
  have H' : steps (tgraph_of_term u) (tgraph_of_nterm (nt v))
    by rewrite h; apply reduce.
  case (confluence H H')=>F [/normal_steps HF /normal_steps HF'].
  rewrite-> (nt_correct u), (nt_correct v).
  apply normal_iso. by rewrite HF'.
Qed.

(** actually an iff since graphs from a 2pdom algebra *)
Theorem soundness_and_completeness (u v: term): graph_of_term u ≃2p graph_of_term v <-> u ≡ v.
Proof.
  split => [|uv]; first exact: completeness.
  change (graph_of_term u ≡ graph_of_term v).
  exact: uv. (* graph_of_term is an evaluation w.r.t. a 2pdom algebra *)
Qed.

End s.


(**********************************************************************************
 * Finmap.v                                                                       *
 * Formalizing Domains, Ultrametric Spaces and Semantics of Programming Languages *
 * Nick Benton, Lars Birkedal, Andrew Kennedy and Carsten Varming                 *
 * Jan 2012                                                                       *
 * Build with Coq 8.3pl2 plus SSREFLECT                                           *
 **********************************************************************************)

Require Export NSetoid MetricCore Finmap.

Section SET.
Variable T:compType.
Variable S:setoidType.

Lemma finmap_setoid_axiom : Setoid.axiom (fun f f' : FinDom T S => dom f =i dom f' /\ forall t, t \in dom f -> f t =-= f' t).
split ; last split.
- by move => f ; simpl ; split ; last by [].
- move => x y z ; simpl => X Y. case: X => D X. case: Y => D' Y.
  split. move => a. rewrite (D a). by rewrite (D' a).
  move => a A. rewrite -> (X a A). rewrite D in A. by apply (Y _ A).
- move => x y ; simpl => X. case: X => D X.
  split => a. by rewrite (D a). move => A. rewrite <- D in A. by rewrite -> (X a A).
Qed.

Definition findom_setoidMixin := SetoidMixin finmap_setoid_axiom.
Canonical Structure findom_setoidType := Eval hnf in SetoidType findom_setoidMixin.

Lemma indom_app_respect (f f': findom_setoidType) x (P:x \in dom f) (P':x \in dom f') : f =-= f' -> indom_app P =-= indom_app P'.
move => e. have X:Some (indom_app P) =-= Some (indom_app P') ; last by apply X.
do 2 rewrite indom_app_eq. case: f e P => s A. case: f' P' => s' A'. move => P e P'.
unfold tset_eq in e. simpl in e. by apply (proj2 e).
Qed.

Lemma respect_domeq (f f':findom_setoidType) : f =-= f' -> dom f =i dom f'.
case:f => s P. case:f' => s' P'.
unfold dom. simpl. unfold tset_eq. simpl. unfold dom. simpl. by move => [A _].
Qed.

Lemma findom_sapp_respect (x:T) : setoid_respect (fun f:findom_setoidType => f x).
move => f f' e. case_eq (x \in dom f) => D. by apply (proj2 e x D).
rewrite findom_undef ; last by rewrite D. rewrite (proj1 e) in D.
rewrite findom_undef ; last by rewrite D. by [].
Qed.

Definition findom_sapp (x:T) : findom_setoidType =-> option_setoidType S :=
  Eval hnf in mk_fset (findom_sapp_respect x).

End SET.

Section MET.
Variable T:compType.
Variable M:metricType.

Lemma findom_metric_axiom : Metric.axiom (fun n => (fun f f' : FinDom T M => match n with O => True | S _ =>
       dom f =i dom f' /\ forall i, i \in dom f -> i \in dom f' -> f i = n = f' i end)).
move => n x y z. split ; last split ; last split ; last split ; clear.
- split => X.
  + split. specialize (X 1). simpl in X. by apply (proj1 X).
    move => t I. apply: (proj1 (Mrefl _ _)) => n. case: n ; first by []. move => n. specialize (X n.+1).
    simpl in X. apply (proj2 X). by apply I. rewrite (proj1 X) in I. by apply I.
  + case ; first by []. move => n. split ; first by apply (proj1 X). move => i I I'.
    apply (proj2 (Mrefl _ _)). by apply (proj2 X _ I).
- move => A. simpl. simpl in A. case: n A ; first by []. move => n [A B]. split ; first by move => a ; rewrite -> A.
  move => i I I'. specialize (B i I' I). by apply (Msym B).
- move => A B. simpl in A,B. simpl. case: n A B ; first by [].
  move => n [A D] [A' D']. split ; first by move => a ; rewrite A; rewrite A'.
  move => i I I'. specialize (D i I). rewrite A in I. specialize (D I). specialize (D' i I I').
  by apply (Mrel_trans D D').
- move => A. simpl. simpl in A. case: n A ; first by []. move => n [D A]. split ; first by [].
  move => i I I'. specialize (A i I I'). by apply Mmono.
- by [].
Qed.

Canonical Structure findom_metricMixin := MetricMixin findom_metric_axiom.
Canonical Structure findom_metricType := Eval hnf in MetricType findom_metricMixin.

Lemma findom_f_nonexp (f f':findom_metricType) n x : f = n = f' -> f x = n = f' x.
case: n x ; first by [].
move => n x [E P]. case_eq (x \in dom f) => D.
- have D':=D. rewrite E in D'. specialize (P x D D'). by apply P.
  rewrite findom_undef ; last by rewrite D.
  rewrite E in D. rewrite findom_undef ; last by rewrite D. by [].
Qed.

Lemma findom_sapp_ne (x:T) : nonexpansive (fun f:findom_metricType => f x).
move => n f f' e. by apply: findom_f_nonexp.
Qed.

Definition findom_napp (x:T) : findom_metricType =-> option_metricType M :=
  Eval hnf in mk_fmet (findom_sapp_ne x).

End MET.

Section CMET.
Variable T:compType.
Variable M:cmetricType.

Lemma findom_chain_dom x n (c:cchain (findom_metricType T M)) : x \in dom (c 1) -> x \in dom (c n.+1).
elim: n c ; first by [].
move => n IH c X. specialize (IH (cutn 1 c)). simpl in IH. do 2 rewrite -> addSn, -> add0n in IH.
apply IH. clear IH. have C:=cchain_cauchy c. specialize (C 1 1 2 (ltnSn _) (ltnW (ltnSn _))).
by rewrite (proj1 C) in X.
Qed.

Definition findom_chainx (c:cchain (findom_metricType T M)) x (P:x \in dom (c 1)) : cchain M.
exists (fun n => @indom_app _ _ (c n.+1) _ (findom_chain_dom _ n _ P)).
case ; first by [].
move => n i j l l'.
have X: Some (indom_app (findom_chain_dom x i c P)) = n.+1 = Some (indom_app (findom_chain_dom x j c P)) ; last by apply X.
do 2 rewrite indom_app_eq. have a:= (@cchain_cauchy _ c n.+1 i.+1 j.+1 (ltnW l) (ltnW l')).
by apply findom_f_nonexp.
Defined.

Definition findom_lub (c:cchain (findom_metricType T M)) : findom_metricType T M :=
  @findom_map _ _ _ (c 1) (fun x X => umet_complete (@findom_chainx c x X)).

Lemma ff (P:T -> nat -> Prop) (A:forall x n m, n <= m -> P x n -> P x m) (s:seq T) :
  (forall x, x \in s -> exists m, P x m) -> exists m, forall x, x \in s -> P x m.
elim: s ; first by move => X; exists 0.
move => t s IH X. specialize (IH (fun x A => X x (mem_cons t A))). case: IH => [m IH].
case: (X t (mem_head t _)) => [m' Pm']. exists (maxn m m'). move => x I.
rewrite in_cons in I. case_eq (x == t) => E.
- rewrite (eqP E). apply: (A _ _ _ _ Pm'). by rewrite leq_maxr.
- rewrite E in I. simpl in I. specialize (IH _ I). apply: (A _ _ _ _ IH). by rewrite leq_maxl.
Qed.

Lemma findom_lubP (c:cchain (findom_metricType T M)) : mconverge c (findom_lub c).
unfold findom_lub. case ; first by exists 0. move => n.
have A:exists m, forall x, x \in dom (c 1) -> forall (X: x \in dom (c 1)) i, m < i -> c i x = n.+1 = Some (umet_complete (findom_chainx _ _ X)).
apply (@ff (fun x m => forall (X:x \in dom (c 1)) i, m < i -> c i x = n.+1 = Some (umet_complete (findom_chainx _ _ X)))).
clear. move => x j i A Y X k L. apply Y. by apply (@ssrnat.leq_ltn_trans _ _ _ A L).
move => x I. destruct (cumet_conv (findom_chainx _ _ I) n.+1) as [m P].
exists m. move => X. case ; first by []. move => i L. specialize (P i L). simpl in P.
rewrite <- (indom_app_eq (findom_chain_dom _ i _ I)).
apply: (Mrel_trans P). apply umet_complete_extn. move=> j. simpl.
have A:Some (indom_app (findom_chain_dom _ j _ I)) = n.+1 = Some (indom_app (findom_chain_dom _ j _ X)) ; last by apply A.
rewrite (indom_app_eq (findom_chain_dom _ j _ I)). by rewrite (indom_app_eq (findom_chain_dom _ j _ X)).
destruct A as [m A]. exists m.+1. case ; first by []. move => i L. split. rewrite <- dom_findom_map.
have B:=cchain_cauchy c. specialize (B 1 i.+1 1 (ltn0Sn i) (ltn0Sn _)). apply (proj1 B).
move => x I I'. specialize (A x).
have J:x \in dom (c 1). have J:=cchain_cauchy c. specialize (J 1 i.+1 1 (ltn0Sn _) (ltn0Sn _)). have X:= (proj1 J).
rewrite X in I. by [].
specialize (A J J i.+1 L). apply (Mrel_trans A).
by rewrite -> (findom_map_app J).
Qed.

Canonical Structure findom_cmetricMixin := CMetricMixin findom_lubP.
Canonical Structure findom_cmetricType := Eval hnf in CMetricType findom_cmetricMixin.

Lemma dom_findom_lub (c:cchain findom_cmetricType) : dom (umet_complete c) = dom (c 1).
unfold umet_complete. simpl. unfold findom_lub.
by rewrite <- dom_findom_map.
Qed.

Lemma findom_lub_eq (c:cchain findom_cmetricType) x : umet_complete c x =-= umet_complete (liftc (findom_napp _ _ x) c).
apply: (proj1 (Mrefl _ _)) => n.
case: (cumet_conv c n). move => m X.
case: (cumet_conv (liftc (findom_napp T M x) c) n). move => m' Y.
specialize (X ((m+m')%N.+1)%N). specialize (X (leqW (leq_addr _ _))). specialize (Y ((m+m')%N.+1) (leqW (leq_addl _ _))).
case: n X Y ; first by [].
move => n X Y. case: X => D X. specialize (X x).
- case_eq (x \in dom (umet_complete c)) => e.
  have e':=e. rewrite dom_findom_lub in e'. specialize (X (findom_chain_dom _ _ _ e') e).
  rewrite <- X. by rewrite <- Y.
- rewrite findom_undef ; last by rewrite e. clear X. rewrite <- Y. clear Y. simpl.
  rewrite findom_undef ; first by []. rewrite D. by rewrite e.
Qed.

End CMET.


Require Coq.Vectors.Vector.
Import Coq.Vectors.VectorDef.VectorNotations.

Set Implicit Arguments.

Definition Vector_caseS'
           {A'} (Q : nat -> Type)
           (P : forall {n} (v : Vector.t A' (S n)), Q n -> Type)
           (H : forall h {n} t q, @P n (h :: t) q) {n} (v: Vector.t A' (S n))
           (q : Q n)
: P v q.
Proof.
  specialize (fun h t => H h _ t q).
  change n with (pred (S n)) in H, q |- *.
  set (Sn := S n) in *.
  pose (fun Sn (v : Vector.t A' Sn) (q : Q (pred Sn)) =>
          match Sn return Vector.t A' Sn -> Q (pred Sn) -> Type with
            | S n' => P n'
            | 0 => fun _ _ => True
          end v q) as P'.
  change (match Sn return Type with
            | 0 => True
            | _ => P' Sn v q
          end).
  change (forall h (t : match Sn with
                          | S n' => Vector.t A' n'
                          | 0 => Vector.t A' Sn
                        end),
            P' Sn (match Sn return match Sn with
                                     | S n' => Vector.t A' n'
                                     | 0 => Vector.t A' Sn
                                   end -> Vector.t A' Sn
                   with
                     | S _ => fun t => h :: t
                     | 0 => fun t => t
                   end t) q) in H.
  clearbody P'; clear P.
  clearbody Sn.
  destruct v as [|h ? t].
  { constructor. }
  { apply H. }
Defined.


Require Import VST.floyd.proofauto.
Require Import VST.progs.sumarray.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.
Definition Gprog: funspecs := nil.
Definition Delta1 : tycontext :=
  ltac:(let x := constr:(func_tycontext f_sumarray Vprog Gprog nil)
         in let y := eval hnf in x
         in exact y).

(* This example is from the "EX, Intros, Exists" chapter of the Verifiable C Reference Manual *)
Lemma exercise1:
 let Delta := @abbreviate _ Delta1 in
 forall sh p,
 ENTAIL Delta,
   EX x:Z,
    PROP(0<=x) LOCAL(temp _i (Vint (Int.repr x)))
    SEP (EX y:Z, !!(x<y) && data_at sh tint (Vint (Int.repr y)) p)
|-- EX u: Z,
     PROP(0<u) LOCAL()
     SEP (data_at sh tint (Vint (Int.repr u)) p).
Proof.
intros.
Intros a b.
Exists b.
entailer!.
Qed.

(* These examples of [rep_lia] are from is from the "Integers: nat, Z, int" chapter of the Verifiable C Reference Manual *)
Lemma exercise2:
  forall x,
  Int.min_signed <= x <= Int.max_signed ->
  Int.signed (Int.repr x) = x.
Proof.
intros x H.
(* Notice that the premise H is needed for the next line *)
rewrite Int.signed_repr by rep_lia.
auto.
Qed.

Lemma exercise3:
  forall n, 0 <= n <= Int.max_signed ->
  Int.min_signed <= 0 <= n.
Proof.
intros.
rep_lia.
Qed.

Lemma exercise3b:
  forall al: list Z ,  Zlength al < 50 ->
         0 <= Zlength al < Int.max_signed.
Proof.
intros.
rep_lia.
Qed.

Lemma exercise3c:
  forall i,
         0 <= Int.unsigned (Int.repr i) <= Int.max_unsigned.
Proof.
intros.
rep_lia.
Qed.

(**  How to manage semi-opaque constants, using Hint Rewrite : rep_lia. *)
(* Suppose you have an uninitialized array of size N: *)

Module Test1.
Definition N : Z := 20.

Lemma exercise4:
 let Delta := @abbreviate _ Delta1 in
 forall sh p,
    data_at sh (tarray tint N) (Vint (Int.repr 1) :: Vint (Int.repr 2) :: repeat Vundef (Z.to_nat (N-2))) p
 |--  !! (0 <= Zlength (repeat Vundef (Z.to_nat (N-2))) < Int.max_signed).
Proof.
intros.
simpl.
(* It's not nice that [simpl] unfolded the list_repeat. *)
entailer!.
repeat rewrite Zlength_cons. rewrite Zlength_nil.
rep_lia.
Abort.

(* To avoid unfolding of the list_repeat, let us make N opaque. *)

Global Opaque N.

(* Unfortunately, that's not good enough:
  Opaque prevents "simpl" and "simple apply" from unfolding N,
  but "reflexivity" and "auto" will still unfold N, causing some
  proofs to blow up. *)
End Test1.

Definition N : Z := proj1_sig (opaque_constant 20).

Lemma exercise4b:
 let Delta := @abbreviate _ Delta1 in
 forall sh p,
    data_at sh (tarray tint N) (Vint (Int.repr 1) :: Vint (Int.repr 2) :: repeat Vundef (Z.to_nat (N-2))) p
 |--  !! (0 <= Zlength (repeat Vundef (Z.to_nat (N-2))) < Int.max_signed).
Proof.
intros.
simpl.
(* That's better; the data_at is more concise.  But now, unfortunately: *)
entailer!.
rewrite Zlength_repeat.
Fail rep_lia.
(* now rep_lia does not know that N=20. *)
Abort.

(* To tell rep_lia that N=20, just add a hint to the rep_lia database: *)

Definition N_eq : N=20 := proj2_sig (opaque_constant _).
Hint Rewrite N_eq : rep_lia.

Lemma exercise4c:
 let Delta := @abbreviate _ Delta1 in
 forall sh p,
    data_at sh (tarray tint N) (Vint (Int.repr 1) :: Vint (Int.repr 2) :: repeat Vundef (Z.to_nat (N-2))) p
 |--  !! (0 <= Zlength (repeat Vundef (Z.to_nat (N-2))) < Int.max_signed).
Proof.
intros.
simpl.
(* That's still good; the data_at is more concise.  *)
entailer!.
rewrite Zlength_repeat.
rep_lia.
rep_lia.
Qed.

(* Summary: Make opaque constants using opaque_constant,
  but Rewrite rule to the rep_lia database. *)


Require Import ZFskol.
Require Import Sublogic.
(*Import CoqSublogicThms.*)

(*Set Printing Universes.*)

(* The level of sets *)
Definition Tj := Type.
(* The level of indices *)
Definition Ti : Tj := Type.

(******************************************************************************)
(** * The type of intensional sets *)

Module Zermelo (Import L:SublogicTheory) <: Zermelo_sig L.

  Inductive iset :=
    isup (X:Ti) (f:X->iset).
  Definition set := iset.

  Definition idx (x:set) := let (X,_) := x in X.
  Definition elts (x:set) : idx x -> set :=
  match x return idx x -> set with
  | isup X f => f
  end.

  Fixpoint eq_set (x y:set) {struct x} :=
  (forall i, #exists j, eq_set (elts x i) (elts y j)) /\
  (forall j, #exists i, eq_set (elts x i) (elts y j)).

  Instance eq_set_refl : Reflexive eq_set.
red; fix rfl 1.
intros (X,f); simpl.
split; intros.
 Texists i; apply rfl.
 Texists j; apply rfl.
Qed.

  Instance eq_set_sym : Symmetric eq_set.
red; fix sym 1.
intros (X,f) (Y,g); simpl.
destruct 1; split; intros.
 Tdestruct (H0 i) as (j,?).
 Texists j.
 apply sym; assumption.

 Tdestruct (H j) as (i,?).
 Texists i.
 apply sym; assumption.
Qed.

Instance eq_set_trans : Transitive eq_set.
red; fix trans 1.
intros (X,f) (Y,g) (Z,h) (xy,yx) (yz,zy); simpl.
split; intros.
 Tdestruct (xy i) as (j,?).
 Tdestruct (yz j) as (k,?).
 Texists k.
 apply trans with (g j); assumption.

 Tdestruct (zy j) as (k,?).
 Tdestruct (yx k) as (i,?).
 Texists i.
 apply trans with (g k); assumption.
Qed.

Lemma eq_set_isL x y : isL (eq_set x y).
destruct x; simpl; intros.
apply and_isL;(apply imp_isL || (apply fa_isL; intro)); prove_isL.
Qed.

Lemma eq_set_def : forall x y,
  (forall i, #exists j, eq_set (elts x i) (elts y j)) ->
  (forall j, #exists i, eq_set (elts x i) (elts y j)) ->
  eq_set x y.
destruct x; simpl; auto.
Qed.

Definition in_set x y :=
  #exists j, eq_set x (elts y j).

Lemma in_set_isL x y : isL (in_set x y).
unfold in_set; auto.
Qed.

Lemma in_set_ind P x y :
  isL P ->
  (forall j, eq_set x (elts y j) -> P) ->
  in_set x y -> P.
intros.
Tdestruct H1 as (i,?); eauto.
Qed.

  Definition incl_set x y := forall z, in_set z x -> in_set z y.

Lemma incl_set_isL x y : isL (incl_set x y).
apply fa_isL; auto using in_set_isL.
Qed.
Hint Resolve eq_set_isL incl_set_isL in_set_isL.

Lemma eq_elim0 x y i :
  eq_set x y ->
  in_set (elts x i) y.
destruct x; simpl; intros.
destruct H.
red; auto.
Qed.

Lemma eq_set_ax : forall x y,
  eq_set x y <-> (forall z, in_set z x <-> in_set z y).
unfold in_set; split; intros.
 split; intros h; Tdestruct h.
  elim (eq_elim0 x y x0) using in_set_ind; intros; auto.
  Texists j; apply eq_set_trans with (elts x x0); trivial.

  apply eq_set_sym in H.
  elim (eq_elim0 y x x0) using in_set_ind; intros; auto.
  Texists j; apply eq_set_trans with (elts y x0); trivial.

  apply eq_set_def; intros.
   apply H.
   Texists i; apply eq_set_refl.

   destruct (H (elts y j)).
   elim H1 using in_set_ind; intros; auto.
    Texists j0; apply eq_set_sym; trivial.

    Texists j; apply eq_set_refl.
Qed.

Definition elts' (x:set) (i:idx x) : {y|in_set y x}.
exists (elts x i).
abstract (Texists i; apply eq_set_refl).
Defined.

Lemma in_reg : forall x x' y,
  eq_set x x' -> in_set x y -> in_set x' y.
intros.
elim H0 using in_set_ind; intros; auto.
Texists j.
apply eq_set_trans with x; trivial.
apply eq_set_sym; trivial.
Qed.

Lemma eq_intro : forall x y,
  (forall z, in_set z x -> in_set z y) ->
  (forall z, in_set z y -> in_set z x) ->
  eq_set x y.
intros.
rewrite eq_set_ax.
split; intros; eauto.
Qed.

Lemma eq_elim : forall x y y',
  in_set x y ->
  eq_set y y' ->
  in_set x y'.
intros.
rewrite eq_set_ax in H0.
destruct (H0 x); auto.
Qed.

  Lemma wf_ax :
  forall (P:set->Prop),
  (forall x, (forall y, in_set y x -> #P y) -> #P x) -> forall x, #P x.
intros P H x.
cut (forall x', eq_set x x' -> #P x');[auto using eq_set_refl|].
induction x; intros.
apply H; intros.
assert (in_set y (isup X f)).
 apply eq_elim with x'; trivial.
 apply eq_set_sym; trivial.
clear H1 H2.
elim H3 using in_set_ind; intros; auto.
apply eq_set_sym in H1; eauto.
Qed.

Definition empty :=
  isup False (fun x => match x with end).

Lemma empty_ax : forall x, in_set x empty -> #False.
intros.
elim H using in_set_ind; intros; auto.
contradiction.
Qed.

Definition singl x := isup unit (fun _ => x).

Definition pair_spec (a b:set->Prop) (x:set) : Prop :=
  forall z, in_set z x <-> #(a z \/ b z).

Definition pair x y :=
  isup bool (fun b => if b then x else y).

Lemma pair_spec_intro a b :
  pair_spec (fun a' => eq_set a' a) (fun b' => eq_set b' b) (pair a b).
intros z.
unfold pair; simpl.
split; intros.
 elim H using in_set_ind; intros; auto.
 apply TrI.
 destruct j; auto.

 Tdestruct H.
  Texists true; trivial.
  Texists false; trivial.
Qed.

Lemma pair_ax : forall a b z,
  in_set z (pair a b) <-> #(eq_set z a \/ eq_set z b).
Proof pair_spec_intro.

Lemma pair_morph :
  forall a a', eq_set a a' -> forall b b', eq_set b b' ->
  eq_set (pair a b) (pair a' b').
unfold pair.
simpl; intros.
split; intros.
 Texists i; destruct i; trivial.
 Texists j; destruct j; trivial.
Qed.

Definition subset_spec (x:set) (P:set->Prop) (y:set) :=
  forall z,
  in_set z y <->
  in_set z x /\ # (exists2 z', eq_set z z' & P z').

Definition subset (x:set) (P:set->Prop) :=
  isup {a|exists2 x', eq_set (elts x a) x' & P x'}
    (fun y => elts x (proj1_sig y)).

Lemma subset_ax : forall x P, subset_spec x P (subset x P).
red.
unfold subset; simpl.
split; intros.
 elim H using in_set_ind; simpl; intros; auto.
 clear H; destruct j as (j,?); simpl in H0.
 split.
  Texists j; trivial.

  destruct e.
  Texists x0; trivial.
  apply eq_set_trans with (elts x j); trivial.

 destruct H.
 elim H using in_set_ind; auto.
 clear H; intros.
 Tdestruct H0.
 assert (exists2 x', eq_set (elts x j) x' & P x').
  exists x0; trivial.
  apply eq_set_trans with z; trivial.
  apply eq_set_sym; trivial.
 Texists (exist (fun a=>exists2 x',eq_set (elts x a) x' & P x') j H2); simpl; trivial.
Qed.

Definition power (x:set) :=
  isup (idx x->Prop)
   (fun P => subset x (fun y => exists2 i, eq_set y (elts x i) & P i)).

Lemma power_ax : forall x z,
  in_set z (power x) <->
  (forall y, in_set y z -> in_set y x).
unfold power; simpl; intros.
split; intros.
 elim H using in_set_ind; intros; auto.
 simpl in *.
 specialize eq_elim with (1:=H0)(2:=H1); intro.
 apply (proj1 (proj1 (subset_ax _ _ _) H2)).

 Texists (fun i => in_set (elts x i) z); simpl.
 apply eq_intro; intros.
  apply (fun x P z => proj2 (subset_ax x P z)).
  split; auto.
  elim H with z0 using in_set_ind; trivial; intros.
  Texists z0.
   apply eq_set_refl.

   exists j; trivial.
   apply in_reg with z0; trivial.

  Tdestruct (proj2 (proj1 (subset_ax _ _ _) H0)) as (z', ?, (i,?,?)).
  apply in_reg with (elts x i); trivial.
  apply eq_set_sym; apply eq_set_trans with z'; trivial.
Qed.

Lemma power_morph : forall x y,
  eq_set x y -> eq_set (power x) (power y).
intros.
apply eq_intro; intros.
 rewrite power_ax in H0|-*; intros.
 apply eq_elim with x; auto.

 apply eq_set_sym in H.
 rewrite power_ax in H0|-*; intros.
 apply eq_elim with y; auto.
Qed.

 Definition union (x:set) :=
  isup {i:idx x & idx (elts x i)}
    (fun p => elts (elts x (projS1 p)) (projS2 p)).

Lemma union_ax : forall a z,
  in_set z (union a) <-> #exists2 b, in_set z b & in_set b a.
unfold in_set at 1, union; simpl; intros.
split; intros.
 Tdestruct H.
 Texists (elts a (projT1 x)).
  Texists (projT2 x); trivial.
  Texists (projT1 x); apply eq_set_refl.

 Tdestruct H.
 Tdestruct H0.
 assert (in_set z (elts a x0)).
  apply eq_elim with x; trivial.
 Tdestruct H1.
 Texists (existT (fun i=>idx(elts a i)) x0 x1); simpl.
 trivial.
Qed.

Lemma union_morph :
  forall a a', eq_set a a' -> eq_set (union a) (union a').
intros.
apply eq_set_ax; intros z.
rewrite union_ax.
rewrite union_ax.
split; intros h; Tdestruct h as (b,?,?); Texists b; trivial.
 apply eq_elim with a; trivial.
 apply eq_elim with a'; trivial.
 apply eq_set_sym; trivial.
Qed.

Fixpoint num (n:nat) : set :=
  match n with
  | 0 => empty
  | S k => union (pair (num k) (pair (num k) (num k)))
  end.

Definition infinite := isup _ num.

Lemma infinity_ax1 : in_set empty infinite.
 Texists 0.
 unfold elts, infinite, num.
 apply eq_set_refl.
Qed.

Lemma infinity_ax2 : forall x, in_set x infinite ->
  in_set (union (pair x (pair x x))) infinite.
intros.
elim H using in_set_ind; intros; auto.
Texists (S j).
simpl elts.
apply union_morph.
apply pair_morph; trivial.
apply pair_morph; trivial.
Qed.

Definition replf (x:set) (F:set->set) :=
  isup _ (fun i => F (elts x i)).

Lemma replf_ax : forall x F z,
  (forall z z', in_set z x ->
   eq_set z z' -> eq_set (F z) (F z')) ->
  (in_set z (replf x F) <->
   #exists2 y, in_set y x & eq_set z (F y)).
unfold replf; simpl; intros.
split; intros.
 elim H0 using in_set_ind; intros; auto.
 simpl in *.
 Texists (elts x j); trivial.
 Texists j; apply eq_set_refl.

 Tdestruct H0 as (x',?,?).
 elim H0 using in_set_ind; intros; auto.
 Texists j; simpl.
 apply eq_set_trans with (F x'); trivial.
 apply eq_set_sym.
 apply H.
  Texists j; apply eq_set_refl.
  apply eq_set_sym; trivial.
Qed.

End Zermelo.