From Coq.Logic Require Import ConstructiveEpsilon.
Require Import Lia Arith List Bool.

(** ** Classical logical axioms  *)

Definition LEM := forall P, P \/ ~ P.
Definition DNE := forall P, ~~P -> P.
Definition CP : Prop := forall X Y : Prop, (~Y -> ~X) -> X -> Y.        (* contraposition *)
Definition Peirce := forall P Q : Prop, ((P -> Q) -> P) -> P.

Goal LEM -> DNE.
unfold LEM, DNE.
intros.
specialize (H P).
unfold not in H0.
destruct H.
- assumption.
- specialize (H0 H).
  contradiction.
Qed.

Goal DNE -> CP.
unfold DNE, CP.
intros.
  apply (H Y).
  unfold not in *.
  intros.
  apply H0.
  apply H2.
  assumption.
Qed.

Goal CP -> Peirce.
	unfold CP, Peirce.
  intros.

  specialize (H P Q) as HPQ.
  intros.
  unfold not in *.
Admitted.

Lemma nnLEM : forall P, ~~ (P \/ ~ P).
intros.
  unfold not.
  intro.
  apply H.
  right.
  intro.
  apply H.
  left.
  assumption.
Qed.

Goal forall p : nat -> Prop, (exists n, p n) -> ~~ exists n, p n /\ forall k, p k -> n <= k.
  intros.
  unfold not.
  intros.
  apply H0.
  destruct H.
  exists x.
  split.
  assumption.
  intros.

Admitted.

Goal Peirce -> forall philosophers_stone infinite_gold : Prop, philosophers_stone \/ (philosophers_stone -> infinite_gold). Admitted.

Goal Peirce -> LEM.
  unfold Peirce, LEM.
  intros.
Admitted.

Definition DGP := forall P Q : Prop, (P -> Q) \/ (Q -> P).
Definition WLEM := forall P, ~~P \/ ~ P.

(* Optional *) Goal LEM -> DGP. Admitted.

(* Optional *) Goal DGP -> WLEM. Admitted.

Definition IP := forall (P : Prop), forall p : nat -> Prop, (P -> exists n, p n) -> exists n, P -> p n.

(* Optional *) Goal LEM -> IP. Admitted.

(* Decidability, semi-decidability *)

Definition semi_decidable {X} (p : X -> Prop) :=
  exists f : X -> nat -> bool, forall x, p x <-> exists n, f x n = true.

Definition co_semi_decidable {X} (p : X -> Prop) :=
  exists f : X -> nat -> bool, forall x, p x <-> forall n, f x n = false.

Definition decidable {X} (p : X -> Prop) :=
  exists f : X -> bool, forall x, p x <-> f x = true.

Lemma decidable_semi_decidable {X} (p : X -> Prop) :
  decidable p -> semi_decidable p.
  unfold decidable, semi_decidable.
  intros.
  destruct H.
  unfold iff in H.

  exists (fun x0 n => x x0).

Admitted.

(*

    LEM --> DGP --> WLEM
     |               |
     |               |
     v               v
    LPO     -->    WLPO   -->   LLPO
     ^               ^
     |               |
     v               v
  MP /\ WLPO     PFP /\ LLPO

     ^
     |

  MP /\ IP

 *)

Definition LPO := forall f : nat -> bool, (exists n, f n = true) \/ ~ (exists n, f n = true).
Definition WLPO := forall f : nat -> bool, (forall n, f n = false) \/ ~ (forall n, f n = false).

Lemma forall_neg_exists_iff (f : nat -> bool) :
  (forall n, f n = false) <-> ~ exists n, f n = true.
Proof.
  unfold iff.
  split; intro.
  - unfold not.
    intro.
    destruct H0.
    specialize (H x).
    rewrite H0 in H.
    inversion H.
  - unfold not in H.
    intro.

Admitted.

Goal LEM -> LPO.
  unfold LEM,LPO.
  intros.
  specialize (H (exists n : nat, f n = true)).
  assumption.
Qed.

Goal WLEM -> WLPO.
  unfold WLEM, WLPO.
  intros.
  specialize (H (forall n : nat, f n = false)).

  destruct H.
  - eapply nnLEM.
  - right.
    assumption.

Admitted.

Goal LPO -> WLPO. Admitted.

Definition LPO_semidecidable := forall X (p : X -> Prop), semi_decidable p -> forall x, p x \/ ~ p x.

Lemma LPO_semidecidable_iff :
  LPO <-> LPO_semidecidable.
Proof.
  split.
  - intros H X p [f Hf] x.
    rewrite Hf. eapply H.
  - intros H f.
    eapply (H unit (fun _ => exists n, f n = true)).
    exists (fun _ => f). cbv. intuition. econstructor.
Qed.

Definition WLPO_semidecidable := forall X (p : X -> Prop), semi_decidable p -> forall x, ~ p x \/ ~~ p x.

Goal WLPO <-> WLPO_semidecidable.
Admitted.

Definition WLPO_cosemidecidable := forall X (p : X -> Prop), co_semi_decidable p -> forall x, p x \/ ~ p x.

Goal WLPO_cosemidecidable <-> WLPO_semidecidable.
Admitted.

Definition MP := forall f : nat -> bool, ~~ (exists n, f n = true) -> exists n, f n = true.

Goal LPO <-> MP /\ WLPO. Admitted.

Goal IP -> MP -> LPO. Admitted.

(** ** Choice axioms *)

(* (** ** Provable choice axioms  *) *)

Definition AC_on X Y :=
  forall R : X -> Y -> Prop, (forall x, exists y, R x y) -> exists f : X -> Y, forall x, R x (f x).

Definition AC := forall X Y, AC_on X Y.

Lemma AC_iff_commute :
  AC <-> forall X (A : X -> Type), (forall x, inhabited (A x)) -> inhabited (forall x, A x).
Proof.
  split.
  - intros ac X A HA.
    destruct (ac X {x & A x} (fun x '(existT _ x' ax) => x = x')) as [f Hf].
    all: admit.
  - intros H X Y R Htot.
Admitted.

Definition UNIF_on X Y := forall R : X -> Y -> Prop,
  (forall x, exists y, R x y) -> exists R' : X -> Y -> Prop, (forall x y, R' x y -> R x y) /\ (forall x, exists! y, R' x y).

Definition AUC_on X Y :=
  forall R : X -> Y -> Prop, (forall x, exists! y, R x y) -> exists f : X -> Y, forall x, R x (f x).

Definition AC_0_0 :=
  AC_on nat nat.

Definition AC_1_0 :=
  AC_on (nat -> nat) nat.

Definition ADC_on X := forall R : X -> X -> Prop, forall x0, (forall x, exists x', R x x') -> exists f : nat -> X, f 0 = x0 /\ forall n, R (f n) (f (S n)).

Definition ADC := forall X, ADC_on X.
Definition ACC := forall X, AC_on nat X.

Goal forall X Y,
  AC_on X Y <-> AUC_on X Y /\ UNIF_on X Y.
Proof. Admitted.

(** ** Extensionality axioms  *)

Definition Fext := forall X Y (f g : X -> Y), (forall x, f x = g x) -> f = g.
Definition Pext := forall P Q : Prop, P <-> Q -> P = Q.
Definition hProp (P : Type) := forall x1 x2 : P, x1 = x2.
Definition PI := forall P : Prop, hProp P.

Lemma Pext_to_PI : Pext -> PI. Admitted.

Lemma hProp_disj (P Q : Prop) :
  hProp P -> hProp Q -> ~ (P /\ Q) -> hProp (P \/ Q).
Proof. Admitted.

Lemma Fext_hProp_neg P :
  Fext -> hProp (~ P).
Proof.
  intros fext H1 H2.
  eapply fext. intros x. exfalso. tauto.
Qed.

Lemma Fext_hProp_disj (P : Prop) :
  Fext -> hProp P -> hProp (P \/ ~ P).
Proof.
  intros. now eapply hProp_disj; [ | eapply Fext_hProp_neg | ].
Qed.

Lemma Diaconescu :
  (forall X Y, AC_on X Y) -> Fext -> Pext -> LEM.
Proof.
  intros C fext pext P.
  pose (U (x : bool) := x = true \/ P).
  pose (V (x : bool) := x = false \/ P).
  destruct (C ({ p : bool -> Prop | p = U \/ p = V}) bool (fun p b => (proj1_sig p b))) as [f Hf].
  - admit.
  - pose proof (Hf (exist _ U (or_introl eq_refl))) as H1.
    pose proof (Hf (exist _ V (or_intror eq_refl))) as H2. cbn in *.
    admit.
Admitted.

(* bijection from nat * nat to nat *)
Definition embed '(x, y) : nat :=
  y + (nat_rec _ 0 (fun i m => (S i) + m) (y + x)).

(* bijection from nat to nat * nat *)
Definition unembed (n : nat) : nat * nat :=
  nat_rec _ (0, 0) (fun _ '(x, y) => match x with S x => (x, S y) | _ => (S y, 0) end) n.

Lemma embedP {xy: nat * nat} : unembed (embed xy) = xy.
Proof.
  assert (forall n, embed xy = n -> unembed n = xy).
    intro n. revert xy. induction n as [|n IH].
      intros [[|?] [|?]]; intro H; inversion H; reflexivity.
    intros [x [|y]]; simpl.
      case x as [|x]; simpl; intro H.
        inversion H.
      rewrite (IH (0, x)); [reflexivity|].
      inversion H; simpl. rewrite Nat.add_0_r. reflexivity.
    intro H. rewrite (IH (S x, y)); [reflexivity|].
    inversion H. simpl. rewrite Nat.add_succ_r. reflexivity.
  apply H. reflexivity.
Qed.

Lemma unembedP {n: nat} : embed (unembed n) = n.
Proof.
  induction n as [|n IH]; [reflexivity|].
  simpl. revert IH. case (unembed n). intros x y.
  case x as [|x]; intro Hx; rewrite <- Hx; simpl.
    rewrite Nat.add_0_r. reflexivity.
  rewrite ?Nat.add_succ_r. simpl. rewrite ?Nat.add_succ_r. reflexivity.
Qed.
Arguments embed : simpl never.

Module EmbedNatNotations.
  Notation "âŸ¨ a , b âŸ©" := (embed (a, b)) (at level 0).
  Notation "'fun!' 'âŸ¨' x ',' y 'âŸ©' '=>' b" := (fun p => let (x,y) := unembed p in b) (at level 30, b at level 200).
End EmbedNatNotations.

Import EmbedNatNotations.

Lemma decidable_AC X :
  forall R : X -> nat -> Prop, decidable (uncurry R) -> (forall x, exists n, R x n) -> exists f, forall x, R x (f x).
Proof.
  intros R [f Hf] Htot.
  assert (H : forall x, exists n, f (x, n) = true).  { intros x. destruct (Htot x) as [y]. exists y. now eapply Hf. }
  eexists (fun x => proj1_sig (constructive_indefinite_ground_description_nat _ _ (H x))).
  intros x. destruct constructive_indefinite_ground_description_nat as [n Hn]; cbn.
  eapply (Hf (x, n)), Hn.
  Unshelve. intros. cbn. destruct f; firstorder congruence.
Qed.

Lemma semi_decidable_AC X (R : X -> nat -> Prop) :
  semi_decidable (uncurry R) ->
  (forall x, exists y, R x y) ->
  exists f : X -> nat, forall x, R x (f x).
Proof.
  intros [g Hg] Htot'. red in Hg. unfold uncurry in *.
  pose (R' x := fun! âŸ¨n,mâŸ© => g (x,n) m = true).
  assert (Htot : forall x, exists n, R' x n). {
    subst R'. intros x. destruct (Htot' x) as (n & [m H] % (Hg (_, _))).
    exists âŸ¨n,mâŸ©. now rewrite embedP.
  }
  assert (Hdec : decidable (uncurry R')). {
    exists  (fun '(x, nm) => let (n, m) := unembed nm in g (x, n) m).
    unfold R'. unfold uncurry. intros (x, nm). destruct (unembed nm) as (n, m).
    destruct g; firstorder congruence.
  }
  eapply (decidable_AC _ _ Hdec) in Htot as [f' Hf'].
  exists (fun x => (fun! âŸ¨n, mâŸ© => n) (f' x)).
  intros x. subst R'. specialize (Hf' x). cbn in Hf'.
  destruct (unembed (f' x)). eapply (Hg (_, _)). eauto.
Qed.

Lemma sdec_compute_lor {X} {p q : X -> Prop} :
  semi_decidable p -> semi_decidable q -> (forall x, p x \/ q x) -> exists f : X -> bool, forall x, if f x then p x else q x.
Proof.
  intros Hp Hq Hpq.
  edestruct (semi_decidable_AC X (fun x n => match n with 0 => p x | _ => q x end)) as [f Hf].
  - destruct Hp as [f1 H1], Hq as [f2 H2].
    exists (fun '(x,n) m => match n with 0 => f1 x m | _ => f2 x m end).
    now intros (x,[]); cbn; rewrite ?H1, ?H2.
  - intros x. destruct (Hpq x). now exists 0. now exists 1.
  - exists (fun x => match f x with 0 => true | _ => false end). intros x.
    specialize (Hf x). destruct (f x); firstorder.
Qed.

Lemma AUC_to_dec (p : nat -> Prop) :
  AUC_on nat bool -> (forall n, p n \/ ~ p n) -> decidable p.
Proof.
  admit.
Admitted.

(* Markov's principle and Post's theorem *)

Definition MP_semidecidable := forall X (p : X -> Prop), semi_decidable p -> forall x, ~~ p x -> p x.
Definition Post_logical := forall X (p : X -> Prop), semi_decidable p -> semi_decidable (fun x => ~ p x) -> forall x, p x \/ ~ p x.
Definition Post := forall X (p : X -> Prop), semi_decidable p -> semi_decidable (fun x => ~ p x) -> decidable p.

Lemma MP_to_MP_semidecidable :
  MP -> MP_semidecidable.
Proof.
Admitted.

Lemma semi_decidable_or {X} {p q : X -> Prop} :
  semi_decidable p -> semi_decidable q -> semi_decidable (fun x => p x \/ q x).
Proof. Admitted.

Lemma MP_semidecidable_to_Post_logical :
  MP_semidecidable -> Post_logical.
Proof. Admitted.

Lemma Post_logical_to_Post :
  Post_logical -> Post.
Proof. Admitted.

Lemma Post_nempty_to_MP {X} (x0 : X) :
  (forall (p : X -> Prop), semi_decidable p -> semi_decidable (fun x => ~ p x) -> decidable p) -> MP.
Proof. Admitted.

Lemma Post_to_MP :
  Post -> MP.
Proof. Admitted.


Require Export XR_Rmult_lt_reg_r.
Require Export XR_Rmult_assoc.
Require Export XR_Rinv_l.
Require Export XR_Rlt_not_eq.
Require Export XR_Rmult_neq_0_reg.

Local Open Scope R_scope.

Lemma Rinv_lt_contravar : forall r1 r2,
  R0 < r1 * r2 ->
  r1 < r2 ->
  / r2 < / r1.
Proof.
  intros x y h hxy.
  apply Rmult_lt_reg_r with (x*y).
  { exact h. }
  {
    apply Rlt_not_eq in h.
    apply not_eq_sym in h.
    apply Rmult_neq_0_reg in h.
    destruct h as [ hx hy ].
    pattern (x*y) at 1 ; rewrite (Rmult_comm x).
    repeat rewrite <- Rmult_assoc.
    rewrite Rinv_l.
    {
      rewrite Rinv_l.
      {
        rewrite Rmult_1_l.
        rewrite Rmult_1_l.
        exact hxy.
      }
      { exact hx. }
    }
    { exact hy. }
  }
Qed.


Definition plus_comm := forall n m : nat, n + m = m + n.


Require Export Structure.

Module Pointed.
Section category.
Context {C: TopCategory}.

Structure obj := Obj {
  carrier: C;
  element: 1 ~> carrier;
}.

Local Coercion carrier: obj >-> Category.obj.

Structure hom (X Y: obj) := Hom {
  arr: X ~> Y;
  comm: arr ∘ element X = element Y;
}.

Global Arguments Hom {X Y} arr comm.
Global Arguments arr {X Y} _.
Global Arguments comm {X Y} _.
Local Coercion arr: hom >-> Categories.hom.

Lemma obj_eq (X Y: obj): X = Y <-> carrier X = Y /\ forall e: carrier X = Y, eq_iso e ∘ element X = element Y.
Proof.
  split.
  + intros H.
    subst Y.
    split.
    reflexivity.
    intros e.
    rewrite eq_iso_refl; clear e.
    apply comp_id_l.
  + destruct X as [X x], Y as [Y y].
    simpl.
    intros [Hc He].
    subst Y.
    specialize (He eq_refl).
    simpl in He.
    rewrite comp_id_l in He.
    now f_equal.
Qed.

Lemma hom_eq {X Y: obj} (f g: hom X Y): f = g <-> arr f = g.
Proof.
  split.
  intros H.
  now subst g.
  destruct f as [f Hf], g as [g Hg].
  simpl.
  intros H.
  subst g.
  f_equal.
  apply proof_irrelevance.
Qed.

Let id (X: obj): hom X X := {|
  arr := id X;
  comm := comp_id_l (element X);
|}.

Program Let comp {X Y Z: obj} (f: hom Y Z) (g: hom X Y): hom X Z := {|
  arr := f ∘ g;
|}.
Next Obligation.
  rewrite <- comp_assoc.
  rewrite comm.
  apply comm.
Qed.

Lemma comp_assoc {X Y Z V: obj} (f: hom Z V) (g: hom Y Z) (h: hom X Y): comp f (comp g h) = comp (comp f g) h.
Proof.
  apply hom_eq; simpl.
  apply comp_assoc.
Qed.

Lemma comp_id_l {X Y: obj} (f: hom X Y): comp (id Y) f = f.
Proof.
  apply hom_eq; simpl.
  apply comp_id_l.
Qed.

Lemma comp_id_r {X Y: obj} (f: hom X Y): comp f (id X) = f.
Proof.
  apply hom_eq; simpl.
  apply comp_id_r.
Qed.

Definition cat_mixin: Category.mixin_of obj :=
  Category.Mixin obj hom id (@comp) (@comp_assoc) (@comp_id_l) (@comp_id_r).

Definition cat := Category.Pack obj cat_mixin.

End category.

Arguments obj C: clear implicits.
Arguments cat_mixin C: clear implicits.
Arguments cat C: clear implicits.

Program Definition forget {C: TopCategory}: Functor (cat C) C := {|
  fobj := carrier;
  fmap := @arr C;
|}.

End Pointed.

Notation Pointed := Pointed.cat.


(* -*- mode: coq; mode: visual-line -*- *)
(** Contractibility *)

Require Import Overture PathGroupoids.
Local Open Scope path_scope.

(** Naming convention: we consistently abbreviate "contractible" as "contr".  A theorem about a space [X] being contractible (which will usually be an instance of the typeclass [Contr]) is called [contr_X]. *)

(** Allow ourselves to implicitly generalize over types [A] and [B], and a function [f]. *)
Generalizable Variables A B f.

(** If a space is contractible, then any two points in it are connected by a path in a canonical way. *)
Definition path_contr `{Contr A} (x y : A) : x = y
  := (contr x)^ @ (contr y).

(** Similarly, any two parallel paths in a contractible space are homotopic, which is just the principle UIP. *)
Definition path2_contr `{Contr A} {x y : A} (p q : x = y) : p = q.
Proof.
  assert (K : forall (r : x = y), r = path_contr x y).
  - intro r; destruct r; symmetry; now apply concat_Vp.
  - transitivity (path_contr x y);auto with path_hints.
Defined.

(** It follows that any space of paths in a contractible space is contractible. *)
(** Because [Contr] is a notation, and [Contr_internal] is the record, we need to iota expand to fool Coq's typeclass machinery into accepting supposedly "mismatched" contexts. *)

Global Instance contr_paths_contr `{Contr A} (x y : A) : Contr (x = y) | 10000 := let c := {|
  center := (contr x)^ @ contr y;
  contr := path2_contr ((contr x)^ @ contr y)
|} in c.

(** Also, the total space of any based path space is contractible.  We define the [contr] fields as separate definitions, so that we can give them [simpl nomatch] annotations. *)

Definition path_basedpaths {X : Type} {x y : X} (p : x = y)
: (x;1) = (y;p) :> {z:X & x=z}.
Proof.
  destruct p; reflexivity.
Defined.

Arguments path_basedpaths {X x y} p : simpl nomatch.

Global Instance contr_basedpaths {X : Type} (x : X) : Contr {y : X & x = y} | 100.
Proof.
  exists (x ; 1).
  intros [y p]; apply path_basedpaths.
Defined.

(* Sometimes we end up with a sigma of a one-sided path type that's not eta-expanded, which Coq doesn't seem able to match with the previous instance. *)
Global Instance contr_basedpaths_etashort {X : Type} (x : X) : Contr (sigT (@paths X x)) | 100
  := contr_basedpaths x.

Definition path_basedpaths' {X : Type} {x y : X} (p : y = x)
: (x;1) = (y;p) :> {z:X & z=x}.
Proof.
  destruct p; reflexivity.
Defined.

Global Instance contr_basedpaths' {X : Type} (x : X) : Contr {y : X & y = x} | 100.
Proof.
  refine (Build_Contr _ (x;1) _).
  intros [y p]; apply path_basedpaths'.
Defined.

Arguments path_basedpaths' {X x y} p : simpl nomatch.

(** Some useful computation laws for based path spaces *)

Definition ap_pr1_path_contr_basedpaths {X : Type}
           {x y z : X} (p : x = y) (q : x = z)
: ap pr1 (path_contr ((y;p):{y':X & x = y'}) (z;q)) = p^ @ q.
Proof.
  destruct p,q; reflexivity.
Defined.

Definition ap_pr1_path_contr_basedpaths' {X : Type}
           {x y z : X} (p : y = x) (q : z = x)
: ap pr1 (path_contr ((y;p):{y':X & y' = x}) (z;q)) = p @ q^.
Proof.
  destruct p,q; reflexivity.
Defined.

Definition ap_pr1_path_basedpaths {X : Type}
           {x y : X} (p : x = y)
: ap pr1 (path_basedpaths p) = p.
Proof.
  destruct p; reflexivity.
Defined.

Definition ap_pr1_path_basedpaths' {X : Type}
           {x y : X} (p : y = x)
: ap pr1 (path_basedpaths' p) = p^.
Proof.
  destruct p; reflexivity.
Defined.

(** If the domain is contractible, the function is propositionally constant. *)
Definition contr_dom_equiv {A B} (f : A -> B) `{Contr A} : forall x y : A, f x = f y
  := fun x y => ap f ((contr x)^ @ contr y).

(** Any retract of a contractible type is contractible *)
Definition contr_retract {X Y : Type} `{Contr X}
           (r : X -> Y) (s : Y -> X) (h : forall y, r (s y) = y)
  : Contr Y
  := Build_Contr _ (r (center X)) (fun y => (ap r (contr _)) @ h _).


Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition aday : day := thursday.

Inductive list (a : Type) : Type :=
  | nil
  | cons : a -> list a -> list a.

Definition xs : list nat := cons nat 5 (nil nat).

Variable A : Type.

Definition length2 (a : Type) (xs : list a) : nat :=
  match xs with
  | nil _ => 0
  | cons _ x xs => 0
  end.

(* Eval compute in length2 nat (cons nat 0 (nil nat)). *)

Inductive Product (a : Type) (b : Type) : Type :=
  P : a -> b -> Product a b.

Definition swap (a:Type) (b:Type) (p : Product a b) : (Product b a) :=
  match p with
  | P _ _ x y => P b a y x
  end.

Eval compute in swap nat day (P nat day 0 monday).

Variable a : Type.
Variable b : Type.
Variable p : Product a b.

Example swap_prop_1: swap b a (swap a b (p : Product a b)) = p.
Proof.
simpl.
destruct p.
simpl.
reflexivity.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(** * Arithmetic libraries for Matiyasevich's theorems *)
(** ** Modular arithmetic *)

Require Import Arith Omega Eqdep_dec ZArith List Permutation.

Require Import utils_tac utils_list gcd prime binomial sums matrix php.

Set Implicit Arguments.

Section le_pirr.

  (* a dependent induction principle for le *)

  Scheme le_indd := Induction for le Sort Prop.

  Fact le_pirr : forall x y (H1 H2 : x <= y), H1 = H2.
  Proof.
    simpl; intros n ? H1.
    induction H1 as [ | m H1 IH ] using le_indd; intro H2.

    change (le_n n) with (eq_rect _ (fun n0 => n <= n0) (le_n n) _ eq_refl).
    generalize (eq_refl n).
    pattern n at 2 4 6 10, H2.
    case H2; [intro E | intros m l E].
    rewrite UIP_dec with (p1 := E) (p2 := eq_refl); auto.
    apply eq_nat_dec.
    contradiction (le_Sn_n m); subst; auto.

    change (le_S n m H1) with (eq_rect _ (fun n0 => n <= n0) (le_S n m H1) _ eq_refl).
    generalize (eq_refl (S m)).
    pattern (S m) at 1 3 4 6, H2.
    case H2; [intro E | intros p H3 E].
    contradiction (le_Sn_n m); subst; auto.
    injection E; intro; subst.
    rewrite (IH H3).
    rewrite UIP_dec with (p1 := E) (p2 := eq_refl); auto.
    apply eq_nat_dec.
  Qed.

End le_pirr.

Fact lt_pirr x y (H1 H2 : x < y) : H1 = H2.
Proof. apply le_pirr. Qed.

Fact Zring : ring_theory 0%Z 1%Z Zplus Zmult Zminus Z.opp eq.
Proof. exists; intros; ring. Qed.

Hint Resolve Zring Zplus_monoid Zmult_monoid.

Section Z_coprime.

  Open Scope Z_scope.

  Definition Z_pos_or_neg u : { 0 <= u } + { u < 0 }.
  Proof.
    destruct (Ztrichotomy_inf u 0) as [ [|] | ]; try (left; omega); tauto.
  Qed.

  Fact Z_coprime u v : (exists a b, a * Z.of_nat u + b*Z.of_nat v = 1) -> is_gcd u v 1%nat.
  Proof.
    intros (a & b & H).
    destruct (Z_pos_or_neg a) as [ Ha | Ha ];
    destruct (Z_pos_or_neg b) as [ Hb | Hb ].
    + apply bezout_sc with (a:= Z.to_nat a) (b := Z.to_nat b) (m := 0%nat).
      2: left; apply divides_0.
      apply Nat2Z.inj.
      rewrite Nat2Z.inj_add.
      repeat rewrite Nat2Z.inj_mul.
      repeat rewrite Z2Nat.id; auto.
    + apply bezout_sc with (a:= Z.to_nat a) (b := 0%nat) (m := (Z.to_nat (-b)*v)%nat).
      2: right; apply divides_mult, divides_refl.
      apply Nat2Z.inj.
      repeat rewrite Nat2Z.inj_add.
      repeat rewrite Nat2Z.inj_mul.
      repeat rewrite Z2Nat.id; auto; try omega.
      simpl Z.of_nat; rewrite <- H; ring.
    + apply bezout_sc with (b:= Z.to_nat b) (a := 0%nat) (m := (Z.to_nat (-a)*u)%nat).
      2: left; apply divides_mult, divides_refl.
      apply Nat2Z.inj.
      repeat rewrite Nat2Z.inj_add.
      repeat rewrite Nat2Z.inj_mul.
      repeat rewrite Z2Nat.id; auto; try omega.
      simpl Z.of_nat; rewrite <- H; ring.
    + apply Z.lt_le_incl in Ha.
      apply Z.lt_le_incl in Hb.
      exfalso; revert H.
      generalize (Z.mul_nonpos_nonneg _ _ Ha (Nat2Z.is_nonneg u)).
      generalize (Z.mul_nonpos_nonneg _ _ Hb (Nat2Z.is_nonneg v)).
      intros; omega.
  Qed.

End Z_coprime.

Section Zp.

  Variable (p : nat) (Hp : p <> 0).

  Definition Z_Zp := { x | x < p }.

  Implicit Type x y : Z_Zp.

  Fact Zp_inj : forall x y, proj1_sig x = proj1_sig y -> x = y.
  Proof. intros (x & H1) (y & H2); simpl; intros; subst; f_equal; apply lt_pirr. Qed.

  Definition Zp_plus : Z_Zp -> Z_Zp -> Z_Zp.
  Proof.
    intros (x & Hx) (y & Hy).
    exists (rem (x+y) p).
    apply div_rem_spec2; trivial.
  Defined.

  (* ⊕  ⊗  ∸    ⊞ ⊠ ⊟ *)

  Infix "⊕" := Zp_plus (at level 50, left associativity).

  Definition Zp_zero : Z_Zp.
  Proof.
    exists 0; omega.
  Defined.

  Definition Zp_opp : Z_Zp -> Z_Zp.
  Proof.
    intros (x & Hx).
    exists (rem (p - x) p).
    apply div_rem_spec2; trivial.
  Defined.

  Notation "∸" := Zp_opp.

  Definition Zp_mult : Z_Zp -> Z_Zp -> Z_Zp.
  Proof.
    intros (x & Hx) (y & Hy).
    exists (rem (x*y) p).
    apply div_rem_spec2; trivial.
  Defined.

  Infix "⊗" := Zp_mult (at level 40, left associativity).

  Definition Zp_one : Z_Zp.
  Proof.
    exists (rem 1 p); apply div_rem_spec2; trivial.
  Defined.

(*

  Infix "+p" := Zp_plus (at level 50, left associativity).
  Infix "*p" := Zp_mult (at level 40, left associativity).
  Notation "-p" := Zp_opp.

*)

  Notation Zp := Zp_zero.
  Notation Op := Zp_one.

  Fact Zp_plus_zero : forall x, Zp ⊕ x = x.
  Proof.
    intros (x & Hx); apply Zp_inj; simpl.
    apply rem_prop with 0; simpl; auto.
  Qed.

  Fact Zp_plus_comm : forall x y,  x ⊕ y = y ⊕ x.
  Proof.
    intros (x & ?) (y & ?); apply Zp_inj; simpl.
    f_equal; omega.
  Qed.

  Fact Zp_plus_assoc : forall x y z, x ⊕ (y ⊕ z) = x ⊕ y ⊕ z.
  Proof.
    intros (x & ?) (y & ?) (z & ?); apply Zp_inj; simpl.
    rewrite (plus_comm (rem _ _) z), rem_plus_rem, rem_plus_rem.
    f_equal; ring.
  Qed.

  Fact Zp_minus : forall x, x ⊕ ∸ x = Zp.
  Proof.
    intros ([ | x ] & Hx); apply Zp_inj; simpl.
    + rewrite Nat.sub_0_r, rem_diag, rem_lt; auto.
    + rewrite rem_lt with (a := _ - _); try omega.
      replace (S (x+(p - S x))) with p by omega.
      apply rem_diag; auto.
  Qed.

  Fact Zp_mult_one : forall x, Op ⊗ x = x.
  Proof.
    intros (x & ?); apply Zp_inj; simpl proj1_sig.
    destruct p as [ | [ | q ] ].
    + destruct Hp; auto.
    + rewrite rem_diag; simpl; auto.
      rewrite rem_lt; omega.
    + rewrite rem_lt with (a := 1); try omega.
      rewrite Nat.mul_1_l, rem_lt; omega.
  Qed.

  Fact Zp_mult_comm : forall x y, x ⊗ y = y ⊗ x.
  Proof.
    intros (x & ?) (y & ?); apply Zp_inj; simpl.
    f_equal; ring.
  Qed.

  Fact Zp_mult_one_r x : x ⊗ Op = x.
  Proof. rewrite Zp_mult_comm, Zp_mult_one; auto. Qed.

  Fact Zp_mult_assoc : forall x y z, x ⊗ (y ⊗ z) = x ⊗ y ⊗ z.
  Proof.
    intros (x & ?) (y & ?) (z & ?); apply Zp_inj; simpl.
    rewrite (mult_comm (rem _ _) z), rem_mult_rem, rem_mult_rem.
    f_equal; ring.
  Qed.

  Fact Zp_mult_plus_distr_l : forall x y z, x ⊗ (y ⊕ z) = x ⊗ y ⊕ x ⊗ z.
  Proof.
    intros (x & ?) (y & ?) (z & ?); apply Zp_inj; simpl.
    rewrite <- rem_plus, <- rem_scal; f_equal; ring.
  Qed.

  Fact Zp_mult_plus_distr_r x y z : (y ⊕ z) ⊗ x = y ⊗ x ⊕ z ⊗ x.
  Proof. do 3 rewrite (Zp_mult_comm _ x); apply Zp_mult_plus_distr_l. Qed.

  (* Define a ring structureon Zp *)

  Definition Zp_is_ring : @ring_theory _ Zp Op Zp_plus Zp_mult (fun x y => x ⊕ ∸ y) Zp_opp eq.
  Proof.
    exists.
    + apply Zp_plus_zero.
    + apply Zp_plus_comm.
    + apply Zp_plus_assoc.
    + apply Zp_mult_one.
    + apply Zp_mult_comm.
    + apply Zp_mult_assoc.
    + intros; apply Zp_mult_plus_distr_r.
    + auto.
    + apply Zp_minus.
  Qed.

  (* Invertible elements are some which are relatively prime to x *)

  Fact Zp_mult_invert : forall x, is_gcd p (proj1_sig x) 1 -> { i | i ⊗ x = Op }.
  Proof.
    intros  (x & Hx); simpl; intros H.
    destruct (bezout_generalized p x) as (u & v & g & l & H1 & H2 & H3 & _).
    generalize (is_gcd_fun H H2); intro; subst g.
    exists (exist _ (rem v p) (@div_rem_spec2 v p Hp)).
    apply Zp_inj; simpl.
    rewrite mult_comm, <- rem_scal.
    destruct H3 as (k & H3).
    rewrite mult_comm.
    rewrite <- rem_erase with (n := u) (1 := eq_refl).
    rewrite <- rem_erase with (n := k) (r := 1) (1 := eq_refl).
    f_equal.
    rewrite H1,H3; ring.
  Qed.

  Fact Zp_mult_revert : forall x i, i ⊗ x = Op -> is_gcd p (proj1_sig x) 1.
  Proof.
    intros (x & Hx) (i & Hi) H; simpl.
    apply f_equal with (f := @proj1_sig _ _) in H; simpl in H.
    destruct (le_lt_dec p 1) as [ H' | H'].
    + replace p with 1 by omega.
      apply is_gcd_1l.
    + rewrite rem_lt with (a := 1) in H; try omega.
      generalize (div_rem_spec1 (i*x) p).
      rewrite H.
      generalize (div (i*x) p); clear H Hi; intros u Hu.
      apply bezout_sc with 1 i ((1+u)* p).
      * rewrite Hu; ring.
      * left; apply divides_mult, divides_refl.
  Qed.

  Definition Zp_invertible x := exists i, i ⊗ x = Op.

  Fact Zp_invertible_spec x : Zp_invertible x <-> is_gcd p (proj1_sig x) 1.
  Proof.
    split.
    + intros (i & Hi); revert Hi; apply Zp_mult_revert.
    + intros H; destruct (Zp_mult_invert _ H) as (i & ?); exists i; auto.
  Qed.

  Fact Zp_prime_invert : prime p -> forall x, x <> Zp -> { i | i ⊗ x = Op }.
  Proof.
    intros Hp' x Hx.
    apply Zp_mult_invert.
    destruct x; simpl in *.
    destruct (prime_gcd x Hp') as [ | H ]; auto.
    exfalso; apply Hx, Zp_inj; simpl.
    destruct H as ([ | k ] & Hk); simpl in Hk; auto.
    revert Hk; generalize (k* p); intros; omega.
  Qed.

  (* So we have the commutative ring structure and the field structure for p prime

     These follow form (non-commutative) ring axioms

   *)

  Add Ring Zp_ring : Zp_is_ring.

  Fact Zp_plus_monoid : monoid_theory Zp_plus Zp_zero.
  Proof. exists; intros; ring. Qed.

  Fact Zp_mult_monoid : monoid_theory Zp_mult Zp_one.
  Proof. exists; intros; ring. Qed.

  Fact Zp_one_invertible : Zp_invertible Op.
  Proof. exists Op; ring. Qed.

  Fact Zp_opp_invertible x : Zp_invertible x <-> Zp_invertible (∸ x).
  Proof. split; intros (i & Hi); exists (∸ i); rewrite <- Hi; ring. Qed.

  Fact Zp_mult_invertible x y : Zp_invertible x -> Zp_invertible y -> Zp_invertible (x ⊗ y).
  Proof.
    intros (u & H1) (v & H2); exists (u⊗v); rewrite <- (Zp_mult_one Op).
    rewrite <- H1 at 1.
    rewrite <- H2; ring.
  Qed.

  Hint Resolve Zp_one_invertible Zp_opp_invertible Zp_mult_invertible.

  Fact Zp_expo_invertible n x : Zp_invertible x -> Zp_invertible (mscal Zp_mult Op n x).
  Proof. intros; induction n; [ rewrite mscal_0 | rewrite mscal_S ]; auto. Qed.

  Fact Zp_invertible_cancel_l x y z : Zp_invertible x -> x⊗y = x⊗z -> y = z.
  Proof.
    intros (i & Hi) H.
    rewrite <- (Zp_mult_one y), <- Hi, <- Zp_mult_assoc,
            H, Zp_mult_assoc, Hi, Zp_mult_one; auto.
  Qed.

  (* ⊕  ⊗  ∸ *)

  Fact Zp_opp_zero : ∸ Zp = Zp.
  Proof. ring. Qed.

  Fact Zp_plus_inj_l x y z : x ⊕ y = x ⊕ z -> y = z.
  Proof.
    intros H.
    apply f_equal with (f := fun a => ∸ x ⊕ a) in H.
    do 2 rewrite Zp_plus_assoc in H.
    rewrite (Zp_plus_comm _ x), Zp_minus in H.
    do 2 rewrite Zp_plus_zero in H; auto.
  Qed.

  Fact Zp_plus_zero_r x : x ⊕ Zp = x.
  Proof. ring. Qed.

  Fact Zp_opp_inv x : ∸ (∸ x) = x.
  Proof. ring. Qed.

  Fact Zp_opp_inj x y : ∸ x = ∸ y -> x = y.
  Proof. intros H; rewrite <- (Zp_opp_inv x), H; ring. Qed.

  Fact Zp_opp_plus x y : ∸ (x ⊕ y) = ∸ x ⊕ ∸ y.
  Proof. ring. Qed.

  Fact Zp_opp_plus_eq x y z : x ⊕ y = z <-> x = z ⊕ ∸ y.
  Proof. split; intros; subst; ring. Qed.

  Fact Zp_mult_zero x : Zp ⊗ x = Zp.
  Proof. ring. Qed.

  Fact Zp_mult_minus_one x : (∸ Op) ⊗ x = ∸ x.
  Proof. ring. Qed.

  Fact Zp_opp_mult x y : (∸ x) ⊗ y = ∸ (x ⊗ y).
  Proof. ring. Qed.

  Fact Zp_invertible_eq_zero x y : Zp_invertible x -> x ⊗ y = Zp -> y = Zp.
  Proof.
    intros (i & Hi) H1.
    rewrite <- (Zp_mult_one y), <- Hi at 1.
    rewrite <- Zp_mult_assoc, H1; ring.
  Qed.

  Fact Zp_zero_is_one : Zp = Op <-> p = 1.
  Proof.
    split.
    + intros H; apply f_equal with (f := @proj1_sig _ _) in H; simpl in H.
      symmetry in H.
      apply divides_rem_eq, divides_1_inv in H; auto.
    + intros; apply Zp_inj; simpl; subst; rewrite rem_diag; auto.
  Qed.

  Fact Zp_eq_dec : forall x y : Z_Zp, { x = y } + { x <> y }.
  Proof.
    intros (x & Hx) (y & Hy).
    destruct (eq_nat_dec x y) as [ | H ].
    + left; apply Zp_inj; auto.
    + right; contradict H.
      apply f_equal with (f := @proj1_sig _ _) in H; auto.
  Qed.

  (* We define a morphism for nat to Z_Zp *)

  Section nat2Zp.

    Definition nat2Zp (u : nat) : Z_Zp.
    Proof.
      exists (rem u p); apply div_rem_spec2; trivial.
    Defined.

    Arguments nat2Zp u /.

    Notation "〚 x 〛" := (nat2Zp x).

    Fact nat2Zp_zero : 〚0〛= Zp.
    Proof.
      apply Zp_inj; simpl.
      apply rem_prop with 0; omega.
    Qed.

    Fact nat2Zp_one : 〚1〛= Op.
    Proof.
      apply Zp_inj; simpl; auto.
    Qed.

    Fact nat2Zp_invertible n : Zp_invertible 〚n〛 <-> is_gcd p n 1.
    Proof.
      rewrite Zp_invertible_spec.
      symmetry; apply is_gcd_rem.
    Qed.

    Fact nat2Zp_p :〚p〛= Zp.
    Proof.
      apply Zp_inj; simpl.
      apply rem_diag; omega.
    Qed.

    Fact nat2Zp_inj u v : 〚u〛=〚v〛 <-> rem u p = rem v p.
    Proof.
      split; intros H.
      + apply f_equal with (f := @proj1_sig _ _) in H; auto.
      + apply Zp_inj; auto.
    Qed.

    Fact nat2Zp_surj u : { x | x < p /\ u = 〚x〛 }.
    Proof.
      destruct u as (u & Hu); exists u; split; auto.
      apply Zp_inj; simpl.
      rewrite rem_prop with (n := 0) (2 := Hu); auto.
    Qed.

    Fact nat2Zp_plus u v : 〚u+v〛=〚u〛⊕〚v〛.
    Proof.
      apply Zp_inj; simpl.
      rewrite rem_plus_rem, (plus_comm (rem _ _)), rem_plus_rem.
      f_equal; ring.
    Qed.

    Fact nat2Zp_minus u v : v <= u -> 〚u-v〛=〚u〛⊕ ∸〚v〛.
    Proof.
      intros; apply Zp_inj; simpl.
      rewrite rem_plus_rem, (plus_comm (rem _ _)), plus_comm.
      generalize (div u p) (div v p) (div_rem_spec1 u p) (div_rem_spec1 v p).
      intros a b H1 H2.
      assert (b <= a) as Hab.
      { destruct (le_lt_dec b a); auto.
        replace b with ((1+a) + (b-a-1)) in H2 by omega.
        generalize (div_rem_spec2 u Hp) (div_rem_spec2 v Hp); intros H3 H4.
        do 2 rewrite Nat.mul_add_distr_r in H2.
        contradict H; rewrite H1, H2, Nat.mul_1_l.
        generalize (a* p) ((b-a-1)* p); intros; omega. }
      destruct (eq_nat_dec a b) as [ | Ha ]; try subst b.
      + assert (rem v p <= rem u p) as H3.
        { rewrite H1, H2 in H; revert H; intros; omega. }
        symmetry; apply rem_erase with 1.
        rewrite H1 at 2.
        rewrite H2 at 2.
        generalize (a* p) (div_rem_spec2 v Hp); intros; omega.
      + apply rem_erase with (a-b-1).
        rewrite H2 at 1; rewrite H1 at 1.
        do 2 rewrite Nat.mul_sub_distr_r.
        rewrite Nat.mul_1_l.
        assert (b* p + p <= a* p) as E.
        { replace a with (1+b+(a-b-1)) by omega.
          do 2 rewrite Nat.mul_add_distr_r.
          generalize (b* p) ((a-b-1)* p); intros; omega. }
        revert E.
        generalize (a* p) (b* p) (div_rem_spec2 u Hp) (div_rem_spec2 v Hp); intros.
        omega.
    Qed.

    Fact nat2Zp_minus_one : 〚p-1〛= ∸Op.
    Proof.
      rewrite nat2Zp_minus; try omega.
      rewrite nat2Zp_p, nat2Zp_one; ring.
    Qed.

    Fact nat2Zp_mult u v :〚u*v〛=〚u〛⊗〚v〛.
    Proof.
      apply Zp_inj; simpl.
      rewrite rem_mult_rem, (mult_comm (rem _ _)), rem_mult_rem.
      f_equal; ring.
    Qed.

    Fact nat2Zp_expo n u : 〚mscal mult 1%nat n u〛 = mscal Zp_mult Zp_one n 〚u〛.
    Proof.
      induction n as [ | n IHn ].
      + do 2 rewrite mscal_0; auto.
      + do 2 rewrite mscal_S.
        rewrite nat2Zp_mult, IHn; auto.
    Qed.

    Fact nat2Zp_divides u v :〚u〛=〚v〛-> divides p u -> divides p v.
    Proof.
      intros H.
      apply f_equal with (f := @proj1_sig _ _) in H; simpl in H.
      do 2 (rewrite divides_rem_eq; auto); omega.
    Qed.

    Fact divides_nat2Zp u : divides p u <-> 〚u〛= Zp.
    Proof.
      split.
      + intros (q & Hq); apply Zp_inj; simpl.
        apply rem_prop with q; omega.
      + intros H.
        apply f_equal with (f := @proj1_sig _ _) in H; simpl in H.
        exists (div u p).
        rewrite (div_rem_spec1 u p) at 1; omega.
    Qed.

  End nat2Zp.

  Arguments nat2Zp u /.

  Definition Zp_list := map nat2Zp (list_an 0 p).

  Fact Zp_list_spec x : In x Zp_list.
  Proof.
    destruct (nat2Zp_surj x) as (n & H1 & H2); subst.
    apply in_map_iff; exists n; split; auto.
    apply list_an_spec; omega.
  Qed.

  Fact Zp_list_length : length Zp_list = p.
  Proof. unfold Zp_list; rewrite map_length, list_an_length; auto. Qed.

  Fact Zp_invertible_prime x : prime p -> Zp_invertible x <-> x <> Zp.
  Proof.
    intros H.
    split.
    + intros (i & Hi) E.
      subst.
      rewrite Zp_mult_comm, Zp_mult_zero, Zp_zero_is_one in Hi.
      apply prime_ge_2 in H; omega.
    + intros Hx.
      destruct (nat2Zp_surj x) as (u & _ & Hu).
      rewrite Hu; apply nat2Zp_invertible.
      destruct (prime_gcd u H) as [ H1 | H1 ]; auto.
      destruct Hx.
      rewrite Hu; apply divides_nat2Zp; auto.
  Qed.

  Fact Zp_prime_integral x y : prime p -> x ⊗ y = Zp -> x = Zp \/ y = Zp.
  Proof.
    intros H1 H2.
    destruct (Zp_eq_dec x Zp) as [ | H ]; auto; right.
    revert H2; apply Zp_invertible_eq_zero, Zp_invertible_prime; auto.
  Qed.

  Fact Zp_prime_square_eq_square x y : prime p -> x⊗x = y⊗y <-> x = y \/ x = ∸y.
  Proof.
    intros H1; split.
    + intros H2.
      assert ((x⊕∸y)⊗(x⊕y) = Zp) as H3.
      { rewrite Zp_mult_plus_distr_l, Zp_mult_plus_distr_r, H2; ring. }
      apply Zp_prime_integral in H3; auto.
      destruct H3 as [ H3 | H3 ]; [ left | right ];
        rewrite Zp_opp_plus_eq in H3; rewrite H3; ring.
    + intros [ | ]; subst x; ring.
  Qed.

  Fact Zp_prime_square_one x : prime p -> x⊗x = Op <-> x = Op \/ x = ∸Op.
  Proof.
    rewrite <- (Zp_mult_one Op) at 1.
    apply Zp_prime_square_eq_square.
  Qed.

  (* We define a morphism for Z to Z_Zp *)

  Section Z2Zp.

    Open Scope Z_scope.

    Implicit Types u v w : Z.

    Definition Z2Zp u : Z_Zp.
    Proof.
      destruct (Z_pos_or_neg u) as [ H | H ].
      + apply nat2Zp, Z.to_nat; exact u.
      + apply Zp_opp, nat2Zp, Z.to_nat; exact (-u).
    Defined.

    Arguments Z2Zp u /.

    Notation "〘 x 〙" := (Z2Zp x).
    Notation "〚 x 〛" := (nat2Zp x).

    Fact Z2Zp_pos u : 0 <= u -> 〘u〙= 〚Z.to_nat u〛.
    Proof.
      intros H.
      unfold Z2Zp.
      destruct (Z_pos_or_neg u); try omega; auto.
    Qed.

    Fact Z2Zp_of_nat n : 〘Z.of_nat n〙 = 〚n〛.
    Proof.
      rewrite Z2Zp_pos, Nat2Z.id; auto.
      apply Zle_0_nat.
    Qed.

    Fact Z2Zp_zero : 〘0〙= Zp.
    Proof.
      rewrite Z2Zp_pos; try omega.
      rewrite Z2Nat.inj_0, nat2Zp_zero; auto.
    Qed.

    Fact Z2Zp_neg u : u <= 0 -> 〘u〙 = ∸〘-u〙.
    Proof.
      intros H.
      unfold Z2Zp at 1.
      destruct (Z_pos_or_neg u) as [ H' | H' ]; try omega; auto.
      replace u with 0 by omega.
      rewrite Z.opp_0, Z2Nat.inj_0, nat2Zp_zero, Z2Zp_zero; auto.
      symmetry; apply Zp_opp_zero.
      unfold Z2Zp.
      destruct (Z_pos_or_neg (-u)) as [ H'' | H'' ]; try omega; auto.
    Qed.

    (* ⊕  ⊗  ∸ *)

    Section Z2Zp_plus.

      Let Z2Zp_plus_loc u v : u <= 0 -> 0 <= v -> -u <= v -> 〘u+v〙=〘u〙⊕〘v〙.
      Proof.
        intros H1 H2 H3.
        rewrite Z2Zp_pos; try omega.
        rewrite Z2Zp_neg; try omega.
        do 2 (rewrite Z2Zp_pos; try omega).
        replace (u+v) with (v-(-u)) by omega.
        rewrite Z2Nat.inj_sub; try omega.
        rewrite nat2Zp_minus.
        + apply Zp_plus_comm.
        + rewrite <- Z2Nat.inj_le; omega.
      Qed.

      Let Z2Zp_plus_loc' u v : u <= 0 -> 0 <= v -> v <= -u -> 〘u+v〙=〘u〙⊕〘v〙.
      Proof.
        intros H1 H2 H3.
        rewrite Z2Zp_neg; try omega.
        rewrite Z2Zp_pos; try omega.
        rewrite Z2Zp_neg; try omega.
        do 2 (rewrite Z2Zp_pos; try omega).
        replace (-(u+v)) with (-u-v) by omega.
        rewrite Z2Nat.inj_sub; try omega.
        rewrite nat2Zp_minus; auto.
        + rewrite Zp_opp_plus, Zp_opp_inv; auto.
        + rewrite <- Z2Nat.inj_le; omega.
      Qed.

      Fact Z2Zp_plus u v : 〘u+v〙=〘u〙⊕〘v〙.
      Proof.
        destruct (Z_pos_or_neg u) as [ H1 | H1 ];
        destruct (Z_pos_or_neg v) as [ H2 | H2 ].
        + do 3 (rewrite Z2Zp_pos; try omega).
          rewrite Z2Nat.inj_add; auto.
          apply nat2Zp_plus.
        + rewrite Z.add_comm, Zp_plus_comm.
          destruct (Z_pos_or_neg (u+v)).
          - apply Z2Zp_plus_loc; omega.
          - apply Z2Zp_plus_loc'; omega.
        + destruct (Z_pos_or_neg (u+v)).
          - apply Z2Zp_plus_loc; omega.
          - apply Z2Zp_plus_loc'; omega.
        + do 3 (rewrite Z2Zp_neg, Z2Zp_pos; try omega).
          rewrite <- Zp_opp_plus; f_equal.
          replace (-(u+v)) with ((-u)+(-v)) by omega.
          rewrite Z2Nat.inj_add; try omega.
          apply nat2Zp_plus.
      Qed.

    End Z2Zp_plus.

    Fact Z2Zp_opp u :〘-u〙= ∸〘u〙.
    Proof.
      apply Zp_plus_inj_l with (Z2Zp u).
      rewrite Zp_minus, <- Z2Zp_plus, <- Z2Zp_zero.
      f_equal; omega.
    Qed.

    Fact Z2Zp_minus u v : 〘u-v〙 = 〘u〙⊕ ∸〘v〙.
    Proof.
      replace (u-v) with (u+(-v)) by omega.
      rewrite Z2Zp_plus; f_equal.
      apply Z2Zp_opp.
    Qed.

    Section Z2Zp_mult.

      Let Z2Zp_mult_loc u v : 0 <= u -> 0 <= v -> 〘u*v〙=〘u〙⊗〘v〙.
      Proof.
        intros H1 H2.
        rewrite Z2Zp_pos; try omega.
        + do 2 (rewrite Z2Zp_pos; try omega).
          rewrite Z2Nat.inj_mul; auto.
          apply nat2Zp_mult.
        + apply Z.mul_nonneg_nonneg; trivial.
      Qed.

      Fact Z2Zp_mult u v : 〘u*v〙=〘u〙⊗〘v〙.
      Proof.
        destruct (Z_pos_or_neg u) as [ H1 | H1 ];
        destruct (Z_pos_or_neg v) as [ H2 | H2 ].
        + apply Z2Zp_mult_loc; auto.
        + replace (u*v) with (-(u*-v)); try ring.
          rewrite Z2Zp_opp, Z2Zp_mult_loc; try omega.
          rewrite Z2Zp_opp, Zp_mult_comm, Zp_opp_mult, Zp_opp_inv.
          apply Zp_mult_comm.
        + replace (u*v) with (- ((-u)*v)); try ring.
          rewrite Z2Zp_opp, Z2Zp_mult_loc; try omega.
          rewrite Z2Zp_opp, Zp_opp_mult, Zp_opp_inv; auto.
        + replace (u*v) with ((-u)*(-v)); try ring.
          rewrite Z2Zp_mult_loc; try omega.
          do 2 rewrite Z2Zp_opp.
          do 2 rewrite Zp_opp_mult, Zp_mult_comm.
          apply Zp_opp_inv.
      Qed.

    End Z2Zp_mult.

    Fact Z2Zp_one : 〘1〙 = Op.
    Proof.
      rewrite Z2Zp_pos; try omega.
      apply Zp_inj; simpl; f_equal; auto.
    Qed.

    Section Z2Zp_inj.

      Let Z2Zp_inj_loc u v : v <= u ->〘u〙=〘v〙-> exists i, u-v = i*Z.of_nat p.
      Proof.
        intros H2 H.
        assert (〘u-v〙= Zp) as H1.
        { rewrite Z2Zp_minus, H; ring. }
        rewrite Z2Zp_pos in H1; auto; try omega.
        rewrite <- nat2Zp_zero in H1.
        apply nat2Zp_inj in H1.
        rewrite rem_of_0 in H1.
        generalize (@div_rem_spec1 (Z.to_nat (u-v)) p); intros H3.
        rewrite H1 in H3.
        apply f_equal with (f := Z.of_nat) in H3.
        rewrite Z2Nat.id in H3; auto; try omega.
        rewrite H3.
        exists (Z.of_nat (div (Z.to_nat (u-v)) p)).
        rewrite Nat2Z.inj_add, Nat2Z.inj_mul; simpl; ring.
      Qed.

      Fact Z2Zp_inj u v :〘u〙=〘v〙<-> exists i, u-v = i*Z.of_nat p.
      Proof.
        split.
        + destruct (Z_pos_or_neg (u-v)) as [ H | H ].
          * apply Z2Zp_inj_loc; omega.
          * intros H'; symmetry in H'.
            apply Z2Zp_inj_loc in H'; try omega.
            destruct H' as (i & Hi).
            exists (-i).
            apply f_equal with (f := Z.opp) in Hi.
            ring_simplify in Hi.
            rewrite <- Hi; ring.
        + intros (i & Hi).
          replace u with (v+(u-v)) by omega.
          rewrite Hi, Z2Zp_plus, Z2Zp_mult, Z2Zp_of_nat, nat2Zp_p; ring.
      Qed.

    End Z2Zp_inj.

    Fact nat2Zp_choose : forall x, x = Zp \/ x = Op \/ x = ∸ Op \/ exists m,  (1 < m < p-1)%nat /\〚m〛= x.
    Proof.
      intros (x & Hx).
      destruct x as [ | [ | x ] ].
      + left; apply Zp_inj; simpl; auto.
      + right; left; apply Zp_inj; simpl; rewrite rem_lt; auto.
      + destruct (eq_nat_dec (S (S x)) (p-1)) as [ H | H ].
        * do 2 right; left.
          rewrite <- nat2Zp_minus_one.
          apply Zp_inj; simpl; rewrite rem_lt; omega.
        * do 3 right; exists (S (S x)); split; try omega.
          apply Zp_inj; simpl; rewrite rem_lt; omega.
    Qed.

    Section prime.

      Hypothesis Hp' : prime p.

      Fact nat2Zp_invertible_prime n : (0 < n < p)%nat -> Zp_invertible 〚n〛.
      Proof.
        intros Hn.
        apply Zp_invertible_prime; auto.
        intros H.
        apply divides_nat2Zp in H.
        destruct H as ([ | k ] & Hk).
        + simpl in Hk; omega.
        + revert Hn; rewrite Hk; simpl.
          generalize (k*p)%nat; intros; omega.
      Qed.

      Let Hp'' : (2 <= p)%nat.
      Proof. apply prime_ge_2; trivial. Qed.

      Let Hzero_one : Zp <> Op.
      Proof.
        intros H.
        apply Zp_zero_is_one in H.
        omega.
      Qed.

      Fact Zp_invertible_factorial n : (n < p)%nat -> Zp_invertible 〚fact n〛.
      Proof.
        induction n as [ | n IHn ]; intros Hn.
        + rewrite fact_0; apply nat2Zp_invertible_prime; omega.
        + rewrite fact_S, nat2Zp_mult; apply Zp_mult_invertible.
          * apply nat2Zp_invertible_prime; omega.
          * apply IHn; omega.
      Qed.

      Section inv.

        Let Zp_invert_full x : { i | (x = Zp -> i = Zp) /\ (x <> Zp -> i ⊗ x = Op) }.
        Proof.
          destruct (Zp_eq_dec x Zp) as [ Hx | Hx ].
          + exists Zp; split; auto; intros []; auto.
          + destruct Zp_prime_invert with (2 := Hx) as (i & Hi); trivial.
            exists i; split; auto; intros; destruct Hx; auto.
        Qed.

        Definition Zp_invert x := proj1_sig (Zp_invert_full x).

        Fact Zp_invert_spec1 : Zp_invert Zp = Zp.
        Proof. apply (proj2_sig (Zp_invert_full Zp)); trivial. Qed.

        Fact Zp_invert_spec2 x : x <> Zp -> Zp_invert x ⊗ x = Op.
        Proof. apply (proj2_sig (Zp_invert_full x)). Qed.

      End inv.

      Notation inv := Zp_invert.

      Fact Zp_invert_eq_not_zero x y : x <> Zp -> inv x = y <-> y ⊗ x = Op.
      Proof.
        intros H1.
        split.
        + intros H2; rewrite <- H2; apply Zp_invert_spec2; auto.
        + intros H2.
          apply Zp_invert_spec2 in H1.
          rewrite <- (Zp_mult_one (inv x)) , <- H2, <- Zp_mult_assoc,
                    (Zp_mult_comm x), H1, Zp_mult_comm, Zp_mult_one.
          trivial.
      Qed.

      Fact Zp_invert_opp x : inv (∸x) = ∸(inv x).
      Proof.
        destruct (Zp_eq_dec x Zp) as [ Hx | Hx ].
        + subst; rewrite Zp_opp_zero, Zp_invert_spec1, Zp_opp_zero; auto.
        + apply Zp_invert_eq_not_zero.
          * contradict Hx.
            rewrite <- (Zp_opp_inv x), Hx, Zp_opp_zero; trivial.
          * do 2 rewrite Zp_opp_mult, Zp_mult_comm.
            rewrite Zp_opp_inv, Zp_invert_spec2; auto.
      Qed.

      Fact Zp_invert_one : inv Op = Op.
      Proof.
        rewrite Zp_invert_eq_not_zero; auto.
        rewrite Zp_mult_one; auto.
      Qed.

      Fact Zp_invert_minus_one : inv (∸ Op) = ∸ Op.
      Proof. rewrite Zp_invert_opp, Zp_invert_one; auto. Qed.

      Fact Zp_invert_fix x : inv x = x <-> x = Zp \/ x = Op \/ x = ∸ Op.
      Proof.
        split.
        + intros H.
          destruct (Zp_eq_dec x Zp) as [ Hx | Hx ]; auto.
          apply Zp_invert_spec2 in Hx.
          rewrite H in Hx.
          apply Zp_prime_square_one in Hx; auto.
        + intros [ | [|]]; subst.
          * apply Zp_invert_spec1.
          * apply Zp_invert_eq_not_zero; try ring.
            intros H; symmetry in H; revert H; rewrite Zp_zero_is_one; omega.
          * apply Zp_invert_eq_not_zero; try ring.
            intros H.
            rewrite <- Zp_opp_zero in H.
            symmetry in H; apply Zp_opp_inj in H.
            revert H; rewrite Zp_zero_is_one; omega.
      Qed.

      Fact Zp_invert_involutive x : inv (inv x) = x.
      Proof.
        destruct (Zp_eq_dec x Zp) as [ Hx | Hx ]; subst.
        + do 2 rewrite Zp_invert_spec1; auto.
        + apply Zp_invert_eq_not_zero.
          * intros H.
            apply Zp_invert_spec2 in Hx.
            rewrite H, Zp_mult_zero in Hx.
            apply Zp_zero_is_one in Hx; omega.
          * rewrite Zp_mult_comm; apply Zp_invert_spec2; auto.
      Qed.

      Fact Zp_invert_not_fix n : (1 < n < p-1)%nat -> inv〚n〛<>〚n〛.
      Proof.
        intros H1 H2.
        apply Zp_invert_fix in H2.
        destruct H2 as [ H2 | [ H2 | H2 ] ].
        + rewrite <- nat2Zp_zero in H2.
          apply nat2Zp_inj in H2.
          rewrite rem_lt, rem_lt in H2; omega.
        + rewrite <- nat2Zp_one in H2.
          apply nat2Zp_inj in H2.
          rewrite rem_lt, rem_lt in H2; omega.
        + rewrite <- nat2Zp_minus_one in H2.
          apply nat2Zp_inj in H2.
          rewrite rem_lt, rem_lt in H2; omega.
      Qed.

      Fact Zp_invert_stable n : (1 < n < p-1)%nat -> exists m, (1 < m < p-1)%nat /\〚m〛= inv〚n〛.
      Proof.
        intros Hn.
        destruct (nat2Zp_choose (inv 〚n〛)) as [ H | [ H | [ H | H ] ] ]; auto;
          exfalso; apply f_equal with (f := inv) in H;
          rewrite Zp_invert_involutive in H; symmetry in H.
        + rewrite Zp_invert_spec1 in H.
          rewrite <- nat2Zp_zero, nat2Zp_inj in H.
          rewrite rem_lt, rem_lt in H; omega.
        + rewrite Zp_invert_one, <- nat2Zp_one in H.
          rewrite nat2Zp_inj, rem_lt, rem_lt in H; omega.
        + rewrite Zp_invert_minus_one, <- nat2Zp_minus_one in H.
          rewrite nat2Zp_inj, rem_lt, rem_lt in H; omega.
      Qed.

      Definition Zp_lprod := fold_right Zp_mult Zp_one.

      Fact Zp_lprod_nil : Zp_lprod nil = Op.
      Proof. trivial. Qed.

      Fact Zp_lprod_cons x l : Zp_lprod (x::l) = x ⊗ Zp_lprod l.
      Proof. trivial. Qed.

      Fact Zp_lprod_app l m : Zp_lprod (l++m) = Zp_lprod l ⊗  Zp_lprod m.
      Proof.
        induction l as [ | x l IHl ].
        + rewrite Zp_lprod_nil, Zp_mult_one; auto.
        + simpl app; do 2 rewrite Zp_lprod_cons.
          rewrite IHl; ring.
      Qed.

      Theorem Zp_mult_autoinv l : ~ list_has_dup l -> (forall x, In x l -> x <> Zp /\ inv x <> x /\ In (inv x) l) -> Zp_lprod l = Op.
      Proof.
        induction on l as IHl with measure (length l); intros H0 Hl.
        destruct l as [ | x l ].
        + rewrite Zp_lprod_nil; auto.
        + destruct (Hl x) as (H1 & H2 & [H3 | H3]); try (simpl; auto; fail).
          1: destruct H2; auto.
          destruct in_split with (1 := H3) as (u & v & ?); subst.
          rewrite Zp_lprod_cons, Zp_lprod_app, Zp_lprod_cons.
          rewrite (Zp_mult_assoc _ (inv x)), (Zp_mult_comm _ (inv x)).
          repeat rewrite Zp_mult_assoc.
          rewrite (Zp_mult_comm _ (inv x)), Zp_invert_spec2; auto.
          rewrite Zp_mult_one, <- Zp_lprod_app.
          apply IHl.
          * simpl; do 2 rewrite app_length; simpl; omega.
          * contradict H0.
            constructor 2.
            apply perm_list_has_dup with (inv x::u++v).
            - apply Permutation_cons_app; auto.
            - constructor 2; auto.
          * intros y Hy.
            destruct (Hl y) as (G1 & G2 & G3).
            - apply in_app_or in Hy; right; apply in_or_app; simpl; tauto.
            - repeat (split; auto).
              destruct G3 as [ G3 | G3 ].
              ++ destruct H0; rewrite G3 at 2.
                 rewrite Zp_invert_involutive.
                 constructor 2.
                 apply perm_list_has_dup with (y::u++v).
                 ** apply Permutation_cons_app; auto.
                 ** constructor 1; auto.
              ++ apply in_or_app.
                 apply in_app_or in G3.
                 destruct G3 as [ | [ G3 | ] ]; try tauto.
                 exfalso.
                 apply f_equal with (f := inv) in G3.
                 do 2 rewrite Zp_invert_involutive in G3.
                 destruct H0.
                 apply perm_list_has_dup with (inv x::(x::u)++v).
                 ** apply Permutation_cons_app with (l1 := x::u); auto.
                 ** simpl; constructor 2; constructor 1; subst; auto.
      Qed.

      Fact Zp_lprod_fact n : 〚fact (S n)〛= Zp_lprod (map nat2Zp (list_an 2 n)).
      Proof.
        induction n as [ | n IHn ].
        + apply Zp_inj; simpl; auto.
        + rewrite fact_S, nat2Zp_mult.
          replace (S n)%nat with (n+1)%nat by omega.
          rewrite list_an_plus, map_app, Zp_lprod_app, <- IHn, Zp_mult_comm.
          f_equal.
          * do 2 f_equal; omega.
          * simpl list_an; unfold map.
            rewrite Zp_lprod_cons, Zp_mult_comm, Zp_mult_one.
            f_equal; omega.
      Qed.

      Theorem Wilson_thm_1 :〚fact (p-1)〛= ∸Op.
      Proof.
        replace (p-1)%nat with (S (p-2))%nat by omega.
        rewrite Zp_lprod_fact.
        destruct (eq_nat_dec p 2) as [ H1 | H1 ].
        + rewrite H1; simpl map; rewrite Zp_lprod_nil.
          rewrite <- nat2Zp_minus_one; apply nat2Zp_inj.
          rewrite H1; auto.
        + replace (p-2)%nat with (p-3+1)%nat by omega.
          rewrite list_an_plus, map_app, Zp_lprod_app.
          replace (p-3+2)%nat with (p-1)%nat by omega.
          simpl list_an at 2; unfold map at 2.
          rewrite Zp_lprod_cons, Zp_lprod_nil.
          rewrite Zp_mult_autoinv.
          * rewrite nat2Zp_minus_one; ring.
          * intros H.
            apply list_has_dup_map_inv in H.
            - revert H; apply not_list_an_has_dup.
            - intros x y; do 2 rewrite list_an_spec.
              intros Hx Hy.
              rewrite nat2Zp_inj, rem_lt, rem_lt; auto; omega.
          * intros x; rewrite in_map_iff.
            intros (n & ? & Hn); subst.
            rewrite list_an_spec in Hn.
            split; [ | split ].
            - intros H.
              rewrite <- nat2Zp_zero in H.
              apply nat2Zp_inj in H.
              rewrite rem_of_0, rem_lt in H; omega.
            - apply Zp_invert_not_fix; omega.
            - destruct Zp_invert_stable with n as (m & G1 & G2); try omega.
              apply in_map_iff.
              exists m; split; auto.
              apply list_an_spec; omega.
      Qed.

    End prime.

    Fact Zp_divides_and_invertible d k n i : (d * k = n)%nat ->〚i〛⊗〚d〛= Op ->〚k〛=〚i〛⊗〚n〛.
    Proof.
      intros H1 H2.
      rewrite <- H1, nat2Zp_mult, Zp_mult_assoc, H2; ring.
    Qed.

  End Z2Zp.

End Zp.

Fact divides_not_0_interval p q : q <> 0 -> divides p q -> 1 <= p <= q.
Proof.
  intros Hq ([ | k ] & Hk); try omega.
  destruct p as [ | p ]; try omega.
  subst; simpl.
  generalize (k*S p); intro; omega.
Qed.

Fact divides_fact_lt q n : 1 <= q <= n -> divides q (fact n).
Proof.
  revert q; induction n as [ | n IHn ].
  + intros; rewrite fact_0; omega.
  + intros q Hq; rewrite fact_S.
    destruct (eq_nat_dec q (S n)).
    - subst; exists (fact n); ring.
    - apply divides_mult, IHn; omega.
Qed.

Theorem Wilson_theorem p : 2 <= p -> prime p <-> divides p (fact (p-1)+1).
Proof.
  intros H1; split.
  + intros H2.
    assert (Hp : p <> 0) by omega.
    rewrite divides_nat2Zp with (Hp := Hp).
    rewrite nat2Zp_plus, Wilson_thm_1; auto.
    rewrite nat2Zp_one, Zp_plus_comm, Zp_minus; auto.
  + intros H2; split; try omega.
    intros q Hq.
    destruct (eq_nat_dec q p) as [ Hp | Hp ]; auto.
    generalize (divides_trans Hq H2); intros H3.
    apply divides_plus_inv in H3.
    - apply divides_1_inv in H3; auto.
    - apply divides_fact_lt.
      apply divides_not_0_interval in Hq; omega.
Qed.

Check Wilson_theorem.
Print Assumptions Wilson_theorem.

Section Z2Zp_morphishm.

  Variable (p : nat) (Hp : p <> 0).

  Fact Z2Zp_morphishm : ring_morphism 0%Z 1%Z Zplus Zmult Z.opp
                                      (Zp_zero Hp) (Zp_one Hp) (Zp_plus Hp) (Zp_mult Hp) (Zp_opp Hp) (Z2Zp Hp).
  Proof.
    exists.
    + apply Z2Zp_zero.
    + apply Z2Zp_one.
    + apply Z2Zp_plus.
    + apply Z2Zp_mult.
    + apply Z2Zp_opp.
  Qed.

End Z2Zp_morphishm.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e174m3_3limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Set Implicit Arguments.
Require Import Omega.

Definition decr(f : nat -> nat) := forall n, f (S n) <= f n.

Definition valley(f : nat -> nat)(n x : nat) := forall y, x <= y -> y <= n+x -> f y = f x.

Lemma decr_0 : forall f x, decr f -> f x = 0 -> forall y, x <= y -> f y = 0.
Proof.
  intros.
  induction y.
  inversion H1.
  rewrite H2 in H0; exact H0.
  inversion H1.
  rewrite <- H2; exact H0.
  pose (H y).
  pose (IHy H3).
  omega.
Qed.

Lemma zero_valley : forall f n x, decr f -> f x = 0 -> valley f n x.
Proof.
  intros f n x fd fx y Hxy _.
  rewrite fx.
  exact (decr_0 fd fx Hxy).
Qed.

Lemma arith_lemma : forall x y, x <= y -> x = y \/ S x <= y.
Proof.
  intros.
  omega.
Qed.

Lemma valley_or_drop : forall n f x, decr f -> valley f n x \/ exists y, f y < f x.
Proof.
  induction n; intros.
  left.
  intros y H1 H2.
  simpl in H2.
  assert (x = y).
  omega.
  rewrite H0; reflexivity.
  destruct (IHn _ (S x) H).
  pose (G := H x).
  inversion G.
  left.
  intros y Hy1 Hy2.
  destruct (arith_lemma Hy1).
  rewrite H1; reflexivity.
  rewrite <- H2.
  apply H0.
  exact H1.
  omega.
  right.
  exists (S x).
  omega.
  right.
  destruct H0 as [y Hy].
  exists y.
  pose (G := H x).
  omega.
Qed.

Lemma valley_aux : forall y f x n, f x <= y -> decr f -> exists x', valley f n x'.
Proof.
  induction y; intros.
  intros.
  exists x.
  apply zero_valley.
  exact H0.
  inversion H.
  reflexivity.
  destruct (valley_or_drop n x H0).
  exists x.
  exact H1.
  destruct H1 as [x' Hx'].
  assert (f x' <= y).
  omega.
  destruct (IHy f x' n H1 H0).
  exists x0; exact H2.
Qed.

Theorem decr_valleys : forall n f, decr f -> exists x, valley f n x.
Proof.
  intros.
  exact (valley_aux 0 n (le_refl (f 0)) H).
Qed.


Require Import
        Fiat.BinEncoders.Env.BinLib.Core
        Fiat.BinEncoders.Env.BinLib.FixInt
        Fiat.BinEncoders.Env.Common.Specs
        Fiat.BinEncoders.Env.Common.Sig.

Set Implicit Arguments.

Section EnumEncoder.

  Variable size : nat.
  Variable A : Type.
  Variable cache : Cache.
  Variable cacheAdd : CacheAdd cache N.

  Variable A_encode : A -> uint size.
  Variable A_decode : uint size -> A.

  Definition Enum_encode (data : A) := FixInt_encode (A_encode data).

  Definition Enum_decode (b : list bool) (cd : CacheDecode) :=
    match FixInt_decode size cacheAdd b cd with
    | (i, b', cd') => (A_decode i, b', cd')
    end.

  Hypothesis A_encode_decode_correct : forall data, A_decode (A_encode data) = data.

  Theorem Enum_encode_correct :
    forall predicate, encode_decode_correct cache btransformer predicate Enum_encode Enum_decode.
  Proof.
    intros pred env env' xenv xenv' c c' bin ext ext' Peq Ppred Penc Pdec. simpl in *.
    unfold Enum_encode, Enum_decode in *.
    destruct (FixInt_decode size cacheAdd (app bin ext) env') as [[? ?] ?] eqn: eq.
    pose proof (@FixInt_encode_correct size cache cacheAdd (fun x => pred (A_decode x))
                   env env' xenv c0 (A_encode c) s bin ext l
                   Peq) as H.
    simpl in H. rewrite A_encode_decode_correct in H.
    specialize (H Ppred Penc eq).
    inversion Pdec; subst; clear Pdec.
    intuition; subst; eauto.
  Qed.
End EnumEncoder.

Arguments Enum_encode {_ _ _ _} _ _ _.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Ch13_1.

Section weak_triangle_circumscription_principle_bachmann_s_lotschnittaxiom.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma weak_triangle_circumscription_principle__bachmann_s_lotschnittaxiom :
  weak_triangle_circumscription_principle -> bachmann_s_lotschnittaxiom.
Proof.
intro HP.
cut (forall A1 A2 B1 B2 C1 C2 D1 D2 IAB IAC IBD,
        Perp A1 A2 B1 B2 -> Perp A1 A2 C1 C2 -> Perp B1 B2 D1 D2 ->
        Col A1 A2 IAB -> Col B1 B2 IAB ->
        Col A1 A2 IAC -> Col C1 C2 IAC ->
        Col B1 B2 IBD -> Col D1 D2 IBD ->
        Coplanar IAB IAC IBD C1 -> Coplanar IAB IAC IBD C2 ->
        Coplanar IAB IAC IBD D1 -> Coplanar IAB IAC IBD D2 ->
       ~ Col IAB IAC IBD ->
        exists I, Col C1 C2 I /\ Col D1 D2 I).

  {
  intros lotschnitt P Q R P1 R1 HPQ HQR HPerQ HPerP HPerR HCop1 HCop2.
  destruct (eq_dec_points P P1).
    subst; exists R; Col.
  destruct (eq_dec_points R R1).
    subst; exists P; Col.
  assert (HNCol : ~ Col P Q R) by (apply per_not_col; auto).
  destruct (lotschnitt P Q Q R P P1 R R1 Q P R) as [S [HS1 HS2]]; Col; Perp; Cop.
  exists S; auto.
  }

  {
  intros A1 A2 B1 B2 C1 C2 D1 D2 IAB IAC IBD HPerp1 HPerp2 HPerp3.
  intros HCol1 HCol2 HCol3 HCol4 HCol5 HCol6 HCop1 HCop2 HCop3 HCop4 HNC.
  destruct (symmetric_point_construction IAB IAC) as [E HE].
  destruct (symmetric_point_construction IAB IBD) as [F HF].
  assert (Col IAB IAC A1) by (assert_diffs; ColR).
  assert (Col IAB IAC A2) by (assert_diffs; ColR).
  assert (HPerp4 : Perp E IAB IAB F).
    {
    assert (E <> IAB).
      {
      intro; treat_equalities; apply HNC; Col.
      }
    assert (IAB <> F).
      {
      intro; treat_equalities; apply HNC; Col.
      }
    apply perp_col0 with B1 B2; try (apply perp_col0 with A1 A2); Col;
    assert_diffs; assert_cols; ColR.
    }
  assert (Coplanar IAB IAC IBD E) by Cop.
  assert (Coplanar IAB IAC IBD F) by Cop.
  assert (Coplanar E F IAB D1) by CopR.
  assert (Coplanar E F IAB D2) by CopR.
  assert (Coplanar E F IAB C1) by CopR.
  assert (Coplanar E F IAB C2) by CopR.
  destruct (HP E F IAB D1 D2 C1 C2) as [I [HC7 HC8]]; auto; try (exists I; Col);
  try (apply not_col_permutation_1; apply perp_not_col); try apply perp_per_1;
  try solve[assert_diffs; Perp]; split; [|assert_diffs| |assert_diffs]; auto;
  split; [exists IBD; split; Col| |exists IAC; split; Col|]; left;
  [apply perp_col0 with B1 B2|apply perp_col0 with A1 A2];
  assert_diffs; Col; ColR.
  }
Qed.

End weak_triangle_circumscription_principle_bachmann_s_lotschnittaxiom.


(** * Coq codes *)
(** ** Dependencies *)

Require Export RegExp.Utility.
Require Export RegExp.Definitions.

(** ** [Empty] *)
(** [Empty] corresponds to 0 in Kleene algebra. *)

Lemma Empty_false : forall s, Empty ~!= s.
Proof.
  induction s.
    reflexivity.
    simpl.  apply IHs.
Qed.

(** ** [Eps] *)
(** [Eps] corresponds to 1 in Kleene algebra. *)

Lemma Eps_true : Eps ~== EmptyString.
Proof.
  simpl.  reflexivity.
Qed.

Lemma Eps_false : forall s, s <> ""%string -> Eps ~!= s.
Proof.
  induction s.
    intro Hs. elim Hs. auto.
    intro Has. simpl. eapply Empty_false.
Qed.

(** ** Boolean operations on [RegExp] are morphism. *)
(** [Or] corresponds to plus in Kleene algebra. *)

Add Parametric Morphism : Or with
signature re_eq ==> re_eq ==> re_eq as Or_morphism.
Proof.
  intros x y H x0 y0 H0.  unfold re_eq in *.  intro s.
  generalize dependent x.  generalize dependent y.
  generalize dependent x0. generalize dependent y0.
  induction s.
    (* s = "" *)
    intros y0 x0 H0 y x H.  specialize (H0 ""%string).  specialize (H ""%string).
    simpl in *.  rewrite <- H0.  rewrite <- H.  reflexivity.
    (* s = String a s *)
    simpl.  intros y0 x0 H0 y x H.  eapply IHs.
      intros.  repeat rewrite <- derivation.  eapply H0.
      intros.  repeat rewrite <- derivation.  eapply H.
Qed.

Add Parametric Morphism : And with
signature re_eq ==> re_eq ==> re_eq as And_morphism.
Proof.
  intros x y H x0 y0 H0.  unfold re_eq in *.  intros s.
  generalize dependent x.  generalize dependent y.
  generalize dependent x0. generalize dependent y0.
  induction s.
    (* s = "" *)
    intros y0 x0 H0 y x H.  specialize (H0 ""%string).  specialize (H ""%string).
    simpl in *.  rewrite <- H0.  rewrite <- H.  reflexivity.
    (* s = String a s *)
    simpl.  intros y0 x0 H0 y x H.  eapply IHs.
      intros s0.  repeat rewrite <- derivation.  eapply H0.
      intros s0.  repeat rewrite <- derivation.  eapply H.
Qed.

Add Parametric Morphism : Not with
signature re_eq ==> re_eq as Not_morphism.
Proof.
  intros x y H.  unfold re_eq in *.  intros s.
  generalize dependent x. generalize dependent y.
  induction s.
    (* s = "" *)
    intros y x H.  specialize (H ""%string).  simpl in *.  rewrite <- H.  reflexivity.
    (* s = String a s *)
    simpl.  intros y x H.  eapply IHs.
    intros s0.  repeat rewrite <- derivation.  eapply H.
Qed.

(** [matches] is a homomorphism from [RegExp] to bool for [And], [Or], and [Not]. *)

Lemma matches_Or : forall s r r',  r || r' ~= s = ((r ~= s) || (r' ~= s))%bool.
Proof.
  induction s.
    simpl.  reflexivity.
    simpl.  intros r r'.  eapply IHs.
Qed.

Lemma matches_And : forall s r r',  matches (And r r') s = ((r ~= s) && (r' ~= s))%bool.
Proof.
  induction s.
    simpl.  reflexivity.
    simpl.  intros.  eapply IHs.
Qed.

Lemma matches_Not : forall s r,  (Not r) ~= s = negb (r ~= s).
Proof.
  induction s.
    simpl.  reflexivity.
    simpl.  intros.  eapply IHs.
Qed.

(** ** Axioms for [Or] *)
(** Commutativity and associativity of [Or] and [And]. *)

Lemma Or_comm_s : forall s r r', (r || r') ~= s = (r' || r) ~= s.
Proof.
  intros s r r'.  repeat erewrite matches_Or.
  destruct (r ~= s); destruct (r' ~= s); reflexivity.
Qed.

Theorem Or_comm : forall r r', r || r' =R= r' || r.
Proof.
  unfold re_eq.  intros r r' s.  eapply Or_comm_s.
Qed.

Lemma Or_assoc_s : forall s r r' r'',
  ((r || r') || r'') ~= s = (r || (r' || r'')) ~= s.
Proof.
  intros.   repeat erewrite matches_Or.
  destruct (r ~= s); destruct (r' ~= s); destruct (r'' ~= s); reflexivity.
Qed.

Theorem Or_assoc : forall r r' r'', (r || r') || r'' =R= r || (r' || r'').
Proof.
  unfold re_eq.  intros r r' r'' s.  eapply Or_assoc_s.
Qed.

Lemma And_comm : forall r r', And r r' =R= And r' r.
Proof.
  unfold re_eq.  intros r r' s.  repeat erewrite matches_And.
  destruct (r ~= s); destruct (r' ~= s); reflexivity.
Qed.

Lemma And_assoc : forall r r' r'', And (And r r') r'' =R= And r (And r' r'').
Proof.
  unfold re_eq.  intros r r' r'' s.  repeat erewrite matches_And.
  destruct (r ~= s); destruct (r' ~= s); destruct (r'' ~= s); reflexivity.
Qed.

(** [Empty] is the identity element 0 for [Or]. *)

Lemma Or_left_id_s : forall s r, (Empty || r) ~= s = r ~= s.
Proof.
  induction s.
    simpl.  reflexivity.
    simpl.  intros r.  eapply IHs.
Qed.

Theorem Or_left_id : forall r, Empty || r =R= r.
Proof.
  unfold re_eq.  intros r s.  eapply Or_left_id_s.
Qed.

Theorem Or_right_id : forall r, r || Empty =R= r.
  intros.  setoid_rewrite Or_comm.
  eapply Or_left_id.
Qed.

Corollary Or_right_id_s : forall s r, (r || Empty) ~= s = r ~= s.
Proof.
  intros s r.  specialize Or_right_id.
  intros H.  unfold re_eq in H.  eapply H.
Qed.

(** [Or] is idempotent. *)

Lemma Or_idem_s : forall s r, (r || r) ~= s = r ~= s.
Proof.
  intros s r.  erewrite matches_Or.  destruct (r ~= s); reflexivity.
Qed.

Theorem Or_idem : forall r, r || r =R= r.
Proof.
  unfold re_eq.  intros r s.  eapply Or_idem_s.
Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype.
Require Import bigops ssralg matrix poly.

(*****************************************************************************)
(* This file contains the definitions of:                                    *)
(*  - char_poly A  : Characteristic polynomial of A                          *)
(*  - phi : the isomorphism between the rings  M(R[X]) and M(R)[X]           *)
(*    with R a commutative and                                               *)
(*     M(R[X]) : matrices with coefficients in the polynomial ring of R      *)
(*     M(R)[X] : polynomials with coefficients in the matrix ring of R       *)
(*  - Zpoly : the injection from the polynomial ring to M(R)[X]              *)
(* In addition to the lemmas relevant to these definitions, this file also   *)
(* contains a proof of the Cayley-Hamilton Theorem.                          *)
(*****************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Import GRing.Theory.
Import Monoid.Theory.

Open Local Scope ring_scope.

Section Cayley.

Variable R : comRingType.

Variable n' : nat.

Notation Local n := n'.+1.
Notation Local "'R'" := R
  (at level 0, format "'R'").
Notation Local "'R' [ 'X' ]" := {poly R}
  (at level 0, format "'R' [ 'X' ]").
Notation Local "'M' ( 'R' )" := 'M[R]_n
  (at level 0, format "'M' ( 'R' )").
Notation Local "'M' ( 'R' [ 'X' ] )" := 'M[R[X]]_n
  (at level 0, format "'M' ( 'R' [ 'X' ] )").
Notation Local "'M' ( 'R' ) [ 'X' ]" := {poly 'M[R]_n}
  (at level 0, format "'M' ( 'R' ) [ 'X' ]").

(* The characteristic polynomial *)

Definition matrixC (A : M(R)) : M(R[X]) := \matrix_(i, j) (A i j)%:P.

Definition char_poly (A : M(R)) : R[X] := \det ('X%:M - matrixC A).

(* The isomorhism phi : M(R[X]) <-> M(R)[X] *)

Definition phi (A : M(R[X])) : M(R)[X] :=
  \poly_(k < \max_i \max_j size (A i j)) \matrix_(i, j) (A i j)`_k.

Lemma coef_phi : forall A i j k, (phi A)`_k i j = (A i j)`_k.
Proof.
move=> A i j k; rewrite coef_poly.
case: (ltnP k _) => le_m_k; rewrite mxE // nth_default //.
apply: leq_trans (leq_trans (leq_bigmax i) le_m_k); exact: (leq_bigmax j).
Qed.

Lemma phi_polyC : forall A, phi (matrixC A) = A%:P.
Proof.
move=> A; apply/polyP=> k; apply/matrixP=> i j.
by rewrite coef_phi !mxE !coefC; case k; last rewrite /= mxE.
Qed.

Lemma phi_zero : phi 0 = 0.
Proof.
apply/polyP=> k; apply/matrixP=> i j.
by rewrite coef_phi mxE !coef0 mxE.
Qed.

Lemma phi_add : forall (A1 A2 : M(R[X])), phi (A1 + A2) = (phi A1) + (phi A2).
Proof.
move=> A1 A2; apply/polyP => k; apply/matrixP=> i j.
by rewrite coef_phi !mxE !coef_add_poly mxE !coef_phi.
Qed.

Lemma phi_opp : forall A, phi (- A) = - phi A.
Proof.
move=> A; apply/polyP=> k; apply/matrixP=> i j.
by rewrite coef_phi !(mxE, coef_opp) coef_phi.
Qed.

Lemma phi_one : phi 1 = 1.
Proof.
apply/polyP=> k; apply/matrixP=> i j.
rewrite coef_phi mxE coef_natmul !coefC.
by case: k => [|k]; rewrite /= !mxE ?mul0rn.
Qed.

Lemma phi_mul : forall (A1 A2 : M(R[X])), phi (A1 * A2) = (phi A1) * (phi A2).
Proof.
move=> A1 A2; apply/polyP=> k; apply/matrixP=> i j.
rewrite !coef_phi !mxE !coef_mul summxE coef_sum.
pose F k1 k2 := (A1 i k1)`_k2 * (A2 k1 j)`_(k - k2).
transitivity (\sum_k1 \sum_(k2 < k.+1) F k1 k2); rewrite {}/F.
  by apply: eq_bigr=> k1 _; rewrite coef_mul.
rewrite exchange_big /=; apply: eq_bigr=> k2 _.
by rewrite mxE; apply: eq_bigr=> k1 _; rewrite !coef_phi.
Qed.

(* Writing a polynomial as a polynomial on matrices *)

Definition Zpoly (p : R[X]) : M(R)[X] := \poly_(i < size p) (p`_i)%:M.

Lemma coef_Zpoly : forall p k, (Zpoly p)`_k = (p`_k)%:M.
Proof.
move=> p k; rewrite coef_poly; case: (ltnP k _) => // le_p_k.
by rewrite nth_default // scalar_mx0.
Qed.

Lemma ZpolyX : Zpoly 'X = 'X.
Proof.
apply/polyP=> k; apply/matrixP=> i j; rewrite coef_Zpoly !coefX.
by case: (k == _); rewrite !mxE ?mul0rn.
Qed.

Lemma phi_Zpoly : forall p, phi p%:M = Zpoly p.
Proof.
move=> p; apply/polyP=> k; apply/matrixP=> i j.
by rewrite coef_phi coef_Zpoly !mxE; case: (i == j); rewrite ?coef0.
Qed.

(* The theorem in three lines! *)

Theorem Cayley_Hamilton : forall A, (Zpoly (char_poly A)).[A] = 0.
Proof.
move=> A; apply/eqP; apply/factor_theorem.
rewrite -phi_Zpoly -mul_adj_mx phi_mul; move: (phi _) => q; exists q.
by rewrite phi_add phi_opp phi_Zpoly phi_polyC ZpolyX.
Qed.

End Cayley.


(** Coq coding by choukh, Oct 2021 **)

Require Import BBST.Axiom.Meta.
Require Import BBST.Definition.Include.
Require Import BBST.Definition.Emptyset.
Require Import BBST.Definition.TransitiveSet.

Notation "a ⋸ b" := (a ∈ b ∨ a = b) (at level 70) : 集合域.

Definition ϵ反自反 := λ A, ∀a ∈ A, a ∉ a.
Definition ϵ传递 := λ A, ∀ a b c ∈ A, a ∈ b → b ∈ c → a ∈ c.
Definition ϵ三歧 := λ A, ∀ a b ∈ A, a = b ∨ a ∈ b ∨ b ∈ a.

Definition ϵ偏序 := λ A, ϵ反自反 A ∧ ϵ传递 A.
Definition ϵ全序 := λ A, ϵ偏序 A ∧ ϵ三歧 A.

Definition ϵq自反 := λ A, ∀a ∈ A, a ⋸ a.
Definition ϵq传递 := λ A, ∀ a b c ∈ A, a ⋸ b → b ⋸ c → a ⋸ c.
Definition ϵq反对称 := λ A, ∀ a b ∈ A, a ⋸ b → b ⋸ a → a = b.
Definition ϵq连通 := λ A, ∀ a b ∈ A, a ⋸ b ∨ b ⋸ a.

Definition ϵq偏序 := λ A, ϵq自反 A ∧ ϵq传递 A ∧ ϵq反对称 A.
Definition ϵq全序 := λ A, ϵq偏序 A ∧ ϵq连通 A.

Lemma ϵ三歧即ϵq连通 : ∀ A, ϵ三歧 A ↔ ϵq连通 A.
Proof with auto.
  split.
  - intros 三歧 a Ha b Hb.
    destruct (三歧 a Ha b Hb) as [|[]]...
  - intros 连通 a Ha b Hb.
    destruct (连通 a Ha b Hb) as [[]|[]]...
Qed.

Definition ϵ非对称 := λ A, ∀ a b ∈ A, a ∈ b → b ∉ a.

Lemma ϵ偏序则ϵ非对称 : ∀ A, ϵ偏序 A → ϵ非对称 A.
Proof with auto.
  intros A [反自反 传递] a Ha b Hb 小于 大于.
  apply 反自反 with a... apply 传递 with b...
Qed.

Definition ϵ可换 := λ A, ∀ a b ∈ A, a ∈ b ↔ ¬ b ⋸ a.

Lemma ϵ全序则ϵ可换 : ∀ A, ϵ全序 A → ϵ可换 A.
Proof with auto.
  intros A [偏序 三歧] a Ha b Hb. split.
  - intros 小于 [大于|等于].
    + apply ϵ偏序则ϵ非对称 with A a b...
    + subst. apply (proj1 偏序) with a...
  - intros 不大于等于.
    apply 德摩根定律 in 不大于等于 as [不大 不等].
    destruct (三歧 a Ha b Hb) as [|[]]... congruence. easy.
Qed.

Definition ϵ最小 := λ m A, m ∈ A ∧ ∀x ∈ A, m ⋸ x.
Notation 有ϵ最小元 A := (∃ m, ϵ最小 m A).
Notation 无ϵ最小元 A := (¬ 有ϵ最小元 A).
Notation 总有ϵ更小 A := (∀x ∈ A, ∃y ∈ A, y ∈ x).

Lemma ϵ全序则无ϵ最小元即总有ϵ更小 : ∀ A, ϵ全序 A → 无ϵ最小元 A ↔ 总有ϵ更小 A.
Proof with auto.
  intros A 全序. split.
  - intros 无最小 x Hx. 反证.
    apply 无最小. exists x. split...
    intros y Hy. 反证. apply 反设.
    exists y. split... apply ϵ全序则ϵ可换 with A...
  - intros 总有更小 [m [Hm 最小]].
    destruct (总有更小 m) as [n [Hn Hnm]]...
    apply ϵ全序则ϵ可换 with A n m...
Qed.

Definition ϵ良基 := λ A, ∀ X, X ≠ ∅ → X ⊆ A → 有ϵ最小元 X.
Definition ϵ良序 := λ A, ϵ全序 A ∧ ϵ良基 A.

Lemma ϵ全序集的任意子集是ϵ全序 : ∀ A B, B ⊆ A → ϵ全序 A → ϵ全序 B.
Proof with auto.
  intros * 子集 全序. repeat split.
  - intros x Hx. apply 全序...
  - intros x Hx y Hy z Hz. apply 全序...
  - intros x Hx y Hy. apply 全序...
Qed.

Lemma ϵ良基集的任意子集是ϵ良基 : ∀ A B, B ⊆ A → ϵ良基 A → ϵ良基 B.
Proof. intros * 子集B 良基 X 非空 子集X. apply 良基; auto. firstorder. Qed.

Theorem ϵ良序集的任意子集是ϵ良序 : ∀ A B, B ⊆ A → ϵ良序 A → ϵ良序 B.
Proof with auto.
  intros * 子集 [全序 良基]. split.
  - apply ϵ全序集的任意子集是ϵ全序 with A...
  - apply ϵ良基集的任意子集是ϵ良基 with A...
Qed.


Inductive Ty : Set :=
| TV : nat -> Ty
| Imp : Ty -> Ty -> Ty
| Or : Ty -> Ty -> Ty
| And : Ty -> Ty -> Ty
| Unit : Ty
| All : Ty -> Ty.

Lemma ty_eq_dec : forall (ty1 ty2 : Ty), {ty1 = ty2} + {ty1 <> ty2}.
Proof.
  decide equality. decide equality.
Defined.

Inductive Term : Set :=
| F : nat -> Term
| V : nat -> Term
| App : Term -> Term -> Term
| TApp : Term -> Ty -> Term
| Abs : Ty -> Term -> Term
| Cas : Term -> Term -> Term -> Term
| Split  Term -> Term -> Term
| Lam : Term -> Term.

Inductive Ctx : Set :=
| G : nat -> list Ty -> Ctx.

Definition Delta := nat -> Term.

Inductive Holds : Set :=
| H : Delta -> Ctx -> Term -> Ty -> Holds.

Notation "d ; n ; l |= t @ ty" := (H d (G n l) t ty) (at level 60).
Open Scope list_scope.

Fixpoint tyshiftn (n : nat) (d : nat) (ty : Ty) {struct ty} : Ty :=
  match ty with
    | TV m => if le_lt_dec d m then TV (n+m) else TV m
    | Imp t s => Imp (tyshiftn n d t) (tyshiftn n d s)
    | All t => All (tyshiftn n (S d) t)
  end.

Definition tyshift := tyshiftn 1 0.

Definition tysub : forall (ty : Ty) (n : nat) (s : Ty), Ty.
Proof.
  refine
    (fix tysub (ty : Ty) (n : nat) (s : Ty) {struct ty} : Ty :=
      match ty with
        | TV m => match le_lt_dec n m with
                    | left p => match eq_nat_dec n m with
                                  | left _ => s
                                  | right p' =>
                                    (match m as m' return (m = m' -> Ty) with
                                      | 0 => (fun p'' => False_rec _ _)
                                      | S m' => (fun _ => TV m')
                                     end) (refl_equal m)
                                end
                    | right _ => TV m
                  end
        | Imp ty1 ty2 => Imp (tysub ty1 n s) (tysub ty2 n s)
        | All t => All (tysub t (S n) (tyshift s))
      end).
  destruct m. apply le_n_O_eq in p. apply p'. auto. inversion p''.
Defined.

Fixpoint tysubt (t : Term) (n : nat) (s : Ty) {struct t} : Term :=
  match t with
    | V m => V m
    | Abs ty t => Abs (tysub ty n s) (tysubt t n s)
    | Lam t => Lam (tysubt t (S n) (tyshift s))
    | App f g => App (tysubt f n s) (tysubt g n s)
    | TApp f ty => TApp (tysubt f n s) (tysub ty n s)
  end.

Eval compute in tysubt (tysubt (Lam (TApp (V 0) (TV 2))) 0 (TV 0)) 0 (TV 3).

Fixpoint valid (ty : Ty) (n : nat) {struct ty} : Prop :=
  match ty with
    | TV m =>
      if le_lt_dec n m
        then False
        else True
    | Imp s t => valid s n /\ valid t n
    | All t => valid t (S n)
  end.

Definition valid_dec : forall (ty : Ty) (n : nat), {valid ty n}+{~ valid ty n}.
Proof.
  induction ty ; intros.
  (* TV *)
  case_eq (le_lt_dec n0 n).
  intros. right. simpl. rewrite H0. auto.
  intros. left. simpl. rewrite H0. auto.
  (* Imp *)
  firstorder.
  (* All *)
  firstorder.
Defined.

Lemma tyshift_level : forall ty1 n m,
  valid ty1 n -> valid (tyshiftn 1 m ty1) (S n).
Proof.
  induction ty1 ; simpl ; intros ; numerical.
  destruct n ; numerical.
  firstorder.
Qed.

Lemma tysub_level : forall ty1 ty2 n,
  valid ty1 (S n) -> valid ty2 n -> valid (tysub ty1 n ty2) n.
Proof.
  induction ty1 ; simpl ; intros ; numerical.
  (* TV *)
  destruct n ; numerical.
  firstorder.
  firstorder.

  apply IHty1. auto. unfold tyshift.
  apply tyshift_level. auto.
Qed.

Definition Zero := (All (TV 0)).
Definition One := (Imp Zero Zero).

Inductive Derivation : Holds -> Set :=
| ImpIntro : forall n l t ty xty,
  valid xty n ->
  Derivation (n ; xty::l |= t @ ty) ->
  Derivation (n ; l |= (Abs xty t) @ (Imp xty ty))
| ImpElim : forall n l t f ty xty,
  Derivation (n ; l |= t @ xty) ->
  Derivation (n ; l |= f @ (Imp xty ty)) ->
  Derivation (n ; l |= (App f t) @ ty)
| AllIntro : forall n l t ty,
  Derivation (S n ; map tyshift l |= t @ ty) ->
  Derivation (n ; l |= (Lam t) @ All ty)
| AllElim : forall n l t ty xty,
  valid xty n ->
  valid ty (S n) ->
  Derivation (n ; l |= t @ All ty) ->
  Derivation (n ; l |= TApp t xty @ (tysub ty 0 xty))
| VarIntro : forall n l ty i,
  i < length l -> nth i l Zero = ty ->
  Derivation (n ; l |= V i @ ty).

Fixpoint typeof (n : nat) (l : list Ty) (t : Term) {struct t} : option Ty :=
  match t with
    | V n' =>
      if le_lt_dec (length l) n'
        then None
        else (fun ty =>
          if valid_dec ty n
            then Some ty
            else None) (nth n' l Zero)
    | App r s =>
      (fun mrty msty =>
        match mrty,msty with
          | Some (Imp xty yty),Some xty' =>
            if ty_eq_dec xty' xty
              then Some yty
              else None
          | _,_ => None
        end) (typeof n l r) (typeof n l s)
    | TApp r ty =>
      (fun mrty =>
        match mrty with
          | Some (All ty') =>
            if valid_dec ty n
              then if valid_dec ty' (S n)
                then Some (tysub ty' 0 ty)
                else None
              else None
          | _ => None
        end) (typeof n l r)
    | Abs ty r =>
      (fun mrty =>
        match mrty with
          | Some ty' =>
            if valid_dec ty n
              then Some (Imp ty ty')
              else None
          | _ => None
        end) (typeof n (ty::l) r)
    | Lam r =>
      (fun mrty =>
        match mrty with
          | Some ty' =>
            if valid_dec ty' (S n)
              then Some (All ty')
              else None
          | _ => None
        end) (typeof (S n) (map tyshift l) r)
  end.


Require Export Base.
Require Import Classes.Galois Classes.Monad Classes.PreorderedSet
  Classes.Joinable Classes.Monad.MonadJoin Types.State.

Inductive optionA (A : Type) : Type :=
  | SomeA : A → optionA A
  | NoneA : optionA A
  | SomeOrNoneA : A → optionA A.
Arguments SomeA {A} a.
Arguments NoneA {A}.
Arguments SomeOrNoneA {A} a.
Definition optionT (M : Type → Type) (A : Type) : Type := M (option A).
Definition optionAT (M : Type → Type) (A : Type) : Type := M (optionA A).

Inductive gamma_optionA {A A'} {GA : Galois A A'} : optionA A → option A' → Prop :=
  | gamma_noneA : gamma_optionA NoneA None
  | gamma_SomeornoneA_none : ∀ a,
      gamma_optionA (SomeOrNoneA a) None
  | gamma_SomeA_Some : ∀ a' a, γ a' a → gamma_optionA (SomeA a') (Some a)
  | gamma_Someornone_Some : ∀ a' a,
      γ a' a →
      gamma_optionA (SomeOrNoneA a') (Some a).
Hint Constructors gamma_optionA : soundness.

Inductive gamma_option {A A'} {GA : Galois A A'} : option A → option A' → Prop :=
  | gamma_none : ∀ m, gamma_option None m
  | gamma_Some_Some : ∀ a' a, γ a' a → gamma_option (Some a') (Some a).
Hint Constructors gamma_option : soundness.

Instance galois_optionA : ∀ A A' (GA : Galois A A'),
  Galois (optionA A) (option A') := @gamma_optionA.
Hint Unfold galois_optionA : soundness.

Instance galois_option : ∀ A A' (GA : Galois A A'),
  Galois (option A) (option A') := @gamma_option.
Hint Unfold galois_option : soundness.

Instance galois_optionAT {M M'}
  {GM : ∀ A A', Galois A A' → Galois (M A) (M' A')} :
    ∀ A A',
  Galois A A' → Galois (optionAT M A) (optionT M' A').
Proof.
  intros A A' GA. apply GM. apply galois_optionA. apply GA.
Defined.

Instance galois_optionT {M M'}
  {GM : ∀ A A', Galois A A' → Galois (M A) (M' A')} :
  ∀ A A', Galois A A' → Galois (optionT M A) (optionT M' A').
Proof.
  intros A A' GA. apply GM. apply galois_option. apply GA.
Defined.

Instance option_joinable {A B} {JA : Joinable A B} : Joinable (option A) (option B) :=
  λ m, λ n,
    match m, n with
    | Some x, Some y => Some (x ⊔ y)
    | _, _ => None
    end.

Instance option_joinable_sound {A A' B} {GA : Galois A A'} {GB : Galois B A'}
  {JA : Joinable A B} :
  JoinableSound JA →
  JoinableSound option_joinable.
Proof.
  intros JAS.
  intros a a'. unfold γ, galois_option. destruct a, a'; cbv; intros m H;
  try constructor. destruct H.
  - destruct m.
     + constructor. inversion H; subst. apply join_sound. left. assumption.
     + inversion H.
  - destruct m.
    + constructor. inversion H; subst. apply join_sound. right. assumption.
    + inversion H.
Qed.
Hint Resolve option_joinable_sound : soundness.

Instance option_joinable_idem {A} {JA : Joinable A A} :
  JoinableIdem JA → JoinableIdem (@option_joinable A A JA).
Proof.
  intros JAI a. destruct a; cbv. rewrite JAI. all: reflexivity.
Qed.
Hint Resolve option_joinable_idem : soundness.

Instance optionT_joinable {M : Type → Type}
  {JM : ∀ A B, Joinable A B → Joinable (M A) (M B)}
  {A B} {JA : Joinable A B} : Joinable (optionT M A) (optionT M B).
Proof.
  intros m m'. unfold optionT. pose proof option_joinable as JO.
  apply JM in JO. exact (JO m m').
Defined.

Instance optionA_joinable {A} (JA : Joinable A A) : Joinable (optionA A) (optionA A) :=
  λ m, λ n,
    match m, n with
    | NoneA, NoneA => NoneA
    | SomeA x, SomeA y => SomeA (x ⊔ y)
    | SomeA x, NoneA | NoneA, SomeA x =>  SomeOrNoneA x
    | NoneA, SomeOrNoneA x | SomeOrNoneA x, NoneA => SomeOrNoneA x
    | SomeA x, SomeOrNoneA y | SomeOrNoneA x, SomeA y =>
        SomeOrNoneA (x ⊔ y)
    | SomeOrNoneA x, SomeOrNoneA y => SomeOrNoneA (x ⊔ y)
    end.

Instance optionA_joinable_idem {A} {JA : Joinable A A} :
  JoinableIdem JA → JoinableIdem (@optionA_joinable A JA).
Proof.
  intros JAI.
  intro. destruct a; cbv; try rewrite JAI; reflexivity.
Qed.

Instance optionA_joinable_sound {A A'} {JA : Joinable A A}
  {GA : Galois A A'} :
  JoinableSound JA → JoinableSound (optionA_joinable JA).
Proof.
  intros JAS a1 a2 a' Hgamma. destruct a1, a2, a'; try constructor; cbn;
    try apply JAS; inversion Hgamma as [Hg|Hg]; inversion Hg; subst;
        auto. 1,3,5,7: left; auto. all: right; auto.
Qed.

Instance optionAT_joinable {M : Type → Type}
  {JM : ∀ A B, Joinable A B → Joinable (M A) (M B)}
  {A} {JA : Joinable A A} : Joinable (optionAT M A) (optionAT M A).
Proof.
  intros m m'. unfold optionT. pose proof (optionA_joinable JA) as JO.
  apply JM in JO. exact (JO m m').
Defined.

Section option_preorder.
  Context {A} `{A_preorder : PreorderedSet A}.

  Inductive option_le : option A → option A → Prop :=
    | option_le_none : ∀ m, option_le m None
    | option_le_just : ∀ x y, preorder x y → option_le (Some x) (Some y).
  Hint Constructors option_le : preorders.

  Global Instance option_preorder : PreorderedSet (option A).
  Proof. proof_preorder option_le. Defined.
End option_preorder.
Hint Constructors option_le : preorders.

Section optionA_preorder.
  Context {A : Type} `{A_preorder : PreorderedSet A}.

  Inductive optionA_le : optionA A → optionA A → Prop :=
    | optionA_le_none : optionA_le NoneA NoneA
    | optionA_le_none_justornone : ∀ y, optionA_le NoneA (SomeOrNoneA y)
    | optionA_le_just : ∀ x y, preorder x y → optionA_le (SomeA x) (SomeA y)
    | optionA_le_justornone_r : ∀ x y, preorder x y →
        optionA_le (SomeA x) (SomeOrNoneA y)
    | optionA_le_justornone : ∀ x y, preorder x y →
        optionA_le (SomeOrNoneA x) (SomeOrNoneA y).
  Hint Constructors optionA_le : preorders.

  Global Instance optionA_preorder : PreorderedSet (optionA A).
  Proof. proof_preorder optionA_le. Defined.
End optionA_preorder.
Hint Constructors optionA_le : preorders.

Section option_monad.
  Global Instance return_op_option : return_op option := @Some.

  Definition bind_option {A B}
    (m : option A) (f : A -> option B) : option B :=
    match m with
    | None => None
    | Some a => f a
    end.
  Hint Unfold bind_option : monads.
  Global Instance bind_op_option : bind_op option := @bind_option.

  Lemma bind_option_id_left : ∀ {A B} (f : A → option B) (a : A),
    bind_option (Some a) f = f a.
  Proof.
    intros; unfold bind_option.
    reflexivity.
  Qed.
  Arguments bind_option_id_left [A B] f a.

  Lemma bind_option_id_right : ∀ {A} (m : option A),
    bind_option m Some = m.
  Proof.
    intros; unfold bind_option.
    destruct m; reflexivity.
  Qed.
  Arguments bind_option_id_right [A] m.

  Lemma bind_option_assoc : ∀ {A B C} (m : option A)
    (f : A → option B) (g : B → option C),
  bind_option (bind_option m f) g = bind_option m (λ a : A, bind_option (f a) g).
  Proof.
    intros; unfold bind_option.
    destruct m; reflexivity.
  Qed.
  Arguments bind_option_assoc [A B C] m f g.

  Global Instance option_monad : Monad option :=
  {
    bind_id_left := bind_option_id_left;
    bind_id_right := bind_option_id_right;
    bind_assoc := bind_option_assoc;
  }.
End option_monad.

Instance option_ordered : OrderedMonad option.
Proof.
  split.
  - intros A PA a a' Ha; constructor; apply Ha.
  - intros A B PA PB m m' f f' Hm Hf Hf' Hff'.
    destruct m, m'; unfold bindM, bind_op_option, bind_option;
      try constructor; inversion Hm; subst.
    apply preorder_trans with (y:=f a0); auto.
Defined.

Instance some_sound : return_sound option option.
Proof.
  unfold return_sound; intros.
  constructor; assumption.
Qed.
Hint Resolve some_sound : soundness.

Instance bind_option_sound : bind_sound option option.
Proof.
  unfold bind_sound; intros A A' B B' GA GB m m' f f' Hm Hf.
  unfold bindM; simpl; unfold bind_option.
  destruct m, m'; eauto with soundness.
Qed.
Hint Resolve bind_option_sound : soundness.

Section optionA_monad.
  Global Instance return_op_optionA : return_op optionA := @SomeA.

  Definition bind_optionA {A B : Type}
    (m : optionA A) (f : A -> optionA B) : optionA B :=
    match m with
    | NoneA => NoneA
    | SomeA a => f a
    | SomeOrNoneA a => match (f a) with
                       | NoneA => NoneA
                       | SomeA b => SomeOrNoneA b
                       | SomeOrNoneA b => SomeOrNoneA b
                       end
    end.
  Arguments bind_optionA [_ _].
  Hint Unfold bind_optionA : monads.
  Global Instance bind_op_optionA : bind_op optionA := @bind_optionA.

  Lemma bind_optionA_id_left : ∀ {A B} (f : A → optionA B) (a : A),
  bind_optionA (SomeA a) f = f a.
  Proof. reflexivity. Qed.
  Arguments bind_optionA_id_left [A B] f a.

  Lemma bind_optionA_id_right :  ∀ {A} (m : optionA A),
    bind_optionA m SomeA = m.
  Proof.
    intros A m; unfold bind_optionA.
    destruct m; reflexivity.
  Qed.
  Arguments bind_optionA_id_right [A].

  Lemma bind_optionA_assoc : ∀ {A B C} (m : optionA A)
    (f : A → optionA B) (g : B → optionA C),
    bind_optionA (bind_optionA m f) g =
    bind_optionA m (λ a : A, bind_optionA (f a) g).
  Proof.
    intros; unfold bind_optionA.
    destruct m; try reflexivity.
    destruct (f a); try reflexivity.
    destruct (g b); try reflexivity.
  Qed.
  Arguments bind_optionA_assoc [A B C] m f g.

  Global Instance optionA_monad : Monad optionA :=
  {
    bind_id_left := bind_optionA_id_left;
    bind_id_right := bind_optionA_id_right;
    bind_assoc := bind_optionA_assoc;
  }.
End optionA_monad.

Instance optionA_ordered : OrderedMonad optionA.
Proof.
  split.
  { intros A PA a a' Ha; constructor; assumption. }
  intros A B PA PB m m' f f' Hm Hf Hf' Hff'.
  destruct m, m'; unfold bindM, bind_op_optionA, bind_optionA.
  - inversion Hm; subst.
    eapply preorder_trans with (f a0); auto.
  - inversion Hm.
  - inversion Hm; subst.
    apply Hf in H1.
    assert (f a ⊑ f' a0) as Hf2.
    { eapply preorder_trans with (f a0); auto. }
    destruct (f' a0).
    + inversion Hf2; subst; constructor; assumption.
    + assumption.
    + assumption.
  - inversion Hm.
  - constructor.
  - destruct (f' a); constructor.
  - inversion Hm.
  - inversion Hm.
  - inversion Hm; subst. assert (f a ⊑ f' a0) as Hb.
    { apply preorder_trans with (f a0); auto. }
    destruct (f a), (f' a0); inversion Hb; subst; constructor; assumption.
Defined.

Instance someA_sound : return_sound optionA option.
Proof.
  unfold return_sound; eauto with soundness.
Qed.
Hint Resolve someA_sound : soundness.

Instance bind_optionA_sound : bind_sound optionA option.
Proof.
  unfold bind_sound. intros A A' B B' GA GB m m' f f' Hm Hf.
  unfold bindM; simpl.
  destruct m as [a | |], m' as [a' |]; eauto with soundness.
  - simpl.
    inversion Hm as [ | | | a1' a1 Ha H1 H0  ]; subst.
    apply Hf in Ha. destruct (f a), (f' a'); eauto with soundness.
  - simpl. destruct (f a); eauto with soundness.
Qed.
Hint Resolve bind_optionA_sound : soundness.

Section optionT_Monad.
  Context {M} `{MM : Monad M}.

  Definition return_optionT {A} (a : A) : optionT M A :=
    returnM (Some a).
  Global Instance return_op_optionT : return_op (optionT M) :=
    @return_optionT.

  Definition bind_optionT {A B} (m : optionT M A)
    (f : A -> optionT M B) : optionT M B :=
    bindM (M:=M) m (λ v : option A,
      match v with
      | None => (returnM None)
      | Some a => f a
      end).
  Arguments bind_optionT [A B] m f.
  Hint Unfold bind_optionT : monads.
  Global Instance bind_op_optionT : bind_op (optionT M) :=
    @bind_optionT.

  Lemma bind_optionT_id_left : ∀ {A B} (f : A → optionT M B) (a : A),
    bind_optionT (return_optionT a) f = f a.
  Proof.
    intros. unfold bind_optionT, return_optionT.
    rewrite bind_id_left. reflexivity.
  Qed.
  Arguments bind_optionT_id_left [A B] f a.

  Lemma bind_optionT_id_right : ∀ {A} (m : optionT M A),
    bind_optionT m (λ a, return_optionT a) = m.
  Proof.
    intros; unfold bind_optionT, return_optionT.
    rewrite <- (bind_id_right (M:=M)); f_equal.
    ext; destruct x; reflexivity.
  Qed.
  Arguments bind_optionT_id_right [A] m.

  Lemma bind_optionT_assoc : ∀ {A B C} (m : optionT M A)
    (f : A → optionT M B) (g : B → optionT M C),
    bind_optionT (bind_optionT m f) g =
    bind_optionT m (λ a : A, bind_optionT (f a) g).
  Proof.
    intros; unfold bind_optionT.
    rewrite bind_assoc; f_equal; extensionality x.
    destruct x; eauto with monads.
    rewrite bind_id_left; reflexivity.
  Qed.
  Arguments bind_optionT_assoc [A B C] m f g.

  Global Instance monad_optionT : Monad (optionT M) :=
  {
    bind_id_left := bind_optionT_id_left;
    bind_id_right := bind_optionT_id_right;
    bind_assoc := bind_optionT_assoc;
  }.
End optionT_Monad.
Hint Unfold bind_optionT : monads.
Hint Rewrite @bind_optionT_id_left @bind_optionT_id_right : monads.

(*Definition optionT_le {M} {PM : ∀ A, PreorderedSet A → PreorderedSet (M A)}
  {BO : bind_op M} {RO : return_op M}
  {A} (m1 m2 : optionT M A) : Prop :=
  m1 >>= (λ o1, *)

Instance optionT_preorder : ∀ {M}
  {PM : ∀ A, PreorderedSet A → PreorderedSet (M A)},
  (∀ A, PreorderedSet A → PreorderedSet (optionT M A)).
Proof.
  intros M PM A PA. unfold optionT. apply PM. apply option_preorder.
Defined.

Instance optionAT_preorder : ∀ {M}
  {PM : ∀ A, PreorderedSet A → PreorderedSet (M A)},
  (∀ A, PreorderedSet A → PreorderedSet (optionAT M A)).
Proof.
  intros M PM A PA. unfold optionAT. apply PM. apply optionA_preorder.
Defined.

Definition return_optionAT {M} {RM : return_op M} A (a : A) : optionAT M A :=
  returnM (SomeA a).
Instance return_op_optionAT {M} {RM : return_op M} :
  return_op (optionAT M) := return_optionAT.
Arguments return_optionAT {M RM A} a.

Instance return_optionAT_sound {M M'} `{RS : return_sound M M'} :
  return_sound (optionAT M) (optionT M').
Proof.
  unfold return_sound, returnM; simpl. eauto with soundness.
Qed.

Section optionAT_stateT_monad.
  Context {M} {RO : return_op M} {BO : bind_op M} {MM : Monad M} {BO2 :
    bind2_op M}.

  Definition bind_optionAT A B
    (m : optionAT M A)
    (f : A → optionAT M B) : optionAT M B :=
   bindM (M:=M) m (λ o,
    match o with
    | NoneA => returnM NoneA
    | SomeA x => f x
    | SomeOrNoneA x => bindM2 (M:=M) (f x) (λ o',
        match o' with
        | NoneA => returnM NoneA
        | SomeA x | SomeOrNoneA x => returnM (SomeOrNoneA x)
        end)
    end).
  Hint Unfold bind_optionAT : monads.
  Global Instance bind_op_optionAT : bind_op (optionAT M) := bind_optionAT.
  Arguments bind_optionAT {A B} m f.

  Lemma bind_optionAT_id_left : ∀ {A B}
    (f : A → optionAT M B) (a : A),
    bind_optionAT (return_optionAT a) f = f a.
  Proof.
    unfold bind_optionAT, return_optionAT; simpl; intros A B f a.
    rewrite bind_id_left. reflexivity.
  Qed.

  Lemma bind_optionAT_id_right : ∀ A (m : optionAT M A),
    bind_optionAT m (λ a, return_optionAT a) = m.
  Proof.
    unfold bind_optionAT, return_optionAT; simpl; intros A m.
    rewrite <- (bind_id_right (M:=M)); f_equal.
    extensionality o; destruct o.
    - reflexivity.
    - reflexivity.
    - rewrite bindM2_return; reflexivity.
  Qed.
End optionAT_stateT_monad.

Section optionAT_sound.
  Context {S S' : Type} {JS : Joinable S S} {JI : JoinableIdem JS} {GS : Galois S S'}
    {JSS : JoinableSound JS} {PS : PreorderedSet S}.

  Global Instance bind_optionAT_sound :
    bind_sound (optionAT (StateT S option)) (optionT (StateT S' option)).
  Proof.
    intros A A' B B' GA GB m m' f f' Hm Hf.
    unfold bindM; simpl.
    unfold bind_op_optionAT, bind_op_optionT.
    unfold bind_optionAT, bind_optionT.
    unfold γ, galois_optionAT; apply bindM_sound.
    assumption.
    intros o o' Ho.
    destruct o, o'.
    - apply Hf; inversion Ho; auto.
    - inversion Ho.
    - inversion Ho.
    - apply returnM_sound; constructor.
    - rewrite <- bind_id_right. apply bindM2_sound_l.
      + apply Hf; inversion Ho; auto.
      + intros o2 o2' Ho2.
        destruct o2, o2'; apply returnM_sound;
        inversion Ho2; constructor; auto.
    - unfold bindM2; simpl; unfold bind2_stateT.
      intros s s' Hs.
      unfold bindM, bind_op_option, bind_option.
      destruct (f a s) eqn:Hfas.
      + destruct p.
        destruct o; repeat constructor; apply join_sound; left; assumption.
      + constructor.
  Qed.
End optionAT_sound.

Definition mjoin_option A {JA : Joinable A A} {JI : JoinableIdem JA} :
  option A → option A → option A :=
  λ m1 : option A, λ m2 : option A,
    match m1, m2 with
    | Some x, Some y => Some (x ⊔ y)
    | _, _ => None
    end.

Instance option_monadjoin : MonadJoin option.
Proof.
  split with mjoin_option. reflexivity.
Defined.
Hint Resolve option_monadjoin : soundness.

Instance option_monadjoin_sound : MonadJoinSound option option.
Proof.
  constructor; intros.
  - destruct m1, m2; try constructor. destruct m'.
    + constructor. apply join_sound.  constructor. inversion H;subst.
      apply H2.
    + inversion H.
  - destruct m1, m2; try constructor. destruct m'.
    + constructor. apply join_sound. right. inversion H; subst.
      apply H2.
    + inversion H.
Qed.

Class BoundedMonad (M : Type → Type) `{OM : OrderedMonad M} :=
{
  f_bounded : ∀ {A B} {PA : PreorderedSet A} {PB : PreorderedSet B},
    ∀ (f : A → optionT M B) (a : A),
    ∃ b, f a ⊑ returnM b;
}.

Instance optionT_ordered {M} `{BM : BoundedMonad M} : OrderedMonad (optionT M).
Proof.
  destruct OM; split.
  - intros A PA a a' Ha; unfold returnM, return_op_optionT, return_optionT.
    apply return_monotone; constructor; assumption.
  - intros A B PA PB m m' f f' Hm Hf Hf' Hff'.
    eapply bind_monotone.
    + assumption.
    + intros v v' Hv; destruct v, v'.
      * apply Hf; inversion Hv; assumption.
      * destruct BM as [f_bounded].
        assert (∃ x, f a ⊑ returnM x) as [x Hup] by auto.
        eapply preorder_trans; apply Hup + apply return_monotone; constructor.
      * inversion Hv.
      * apply return_monotone; constructor.
    + intros v v' Hv; destruct v, v'.
      * apply Hf'; inversion Hv; assumption.
      * assert (∃ x, f' a ⊑ returnM x) as [x Hup].
        { destruct BM as [f_bounded]; auto. }
        eapply preorder_trans; apply Hup + apply return_monotone; constructor.
      * inversion Hv.
      * apply return_monotone; constructor.
    + destruct a.
      * apply Hff'.
      * apply return_monotone; constructor.
Qed.