(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

Set Implicit Arguments.
Require Import CyclicAxioms Cyclic63 Int63Compat.
From Bignums Require Import DoubleCyclic BigN.
Require Import ZArith ZCAux Mod_op.

(* ** Type of words ** *)

(* Make the words *)

Definition mk_word: forall (w: Type) (n:nat), Type.
fix mk_word 2.
intros w n; case n; simpl.
exact int.
intros n1; exact (zn2z (mk_word w n1)).
Defined.

(* Make the op *)
Fixpoint mk_op (w : univ_of_cycles) (op : ZnZ.Ops w) (n : nat) {struct n} :
  ZnZ.Ops (word w n) :=
  match n return (ZnZ.Ops (word w n)) with
  | O => op
  | S n1 => mk_zn2z_ops_karatsuba (mk_op op n1)
  end.

Theorem mk_op_digits: forall (w:univ_of_cycles) (op: ZnZ.Ops w) n,
  (Zpos (ZnZ.digits (mk_op op n)) = 2 ^ Z_of_nat n * Zpos (ZnZ.digits op))%Z.
intros w op n; elim n; simpl mk_op; auto; clear n.
intros n Rec; simpl ZnZ.digits.
rewrite Zpos_xO; rewrite Rec.
rewrite Zmult_assoc; apply f_equal2 with (f := Zmult); auto.
rewrite inj_S; unfold Z.succ; rewrite Zplus_comm.
rewrite Zpower_exp; auto with zarith.
Qed.

Theorem digits_pos: forall (w:univ_of_cycles) (op: ZnZ.Ops w) n,
  (1 < Zpos (ZnZ.digits op) ->  1 < Zpos (ZnZ.digits (mk_op op n)))%Z.
intros w op n H.
rewrite mk_op_digits.
rewrite <- (Zmult_1_r 1).
apply Z.le_lt_trans with (2 ^ (Z_of_nat n) * 1)%Z.
apply Zmult_le_compat_r;[ | auto with zarith].
rewrite <- (Zpower_0_r 2).
apply Zpower_le_monotone; auto with zarith.
apply Zmult_lt_compat_l; auto with zarith.
Qed.

Fixpoint mk_spec (w : univ_of_cycles) (op : ZnZ.Ops w) (op_spec : ZnZ.Specs op)
    (H: (1 < Zpos (ZnZ.digits op))%Z)  (n : nat)
            {struct n} : ZnZ.Specs (mk_op op n) :=
  match n return (ZnZ.Specs (mk_op op n)) with
  | O => op_spec
  | S n1 =>
      @mk_zn2z_specs_karatsuba (word w n1) (mk_op op n1)
        (* (digits_pos op n1 H) *) (mk_spec op_spec H n1)
  end.

(* ** Operators ** *)
Definition w63_1_op := mk_zn2z_ops int_ops.
Definition w63_2_op := mk_zn2z_ops w63_1_op.
Definition w63_3_op := mk_zn2z_ops w63_2_op.
Definition w63_4_op := mk_zn2z_ops_karatsuba w63_3_op.
Definition w63_5_op := mk_zn2z_ops_karatsuba w63_4_op.
Definition w63_6_op := mk_zn2z_ops_karatsuba w63_5_op.
Definition w63_7_op := mk_zn2z_ops_karatsuba w63_6_op.
Definition w63_8_op := mk_zn2z_ops_karatsuba w63_7_op.
Definition w63_9_op := mk_zn2z_ops_karatsuba w63_8_op.
Definition w63_10_op := mk_zn2z_ops_karatsuba w63_9_op.
Definition w63_11_op := mk_zn2z_ops_karatsuba w63_10_op.
Definition w63_12_op := mk_zn2z_ops_karatsuba w63_11_op.
Definition w63_13_op := mk_zn2z_ops_karatsuba w63_12_op.
Definition w63_14_op := mk_zn2z_ops_karatsuba w63_13_op.

Definition cmk_op: forall (n: nat), ZnZ.Ops (word int n).
intros n; case n; clear n.
exact int_ops.
intros n; case n; clear n.
exact w63_1_op.
intros n; case n; clear n.
exact w63_2_op.
intros n; case n; clear n.
exact w63_3_op.
intros n; case n; clear n.
exact w63_4_op.
intros n; case n; clear n.
exact w63_5_op.
intros n; case n; clear n.
exact w63_6_op.
intros n; case n; clear n.
exact w63_7_op.
intros n; case n; clear n.
exact w63_8_op.
intros n; case n; clear n.
exact w63_9_op.
intros n; case n; clear n.
exact w63_10_op.
intros n; case n; clear n.
exact w63_11_op.
intros n; case n; clear n.
exact w63_12_op.
intros n; case n; clear n.
exact w63_13_op.
intros n; case n; clear n.
exact w63_14_op.
intros n.
match goal with |- context[S ?X] =>
 exact (mk_op int_ops (S X))
end.
Defined.

Definition cmk_spec: forall n, ZnZ.Specs (cmk_op n).
assert (S1: ZnZ.Specs w63_1_op).
unfold w63_1_op; apply mk_zn2z_specs; auto with zarith.
exact int_specs.
assert (S2: ZnZ.Specs w63_2_op).
unfold w63_2_op; apply mk_zn2z_specs; auto with zarith.
assert (S3: ZnZ.Specs w63_3_op).
unfold w63_3_op; apply mk_zn2z_specs; auto with zarith.
assert (S4: ZnZ.Specs w63_4_op).
unfold w63_4_op; apply mk_zn2z_specs_karatsuba; auto with zarith.
assert (S5: ZnZ.Specs w63_5_op).
unfold w63_5_op; apply mk_zn2z_specs_karatsuba; auto with zarith.
assert (S6: ZnZ.Specs w63_6_op).
unfold w63_6_op; apply mk_zn2z_specs_karatsuba; auto with zarith.
assert (S7: ZnZ.Specs w63_7_op).
unfold w63_7_op; apply mk_zn2z_specs_karatsuba; auto with zarith.
assert (S8: ZnZ.Specs w63_8_op).
unfold w63_8_op; apply mk_zn2z_specs_karatsuba; auto with zarith.
assert (S9: ZnZ.Specs w63_9_op).
unfold w63_9_op; apply mk_zn2z_specs_karatsuba; auto with zarith.
assert (S10: ZnZ.Specs w63_10_op).
unfold w63_10_op; apply mk_zn2z_specs_karatsuba; auto with zarith.
assert (S11: ZnZ.Specs w63_11_op).
unfold w63_11_op; apply mk_zn2z_specs_karatsuba; auto with zarith.
assert (S12: ZnZ.Specs w63_12_op).
unfold w63_12_op; apply mk_zn2z_specs_karatsuba; auto with zarith.
assert (S13: ZnZ.Specs w63_13_op).
unfold w63_13_op; apply mk_zn2z_specs_karatsuba; auto with zarith.
assert (S14: ZnZ.Specs w63_14_op).
unfold w63_14_op; apply mk_zn2z_specs_karatsuba; auto with zarith.
intros n; case n; clear n.
exact int_specs.
intros n; case n; clear n.
exact S1.
intros n; case n; clear n.
exact S2.
intros n; case n; clear n.
exact S3.
intros n; case n; clear n.
exact S4.
intros n; case n; clear n.
exact S5.
intros n; case n; clear n.
exact S6.
intros n; case n; clear n.
exact S7.
intros n; case n; clear n.
exact S8.
intros n; case n; clear n.
exact S9.
intros n; case n; clear n.
exact S10.
intros n; case n; clear n.
exact S11.
intros n; case n; clear n.
exact S12.
intros n; case n; clear n.
exact S13.
intros n; case n; clear n.
exact S14.
intro n.
simpl cmk_op.
repeat match goal with |- ZnZ.Specs
 (mk_zn2z_ops_karatsuba ?X) =>
  generalize (@mk_zn2z_specs_karatsuba _ X); intros tmp;
  apply tmp; clear tmp; auto with zarith
end.
(*
apply digits_pos.
*)
auto with zarith.
apply mk_spec.
exact int_specs.
auto with zarith.
Defined.

Theorem cmk_op_digits: forall n,
  (Zpos (ZnZ.digits (cmk_op n)) = 2 ^ (Z_of_nat n) * 63)%Z.
do 15 (intros n; case n; clear n; [try reflexivity | idtac]).
intros n; unfold cmk_op; lazy beta.
rewrite mk_op_digits; auto.
Qed.


Require Export Classical.
Require Export Coq.Reals.RIneq.
Require Export Lra.
Open Scope R_scope.
Set Implicit Arguments.

Module A0.

Notation "∀ x .. y , P" := (forall x, .. (forall y , P) ..)
(at level 200, x binder, y binder, right associativity,
format "'[' ∀ x .. y ']' , P") : type_scope.

Notation "∃ x .. y , P" := (exists x, .. (exists y , P) ..)
(at level 200, x binder, y binder, right associativity,
format "'[' ∃ x .. y ']' , P" ) :type_scope.

Notation "'λ' x .. y , t " := ( fun x => .. (fun y => t) ..)
(at level 200, x binder, y binder, right associativity,
format "'[' 'λ' x .. y ']' , t" ).

(* 定义：集合 *)
Parameter set : Type -> Type.

(* 定义：属于 *)
Parameter In : ∀ (A : Type), A -> (set A) -> Prop.
Notation "x ∈ A" :=(In x A) (at level 80).

(* 公理I：外延公理 *)
Axiom AxiomI : ∀ (A :Type) (x y : (set A)), x = y
  <-> (∀ z : A, z ∈ x <-> z ∈ y).

Parameter Classifier : ∀ (A: Type) (P: A -> Prop), (set A).
Notation "\{ P \}" := (Classifier P) (at level 0).

(* 公理II：分类公理图式 *)
Axiom AxiomII : ∀ (A : Type) (b : A) (P : A -> Prop),
  b ∈ \{ P \} <-> (P b).

Ltac applyAxiomII H := apply -> AxiomII in H; simpl in H.

(* 定义: 非空集 *)
Definition NotEmpty (A : Type) (S : (set A)) := ∃ (x : A), x ∈S.

(* 定义：两集合中的关系 *)
Definition Union (A : Type) (x y :(set A)) : (set A) :=
  \{ λ z : A, z ∈ x \/ z ∈ y  \} .
Notation "x ∪ y" := (Union x y)(at level 65, right associativity).

Definition Intersection (A : Type) (x y :(set A)) : (set A) :=
  \{ λ z : A, z ∈ x /\ z ∈ y \}.
Notation "x ∩ y" := (Intersection x y)(at level 65, right associativity).

Definition NotIn (A: Type) (x : A) (y : (set A)) : Prop :=
  ~(x ∈ y).
Notation "x ∉ y" := (NotIn x y)(at level 80).

Definition Complement (A : Type) (x : (set A)) := \{ λ y : A, y ∉ x \}.
Notation "～ x" := (Complement x) (at level 5, right associativity).

Definition Difference (A : Type) (x y :(set A)) : (set A) := x ∩ (～ y).
Notation "x \~ y" := (Difference x y)(at level 50).

(* 定义：空集 *)
Definition Empty (A : Type) := \{λ x : A, x <> x \}.

(* 定义：满集 *)
Definition Full (A : Type)  := \{ λ x : A, x = x \}.

(* 非空集性质 *)
Theorem not_empty : ∀ (X : Type) (A : set X), A <> (Empty X) <-> NotEmpty A.
Proof.
  intros X A. unfold NotEmpty. split; intro H0.
  - apply not_all_not_ex. intro H1.
    apply H0. apply AxiomI. intro z; split; intro H2.
    + exfalso. apply (H1 z). auto.
    + exfalso. apply -> AxiomII in H2; simpl in H2. apply H2; auto.
  - intro H1. destruct H0 as [x H2]. rewrite H1 in H2. apply -> AxiomII in H2;
    simpl in H2. apply H2; auto.
Qed.

Definition Inter (A : Type) (x : set (set A)) :=
    \{ λ z : A, ∀ y, y ∈ x -> z ∈ y  \}.
Notation "∩ x" := (Inter x) (at level 55,right associativity).

Definition Un (A : Type) (x : set (set A)) :=
    \{ λ z : A, ∃ y, y ∈ x /\ z ∈ y \}.
Notation "∪ x" := (Un x) (at level 55, right associativity).

Definition Contain (A : Type) (x y : (set A))  := ∀ z, z ∈ x -> z ∈ y.
Notation "x ⊂ y" := (Contain x y) (at level 70).

Definition Singleton (A: Type) (x : A): (set A) := \{ λ z, z = x \}.
Notation "[ x ]" := (Singleton x) (at level 0,right associativity).

(* 公理：选择公理 *)
Parameter choose : ∀ (A : Type) (x : (set A)) (a : A),  A.
Axiom Axiomc : ∀ (A : Type) (x : (set A)) (a : A),
  NotEmpty x -> (choose x a) ∈ x.

Definition cR (x : (set R)) : R := choose x 0.
Definition cN (x : (set nat)) : nat := choose x 0%nat.

Theorem AxiomcR : ∀ (x : (set R)), NotEmpty x -> (cR x) ∈ x.
Proof. intros x H0; apply Axiomc; auto. Qed.
Theorem AxiomcN : ∀ (x : (set nat)), NotEmpty x -> (cN x) ∈ x.
Proof. intros x H0; apply Axiomc; auto. Qed.

Theorem ChooseSingleton : ∀ (A : Type) (x a : A), choose [x] a = x.
Proof.
  intros A x a. assert (H0 : choose [x] a ∈ [x]).
  { apply Axiomc. unfold NotEmpty. exists x. apply <- AxiomII. auto. }
  apply -> AxiomII in H0. apply H0.
Qed.

Theorem ChooseSingletonR : ∀ (x : R), cR [x] = x.
Proof. intros x; apply ChooseSingleton. Qed.

Theorem ChooseSingletonN : ∀ (x : nat), cN [x] = x.
Proof. intros x; apply ChooseSingleton. Qed.

(* 定义：有序对 *)
Inductive prod (X Y : Type) : Type :=
| pair (x : X) (y : Y).
Notation "[ x , y ]" := (pair x y).

Definition fst (X Y : Type) (p : (prod X Y)) : X :=
  match p with
  | [x , y] => x
  end.

Definition snd (X Y : Type) (p : (prod X Y)) : Y :=
  match p with
  | [x , y] => y
  end.

Theorem ProdEqual : ∀ (X Y : Type) (x u : X) (y v : Y),
  [x , y] = [u , v] -> x = u /\ y = v.
Proof.
  intros X Y x u y v H0. assert (H1 : fst [x, y] = x). auto.
  assert (H2 : snd [x, y] = y). auto.
  assert (H3 : fst [u, v] = u). auto.
  assert (H4 : snd [u, v] = v). auto. split.
  - rewrite H0 in H1. rewrite H1 in H3. auto .
  - rewrite H0 in H2. rewrite H2 in H4. auto.
Qed.

Definition Relation (X Y : Type) (r : set (prod X Y)) : Prop :=
  ∀ z , z ∈ r -> (∃ x y, z = [x , y]).

(* 引入符号((x, y) : ...) *)
Definition Classifier_P (X Y : Type) (P : X -> Y -> Prop) :=
  \{ λ u , ∃ x y, u = [x , y] /\ P x y \}.
Notation "{` P `} " := (Classifier_P P) (at level 0).

Definition Comosition (X Y Z : Type) (r : set (prod Y Z)) (s : set (prod X Y))
  : set (prod X Z) := {` λ x z, (∃ y, [x, y] ∈ s /\ [y, z] ∈ r ) `}.
Notation "r ◦ s" := (Comosition r s) (at level 50,no associativity).

Definition Inverse (X Y : Type)( r : set (prod X Y)) : set (prod Y X) :=
  {` λ x y, [y, x] ∈ r  `}.
Notation "r ﹣¹" := (Inverse r) (at level 5).

Theorem AxiomII' : ∀ (X Y : Type) (x : X) (y : Y) (P : X -> Y -> Prop),
  [x, y] ∈ {` P `}  <-> P x y.
Proof.
  intros X Y x y P. split;intros.
  - apply -> AxiomII in H. simpl in H. destruct H as [u [v [H H0]]].
    apply ProdEqual in H. destruct H. rewrite H,H1. auto.
  - apply  AxiomII. exists x, y. split;auto.
Qed.

Ltac applyAxiomII' H := apply -> AxiomII' in H; simpl in H.

(* 定义：函数  *)
Definition Function (A B : Type) (f : set (prod A B)) : Prop :=
  ∀ x y z, [x, y] ∈ f -> [x, z] ∈ f -> y = z.

(* 定义：定义域 *)
Definition Domain (X Y : Type) (f : set (prod X Y)) :=
  \{ λ x, ∃ y, [x, y] ∈ f \}.
Notation "dom[ f ]" := (Domain f) (at level 5).

(* 定义：值域 *)
Definition Range (X Y : Type) (f : set (prod X Y)) :=
  \{ λ y, ∃ x, [x, y] ∈ f \}.
Notation "ran[ f ]" := (Range f) (at level 5).

(* 定义：值 *)
Definition Value (X Y : Type) (f : set (prod X Y)) (x : X) (o : Y) :=
  choose \{ λ y, [x, y] ∈ f \} o.
Definition ValueR (X : Type) (f : set (prod X R)) (x : X) :=
  cR \{ λ y, [x, y] ∈ f \}.
Definition ValueN (X : Type) (f : set (prod X nat)) (x : X) :=
  cN \{ λ y, [x, y] ∈ f \}.
Notation "f [ x | y ]" := (Value f x y) (at level 5).
Notation "f [ x ]" := (ValueR f x) (at level 5).
Notation "f \[ x \]" := (ValueN f x) (at level 5).

Theorem f_x_T : ∀ (X Y : Type) (f : set (prod X Y)) (x : X)(y o : Y) ,
  Function f -> [x, y] ∈ f -> f[ x | o ] = y.
Proof.
  intros X Y f x y o H1 H2. unfold Value.
  assert (H3 : \{ λ y0 : Y, [x, y0] ∈ f \} = [y]).
  { apply AxiomI. intro z. split; intro H3.
    + apply -> AxiomII in H3. simpl in H3. apply  AxiomII.
      apply H1 with (x := x);auto.
    + apply AxiomII. apply -> AxiomII in H3. simpl in H3.
      rewrite H3. auto. }
  rewrite H3. apply ChooseSingleton.
Qed.

Theorem f_x : ∀ (X : Type) (f : set (prod X R)) (x : X)(y : R) ,
  Function f -> [x, y] ∈ f -> f[ x ] = y.
Proof.
  intros X f x y H1 H2. unfold ValueR.
  assert (H3 : \{ λ y0 : R, [x, y0] ∈ f \} = [y]).
  { apply AxiomI. intro z. split; intro H3.
    + apply -> AxiomII in H3. simpl in H3. apply  AxiomII.
      apply H1 with (x := x);auto.
    + apply AxiomII. apply -> AxiomII in H3. simpl in H3.
      rewrite H3. auto. }
  rewrite H3. apply ChooseSingletonR.
Qed.

Theorem f_x_N : ∀ (X : Type) (f : set (prod X nat)) (x : X)(y : nat) ,
  Function f -> [x, y] ∈ f -> f\[ x \] = y.
Proof.
  intros X f x y H1 H2. unfold ValueN.
  assert (H3 : \{ λ y0 : nat, [x, y0] ∈ f \} = [y]).
  { apply AxiomI. intro z. split; intro H3.
    + apply -> AxiomII in H3. simpl in H3. apply  AxiomII.
      apply H1 with (x := x);auto.
    + apply AxiomII. apply -> AxiomII in H3. simpl in H3.
      rewrite H3. auto. }
  rewrite H3. apply ChooseSingletonN.
Qed.

Theorem fx_ran : ∀ (X : Type) (f : set (prod X R)) (x : X),
  Function f -> x ∈ dom[f] -> f[x] ∈ ran[f].
Proof.
  intros X f x H0 H1. apply -> AxiomII in H1. simpl in H1.
  destruct H1 as [y H1]. apply f_x in H1 as H2; auto. rewrite H2.
  apply <- AxiomII. exists x; auto.
Qed.

Theorem fx_ran_N : ∀ (X : Type) (f : set (prod X nat)) (x : X),
  Function f -> x ∈ dom[f] -> f\[x\] ∈ ran[f].
Proof.
  intros X f x H0 H1. apply -> AxiomII in H1. simpl in H1.
  destruct H1 as [y H1]. apply f_x_N in H1 as H2; auto. rewrite H2.
  apply <- AxiomII. exists x; auto.
Qed.

Theorem x_fx_T : ∀ (X Y : Type) (f : set (prod X Y)) (x : X) (o : Y),
  Function f -> x ∈ dom[f] -> [x, f[x | o]] ∈ f.
Proof.
  intros X Y f x o H0 H1. apply -> AxiomII in H1; simpl in H1.
  destruct H1 as [y H1]. apply f_x_T with (o := o) in H1 as H2; auto.
  rewrite H2; auto.
Qed.

Theorem x_fx : ∀ (X : Type) (f : set (prod X R)) (x : X),
  Function f -> x ∈ dom[f] -> [x, f[x]] ∈ f.
Proof.
  intros X f x H0 H1. apply -> AxiomII in H1; simpl in H1.
  destruct H1 as [y H1]. apply f_x in H1 as H2; auto.
  rewrite H2; auto.
Qed.

Theorem x_fx_N : ∀ (X : Type) (f : set (prod X nat)) (x : X),
  Function f -> x ∈ dom[f] -> [x, f\[x\]] ∈ f.
Proof.
  intros X f x H0 H1. apply -> AxiomII in H1; simpl in H1.
  destruct H1 as [y H1]. apply f_x_N in H1 as H2; auto.
  rewrite H2; auto.
Qed.

Lemma IsFun : ∀ (X Y : Type) (f : X -> Y),
  Function {` λ x y, y = f x `}.
Proof.
  intros X Y f n v1 v2 H0 H1.
  applyAxiomII' H0. applyAxiomII' H1.
  rewrite H1. assumption.
Qed.

Lemma FunValue : ∀ (X Y : Type) (f : X -> Y) (x : X)
  (o : Y), {` λ x y, y = f x `}[x | o] = f x.
Proof.
  intros X Y f x o.
  apply f_x_T; [apply IsFun | apply AxiomII'].
  reflexivity.
Qed.

Lemma FunValueR : ∀ (X : Type) (f : X -> R) (x : X),
  {` λ t y, y = f t `}[x] = f x.
Proof.
  intros X f n. apply FunValue.
Qed.

(* 定义:笛卡尔积 *)
Definition Cartesian (X Y : Type) (x : set X) (y : set Y) :=
  {` λ u v, u ∈ x /\ v ∈ y `}.
Notation "x × y" := (Cartesian x y)(at level 2, right associativity).

(* 定义:限制 *)
Definition Restriction (X Y : Type) (f : set (prod X Y)) (x : set X) :=
  f ∩ (x × (Full Y)).
Notation "f | [ x ]" := (Restriction f x)(at level 30).

Theorem RestrictFun : ∀ (X : Type) (f : set (prod X R)) (x : set X),
  Function f -> (Function (f|[x]) /\ dom[f|[x]] = (x ∩ (dom[f]))
  /\ (∀ y, y ∈ dom[f|[x]] -> (f|[x])[y] = f[y] )).
Proof.
  intros X f x H0. assert (H1 : Function (f | [x])).
  { unfold Function. intros x0 y0 z0 H1 H2. apply -> AxiomII in H1; simpl in H1.
    apply -> AxiomII in H2; simpl in H2. destruct H1 as [H1 H3].
    destruct H2 as [H2 H4]. apply H0 with (x := x0); auto. }
  split; [auto | split].
  - apply AxiomI. intro u; split; intro H2.
    + apply -> AxiomII in H2; simpl in H2. destruct H2 as [v H3].
      apply -> AxiomII in H3; simpl in H3.
      destruct H3 as [H4 H5]. apply <- AxiomII. split.
      * apply -> AxiomII' in H5;simpl in H5. apply H5.
      * apply <- AxiomII. exists v; auto.
    + apply -> AxiomII in H2; simpl in H2. destruct H2 as [H3 H4].
      apply -> AxiomII in H4; simpl in H4.
      destruct H4 as [v H5]. apply <- AxiomII.
      exists v. apply <- AxiomII. split; auto. apply <- AxiomII'.
      split; auto. apply <- AxiomII. auto.
  - intros y H2. apply -> AxiomII in H2; simpl in H2.
    destruct H2 as [fy H3]. apply f_x in H3 as H4; auto. rewrite H4.
    apply -> AxiomII in H3; simpl in H3. destruct H3 as [H3 H5].
    apply f_x in H3; auto.
Qed.

Theorem RestrictFun_N : ∀ (X : Type) (f : set (prod X nat)) (x : set X),
  Function f -> (Function (f|[x]) /\ dom[f|[x]] = (x ∩ (dom[f]))
  /\ (∀ y, y ∈ dom[f|[x]] -> (f|[x])\[y\] = f\[y\] )).
Proof.
  intros X f x H0. assert (H1 : Function (f | [x])).
  { unfold Function. intros x0 y0 z0 H1 H2. apply -> AxiomII in H1; simpl in H1.
    apply -> AxiomII in H2; simpl in H2. destruct H1 as [H1 H3].
    destruct H2 as [H2 H4]. apply H0 with (x := x0); auto. }
  split; [auto | split].
  - apply AxiomI. intro u; split; intro H2.
    + apply -> AxiomII in H2; simpl in H2. destruct H2 as [v H3].
      apply -> AxiomII in H3; simpl in H3.
      destruct H3 as [H4 H5]. apply <- AxiomII. split.
      * apply -> AxiomII' in H5;simpl in H5. apply H5.
      * apply <- AxiomII. exists v; auto.
    + apply -> AxiomII in H2; simpl in H2. destruct H2 as [H3 H4].
      apply -> AxiomII in H4; simpl in H4.
      destruct H4 as [v H5]. apply <- AxiomII.
      exists v. apply <- AxiomII. split; auto. apply <- AxiomII'.
      split; auto. apply <- AxiomII. auto.
  - intros y H2. apply -> AxiomII in H2; simpl in H2.
    destruct H2 as [fy H3]. apply f_x_N in H3 as H4; auto. rewrite H4.
    apply -> AxiomII in H3; simpl in H3. destruct H3 as [H3 H5].
    apply f_x_N in H3; auto.
Qed.

(* 定义:1_1函数 *)
Definition Function1_1 (A B : Type) (f : set (prod A B)) : Prop :=
  Function f /\ Function (f﹣¹).

Theorem RestrictFun1_1 : ∀ (X : Type) (f : set (prod X R)) (x : set X),
  Function1_1 f -> Function1_1 (f|[x]).
Proof.
  intros X f x H0. destruct H0 as [H0 H1].
  apply RestrictFun with (x := x) in H0 as H2.
  destruct H2 as [H2 [H3 H4]]. split; auto. unfold Function.
  intros x0 y0 z0 H5 H6. apply -> AxiomII' in H5; simpl in H5.
  apply -> AxiomII' in H6; simpl in H6. apply -> AxiomII in H5; simpl in H5.
  apply -> AxiomII in H6; simpl in H6. destruct H5 as [H5 H7].
  destruct H6 as [H6 H8]. apply H1 with (x := x0); apply <- AxiomII'; auto.
Qed.

Theorem RestrictFun1_1_N : ∀ (X : Type) (f : set (prod X nat)) (x : set X),
  Function1_1 f -> Function1_1 (f|[x]).
Proof.
  intros X f x H0. destruct H0 as [H0 H1].
  apply RestrictFun_N with (x := x) in H0 as H2.
  destruct H2 as [H2 [H3 H4]]. split; auto. unfold Function.
  intros x0 y0 z0 H5 H6. apply -> AxiomII' in H5; simpl in H5.
  apply -> AxiomII' in H6; simpl in H6. apply -> AxiomII in H5; simpl in H5.
  apply -> AxiomII in H6; simpl in H6. destruct H5 as [H5 H7].
  destruct H6 as [H6 H8]. apply H1 with (x := x0); apply <- AxiomII'; auto.
Qed.

Definition IsNaturalNumber (r : R) : Prop := ∃ (n : nat), (INR n) = r.
Definition IsInteger (r : R) : Prop := ∃ (n : Z), (IZR n) = r.

Theorem Rlt_not_ge : forall r1 r2 : R, r1 < r2 -> ~ (r1 >= r2).
Proof.
  intros r1 r2 H0 H1. destruct H1 as [H1 | H1].
  - apply Rlt_asym in H0. auto.
  - rewrite H1 in H0. apply Rlt_asym in H0 as H2. auto.
Qed.

Theorem Rgt_not_le : forall r1 r2 : R, r1 > r2 -> ~(r1 <= r2).
Proof.
  intros r1 r2 H0 H1. destruct H1 as [H1 | H1].
  - apply Rlt_asym in H0. auto.
  - rewrite H1 in H0. apply Rlt_asym in H0 as H2. auto.
Qed.

Theorem Rge_lt :∀ r1 r2 : R, r1 >= r2 \/ r1 < r2.
Proof.
  intros r1 r2.
  destruct (total_order_T r1 r2) as [[I1 | I1] | I1].
  - right; auto.
  - left; right; auto.
  - left; left; auto.
Qed.

(* 定义：绝对值函数 *)
Definition Abs := {` λ x y , (x < 0 /\ y = -x) \/ (x >= 0 /\ y = x) `}.

Theorem Fun_Abs : Function Abs.
Proof.
  unfold Abs. unfold Function. intros x y z H0 H1.
  apply -> AxiomII' in H0. simpl in H0. apply -> AxiomII' in H1. simpl in H1.
  destruct H0,H1,H0,H.
  + rewrite <- H2 in H1. auto.
  + apply Rlt_not_ge in H. contradiction.
  + apply Rlt_not_ge in H0. contradiction.
  + rewrite <- H2 in H1. auto.
Qed.

Definition sR := (set R).
Definition R2 := prod R R.
Definition sR2 := (set R2).

(* 非空有限集 *)
Definition NotEmptyFinite {X : Type} (A : set X) : Prop :=
     ∃ (n : nat) (f : set (prod nat X)),
    Function1_1 f /\ dom[f] = \{ λ (x : nat), (x <= n)%nat \} /\ ran[f] = A.

(* 有限集 *)
Definition Finite {X : Type} (A : set X) : Prop :=
    NotEmptyFinite A \/ A = (Empty X).

(* 单点集为非空有限集 *)
Theorem SingletonFinite : ∀ (X : Type) (x : X), (NotEmptyFinite ([x])).
Proof.
  intros X a. unfold NotEmptyFinite.
  exists 0%nat, {` λ u v, u = 0%nat /\ v = a `}. split; [idtac | split].
  - split.
    + unfold Function. intros x y z J1 J2. apply -> AxiomII' in J1;
      simpl in J1. apply -> AxiomII' in J2; simpl in J2.
      destruct J2 as [J2 J3]. rewrite J3. apply J1.
    + unfold Function. intros x y z J1 J2. apply -> AxiomII' in J1;
      simpl in J1. apply -> AxiomII' in J2; simpl in J2.
      apply -> AxiomII' in J1; simpl in J1.
      apply -> AxiomII' in J2; simpl in J2. destruct J2 as [J2 J3].
      rewrite J2. apply J1.
  - apply AxiomI. intro z; split; intro J1.
    + apply -> AxiomII in J1; simpl in J1. destruct J1 as [y J1].
      apply -> AxiomII' in J1; simpl in J1. destruct J1 as [J1 J2].
      rewrite J1. apply <- AxiomII. auto.
    + apply -> AxiomII in J1; simpl in J1. apply le_n_0_eq in J1.
      rewrite <- J1. apply <- AxiomII. exists a.
      apply <- AxiomII'. split; auto.
  - apply AxiomI. intro z; split; intro J1.
    + apply -> AxiomII in J1; simpl in J1. destruct J1 as [x J1].
      apply -> AxiomII' in J1; simpl in J1. destruct J1 as [J1 J2].
      rewrite J2. apply <- AxiomII; auto.
    + apply -> AxiomII in J1; simpl in J1.
      apply <- AxiomII. exists 0%nat. apply <- AxiomII'. split; auto.
Qed.

(* 小于等于某个数的自然数集为非空有限集 *)
Theorem NatFinite : ∀ n : nat, NotEmptyFinite \{ λ u : nat, (u <= n)%nat \}.
Proof.
  intros n. unfold NotEmptyFinite.
  exists n, {` λ u v, v = u /\ (u <= n)%nat `}.
  split; [idtac | split].
  - split.
    + unfold Function. intros x y z H0 H1. applyAxiomII' H0.
      applyAxiomII' H1. destruct H1 as [H1 H2]. rewrite H1. apply H0.
    + unfold Function. intros x y z H0 H1. applyAxiomII' H0.
      applyAxiomII' H1. applyAxiomII' H0. applyAxiomII' H1.
      destruct H0 as [H0 H2]. rewrite <- H0. apply H1.
  - apply AxiomI; intro z; split; intro H0.
    + applyAxiomII H0. destruct H0 as [y H0]. applyAxiomII' H0.
      apply <- AxiomII. apply H0.
    + apply <- AxiomII. exists z. apply <- AxiomII'. applyAxiomII H0.
      split; auto.
  - apply AxiomI; intro z; split; intro H0.
    + applyAxiomII H0. destruct H0 as [x H0]. applyAxiomII' H0.
      apply <- AxiomII. destruct H0 as [H0 H1]. rewrite H0; auto.
    + apply <- AxiomII. exists z. apply <- AxiomII'. applyAxiomII H0.
      split; auto.
Qed.

(* 有限集的子集为有限集 *)
Theorem SubSetFinite_R : ∀ (A B : set R),
    Finite A -> B ⊂ A -> Finite B.
Proof.
  intros A B H0 H1. unfold Finite in *. destruct H0 as [H0 | H0].
  - destruct classic with (P := B = Empty R) as [H2 | H2];
    [right | idtac]; auto. apply not_empty in H2. left.
    unfold NotEmptyFinite in H0. destruct H0 as [n H0].
    generalize dependent H0. generalize dependent A. generalize dependent B.
    induction n as [|n H0].
    + intros B H2 A H0 H1. destruct H1 as [f [H1 [H3 H4]]].
      assert (H5 : A = [f[0%nat]]).
      { apply AxiomI. intro z; split; intro J1.
        - rewrite <- H4 in J1. apply -> AxiomII in J1; simpl in J1.
          destruct J1 as [x J1]. assert (J2 : x ∈ dom[f]).
          { apply <- AxiomII. exists z. auto. }
          rewrite H3 in J2. apply -> AxiomII in J2; simpl in J2.
          apply le_n_0_eq in J2. apply <- AxiomII. rewrite J2.
          symmetry. apply f_x; auto. apply H1.
        - apply -> AxiomII in J1; simpl in J1. rewrite <- H4. apply <- AxiomII.
          exists 0%nat. assert (J2 : 0%nat ∈ dom[f]).
          { rewrite H3. apply <- AxiomII. auto. }
          apply -> AxiomII in J2; simpl in J2. destruct J2 as [y J2].
          apply f_x in J2 as J3; try apply H1. rewrite J1. rewrite J3.
          auto. }
      assert (H6 : B = [f[0%nat]]).
      { apply AxiomI. intro z; split; intro H6.
        - rewrite <- H5. auto.
        - unfold NotEmpty in H2. destruct H2 as [x H2]. assert (J1 : x ∈ A).
          auto. rewrite H5 in J1. apply -> AxiomII in H6; simpl in H6.
          apply -> AxiomII in J1; simpl in J1. rewrite H6. rewrite <- J1.
          auto. }
      rewrite H6. apply SingletonFinite.
    + intros B H2 A H1 H3. destruct H3 as [f [H3 [H4 H5]]].
      assert (H6 : ∃ C, C = \{ λ x : nat,(x <= n)%nat \}).
      { exists \{ λ x : nat,(x <= n)%nat \}; auto. }
      destruct H6 as [C H6]. assert (H7 : Function1_1 f). auto.
      destruct H7 as [H7 H8]. assert (H9 : ran[f|[C]] ∪ [f[S n]] = A).
      { apply AxiomI. intro z; split; intro J1.
        - apply -> AxiomII in J1; simpl in J1. destruct J1 as [J1 | J1].
          + rewrite <- H5. apply -> AxiomII in J1; simpl in J1.
            destruct J1 as [x J1]. apply -> AxiomII in J1; simpl in J1.
            destruct J1 as [J1 J2]. apply <- AxiomII. exists x. auto.
          + rewrite <- H5. apply -> AxiomII in J1; simpl in J1.
            rewrite J1. apply fx_ran; auto. rewrite H4. apply <- AxiomII.
            apply le_n.
        - rewrite <- H5 in J1. apply -> AxiomII in J1; simpl in J1.
          destruct J1 as [x J1]. assert (J2 : x ∈ dom[f]).
          { apply <- AxiomII. exists z. auto. }
          rewrite H4 in J2. apply -> AxiomII in J2; simpl in J2.
          apply Nat.le_succ_r in J2 as J3. apply <- AxiomII.
          destruct J3 as [J3 | J3].
          + left. apply <- AxiomII. exists x. apply <- AxiomII. split; auto.
            apply <- AxiomII'. split.
            * rewrite H6. apply <- AxiomII. auto.
            * apply <- AxiomII. auto.
          + right. apply <- AxiomII. symmetry. apply f_x; auto. rewrite <- J3.
            auto. }
      apply RestrictFun with (x := C) in H7 as H10.
      destruct H10 as [H10 [H11 H12]].
      assert (H13 : dom[f|[C]] = C).
      { rewrite H11. apply AxiomI. intro z; split; intro J1.
        - apply -> AxiomII in J1. apply J1.
        - apply <- AxiomII. split; auto. rewrite H4. apply <- AxiomII.
          rewrite H6 in J1. apply -> AxiomII in J1; simpl in J1.
          apply le_S. auto. }
      assert (H14 : (B \~ ([f[S n]])) ⊂ (A \~ ([f[S n]]))).
      { intros z J1. apply -> AxiomII in J1; simpl in J1.
        destruct J1 as [J1 J2]. apply -> AxiomII in J2; simpl in J2.
        apply <- AxiomII. split; auto. apply <- AxiomII. auto. }
      assert (H20 : ran[ f | [C]] = A \~ [f [S n]]).
      { apply AxiomI. intro z; split; intro K1.
        - apply <- AxiomII. split.
          + rewrite <- H9. apply <- AxiomII. left; auto.
          + apply <- AxiomII. intro K2. apply -> AxiomII in K1;
            simpl in K1. destruct K1 as [x K1]. apply -> AxiomII in K2;
            simpl in K2. assert (K3 : x ∈ (C ∩ dom[f])).
            { rewrite <- H11. apply <- AxiomII. exists z. auto. }
            apply -> AxiomII in K3; simpl in K3.
            destruct K3 as [K3 K4]. rewrite H6 in K3.
            apply -> AxiomII in K3; simpl in K3.
            apply -> AxiomII in K1; simpl in K1.
            assert (K5 : [S n, z] ∈ f).
            { assert (L1 : S n ∈ dom[f]).
              { rewrite H4. apply <- AxiomII. auto. }
              apply -> AxiomII in L1; simpl in L1.
              destruct L1 as [y L1]. apply f_x in L1 as L2; auto.
              rewrite K2. rewrite L2. auto. }
            destruct K1 as [K1 K6]. assert (K7 : x = S n).
            { apply H8 with (x := z); apply <- AxiomII'; auto. }
            rewrite K7 in K3. assert (K8 : (n < S n)%nat).
            { apply Nat.lt_succ_diag_r. }
            apply lt_not_le in K8. auto.
        - apply -> AxiomII in K1; simpl in K1.
          destruct K1 as [K1 K2]. rewrite <- H9 in K1.
          apply -> AxiomII in K2; simpl in K2.
          apply -> AxiomII in K1; simpl in K1.
          destruct K1 as [K1 | K1]; auto. exfalso. auto. }
      destruct classic with (P := f[S n] ∈ B) as [H15 | H15].
      * destruct classic with (P := (B \~ ([f[S n]])) = Empty R) as [J1 | J1].
        -- assert (J2 : B = [f[S n]]).
          { apply AxiomI. intro z; split; intro K1.
            - apply <- AxiomII. apply NNPP. intro K2.
              assert (K3 : z ∈ (Empty R)).
              { rewrite <- J1. apply <- AxiomII. split; auto. apply <- AxiomII.
                intro L1. apply K2. apply -> AxiomII in L1. auto. }
              apply -> AxiomII in K3; simpl in K3. auto.
            - apply -> AxiomII in K1; simpl in K1. rewrite K1. auto. }
          rewrite J2. apply SingletonFinite.
        -- assert (J2 : NotEmptyFinite (B \~ [f[S n]])).
          { apply H0 with (A := (A \~ [f[S n]])); auto.
            - apply not_empty. auto.
            - exists (f|[C]). split; [idtac | split]; auto.
              + apply RestrictFun1_1. auto.
              + rewrite H13. auto. }
          unfold NotEmptyFinite in J2. destruct J2 as [n0 [f0 [J3 [J4 J5]]]].
          unfold NotEmptyFinite. exists (S n0), (f0 ∪ [[(S n0), f[S n]]]).
          split; [idtac | split].
          ++ split.
            ** unfold Function. intros x y z K1 K2.
              apply -> AxiomII in K1; simpl in K1.
              apply -> AxiomII in K2; simpl in K2.
              destruct K1 as [K1 | K1].
              --- destruct K2 as [K2 | K2].
                +++ destruct J3 as [J3 J6]. apply J3 with (x := x); auto.
                +++ exfalso. apply -> AxiomII in K2; simpl in K2.
                  apply ProdEqual in K2. destruct K2 as [K2 K3].
                  assert (K4 : x ∈ dom[f0]).
                  { apply <- AxiomII. exists y; auto. }
                  rewrite J4 in K4. apply -> AxiomII in K4; simpl in K4.
                  rewrite K2 in K4. assert (K5 : (n0 < S n0)%nat).
                  { apply Nat.lt_succ_diag_r. }
                  apply lt_not_le in K5. auto.
              --- destruct K2 as [K2 | K2].
                +++ exfalso. apply -> AxiomII in K1; simpl in K1.
                  apply ProdEqual in K1. destruct K1 as [K1 K3].
                  assert (K4 : x ∈ dom[f0]).
                  { apply <- AxiomII. exists z; auto. }
                  rewrite J4 in K4. apply -> AxiomII in K4; simpl in K4.
                  rewrite K1 in K4. assert (K5 : (n0 < S n0)%nat).
                  { apply Nat.lt_succ_diag_r. }
                  apply lt_not_le in K5. auto.
                +++ apply -> AxiomII in K1; simpl in K1.
                    apply -> AxiomII in K2; simpl in K2.
                    apply ProdEqual in K1. apply ProdEqual in K2.
                    destruct K2 as [K2 K3]. rewrite K3. apply K1.
            ** unfold Function. intros x y z K1 K2.
              apply -> AxiomII' in K1; simpl in K1.
              apply -> AxiomII' in K2; simpl in K2.
              apply -> AxiomII in K1; simpl in K1.
              apply -> AxiomII in K2; simpl in K2.
              destruct K1 as [K1 | K1].
              --- destruct K2 as [K2 | K2].
                +++ apply J3 with (x := x); apply <- AxiomII'; auto.
                +++ exfalso. apply -> AxiomII in K2; simpl in K2.
                  apply ProdEqual in K2. destruct K2 as [K2 K3].
                  assert (K4 : x ∈ ran[f0]).
                  { apply <- AxiomII. exists y. auto. }
                  rewrite J5 in K4. apply -> AxiomII in K4; simpl in K4.
                  destruct K4 as [K4 K5]. apply -> AxiomII in K5; simpl in K5.
                  apply K5. apply <- AxiomII. auto.
              --- destruct K2 as [K2 | K2].
                +++ exfalso. apply -> AxiomII in K1; simpl in K1.
                  apply ProdEqual in K1. destruct K1 as [K1 K3].
                  assert (K4 : x ∈ ran[f0]).
                  { apply <- AxiomII. exists z. auto. }
                  rewrite J5 in K4. apply -> AxiomII in K4; simpl in K4.
                  destruct K4 as [K4 K5]. apply -> AxiomII in K5; simpl in K5.
                  apply K5. apply <- AxiomII. auto.
                +++ apply -> AxiomII in K1; simpl in K1.
                    apply -> AxiomII in K2; simpl in K2.
                    apply ProdEqual in K1. apply ProdEqual in K2.
                    destruct K2 as [K2 K3]. rewrite K2. apply K1.
          ++ apply AxiomI. intro z; split; intro K1.
            ** apply -> AxiomII in K1; simpl in K1. destruct K1 as [y K1].
              apply -> AxiomII in K1; simpl in K1. destruct K1 as [K1 | K1].
              --- assert (K2 : z ∈ dom[f0]).
                { apply <- AxiomII. exists y. auto. }
                rewrite J4 in K2. apply -> AxiomII in K2; simpl in K2.
                apply <- AxiomII. apply le_S. auto.
              --- apply -> AxiomII in K1; simpl in K1.
                apply ProdEqual in K1. destruct K1 as [K1 K2].
                apply <- AxiomII. rewrite K1. auto.
            ** apply -> AxiomII in K1; simpl in K1.
              apply Nat.le_succ_r in K1 as K2. apply <- AxiomII.
              destruct K2 as [K2 | K2].
              --- assert (K3 : z ∈ dom[f0]).
                { rewrite J4. apply <- AxiomII. auto. }
                apply -> AxiomII in K3; simpl in K3.
                destruct K3 as [y K3]. exists y. apply <- AxiomII.
                left; auto.
              --- exists (f[S n]). apply <- AxiomII. right.
                apply <- AxiomII. rewrite K2. auto.
          ++ apply AxiomI. intro z; split; intro K1.
            ** apply -> AxiomII in K1; simpl in K1. destruct K1 as [x K1].
              apply -> AxiomII in K1; simpl in K1. destruct K1 as [K1 | K1].
              ---  assert (K2 : z ∈ ran[f0]).
                { apply <- AxiomII. exists x. auto. }
                rewrite J5 in K2. apply -> AxiomII in K2; simpl in K2.
                apply K2.
              --- apply -> AxiomII in K1; simpl in K1.
                apply ProdEqual in K1. destruct K1 as [K1 K2]. rewrite K2.
                auto.
            ** apply <- AxiomII.
              destruct classic with (P := z = f[S n]) as [K2 | K2].
              --- exists (S n0). apply <- AxiomII. right. apply <- AxiomII.
                rewrite K2. auto.
              --- assert (K3 : z ∈ ran[f0]).
                { rewrite J5. apply <- AxiomII. split; auto. apply <- AxiomII.
                  intro K3. apply K2. apply -> AxiomII in K3. auto. }
                apply -> AxiomII in K3; simpl in K3. destruct K3 as [x K3].
                exists x. apply <- AxiomII. left. auto.
      * assert (H16 : B ⊂ (A \~ ([f[S n]]))).
        { assert (I1 : (B \~ ([f[S n]])) = B).
          { apply AxiomI. intro z; split; intro I1.
            - apply -> AxiomII in I1; simpl in I1. apply I1.
            - apply <- AxiomII. split; auto. apply <- AxiomII. intro I2.
              apply -> AxiomII in I2; simpl in I2. rewrite <- I2 in H15.
              auto. }
          rewrite <- I1. auto. }
        apply H0 with (A := (A \~ [f[S n]])); auto. exists (f|[C]).
        split; [idtac | split]; auto.
        -- apply RestrictFun1_1. auto.
        -- rewrite H13. auto.
  - right. apply AxiomI. intro z; split; intro H2.
    + rewrite <- H0. auto.
    + exfalso. apply -> AxiomII in H2; simpl in H2. auto.
Qed.

Theorem SubSetFinite_N : ∀ (A B : set nat),
    Finite A -> B ⊂ A -> Finite B.
Proof.
  intros A B H0 H1. unfold Finite in *. destruct H0 as [H0 | H0].
  - destruct classic with (P := B = Empty nat) as [H2 | H2];
    [right | idtac]; auto. apply not_empty in H2. left.
    unfold NotEmptyFinite in H0. destruct H0 as [n H0].
    generalize dependent H0. generalize dependent A. generalize dependent B.
    induction n as [|n H0].
    + intros B H2 A H0 H1. destruct H1 as [f [H1 [H3 H4]]].
      assert (H5 : A = [f\[0%nat\]]).
      { apply AxiomI. intro z; split; intro J1.
        - rewrite <- H4 in J1. apply -> AxiomII in J1; simpl in J1.
          destruct J1 as [x J1]. assert (J2 : x ∈ dom[f]).
          { apply <- AxiomII. exists z. auto. }
          rewrite H3 in J2. apply -> AxiomII in J2; simpl in J2.
          apply le_n_0_eq in J2. apply <- AxiomII. rewrite J2.
          symmetry. apply f_x_N; auto. apply H1.
        - apply -> AxiomII in J1; simpl in J1. rewrite <- H4. apply <- AxiomII.
          exists 0%nat. assert (J2 : 0%nat ∈ dom[f]).
          { rewrite H3. apply <- AxiomII. auto. }
          apply -> AxiomII in J2; simpl in J2. destruct J2 as [y J2].
          apply f_x_N in J2 as J3; try apply H1. rewrite J1. rewrite J3.
          auto. }
      assert (H6 : B = [f\[0%nat\]]).
      { apply AxiomI. intro z; split; intro H6.
        - rewrite <- H5. auto.
        - unfold NotEmpty in H2. destruct H2 as [x H2]. assert (J1 : x ∈ A).
          auto. rewrite H5 in J1. apply -> AxiomII in H6; simpl in H6.
          apply -> AxiomII in J1; simpl in J1. rewrite H6. rewrite <- J1.
          auto. }
      rewrite H6. apply SingletonFinite.
    + intros B H2 A H1 H3. destruct H3 as [f [H3 [H4 H5]]].
      assert (H6 : ∃ C, C = \{ λ x : nat,(x <= n)%nat \}).
      { exists \{ λ x : nat,(x <= n)%nat \}; auto. }
      destruct H6 as [C H6]. assert (H7 : Function1_1 f). auto.
      destruct H7 as [H7 H8]. assert (H9 : ran[f|[C]] ∪ [f\[S n\]] = A).
      { apply AxiomI. intro z; split; intro J1.
        - apply -> AxiomII in J1; simpl in J1. destruct J1 as [J1 | J1].
          + rewrite <- H5. apply -> AxiomII in J1; simpl in J1.
            destruct J1 as [x J1]. apply -> AxiomII in J1; simpl in J1.
            destruct J1 as [J1 J2]. apply <- AxiomII. exists x. auto.
          + rewrite <- H5. apply -> AxiomII in J1; simpl in J1.
            rewrite J1. apply fx_ran_N; auto. rewrite H4. apply <- AxiomII.
            apply le_n.
        - rewrite <- H5 in J1. apply -> AxiomII in J1; simpl in J1.
          destruct J1 as [x J1]. assert (J2 : x ∈ dom[f]).
          { apply <- AxiomII. exists z. auto. }
          rewrite H4 in J2. apply -> AxiomII in J2; simpl in J2.
          apply Nat.le_succ_r in J2 as J3. apply <- AxiomII.
          destruct J3 as [J3 | J3].
          + left. apply <- AxiomII. exists x. apply <- AxiomII. split; auto.
            apply <- AxiomII'. split.
            * rewrite H6. apply <- AxiomII. auto.
            * apply <- AxiomII. auto.
          + right. apply <- AxiomII. symmetry. apply f_x_N; auto.
            rewrite <- J3. auto. }
      apply RestrictFun_N with (x := C) in H7 as H10.
      destruct H10 as [H10 [H11 H12]].
      assert (H13 : dom[f|[C]] = C).
      { rewrite H11. apply AxiomI. intro z; split; intro J1.
        - apply -> AxiomII in J1. apply J1.
        - apply <- AxiomII. split; auto. rewrite H4. apply <- AxiomII.
          rewrite H6 in J1. apply -> AxiomII in J1; simpl in J1.
          apply le_S. auto. }
      assert (H14 : (B \~ ([f\[S n\]])) ⊂ (A \~ ([f\[S n\]]))).
      { intros z J1. apply -> AxiomII in J1; simpl in J1.
        destruct J1 as [J1 J2]. apply -> AxiomII in J2; simpl in J2.
        apply <- AxiomII. split; auto. apply <- AxiomII. auto. }
      assert (H20 : ran[ f | [C]] = A \~ [f \[S n\]]).
      { apply AxiomI. intro z; split; intro K1.
        - apply <- AxiomII. split.
          + rewrite <- H9. apply <- AxiomII. left; auto.
          + apply <- AxiomII. intro K2. apply -> AxiomII in K1;
            simpl in K1. destruct K1 as [x K1]. apply -> AxiomII in K2;
            simpl in K2. assert (K3 : x ∈ (C ∩ dom[f])).
            { rewrite <- H11. apply <- AxiomII. exists z. auto. }
            apply -> AxiomII in K3; simpl in K3.
            destruct K3 as [K3 K4]. rewrite H6 in K3.
            apply -> AxiomII in K3; simpl in K3.
            apply -> AxiomII in K1; simpl in K1.
            assert (K5 : [S n, z] ∈ f).
            { assert (L1 : S n ∈ dom[f]).
              { rewrite H4. apply <- AxiomII. auto. }
              apply -> AxiomII in L1; simpl in L1.
              destruct L1 as [y L1]. apply f_x_N in L1 as L2; auto.
              rewrite K2. rewrite L2. auto. }
            destruct K1 as [K1 K6]. assert (K7 : x = S n).
            { apply H8 with (x := z); apply <- AxiomII'; auto. }
            rewrite K7 in K3. assert (K8 : (n < S n)%nat).
            { apply Nat.lt_succ_diag_r. }
            apply lt_not_le in K8. auto.
        - apply -> AxiomII in K1; simpl in K1.
          destruct K1 as [K1 K2]. rewrite <- H9 in K1.
          apply -> AxiomII in K2; simpl in K2.
          apply -> AxiomII in K1; simpl in K1.
          destruct K1 as [K1 | K1]; auto. exfalso. auto. }
      destruct classic with (P := f\[S n\] ∈ B) as [H15 | H15].
      * destruct classic with (P := (B \~ ([f\[S n\]])) =
          Empty nat) as [J1 | J1].
        -- assert (J2 : B = [f\[S n\]]).
          { apply AxiomI. intro z; split; intro K1.
            - apply <- AxiomII. apply NNPP. intro K2.
              assert (K3 : z ∈ (Empty nat)).
              { rewrite <- J1. apply <- AxiomII. split; auto. apply <- AxiomII.
                intro L1. apply K2. apply -> AxiomII in L1. auto. }
              apply -> AxiomII in K3; simpl in K3. auto.
            - apply -> AxiomII in K1; simpl in K1. rewrite K1. auto. }
          rewrite J2. apply SingletonFinite.
        -- assert (J2 : NotEmptyFinite (B \~ [f\[S n\]])).
          { apply H0 with (A := (A \~ [f\[S n\]])); auto.
            - apply not_empty. auto.
            - exists (f|[C]). split; [idtac | split]; auto.
              + apply RestrictFun1_1_N. auto.
              + rewrite H13. auto. }
          unfold NotEmptyFinite in J2. destruct J2 as [n0 [f0 [J3 [J4 J5]]]].
          unfold NotEmptyFinite. exists (S n0), (f0 ∪ [[(S n0), f\[S n\]]]).
          split; [idtac | split].
          ++ split.
            ** unfold Function. intros x y z K1 K2.
              apply -> AxiomII in K1; simpl in K1.
              apply -> AxiomII in K2; simpl in K2.
              destruct K1 as [K1 | K1].
              --- destruct K2 as [K2 | K2].
                +++ destruct J3 as [J3 J6]. apply J3 with (x := x); auto.
                +++ exfalso. apply -> AxiomII in K2; simpl in K2.
                  apply ProdEqual in K2. destruct K2 as [K2 K3].
                  assert (K4 : x ∈ dom[f0]).
                  { apply <- AxiomII. exists y; auto. }
                  rewrite J4 in K4. apply -> AxiomII in K4; simpl in K4.
                  rewrite K2 in K4. assert (K5 : (n0 < S n0)%nat).
                  { apply Nat.lt_succ_diag_r. }
                  apply lt_not_le in K5. auto.
              --- destruct K2 as [K2 | K2].
                +++ exfalso. apply -> AxiomII in K1; simpl in K1.
                  apply ProdEqual in K1. destruct K1 as [K1 K3].
                  assert (K4 : x ∈ dom[f0]).
                  { apply <- AxiomII. exists z; auto. }
                  rewrite J4 in K4. apply -> AxiomII in K4; simpl in K4.
                  rewrite K1 in K4. assert (K5 : (n0 < S n0)%nat).
                  { apply Nat.lt_succ_diag_r. }
                  apply lt_not_le in K5. auto.
                +++ apply -> AxiomII in K1; simpl in K1.
                    apply -> AxiomII in K2; simpl in K2.
                    apply ProdEqual in K1. apply ProdEqual in K2.
                    destruct K2 as [K2 K3]. rewrite K3. apply K1.
            ** unfold Function. intros x y z K1 K2.
              apply -> AxiomII' in K1; simpl in K1.
              apply -> AxiomII' in K2; simpl in K2.
              apply -> AxiomII in K1; simpl in K1.
              apply -> AxiomII in K2; simpl in K2.
              destruct K1 as [K1 | K1].
              --- destruct K2 as [K2 | K2].
                +++ apply J3 with (x := x); apply <- AxiomII'; auto.
                +++ exfalso. apply -> AxiomII in K2; simpl in K2.
                  apply ProdEqual in K2. destruct K2 as [K2 K3].
                  assert (K4 : x ∈ ran[f0]).
                  { apply <- AxiomII. exists y. auto. }
                  rewrite J5 in K4. apply -> AxiomII in K4; simpl in K4.
                  destruct K4 as [K4 K5]. apply -> AxiomII in K5; simpl in K5.
                  apply K5. apply <- AxiomII. auto.
              --- destruct K2 as [K2 | K2].
                +++ exfalso. apply -> AxiomII in K1; simpl in K1.
                  apply ProdEqual in K1. destruct K1 as [K1 K3].
                  assert (K4 : x ∈ ran[f0]).
                  { apply <- AxiomII. exists z. auto. }
                  rewrite J5 in K4. apply -> AxiomII in K4; simpl in K4.
                  destruct K4 as [K4 K5]. apply -> AxiomII in K5; simpl in K5.
                  apply K5. apply <- AxiomII. auto.
                +++ apply -> AxiomII in K1; simpl in K1.
                    apply -> AxiomII in K2; simpl in K2.
                    apply ProdEqual in K1. apply ProdEqual in K2.
                    destruct K2 as [K2 K3]. rewrite K2. apply K1.
          ++ apply AxiomI. intro z; split; intro K1.
            ** apply -> AxiomII in K1; simpl in K1. destruct K1 as [y K1].
              apply -> AxiomII in K1; simpl in K1. destruct K1 as [K1 | K1].
              --- assert (K2 : z ∈ dom[f0]).
                { apply <- AxiomII. exists y. auto. }
                rewrite J4 in K2. apply -> AxiomII in K2; simpl in K2.
                apply <- AxiomII. apply le_S. auto.
              --- apply -> AxiomII in K1; simpl in K1.
                apply ProdEqual in K1. destruct K1 as [K1 K2].
                apply <- AxiomII. rewrite K1. auto.
            ** apply -> AxiomII in K1; simpl in K1.
              apply Nat.le_succ_r in K1 as K2. apply <- AxiomII.
              destruct K2 as [K2 | K2].
              --- assert (K3 : z ∈ dom[f0]).
                { rewrite J4. apply <- AxiomII. auto. }
                apply -> AxiomII in K3; simpl in K3.
                destruct K3 as [y K3]. exists y. apply <- AxiomII.
                left; auto.
              --- exists (f\[S n\]). apply <- AxiomII. right.
                apply <- AxiomII. rewrite K2. auto.
          ++ apply AxiomI. intro z; split; intro K1.
            ** apply -> AxiomII in K1; simpl in K1. destruct K1 as [x K1].
              apply -> AxiomII in K1; simpl in K1. destruct K1 as [K1 | K1].
              ---  assert (K2 : z ∈ ran[f0]).
                { apply <- AxiomII. exists x. auto. }
                rewrite J5 in K2. apply -> AxiomII in K2; simpl in K2.
                apply K2.
              --- apply -> AxiomII in K1; simpl in K1.
                apply ProdEqual in K1. destruct K1 as [K1 K2]. rewrite K2.
                auto.
            ** apply <- AxiomII.
              destruct classic with (P := z = f\[S n\]) as [K2 | K2].
              --- exists (S n0). apply <- AxiomII. right. apply <- AxiomII.
                rewrite K2. auto.
              --- assert (K3 : z ∈ ran[f0]).
                { rewrite J5. apply <- AxiomII. split; auto. apply <- AxiomII.
                  intro K3. apply K2. apply -> AxiomII in K3. auto. }
                apply -> AxiomII in K3; simpl in K3. destruct K3 as [x K3].
                exists x. apply <- AxiomII. left. auto.
      * assert (H16 : B ⊂ (A \~ ([f\[S n\]]))).
        { assert (I1 : (B \~ ([f\[S n\]])) = B).
          { apply AxiomI. intro z; split; intro I1.
            - apply -> AxiomII in I1; simpl in I1. apply I1.
            - apply <- AxiomII. split; auto. apply <- AxiomII. intro I2.
              apply -> AxiomII in I2; simpl in I2. rewrite <- I2 in H15.
              auto. }
          rewrite <- I1. auto. }
        apply H0 with (A := (A \~ [f\[S n\]])); auto. exists (f|[C]).
        split; [idtac | split]; auto.
        -- apply RestrictFun1_1_N. auto.
        -- rewrite H13. auto.
  - right. apply AxiomI. intro z; split; intro H2.
    + rewrite <- H0. auto.
    + exfalso. apply -> AxiomII in H2; simpl in H2. auto.
Qed.

(* 最大值 *)
Definition maxR (A : sR) (r : R) := r ∈ A /\ (∀ x, x ∈ A -> x <= r).
Definition maxN (A : set nat) (n : nat) :=
    n ∈ A /\ (∀ x, x ∈ A -> x <= n)%nat.

(* 非空有限的自然数集有最大值 *)
Theorem finite_maxN : ∀ (A : set nat),
    NotEmptyFinite A -> (∃ n : nat, maxN A n).
Proof.
  intros A H1. unfold NotEmptyFinite in H1. destruct H1 as [n H1].
  generalize dependent H1. generalize dependent A. induction n as [|n H1].
  - intros A H1. destruct H1 as [f [H1 [H2 H3]]].
    assert (H4 : \{ λ x : nat, (x <= 0)%nat \} = [0%nat]).
    { apply AxiomI. intro z; split; intro I1.
      - apply <- AxiomII. apply -> AxiomII in I1. simpl in I1. symmetry.
        apply le_n_0_eq. auto.
      - apply -> AxiomII in I1; simpl in I1. rewrite I1. apply <- AxiomII.
        apply le_n. }
    rewrite H4 in H2. assert (H5 : A = [f\[0%nat\]]).
    { apply AxiomI. intro z; split; intro J1.
      - apply <- AxiomII. rewrite <- H3 in J1.
        apply -> AxiomII in J1; simpl in J1. destruct J1 as [x J1].
        assert (J2 : x ∈ dom[f]).
        { apply <- AxiomII. exists z. auto. }
        rewrite H2 in J2. apply -> AxiomII in J2; simpl in J2.
        rewrite J2 in J1. destruct H1 as [H1 J3]. apply f_x_N in J1; auto.
      - apply -> AxiomII in J1; simpl in J1. rewrite <- H3.
        apply <- AxiomII. exists 0%nat. assert (J2 : 0%nat ∈ dom[f]).
        { rewrite H2. apply <- AxiomII. auto. }
        apply -> AxiomII in J2; simpl in J2. destruct J2 as [y J2].
        destruct H1 as [H1 J3]. apply f_x_N in J2 as J4; auto.
        rewrite J1. rewrite J4. auto. }
    exists f\[0%nat\]. unfold maxN. split.
    + rewrite H5. apply <- AxiomII. auto.
    + intros x. intro J1. rewrite H5 in J1.
      apply -> AxiomII in J1; simpl in J1. rewrite <- J1. apply le_n.
  - intros A H2. destruct H2 as [f [H2 [H3 H4]]].
    assert (H5 : ∃ B, B = \{ λ (x : nat), (x <= n)%nat \}).
    { exists \{ λ (x : nat), (x <= n)%nat \}. auto. }
    destruct H5 as [B H5]. apply RestrictFun1_1_N with (x := B) in H2 as H6.
    destruct H2 as [H2 H7]. apply RestrictFun_N with (x := B) in H2 as H8.
    destruct H8 as [H8 [H9 H10]].
    assert (H11 : ∃n : nat, maxN ran[f|[B]] n).
    { apply H1. exists (f|[B]). split; [auto | split]; auto. rewrite H9.
      rewrite H5. rewrite H3. apply AxiomI. intro z; split; intro J1.
      - apply -> AxiomII in J1; simpl in J1. apply J1.
      - apply <- AxiomII. split; auto. apply -> AxiomII in J1; simpl in J1.
        apply <- AxiomII. apply le_S. auto. }
    assert (H12 : ran[f|[B]] ∪ [f\[S n\]] = A).
    { apply AxiomI. intro z; split; intro J1.
      - apply -> AxiomII in J1; simpl in J1. destruct J1 as [J1 | J1].
        + rewrite <- H4. apply -> AxiomII in J1; simpl in J1.
          destruct J1 as [x J1]. apply -> AxiomII in J1; simpl in J1.
          destruct J1 as [J1 J2]. apply <- AxiomII. exists x. auto.
        + rewrite <- H4. apply -> AxiomII in J1; simpl in J1.
          rewrite J1. apply fx_ran_N; auto. rewrite H3. apply <- AxiomII.
          apply le_n.
      - rewrite <- H4 in J1. apply -> AxiomII in J1; simpl in J1.
        destruct J1 as [x J1]. assert (J2 : x ∈ dom[f]).
        { apply <- AxiomII. exists z. auto. }
        rewrite H3 in J2. apply -> AxiomII in J2; simpl in J2.
        apply Nat.le_succ_r in J2 as J3. apply <- AxiomII.
        destruct J3 as [J3 | J3].
        + left. apply <- AxiomII. exists x. apply <- AxiomII. split; auto.
          apply <- AxiomII'. split.
          * rewrite H5. apply <- AxiomII. auto.
          * apply <- AxiomII. auto.
        + right. apply <- AxiomII. symmetry. apply f_x_N; auto. rewrite <- J3.
          auto. }
    destruct H11 as [n1 H11].
    destruct (le_gt_dec n1 (f\[S n\])) as [H13 | H13].
    + exists (f\[S n\]). unfold maxN. split.
      * rewrite <- H12. apply <- AxiomII. right. apply <- AxiomII; auto.
      * intros x J1. rewrite <- H12 in J1. apply -> AxiomII in J1; simpl in J1.
        destruct J1 as [J1 | J1].
        -- apply H11 in J1. apply Nat.le_trans with (m := n1); auto.
        -- apply -> AxiomII in J1; simpl in J1. rewrite <- J1. apply le_n.
    + exists n1. unfold maxN. split.
      * rewrite <- H12. apply <- AxiomII. left. apply H11.
      * intros x J1. rewrite <- H12 in J1. apply -> AxiomII in J1; simpl in J1.
        destruct J1 as [J1 | J1].
        -- apply H11. auto.
        -- apply -> AxiomII in J1; simpl in J1. rewrite J1.
          apply Nat.lt_le_incl. auto.
Qed.

(* 非空有限的实数集有最大值 *)
Theorem finite_maxR : ∀ (A : sR), NotEmptyFinite A -> (∃ r : R, maxR A r).
Proof.
  intros A H1. unfold NotEmptyFinite in H1. destruct H1 as [n H1].
  generalize dependent H1. generalize dependent A. induction n as [|n H1].
  - intros A H1. destruct H1 as [f [H1 [H2 H3]]].
    assert (H4 : \{ λ x : nat, (x <= 0)%nat \} = [0%nat]).
    { apply AxiomI. intro z; split; intro I1.
      - apply <- AxiomII. apply -> AxiomII in I1. simpl in I1. symmetry.
        apply le_n_0_eq. auto.
      - apply -> AxiomII in I1; simpl in I1. rewrite I1. apply <- AxiomII.
        apply le_n. }
    rewrite H4 in H2. assert (H5 : A = [f[0%nat]]).
    { apply AxiomI. intro z; split; intro J1.
      - apply <- AxiomII. rewrite <- H3 in J1.
        apply -> AxiomII in J1; simpl in J1. destruct J1 as [x J1].
        assert (J2 : x ∈ dom[f]).
        { apply <- AxiomII. exists z. auto. }
        rewrite H2 in J2. apply -> AxiomII in J2; simpl in J2.
        rewrite J2 in J1. destruct H1 as [H1 J3]. apply f_x in J1; auto.
      - apply -> AxiomII in J1; simpl in J1. rewrite <- H3.
        apply <- AxiomII. exists 0%nat. assert (J2 : 0%nat ∈ dom[f]).
        { rewrite H2. apply <- AxiomII. auto. }
        apply -> AxiomII in J2; simpl in J2. destruct J2 as [y J2].
        destruct H1 as [H1 J3]. apply f_x in J2 as J4; auto.
        rewrite J1. rewrite J4. auto. }
    exists f[0%nat]. unfold max. split.
    + rewrite H5. apply <- AxiomII. auto.
    + intros x. intro J1. rewrite H5 in J1.
      apply -> AxiomII in J1; simpl in J1. rewrite <- J1. right. auto.
  - intros A H2. destruct H2 as [f [H2 [H3 H4]]].
    assert (H5 : ∃ B, B = \{ λ (x : nat), (x <= n)%nat \}).
    { exists \{ λ (x : nat), (x <= n)%nat \}. auto. }
    destruct H5 as [B H5]. apply RestrictFun1_1 with (x := B) in H2 as H6.
    destruct H2 as [H2 H7]. apply RestrictFun with (x := B) in H2 as H8.
    destruct H8 as [H8 [H9 H10]].
    assert (H11 : ∃n : R, maxR ran[f|[B]] n).
    { apply H1. exists (f|[B]). split; [auto | split]; auto. rewrite H9.
      rewrite H5. rewrite H3. apply AxiomI. intro z; split; intro J1.
      - apply -> AxiomII in J1; simpl in J1. apply J1.
      - apply <- AxiomII. split; auto. apply -> AxiomII in J1; simpl in J1.
        apply <- AxiomII. apply le_S. auto. }
    assert (H12 : ran[f|[B]] ∪ [f[S n]] = A).
    { apply AxiomI. intro z; split; intro J1.
      - apply -> AxiomII in J1; simpl in J1. destruct J1 as [J1 | J1].
        + rewrite <- H4. apply -> AxiomII in J1; simpl in J1.
          destruct J1 as [x J1]. apply -> AxiomII in J1; simpl in J1.
          destruct J1 as [J1 J2]. apply <- AxiomII. exists x. auto.
        + rewrite <- H4. apply -> AxiomII in J1; simpl in J1.
          rewrite J1. apply fx_ran; auto. rewrite H3. apply <- AxiomII.
          apply le_n.
      - rewrite <- H4 in J1. apply -> AxiomII in J1; simpl in J1.
        destruct J1 as [x J1]. assert (J2 : x ∈ dom[f]).
        { apply <- AxiomII. exists z. auto. }
        rewrite H3 in J2. apply -> AxiomII in J2; simpl in J2.
        apply Nat.le_succ_r in J2 as J3. apply <- AxiomII.
        destruct J3 as [J3 | J3].
        + left. apply <- AxiomII. exists x. apply <- AxiomII. split; auto.
          apply <- AxiomII'. split.
          * rewrite H5. apply <- AxiomII. auto.
          * apply <- AxiomII. auto.
        + right. apply <- AxiomII. symmetry. apply f_x; auto. rewrite <- J3.
          auto. }
    destruct H11 as [r1 H11].
    destruct (total_order_T r1 (f[S n])) as [[H13 | H13] | H13].
    + exists (f[S n]). unfold maxR. split.
      * rewrite <- H12. apply <- AxiomII. right. apply <- AxiomII; auto.
      * intros x J1. rewrite <- H12 in J1. apply -> AxiomII in J1; simpl in J1.
        destruct J1 as [J1 | J1].
        -- apply H11 in J1. left. destruct J1 as [J1 | J1].
          ++ apply Rlt_trans with (r2 := r1); auto.
          ++ rewrite J1; auto.
        -- apply -> AxiomII in J1; simpl in J1. rewrite <- J1. right;auto.
    + exists r1. unfold maxR. split.
      * rewrite <- H12. apply <- AxiomII. left. apply H11.
      * intros x J1. rewrite <- H12 in J1. apply -> AxiomII in J1; simpl in J1.
        destruct J1 as [J1 | J1].
        -- apply H11. auto.
        -- apply -> AxiomII in J1; simpl in J1. rewrite J1.
          rewrite <- H13. right; auto.
    + exists r1. unfold maxR. split.
      * rewrite <- H12. apply <- AxiomII. left. apply H11.
      * intros x J1. rewrite <- H12 in J1. apply -> AxiomII in J1; simpl in J1.
        destruct J1 as [J1 | J1].
        -- apply H11. auto.
        -- apply -> AxiomII in J1; simpl in J1. rewrite J1.
          left; auto.
Qed.

End A0.

Export A0.


(** * The writer monad transformer *)

From Coq Require Import List FunctionalExtensionality.
Import ListNotations.
From mtl.Classes Require Import All.

Implicit Types w a b : Type.
Implicit Types m : Type -> Type.

(** ** Monoids *)

Class Monoid w : Type :=
  { mempty : w
  ; mappend : w -> w -> w
  }.

Arguments mempty {w _}.
Arguments mappend {w _}.

Delimit Scope monoid_scope with monoid.

Infix "++" := mappend : monoid_scope.

Class LawfulMonoid w `{Monoid w} : Type :=
  { mappend_mempty_l : forall r, mappend mempty r = r
  ; mappend_mempty_r : forall r, mappend r mempty = r
  ; mappend_assoc : forall r s t, mappend (mappend r s) t = mappend r (mappend s t)
  }.

(** *** List monoid *)

Instance Monoid_list {a} : Monoid (list a) :=
  {| mempty := []
   ; mappend := @app _
  |}.

Instance LawfulMonoid_list {a} : LawfulMonoid (list a).
Proof.
  split; intros.
  - auto.
  - apply app_nil_r.
  - symmetry; apply app_assoc.
Qed.

(** ** Writer transformer *)

Record WriterT w m a : Type :=
  MkWriterT { runWriterT : m (w * a)%type }.

Arguments MkWriterT {w m a} _.
Arguments runWriterT {w m a} _.

(** ** Instances *)

Instance Monad_WriterT {w} `{Monoid w} {m} `{Monad m} : Monad (WriterT w m) :=
  {| pure _ x := MkWriterT (pure (mempty, x))
   ; bind _ _ u k := MkWriterT (
       runWriterT u >>= fun '(r, x) =>
       runWriterT (k x) >>= fun '(s, y) =>
       pure (r ++ s, y)%monoid)
  |}.

Instance MonadTrans_WriterT {w} `{Monoid w} : MonadTrans (WriterT w) :=
  {| lift _ _ _ u := MkWriterT (u >>= fun x => pure (mempty, x))
  |}.

Instance MonadState_WriterT {w} `{Monoid w} {s m} `{Monad m} `{MonadState s m} :
  MonadState s (WriterT w m) :=
  MonadState_MonadTrans.

Instance MonadError_WriterT {w} `{Monoid w} {e m} `{Monad m} `{MonadError e m} :
  MonadError e (WriterT w m) :=
  {| throwError _ err := MkWriterT (throwError err)
   ; catchError _ u h := MkWriterT (
       catchError (runWriterT u) (fun err => runWriterT (h err)))
  |}.

(** ** Simple facts *)

Lemma injective_runWriterT {w m a} (u v : WriterT w m a) :
  runWriterT u = runWriterT v -> u = v.
Proof.
  destruct u, v; simpl; intros []; auto.
Qed.

(** ** Laws *)

Section Laws.

Context {w} `{LawfulMonoid w}.

Instance LawfulMonad_WriterT {m} `{LawfulMonad m} :
  LawfulMonad (WriterT w m).
Proof.
  split; intros; apply injective_runWriterT; cbn; auto.
  - rewrite bind_pure_l.
    transitivity (runWriterT (k x) >>= pure).
    + f_equal; apply functional_extensionality; intros [].
      rewrite mappend_mempty_l. reflexivity.
    + rewrite bind_pure_r; reflexivity.
  - transitivity (runWriterT u >>= pure).
    + f_equal; apply functional_extensionality; intros [].
      rewrite bind_pure_l, mappend_mempty_r. reflexivity.
    + rewrite bind_pure_r; reflexivity.
  - do 3 (rewrite !bind_assoc; f_equal; apply functional_extensionality; intros [];
      try rewrite bind_pure_l).
    rewrite mappend_assoc; reflexivity.
Qed.

Instance LawfulMonadTrans_WriterT : LawfulMonadTrans (WriterT w).
Proof.
  split; intros; apply injective_runWriterT; cbn; auto.
  - rewrite bind_pure_l; reflexivity.
  - do 2 (rewrite !bind_assoc; f_equal; apply functional_extensionality; intros;
      try rewrite bind_pure_l).
    rewrite mappend_mempty_l; reflexivity.
Qed.

Instance LawfulMonadState_WriterT {s m}
  `{LawfulMonad m} `{MonadState s m} {LMS : LawfulMonadState s m} :
  LawfulMonadState s (WriterT w m) :=
  LawfulMonadState_LawfulMonadTrans.

Instance LawfulMonadError_WriterT {e m}
  `{LawfulMonad m} `{MonadError e m} {LME : LawfulMonadError e m} :
  LawfulMonadError e (WriterT w m).
Proof.
  destruct LME.
  split; intros; apply injective_runWriterT; cbn; intros; auto.
  - rewrite catch_throw; reflexivity.
  - replace (fun '(r, x) => pure (mempty, f x) >>= fun '(s, y) => pure ((r ++ s)%monoid, y))
      with (fun rx : w * a => pure (fst rx, f (snd rx))).
    + fold (mapM (fun rx => (fst rx, f (snd rx))) (catchError (runWriterT u) (fun err => runWriterT (h err)))).
      rewrite natural_catch. reflexivity.
    + apply functional_extensionality; intros []; rewrite bind_pure_l.
      rewrite mappend_mempty_r; reflexivity.
Qed.

End Laws.


Require Import Cosa.Lib.Header.
Require Import Cosa.Lib.Relation.
Require Import Cosa.Interaction.Interaction.

(** This file deals with simulations, the interaction structure
    equivalent of forward refinement in the predicate transformers
    setting. Forward refinement, as noticed by Arnaud Spiwack,
    corresponds to the kind of abstract interpretation we are
    interested in. The relations here are manipulated in expanded form
    [A->B->Prop], rather than [rel [A;B]], it seems easier for our
    usecase. *)

(** A pair of interaction structures can act jointly on a
    relation. Roughly the two act dually, but the connectives are
    interleaved. [RT] stands for "relation transformer". Choosing [RT]
    to act on [Prop] (with [ex]) rather than on [Type] (with [sigT])
    forces the [has_choice] condition on the commutation rule with
    [seq]. However, empirically, it seems a better choice in the
    context of abstract interpretation.  *)
Definition RT {S₁ T₁ S₂ T₂}
   (i:Interaction S₁ T₁) (j:Interaction S₂ T₂) (Q:T₁ -> T₂ -> Prop) : S₁ -> S₂ -> Prop :=
  fun s t =>
    forall c₁:i.(Com)  s , exists c₂:j.(Com)  t,
    forall x₂:j.(Resp) c₂, exists x₁:i.(Resp) c₁,
    Q (i.(Output) x₁) (j.(Output) x₂)
.

(** We say that the pair [(R,Q)] is a correspondance from [i] to [j]
    when [R] is included in [RT i j Q]. This parallels the definition
    of a pair of precondition and postcondition as [P⊆wp Q]. In plain
    English: if [s] and [t] are related by [R] then, outcomes of [i]
    and [j] are related by [Q]. The choice of quantifiers in [RT]
    allows to read [j] as a more concrete version of [i]. *)
Definition Correspondance {S₁ T₁ S₂ T₂}
   (i:Interaction S₁ T₁) (j:Interaction S₂ T₂) (R:S₁ -> S₂ -> Prop) (Q:T₁ -> T₂ -> Prop) : Prop :=
  forall s t, R s t -> RT i j Q s t
.

Definition Simulation {S T} (i:Interface S) (j:Interface T) (R:S->T->Prop) : Prop :=
  Correspondance i j R R
.

Lemma correspondance_transitive {S₁ T₁ S₂ T₂ S₃ T₃}
      (i:Interaction S₁ T₁) (j:Interaction S₂ T₂) (k:Interaction S₃ T₃) R₁ Q₁ R₂ Q₂ :
  Correspondance i j R₁ Q₁ -> Correspondance j k R₂ Q₂ -> Correspondance i k (R₁•R₂) (Q₁•Q₂).
Proof.
  unfold Simulation, Relation.comp.
  intros h₁ h₂.
  intros s u [ t [ h₃ h₄ ] ].
  specialize (h₁ s t h₃).
  specialize (h₂ t u h₄).
  intros c₁.
  specialize (h₁ c₁).
  destruct h₁ as [ c₁' h₁ ].
  specialize (h₂ c₁').
  destruct h₂ as [ c₂ h₂ ].
  exists c₂.
  intros x₂.
  specialize (h₂ x₂).
  destruct h₂ as [ x₂' h₂ ].
  specialize (h₁ x₂').
  destruct h₁ as [ x₁ h₁ ].
  exists x₁.
  unfold Relation.comp.
  eexists; intuition eauto.
Qed.

Lemma simulation_transitive {S T U} (i:Interface S) (j:Interface T) (k:Interface U) Q R :
                  Simulation i j R -> Simulation j k Q -> Simulation i k (R•Q).
Proof. apply correspondance_transitive. Qed.

Instance correspondance_proper_impl S₁ T₁ S₂ T₂ (i:Interaction S₁ T₁) (j:Interaction S₂ T₂) :
         Proper (Relation.equiv ==> Relation.equiv ==> Basics.impl) (Correspondance i j).
Proof.
  unfold Proper, respectful, Simulation.
  intros R₁ R₂ equiv_R₁_R₂.
  intros Q₁ Q₂ equiv_Q₁_Q₂.
  intros h s t R₂_s_t.
  apply equiv_R₁_R₂ in R₂_s_t.
  specialize (h s t R₂_s_t).
  intros c₁.
  specialize (h c₁).
  destruct h as [ c₂ h ].
  exists c₂.
  intros x₂.
  specialize (h x₂).
  destruct h as [ x₁ h ].
  exists x₁.
  now apply equiv_Q₁_Q₂.
Qed.

Instance correspondance_proper S₁ T₁ S₂ T₂ (i:Interaction S₁ T₁) (j:Interaction S₂ T₂) :
         Proper (Relation.equiv ==> Relation.equiv ==>iff) (Correspondance i j).
  unfold Proper, respectful.
  intros R₁ R₂ equiv_R₁_R₂ Q₁ Q₂ equiv_Q₁_Q₂.
  split.
  - rewrite equiv_R₁_R₂, equiv_Q₁_Q₂; trivial.
  - rewrite <- equiv_R₁_R₂, <- equiv_Q₁_Q₂; trivial.
Qed.

Instance simulation_proper S T (i:Interface S) (j:Interface T) :
                  Proper (Relation.equiv ==> Logic.iff) (Simulation i j).
Proof.
  unfold Proper, respectful, Simulation.
  intros R Q equiv_R_Q.
  now rewrite equiv_R_Q.
Qed.

Lemma RT_increasing S₁ S₂ T₁ T₂ (i:Interaction S₁ S₂) (j:Interaction T₁ T₂) :
  forall (R R':S₂->T₂->Prop), (forall s t, R s t -> R' s t) ->
  forall s t, RT i j R s t -> RT i j R' s t.
Proof.
  intros * h * h₁; unfold RT in *.
  intros c₁; specialize (h₁ c₁).
  destruct h₁ as [ c₂ h₁ ]; exists c₂.
  intros x₂; specialize (h₁ x₂).
  destruct h₁ as [ x₁ h₁ ]; exists x₁.
  eauto.
Qed.

(** relation transformers of composed interaction structures. *)

Lemma correspondance_seq_seq S₁ S₂ S₃ T₁ T₂ T₃
  (i₁:Interaction S₁ S₂) (i₂:Interaction S₂ S₃) (j₁:Interaction T₁ T₂) (j₂:Interaction T₂ T₃) :
  (forall s (c:j₁.(Com) s), has_choice (j₁.(Resp) c)) ->
  forall R s t, RT i₁ j₁ (RT i₂ j₂ R) s t -> RT (seq i₁ i₂) (seq j₁ j₂) R s t.
Proof.
  intros choice * h; unfold RT in *; unfold seq; simpl.
  generalize (fun s c => choice_exists _ (choice s c)); clear choice; intros choice.
  intros [c₁ c₁'].
  specialize (h c₁).
  destruct h as [c₂ h].
  apply choice in h.
  destruct h as [c₂' h ].
  generalize (fun x₂ => h x₂ (c₁' (c₂' x₂))); clear h; intros h.
  apply choice in h.
  destruct h as [ c₂'' h ].
  exists (existT _ c₂ c₂''); simpl.
  intros [ x₂ x₂' ]; simpl.
  specialize (h x₂ x₂').
  destruct h as [ x₁' h ].
  exists (existT _ (c₂' x₂) x₁'); simpl.
  assumption.
Qed.

Lemma correspondance_add_skip S₁ S₂ T₁ T₂ (i:Interaction S₁ S₂) (j:Interaction T₁ T₂) :
  forall R s t, RT i (seq skip j) R s t -> RT i j R s t.
Proof.
  intros * h; unfold seq,RT in *; simpl in *.
  intros c₁; specialize (h c₁).
  destruct h as [ [ [] c₂ ] h ].
  exists (c₂ tt).
  intros x₂.
  specialize (h (existT _ tt x₂)); simpl in h.
  exact h.
Qed.

Corollary correspondance_seq_skip S₁ S₂ S₃ T₁ T₂
  (i₁:Interaction S₁ S₂) (i₂:Interaction S₂ S₃) (j:Interaction T₁ T₂) :
  forall R s t, RT i₁ skip (RT i₂ j R) s t -> RT (seq i₁ i₂) j R s t.
Proof.
  intros * h.
  apply correspondance_add_skip.
  apply correspondance_seq_seq.
  { simpl; intros **.
    apply unit_has_choice. }
  assumption.
Qed.

Lemma correspondance_curry A S₁ S₂ T₁ T₂ (i:A->Interaction S₁ S₂) (j:Interaction T₁ T₂) :
  forall R s t, RT (i (fst s)) j R (snd s) t -> RT (curry i) j R s t.
Proof.
  intros * h; unfold RT,curry in *; simpl in *.
  exact h.
Qed.

Lemma correspondance_bind_seq A S₁ S₂ S₃ T₁ T₂ T₃
  (i₁:Interaction S₁ (A*S₂)) (i₂:A-> Interaction S₂ S₃) (j₁:Interaction T₁ T₂) (j₂:Interaction T₂ T₃) :
  (forall s (c:j₁.(Com) s), has_choice (j₁.(Resp) c)) ->
  forall R s t, RT i₁ j₁ (fun s' t' => RT (i₂ (fst s')) j₂ R (snd s') t') s t ->
                RT (bind i₁ i₂) (seq j₁ j₂) R s t.
Proof.
  intros choice * h; unfold bind.
  apply correspondance_seq_seq.
  { apply choice. }
  eapply RT_increasing.
  + eapply correspondance_curry.
  + assumption.
Qed.

Corollary correspondance_bind_skip A S₁ S₂ S₃ T₁ T₂
  (i₁:Interaction S₁ (A*S₂)) (i₂:A-> Interaction S₂ S₃) (j:Interaction T₁ T₂) :
  forall R s t, RT i₁ skip (fun s' t' => RT (i₂ (fst s')) j R (snd s') t') s t ->
                RT (bind i₁ i₂) j R s t.
Proof.
  intros **.
  apply correspondance_add_skip.
  apply correspondance_bind_seq.
  { simpl; intros **.
    apply unit_has_choice. }
  assumption.
Qed.

Lemma correspondance_seq_fun_skip S₁ S₂ S₃ T₁ T₂
  (f:S₁ -> S₂) (i:Interaction S₂ S₃) (j:Interaction T₁ T₂) :
  forall R s t, RT i j R (f s) t -> RT (seq (functional_extension f) i) j R s t.
Proof.
  intros * h.
  apply correspondance_seq_skip.
  unfold RT at 1; simpl.
  repeat (decompose_goal;eauto).
Qed.

Lemma correspondance_bind_fun_skip A S₁ S₂ S₃ T₁ T₂
  (f:S₁ -> (A*S₂)) (i:A->Interaction S₂ S₃) (j:Interaction T₁ T₂) :
  forall R s t, RT (i (fst (f s))) j R (snd (f s)) t ->
                RT (bind (functional_extension f) i) j R s t.
Proof.
  intros * h.
  apply correspondance_bind_skip.
  unfold RT at 1; simpl.
  repeat (decompose_goal;eauto).
Qed.

(** Interaction structures and strategies. *)

Definition select {S T} (i:Interaction S T) (strat:forall s, i.(Com) s) : Interaction S T := {|
  Com s := unit ;
  Resp s c := i.(Resp) (strat s) ;
  Output s c x := i.(Output) x
|}.

Lemma select_simulation S (i:Interface S) strat : Simulation (select i strat) i eq.
Proof.
  unfold Simulation, Correspondance.
  intros s ? <-.
  intros [].
  exists (strat s); simpl.
  intros x₂.
  exists x₂.
  reflexivity.
Qed.

(** [serve] is given for demonstration, it shouldn't have a use in Cosa. *)
Definition serve {S T} (i:Interaction S T) (server:forall s (c:i.(Com) s), i.(Resp) c) : Interaction S T := {|
  Com s := i.(Com) s;
  Resp s c := unit;
  Output s c x := i.(Output) (server s c)
|}.

Lemma serve_simulation S (i:Interface S) server : Simulation i (serve i server) eq.
Proof.
  unfold Simulation,Correspondance,RT; simpl.
  intros s ? <-.
  intros c.
  exists c.
  intros _.
  exists (server s c).
  reflexivity.
Qed.


(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Reduction from:
    Uniform Two-inequality Semi-unification (RU2SemiU)
  to:
    Semi-unification (SemiU)
*)

Require Import List.
Import ListNotations.

Require Import Undecidability.SemiUnification.SemiU.

Require Import ssreflect ssrfun ssrbool.

Require Import Undecidability.Synthetic.Definitions.

(* many-one reduction from right-uniform two-inequality semi-unification to semi-unification *)
Theorem reduction : RU2SemiU ⪯ SemiU.
Proof.
  exists (fun '(s0, s1, t) => [(s0, t); (s1, t)]).
  move=> [[s0 s1] t]. constructor.
  - move=> [φ] [ψ0] [ψ1] [Hψ0 Hψ1]. exists φ.
    apply /Forall_forall.
    by constructor; [by exists ψ0 | constructor; [by exists ψ1|]].
  - move=> [φ].
    move=> /Forall_forall /Forall_cons_iff [[ψ0 Hψ0]] /Forall_cons_iff [[ψ1 Hψ1]] _.
    by exists φ, ψ0, ψ1.
Qed.


(** Using [DProp] to implement the decidable set-equality of
    lists. This is certainly not the most minimal implementation, as
    most of it could be lifted from Coq's standard library. But it is
    very self-contained, and was rather fun to write. *)

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import FinSet.Lib.DProp.

(** * Inductive member predicate *)

(** The point of this predicate is to avoid using full-blown equality
    to define members. Indeed, the indices are patterns, which can be
    handled by well-crafted return predicates of pattern matching. *)
Inductive Mem {A:Type} : list A -> Type :=
| head : forall x {l}, Mem (x::l)
| tail : forall {x l}, Mem l -> Mem (x::l)
.

Definition no_mem_empty A : forall B, @Mem A [] -> B :=
  fun B c => match c with end.

Ltac use_no_mem_empty :=
  lazymatch goal with
  | h:@Mem _ [] |- _ => eapply no_mem_empty; exact h
  end.

Hint Extern 1 => use_no_mem_empty.

Fixpoint of_mem {A} {l:list A} (m:Mem l) : A :=
  match m with
  | head x => x
  | tail m' => of_mem m'
  end
.

(** The members of a list are thoses [x] such that [In x l]. It will
    give the appropriate glue when we use membership predicates and
    equality to specify operations. *)
Lemma in_is_mem A (l:list A) (x:A) : In x l <-> exists m:Mem l, x=of_mem m.
Proof.
  induction l as [|a l hl].
  + cbn. split.
    * intuition.
    * intros [? _]. contradictory.
  + cbn. split.
    * intros [<-|h].
      - now exists (head a).
      - apply hl in h. destruct h as [m h].
        now exists (tail m).
    * intros [m ->]. revert hl.
      refine match m with head a => _ | tail m => _ end.
      - cbn. intuition.
      - cbn. intros hl.
        right.
        apply hl.
        now exists m.
Qed.

(** * Decidable quantifiers on lists members *)

Program Fixpoint exists_dec {A:Type} (P:A->DProp) (l:list A) : {exists x:Mem l, P (of_mem x)} + {forall x:Mem l, DNot (P (of_mem x))} :=
  match l return _ with
  | [] => right _
  | a::q => dec_lift (Sumbool.sumbool_or _ _ _ _ (P a) (exists_dec P q))
  end
.
Next Obligation.
  intros * _ * h.
  destruct h as [h|[m h]].
  + exists (head a). cbn.
    assumption.
  + exists (tail m). cbn.
    assumption.
Qed.
Next Obligation.
  intros * _ * h m. revert h.
  refine match m with
         | head x => _
         | tail m => _
         end.
  + intros h. cbn.
    apply h.
  + intros h. cbn.
    apply h.
Qed.

Program Definition dexists {A:Type} (P:A->DProp) (l:list A) : DProp := {|
  dec := exists_dec P l
|}.
Next Obligation.
  intros * [m he] hu.
  specialize (hu m).
  contradictory.
Qed.

Definition dforall {A:Type} (P:A->DProp) (l:list A) : DProp :=
  DNot (dexists (fun x=> DNot (P x)) l)
.

(** * Set-like decidable relations on lists *)

(** ** Decidable membership predicate *)

Definition mem_list {A:Type} (E:A->A->DProp) (x:A) :=
  dexists (E x).

Remark no_mem_list_empty A E x : forall B, @mem_list A E x [] -> B.
Proof.
  intros B c. elimtype False.
  destruct c as [c _].
  auto.
Qed.

Ltac use_no_mem_list_empty :=
  lazymatch goal with
  | h:Holds (@mem_list _ _ _ []) |- _ => eapply no_mem_list_empty; exact h
  end.

Hint Extern 1 => use_no_mem_list_empty.

Lemma mem_list_right {A:Type} (E:A->A->DProp) (x y:A) (l:list A) :
  mem_list E x l -> mem_list E x (y::l).
Proof.
  intros [m h].
  exists (tail m). cbn.
  assumption.
Qed.

Lemma mem_list_left {A:Type} (E:A->A->DProp) (x y:A) (l:list A) :
  E x y -> mem_list E x (y::l).
Proof.
  intros h. cbn.
  exists (head y). cbn.
  assumption.
Qed.

Corollary mem_list_cons {A:Type} (E:A->A->DProp) (x y:A) (l:list A) :
  eq_dprop (mem_list E x (y::l)) (E x y || mem_list E x l).
Proof.
  split; cycle 1.
  { intros [h|h].
    all:eauto using mem_list_right,mem_list_left. }
  intros [m h]. revert h.
  refine match m with head y' => _ | tail m' => _ end. all:cbn -[mem_list].
  + intuition.
  + intros hm. right.
    exists m'. assumption.
Qed.

Lemma mem_list_app {A:Type} (E:A->A->DProp) (x:A) (l₁ l₂:list A) :
  eq_dprop (mem_list E x (l₁++l₂)) (mem_list E x l₁ || mem_list E x l₂).
Proof.
  induction l₁ as [|y l₁ hl₁].
  + cbn [app]. cbn -[mem_list]. intuition.
  + cbn [app]. rewrite !mem_list_cons,hl₁.
    cbn -[mem_list]. intuition.
Qed.

Program Fixpoint mem_of_mem_list {A:Type} (E:A->A->DProp) (l:list A) (x:A) : mem_list E x l -> Mem l :=
  match l return mem_list E x l -> Mem l with
  | [] => fun h => _
  | a::q => fun h => if dec (E x a) then head a
                     else tail (mem_of_mem_list E q x _)
  end
.
Next Obligation.
  intros * _ a q x [m h₁] h₂. cbn in h₂|-*. revert h₁ h₂.
  refine match m with head y => _ | tail m' => _ end. all: intros h₁ h₂.
  + cbn in h₁. contradictory.
  + cbn in h₁.
    now exists m'.
Qed.

Lemma mem_of_mem_list_spec A (E:A->A->DProp) (l:list A) (x:A) (h:mem_list E x l) : E x (of_mem (mem_of_mem_list E l x h)).
Proof.
  induction l as [|a q hq].
  + elimtype False.
    now destruct h as [c _].
  + cbn -[mem_list]. destruct (dec (E x a)) as [p|n].
    * cbn. assumption.
    * cbn -[mem_list].
      apply hq.
Qed.

(** ** Inclusion and equivalence *)

Definition included_list {A:Type} (E:A->A->DProp) (l₁ l₂:list A) : DProp :=
  dforall (fun x => mem_list E x l₂) l₁.

Instance included_list_preorder A (E:A->A->DProp) :
     PreOrder E -> PreOrder (included_list E).
Proof.
  intros P.
  split.
  + intros l. cbn.
    intros m. exists m.
    reflexivity.
  + intros l₁ l₂ l₃ h₁ h₂.
    cbn in h₁,h₂|-*.
    intros m₁.
    specialize (h₁ m₁). destruct h₁ as [m₂ h₁].
    specialize (h₂ m₂). destruct h₂ as [m₃ h₂].
    exists m₃.
    etransitivity; eauto.
Qed.

Corollary mem_included_list A (E:A->A->DProp) (_:Transitive E) : forall x l₁ l₂,
   included_list E l₁ l₂ -> Basics.impl (mem_list E x l₁) (mem_list E x l₂).
Proof.
  intros * hi hm. cbn -[mem_list] in hi. cbn in hm.
  destruct hm as [m₁ hm]. specialize (hi m₁). cbn in hi.
  destruct hi as [m₂ hi]. cbn.
  exists m₂.
  etransitivity. all:eassumption.
Qed.

Definition eq_set_list {A:Type} (E:A->A->DProp) (l₁ l₂:list A) : DProp :=
  included_list E l₁ l₂ && included_list E l₂ l₁.

Instance equivalence_preorder A (R:A->A->Prop) (_:Equivalence R) : PreOrder R.
Proof.
  split.
  + apply Equivalence_Reflexive.
  + apply Equivalence_Transitive.
Qed.

Instance eq_set_list_eq A (E:A->A->DProp) :
     Equivalence E -> Equivalence (eq_set_list E).
Proof.
  intros EQ.
  split.
  + intros l.
    split. all:reflexivity.
  + intros l₁ l₂ h.
    split. all:apply h.
  + intros l₁ l₂ l₃ h₁ h₂.
    split.
    all:etransitivity. all:eapply h₁||eapply h₂.
Qed.

Corollary mem_eq_set_list A (E:A->A->DProp) (_:Transitive E): forall l₁ l₂ x,
  eq_set_list E l₁ l₂ -> (mem_list E x l₁ <-> mem_list E x l₂).
Proof.
  intros * [hi hr].
  split.
  + erewrite mem_included_list;[|try eassumption..].
    trivial.
  + erewrite mem_included_list;[|try eassumption..].
    trivial.
Qed.

Instance mem_eq_set_list_proper A (E:A->A->DProp) (_:Transitive E) :
  Proper (eq ==> eq_set_list E ==> eq_dprop) (mem_list E).
Proof.
  intros x ? <- l₁ l₂ hl. unfold eq_dprop.
  eauto using mem_eq_set_list.
Qed.

(** * List without duplicates *)

Fixpoint nodup {A} (R:A->A->DProp) (l:list A) : DProp :=
  match l with
  | [] => DTrue
  | a::l => nodup R l && DNot (mem_list R a l)
  end
.

Fixpoint deduplicate {A} (R:A->A->DProp) (l:list A) : list A :=
  match l with
  | [] => []
  | a::l =>
    let dl :=
      List.filter
        (fun x => if dec (DNot (R a x)) then true else false)
        (deduplicate R l)
    in
    a::dl
  end
.

Lemma filter_sub A R l (p:A->bool) :
  forall x, mem_list R x (filter p l) -> mem_list R x l.
Proof.
  induction l as [|a l hl].
  + cbn -[mem_list]. eauto.
  + cbn -[mem_list]. intros x. destruct (p a).
    * rewrite !mem_list_cons. cbn -[mem_list]. intuition.
    * eauto using mem_list_right.
Qed.

Lemma filter_nodup A R (l:list A) : forall p:A->bool,
  nodup R l -> nodup R (filter p l).
Proof.
  intros p.
  induction l as [|a l hl].
  + cbn. trivial.
  + cbn -[mem_list]. destruct (p a).
    * cbn -[mem_list]. rewrite !denies_spec.
      intuition eauto using filter_sub.
    * intuition.
Qed.

Lemma deduplicate_nodup A R (l:list A) : nodup R (deduplicate R l).
Proof.
  induction l as [ | a l hl].
  + cbn. trivial.
  + cbn -[DNot]. split.
    * eauto using filter_nodup.
    * revert hl. induction (deduplicate R l) as [|x l' hl'].
      - cbn. auto.
      - cbn -[DNot mem_list]. destruct dec as [hr|_];cycle 1.
        { intuition. }
        cbn -[mem_list] in *. rewrite mem_list_cons. cbn -[mem_list].
        intuition.
Qed.

Lemma deduplicate_eq_set_list A (R:A->A->DProp) (l:list A) :
  Equivalence R -> eq_set_list R l (deduplicate R l).
Proof.
  (* spiwack: This proof is much longer than it should be, reflecting
     my dedication to avoiding equality… *)
  intros e. cbn -[mem_list]. split.
  + revert l. fix 2. intros l m.
    refine match m with head a => _ | @tail _ _ l' m' => _ end.
    * cbn [deduplicate of_mem].
      apply mem_list_left. reflexivity.
    * set (hl := deduplicate_eq_set_list _ m'). clearbody hl.
      cbn [of_mem deduplicate].
      rewrite mem_list_cons. cbn -[mem_list DNot].
      generalize (deduplicate R l') (of_mem m') hl. clear -e.
      { intros l. induction l as [|b l hl].
        + eauto.
        + intros x. cbn [filter].
          destruct dec as [hr|hr].
          * rewrite !mem_list_cons. cbn -[mem_list DNot].
            intros [h|h].
            - intuition.
            - apply hl in h. intuition.
          * rewrite mem_list_cons. cbn -[mem_list DNot]. cbn in hr.
            intros [h|h].
            - left. etransitivity. all:((idtac+symmetry);eassumption).
            - intuition. }
  + assert
      (forall l x, mem_list R x (deduplicate R l) -> mem_list R x l) as incl.
    { clear. intros l. induction l as [|a l hl].
      + cbn -[mem_list]. eauto.
      + intros x. cbn [deduplicate].
        rewrite !mem_list_cons. cbn -[mem_list DNot].
        intuition eauto using filter_sub. }
    intros m. generalize l (deduplicate R l) m (incl l). clear -e.
    intros l₁ l₂ m. induction m as [a l₂|a l₂ m hm].
    * cbn -[mem_list]. intros h. apply h.
      apply mem_list_left. reflexivity.
    * cbn -[mem_list]. eauto using mem_list_right.
Qed.


From SSL_Iris Require Import core.
From iris.program_logic Require Export weakestpre.
From iris.proofmode Require Export tactics coq_tactics ltac_tactics reduction.
From iris.heap_lang Require Import lang notation proofmode.
Require Import common.
From iris_string_ident Require Import ltac2_string_ident.
From Hammer Require Import Hammer.
Context `{!heapG Σ}.
Set Default Proof Using "Type".

Definition sll_len : val :=
rec: "sll_len" "x" "r" :=
let: "a2" := ! ("r") in
#();;
if: "x" = #null_loc
then (
("r") <- (#0);;
#()
)
else (
let: "vx2" := ! ("x") in
#();;
let: "nxtx2" := ! ("x" +ₗ #1) in
#();;
"sll_len" "nxtx2" "r";;
let: "len1x2" := ! ("r") in
#();;
("r") <- (#1 + "len1x2");;
#()
).

Lemma sll_len_spec :
∀ (r : loc) (n : Z) (x : loc) (_alpha_514 : sll_card) (a : loc) (hi : Z) (lo : Z),
{{{ ⌜(0 ≤ n)%Z⌝ ∗ r ↦ #a ∗ (sll x n lo hi _alpha_514) }}}
  sll_len #x #r
{{{ RET #(); ∃ (_alpha_515 : sll_card), r ↦ #n ∗ (sll x n lo hi _alpha_515) }}}.
Proof.
iIntros (r n x _alpha_514 a hi lo ϕ) "(%iH1 & iH2 & iH3) Post".
iRewriteHyp.
iLöb as "sll_len" forall (r n x _alpha_514 a hi lo iH1 ϕ).
ssl_begin.
try rename a into a2.
ssl_load.
iRename select ((sll x n lo hi _alpha_514))%I into "iH4".
ssl_if Cond_iH4.

iDestruct (sll_card_0_learn with "iH4") as "[iH4 %iH4_eqn]".
rewrite iH4_eqn; last by safeDispatchPure.
tac_except_post ltac:(rewrite sll_card_0_open).
iDestruct "iH4" as  "(%iH5 & %iH6 & %iH7 & %iH8)".
ssl_store.
try wp_pures.
iFindApply.
iExists (sll_card_0  : sll_card).
ssl_finish.
ssl_rewrite_first_heap sll_card_0_open.
ssl_finish.

iDestruct (sll_card_1_learn with "iH4") as "[iH4 %iH4_eqn]".

edestruct iH4_eqn as [_alpha_513x ->]; first by safeDispatchPure.
tac_except_post ltac:(rewrite sll_card_1_open).
iDestruct "iH4" as (len1x vx hi1x lo1x nxtx) "((%iH9 & %iH10 & %iH11 & %iH12 & %iH13 & %iH14 & %iH15) & (iH16 & iH17 & iH18 & iH19))".
try rename vx into vx2.
ssl_load.
try rename nxtx into nxtx2.
ssl_load.
wp_apply ("sll_len" $! (r) (len1x) (nxtx2) (_alpha_513x) (a2) (hi1x) (lo1x) with "[] [$] [$]").
ssl_finish.

iIntros  "iH22".
iDestruct "iH22" as (_alpha_5151) "(iH20 & iH21)".
try wp_pures.
try rename len1x into len1x2.
ssl_load.
ssl_store.
try wp_pures.
iFindApply.
iExists (sll_card_1 _alpha_5151 : sll_card).
ssl_finish.
ssl_rewrite_first_heap sll_card_1_open.
pull_out_exist.
iExists len1x2.
pull_out_exist.
iExists vx2.
pull_out_exist.
iExists hi1x.
pull_out_exist.
iExists lo1x.
pull_out_exist.
iExists nxtx2.
ssl_finish.
Qed.


Require Export parser.
Require Export refine.

Definition adapter: IA := parse
"IA [s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11] (s1)
[login,req,connected,arg,service]
[usr,pass,ok,ack,value,query] []
[s1->(login)s2, s2->(usr)s3, s3->(pass)s4,
s4->(connected)s5, s5->(ok)s6, s6->(req)s7,
s7->(arg)s8, s8->(value)s9, s9->(query)s10,
s10->(service)s11, s11->(ack)s1]".

Definition adapter_rep: IA :=
 IAutomaton.hiding
 ( IAutomaton.replacement adapter (&"tau") (ASet.GenActs [&"req",&"arg",&"service"]) )
 (ASet.GenActs [&"value",&"query",&"ack"]).

Definition adapter_hid: IA :=
 IAutomaton.hiding adapter (ASet.GenActs [&"req",&"arg",&"service",&"value",&"query",&"ack"]).

Eval compute in SMENI_refinement adapter_rep adapter_hid. (*false*)


From Undecidability.L Require Import L HaltMuRec_to_HaltL.
From Undecidability.MuRec Require Import MuRec.

Theorem MuRec_computable_to_L_computable {k} (R : Vector.t nat k -> nat -> Prop) :
  MuRec_computable R -> L_computable R.
Proof.
  eapply HaltMuRec_to_HaltL.computable_MuRec_to_L.
Qed.


Check pred(S 0) = 0.
Definition test1 := pred(S 0) = 0.
Check test1.

Check forall n:nat, pred (S n) = n.
Definition test2 := forall n:nat, pred (S n) = n.
Check test2.
Lemma lemma2 : forall n:nat, pred (S n) = n.
Proof.
  intros.
  reflexivity.
Qed.

Check forall n:nat, S(pred n) = n.
Definition test3 := forall n:nat, S(pred n) = n.
Check test3.
Lemma lemma3 : forall n:nat, S(pred n) = n.
Proof.
Admitted.

(** Check forall n : nat, pred (S n).**)
Check 5.
Check fun n => pred (S n).
Check forall n:nat, pred (S n).
Definition test4 := forall n:nat, pred (S 3).
Check 5.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import bedrock2.Syntax.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Language.API.
Require Import Crypto.Util.ZRange.
Local Open Scope Z_scope.

Import API.Compilers.
Import Types.Notations.

Section Expr.
  Context {p : Types.parameters}.
  Existing Instance Types.rep.Z.
  Existing Instance Types.rep.listZ_local. (* local list representation *)
  Definition max_range : zrange := {| lower := 0; upper := 2 ^ Semantics.width - 1 |}.
  Definition range_good (r : zrange) : bool := zrange_beq r max_range.

  (* for the second argument of shifts *)
  Definition width_range :=  r[0~>Semantics.width-1]%zrange.

  Local Notation Zcast r :=
    (@expr.App
       _ _ _ type_range (type.arrow type_Z type_Z)
       (expr.Ident ident.Z_cast)
       (expr.Ident (@ident.Literal base.type.zrange r))).
  Local Notation Zcast2 r1 r2 :=
    (@expr.App
       _ _ _ type_range2 (type.arrow type_ZZ type_ZZ)
       (expr.Ident ident.Z_cast2)
       (@expr.App
          _ _ _ type_range type_range2
          (@expr.App
             _ _ _ type_range (type.arrow type_range type_range2)
             (expr.Ident ident.pair)
             (expr.Ident (@ident.Literal base.type.zrange r1)))
          (expr.Ident (@ident.Literal base.type.zrange r2)))).

  (* Literal Zs or nats, and lists, do not need casts *)
  Definition cast_exempt {var t} (e : @API.expr var t)
    : bool :=
    match e with
    | (expr.Ident _ (ident.Literal base.type.Z z)) =>
      true
    | (expr.Ident _ (ident.Literal base.type.nat n)) =>
      true
    | expr.Var _ _ =>
      true
    | _ => false
    end.

  Definition invert_literal (x : Syntax.expr) : option Z :=
    match x with
    | expr.literal x => Some x
    | _ => None
    end.
  Definition literal_eqb x y : bool :=
    match invert_literal x with
    | Some x => Z.eqb x y
    | None => false
    end.
  Definition literal_ltwidth x :=
    match invert_literal x with
    | Some x => is_bounded_by_bool x width_range
    | None => false
    end.

  Definition rshiftr
    : rtype (type_Z -> type_Z -> type_Z) :=
    fun x n =>
      if literal_ltwidth n
      then expr.op bopname.sru x n
      else base_make_error _.

  Definition rshiftl
    : rtype (type_Z -> type_Z -> type_Z) :=
    fun x n =>
      if literal_ltwidth n
      then expr.op bopname.slu x n
      else base_make_error _.

  Definition rtruncating_shiftl
    : rtype (type_Z -> type_Z -> type_Z -> type_Z) :=
    fun s x n =>
      if literal_eqb s Semantics.width
      then if literal_ltwidth n
           then expr.op bopname.slu x n
           else make_error type_Z
      else base_make_error _.

  Definition rlnot_modulo
    : rtype (type_Z -> type_Z -> type_Z) :=
    fun x m =>
      match invert_literal m with
      | Some m => if (2^(Z.log2 m) =? m)
                  then expr.op bopname.xor
                               (if Z.log2 m =? Semantics.width (* is this a good place to do this optimization? *)
                                then x
                                else expr.op bopname.and x (expr.literal (Z.ones (Z.log2 m))))
                               (expr.literal (Z.ones (Z.log2 m)))
                  else make_error type_Z
      | None => make_error type_Z
      end.

  Definition rselect
    : rtype (type_Z -> type_Z -> type_Z -> type_Z) :=
    fun c x y =>
      if literal_eqb x 0
      then if literal_eqb y (2^Semantics.width - 1)
           then expr.op bopname.add (expr.literal (-1))
                        (expr.op bopname.eq c (expr.literal 0))
           else base_make_error _
      else base_make_error _.

  Definition rnth_default
    : rtype (type_Z -> type_listZ -> type_nat -> type_Z) :=
    fun d l i =>
      match i with
      | expr.literal i =>
        nth_default d l (Z.to_nat i)
      | _ => base_make_error _
      end.

  Definition rmul_high
    : rtype (type_Z -> type_Z -> type_Z -> type_Z) :=
    fun s x y =>
      if literal_eqb s (2 ^ Semantics.width)
      then expr.op bopname.mulhuu x y
      else base_make_error _.

  Definition is_cast_literal_ident {t} (i : ident.ident t) : bool :=
    match i with
    | ident.Literal base.type.zrange r =>
      range_good r
    | _ => false
    end.
  Definition is_cast_literal
             {var t} (e : @API.expr var t) : bool :=
    match e with
    | expr.Ident type_range i =>
      is_cast_literal_ident i
    | _ => false
    end.

  Definition is_pair_range {t} (i : ident.ident t) : bool :=
    match i with
    | ident.pair base_range base_range => true
    | _ => false
    end.
  Definition is_cast2_literal_App2
             {var t} (e : @API.expr var t) : bool :=
    match e with
    | expr.Ident (type.arrow type_range
                             (type.arrow type_range type_range2))
                 i =>
      is_pair_range i
    | _ => false
    end.
  Definition is_cast2_literal_App1
             {var t} (e : @API.expr var t) : bool :=
    match e with
    | expr.App
        type_range (type.arrow type_range type_range2)
        f r1 =>
      is_cast2_literal_App2 f && is_cast_literal r1
    | _ => false
    end.
  Definition is_cast2_literal
             {var t} (e : @API.expr var t) : bool :=
    match e with
    | expr.App type_range type_range2 f r2 =>
      is_cast2_literal_App1 f && is_cast_literal r2
    | _ => false
    end.

  Definition is_cast_ident {t} (i : ident.ident t) : bool :=
    match i with
    | ident.Z_cast => true
    | ident.Z_cast2 => true
    | _ => false
    end.

  Definition is_cast_ident_expr {var t}
             (e : @API.expr var t) : bool :=
    match e with
    | expr.Ident _ i => is_cast_ident i
    | _ => false
    end.

  Definition is_cast
             {var t} (e : @API.expr var t) : bool :=
    match e with
    | expr.App type_range (type.arrow type_Z type_Z) f r =>
      is_cast_ident_expr f && is_cast_literal r
    | expr.App type_range2 (type.arrow type_ZZ type_ZZ) f r =>
      is_cast_ident_expr f && is_cast2_literal r
    | _ => false
    end.

  (* only require cast for the argument of (App f x) if:
     - f is not a cast
     - f is not mul_high (then, x = 2^width)
     - f is not (lnot_modulo _) (then x is allowed to be 2^width)
     - f is not (nth_default ?d ?l) (i doesn't need to fit in a word) *)
  Definition require_cast_for_arg
             {var t} (e : @API.expr var t) : bool :=
    match e with
    | Zcast r => negb (range_good r)
    | Zcast2 r1 r2 =>
      negb (range_good r1 && range_good r2)
    | expr.Ident _ ident.Z_mul_high => false
    | expr.App
        _ _ (expr.Ident _ ident.Z_lnot_modulo)
        _ => false
    | expr.App
        _ _ (expr.App
               _ _ (expr.Ident _ (ident.List_nth_default _))
                      _) _ => false
    | _ => true
    end.

  Definition translate_binop {t} (i : ident.ident t)
    : option (rtype t) :=
    match i with
    | ident.Z_add => Some (expr.op bopname.add)
    | ident.Z_sub => Some (expr.op bopname.sub)
    | ident.Z_mul => Some (expr.op bopname.mul)
    | ident.Z_ltz => Some (expr.op bopname.ltu)
    | ident.Z_lor => Some (expr.op bopname.or)
    | ident.Z_land => Some (expr.op bopname.and)
    | ident.Z_lxor => Some (expr.op bopname.xor)
    | _ => None
    end.

  Definition translate_ident
           {t} (i : ident.ident t) : rtype t :=
    match i in ident.ident t0 return rtype t0 with
    | ident.fst _ _ => fst
    | ident.snd _ _ => snd
    | ident.Z_opp => fun x => expr.op bopname.sub (expr.literal 0) x
    | ident.List_nth_default base_Z => rnth_default
    | ident.Z_shiftr => rshiftr
    | ident.Z_shiftl => rshiftl
    | ident.Z_truncating_shiftl => rtruncating_shiftl
    | ident.Z_lnot_modulo => rlnot_modulo
    | ident.Z_zselect => rselect
    | ident.Z_mul_high => rmul_high
    | ident.Z_cast => fun _ x => x
    | ident.Z_cast2 => fun _ x => x
    | i => match translate_binop i with
           | Some x => x
           | None => make_error _
           end
    end.

  Definition translate_cast_exempt {t}
             (require_in_bounds : bool)
             (e : @API.expr ltype t) : rtype t :=
    match e in expr.expr t0 return rtype t0 with
    | (expr.Ident type_Z (ident.Literal base.type.Z z)) =>
      if require_in_bounds
      then if is_bounded_by_bool z max_range
           then expr.literal z
           else make_error _
      else expr.literal z
    | (expr.Ident type_nat (ident.Literal base.type.nat n)) =>
      expr.literal (Z.of_nat n)
    | expr.Var type_listZ x => map expr.var x
    | expr.Var type_Z x => expr.var x
    | _ => make_error _
    end.

  Fixpoint translate_expr
           (require_cast : bool)
           {t} (e : @API.expr ltype t) : rtype t :=
    if cast_exempt e
    then translate_cast_exempt require_cast e
    else if require_cast
         then
           match e in expr.expr t0 return rtype t0 with
           | expr.App _ _ f x =>
             if is_cast f
             then translate_expr false f (translate_expr false x)
             else make_error _
           | _ => make_error _
           end
         else
           match e in expr.expr t0 return rtype t0 with
           | expr.App _ _ f x =>
             let rc := require_cast_for_arg f in
             translate_expr false f (translate_expr rc x)
           | expr.Ident _ i => translate_ident i
           | expr.Var _ x => rtype_of_ltype _ x
           | _ => make_error _
           end.
End Expr.