(**************************************************************)
(*   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.


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.


Require Import QArith.QArith_base.
Require Import QArith.Qabs.
Require Import QArith.Qpower.
Require Import QArith.Qround.
Require Import ZArith.Znat.
Require Import Psatz.
Require Import Init.Nat.
Require Import Omega.
Require Extraction.

Module Type Sig.

Parameter R : Type.
Parameter Rzero : R.
Parameter Rone : R.
Parameter Req : R -> R -> Prop.
Parameter Rlt : R -> R -> Prop.
Parameter Radd : R -> R -> R.
Parameter Radd_inv : R -> R.
Parameter Rmult : R -> R -> R.
Parameter Rmult_inv  : R -> R.
(*Req is an equivalence relation.*)
Axiom Req_refl : forall (r:R), Req r r.
Axiom Req_trans : forall (r1 r2 r3:R), Req r1 r2 -> Req r2 r3 -> Req r1 r3.
Axiom Req_symm : forall (r1 r2:R), Req r1 r2 -> Req r2 r1.

(*Radd,Radd_inv,Req forms a commutative group*)
Axiom Radd_commutative : forall (r1 r2:R), Req (Radd r1 r2) (Radd r2 r1).
Axiom Radd_associative : forall (r1 r2 r3:R), Req (Radd r1 (Radd r2 r3)) (Radd (Radd r1 r2) r3).
Axiom Radd_inv_compat  : forall (r:R), Req (Radd r (Radd_inv r)) Rzero.

(*Rmult,Rmult_inv form commutative semigroup*)
Axiom Rmult_commutative : forall (r1 r2:R), Req (Rmult r1 r2) (Rmult r2 r1).
Axiom Rmult_associative : forall (r1 r2 r3:R), Req (Rmult r1 (Rmult r2 r3)) (Rmult (Rmult r1 r2) r3).
Axiom Rmult_inv_compat : forall r, (not (Req r Rzero)) -> Req (Rmult r (Rmult_inv r)) Rone.

(*Radd,Rmult,Radd_inv,Rmult_inv,Req form field*)

Axiom Rmult_distributes_Radd : forall (a b c:R), Req (Rmult (Radd a b) c) (Radd (Rmult a c) (Rmult b c)).

End Sig.

Definition Cauchy (F:Q->Q) := forall err err1 err2, err>0 -> err1>0 -> err2>0 ->
          err1<err -> err2<err ->
          ((Qabs ((F err1) - (F err2))) < err).

Definition R := { F:Q->Q | Cauchy F}.

Lemma Qabs_extensional : forall q1 q2, q1==q2 -> Qabs q1 == Qabs q2.
Proof.
intros.
destruct q1. destruct q2.
unfold Qabs. unfold Z.abs.
destruct Qnum, Qnum0.
* lra.
* auto.
* assert( not (0 # Qden == Z.neg p # Qden0) ).
** unfold Qeq. assert( (Qnum (0 # Qden) = 0)%Z ) by auto with *.
   rewrite H. auto with *.
** contradiction.
* auto.
* auto.
* assert( not (Zpos p # Qden == Z.neg p0 # Qden0) ).
** unfold Qeq. auto with *.
** contradiction.
* assert( not (Z.neg p # Qden == 0 # Qden0) ).
** unfold Qeq. auto with *.
** contradiction.
* assert( not ( Z.neg p # Qden == ' p0 # Qden0) ).
** unfold Qeq. auto with *.
** contradiction.
* unfold Qeq. unfold Qeq in H. simpl. simpl in H.
  assert ( (p*Qden0 = p0*Qden)%positive ).
** nia.
** rewrite H0. auto with *.

Qed.

Definition injectQ (q:Q) : R.
Proof.
unfold R.
exists (fun err =>q ).
unfold Cauchy.
intros.
assert( Qabs(q-q) == Qabs(0) ).
{
  apply Qabs_extensional. lra.
}
rewrite H4.
simpl.
lra.
Defined.

Definition oneR := injectQ 1.
Definition zeroR := injectQ 0.
Definition twoR := injectQ (1+1).

Definition Rplus (r1:R) (r2:R) : R.
Proof.
apply (Rmake (fun q => (F r1) (q*(1#2)) + (F r2) (q*(1#2)))).
intros.
remember (F r1 (err1 * (1 # 2))) as x.
remember (F r2 (err1 * (1 # 2))) as y.
remember (F r1 (err2 * (1 # 2))) as z.
remember (F r2 (err2 * (1 # 2))) as u.
assert( Qabs( x + y - (z+u) ) == Qabs((x-z) + (y-u)) ).
{
  apply (Qabs_extensional).
  field.
}
rewrite H4.
assert( Qabs (x-z +y-u) <= Qabs (x-z) + Qabs(y-u) ).
{
  assert( Qabs (x-z+y-u) == Qabs( (x-z) + (y-u) )).
  {
    apply Qabs_extensional. field.
  }
  rewrite H5.
  apply Qabs_triangle.
}
assert( Qabs (x-z) < err * (1#2) ).
{
  rewrite Heqx. rewrite Heqz.
  apply ((Cauchy r1) (err*(1#2)) (err1*(1#2)) (err2*(1#2))).
  * lra.
  * lra.
  * lra.
  * lra.
  * lra.
}
assert( Qabs (y-u) < err*(1#2) ).
{
  rewrite Heqy. rewrite Hequ.
  apply ((Cauchy r2) (err*(1#2)) (err1*(1#2)) (err2*(1#2))).
  * lra.
  * lra.
  * lra.
  * lra.
  * lra.
}
assert( (Qabs (x - z) + Qabs (y - u)) < err ) by lra.
assert( Qabs (x - z + y - u) == Qabs( x - z + (y-u) )).
{
  apply Qabs_extensional.
  field.
}
rewrite H9 in H5.
lra.
Defined.

Definition Req (r1 r2 : R):= {c | forall q, q>0 -> Qabs( (F r1) q - (F r2) q) < c*q}.

Theorem z_not_eq_1 : (Req zeroR oneR) -> False.

Theorem req_works : Req oneR oneR.
Proof.
unfold Req.
exists 1.
intros.
unfold oneR.
simpl.
lra.
Qed.

Theorem req_refl : forall (r:R), Req r r.
Proof.
intros.
unfold Req.
exists 1.
intros.
remember (F r q) as z.
assert(Qabs (z-z)==Qabs 0).
{
  assert((z-z)==0) by field.
  apply (Qabs_extensional (z-z)). auto.
}
rewrite H0.
simpl. lra.
Qed.

Theorem req_trans : forall (r1 r2 r3:R), Req r1 r2 -> Req r2 r3 -> Req r1 r3.
Proof.
intros.
unfold Req in H.
unfold Req in H0.
destruct H.
destruct H0.
unfold Req.
exists (x+x0).
intros.
remember (F r1 q1) as z1.
remember (F r3 q1) as z3.
remember (F r2 q1) as z2.
assert( Qabs(z1 - z3) == Qabs( (z1 - z2) + (z2 - z3) ) ).
{
  apply Qabs_extensional.
  field.
}
rewrite H0.
assert( Qabs (z1-z2 + (z2-z3)) <= Qabs (z1-z2) + Qabs (z2-z3) ) by apply Qabs_triangle.
assert(Qabs(z1-z2) < x * q1).
{
  rewrite Heqz1.
  rewrite Heqz2.
  apply (q q1 H).
}
assert(Qabs(z2-z3) < x0*q1).
{
  rewrite Heqz2. rewrite Heqz3.
  apply (q0 q1 H).
}
assert( Qabs (z1 - z2) + Qabs (z2 - z3) < (x+x0)*q1 ) by lra.
lra.
Qed.

Theorem req_symm : forall (r1 r2 : R), Req r1 r2 -> Req r2 r1.
Proof.
intros.
unfold Req.
unfold Req in H.
destruct H.
exists x.
intros.
remember (F r1 q0) as z1.
remember (F r2 q0) as z2.
assert( Qabs(z2 - z1) == Qabs (z1 - z2) ).
{
  assert(Qabs (z2-z1) == Qabs ( -(z1-z2) ) ).
  {
    apply Qabs_extensional. field.
  }
  rewrite H0.
  apply Qabs_opp.
}
rewrite H0.
rewrite Heqz1.
rewrite Heqz2.
apply (q q0 H).
Qed.

Theorem rplus_req_compat : forall (r1 r2 : R), Req (Rplus r1 r2) (Rplus r2 r1).
Proof.
intros.
unfold Req.
exists 1.
intros.
unfold Rplus. simpl. remember (q*(1#2)) as p.
remember (Qnum (F r1 p)) as z1.
remember (Zpos (Qden (F r2 p))) as z2.
remember (Qnum (F r2 p)) as z3.
remember (Zpos (Qden (F r1 p))) as z4.
remember (Zpos (Qden (F r2 p))) as z5.
assert( (' (Qden (F r2 p) * Qden (F r1 p)) = z4*z5)%Z ).
{
  nia.
}
rewrite H0.
assert( (Zpos (Qden (F r1 p) * Qden (F r2 p)) = z4*z5)%Z ).
{
  nia.
}
rewrite H1.
assert( (((z1 * z2 + z3 * z4) * (z4 * z5) +
   - (z3 * z4 + z1 * z2) * (z4 * z5)) = 0)%Z ) by nia.
rewrite H2.
simpl.
assert( 0
# Qden (F r1 p) * Qden (F r2 p) *
  (Qden (F r2 p) * Qden (F r1 p)) == 0).
{
  unfold Qeq. simpl. auto.
}
rewrite H3.
lra.

Qed.

Definition Rmult (r1 r2:R) : R.
Proof.
apply (Rmake (fun q => (F r1 q)*(F r2 q) ) ).
intros.
remember (F r1 err1) as z11.
remember (F r2 err1) as z21.
remember (F r1 err2) as z12.
remember (F r2 err2) as z22.
Admitted.

Module ConReal <: Sig.
Definition R:= R.
End ConReal.

Eval vm_compute in (F (Rplus oneR oneR)).


Inductive bool : Type :=
| true
| false.

Definition negb (b: bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b1: bool) (b2: bool): bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb (b1: bool) (b2: bool): bool :=
  match b1 with
  | true => true
  | false => b2
end.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.
Require real.Real.
Require real.RealInfix.

Parameter pow2: Z -> R.

Axiom Power_0 : ((pow2 0%Z) = 1%R).

Axiom Power_s : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p : forall (n:Z), (n <= 0%Z)%Z ->
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_s_all : forall (n:Z), ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p_all : forall (n:Z),
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_1_2 : ((05 / 10)%R = (Rdiv 1%R 2%R)%R).

Axiom Power_1 : ((pow2 1%Z) = 2%R).

Axiom Power_neg1 : ((pow2 (-1%Z)%Z) = (05 / 10)%R).

Axiom Power_non_null_aux : forall (n:Z), (0%Z <= n)%Z -> ~ ((pow2 n) = 0%R).

Require Import Why3.
Ltac ae := why3 "alt-ergo" timelimit 2.
Open Scope Z_scope.

(* Why3 goal *)
Theorem Power_neg_aux : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (-n)%Z) = (Rdiv 1%R (pow2 n))%R).
intros n Hn.
generalize Hn.
pattern n; apply Z_lt_induction; auto.
clear n Hn.
intros n Hind Hn.
assert (h:n=0\/n>0) by omega; destruct h.
ae.
replace n with (n-1+1) by omega.
replace (- (n - 1 + 1)) with (-(n-1) -1)  by omega.
rewrite Power_p;auto with zarith.
rewrite Power_s;auto with zarith.
ae.
Qed.


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

(* A Coq computable reduction from n-registers MM termination
    to 2-registers MMA termination. Beware that the semantics
    of MMA is a bit different than the semantics of MM:

       the DEC instruction jumps when not zero instead of when zero

    Compare mm_sss  (MinskyMachines/mm_defs.v)
    and     mma_sss (MinskyMachines/mma_defs.v)

    The reduction goes via regular FRACTRAN termination *)

Require Import Undecidability.Synthetic.Definitions.

From Undecidability.Shared.Libs.DLW Require Import pos vec sss.

From Undecidability.FRACTRAN Require Import FRACTRAN FRACTRAN_sss.
From Undecidability.MinskyMachines Require Import mma_defs fractran_mma.

Set Implicit Arguments.

Local Notation "P //ₐ s ↓" := (sss_terminates (@mma_sss 2) P s) (at level 70, no associativity).

Section FRACTRAN_REG_MMA2_and_ON_ZERO.

  Let f : FRACTRAN_REG_PROBLEM -> MMA2_PROBLEM.
  Proof.
    intros (Q & x & _).
    exact (fractran_mma0 Q,x##0##vec_nil).
  Defined.

  Theorem FRACTRAN_REG_MMA2_HALTING : FRACTRAN_REG_HALTING ⪯ MMA2_HALTING.
  Proof.
    exists f; intros (? & ? & ?); simpl.
    now apply fractran_reg_mma0_reductions.
  Qed.

  Theorem FRACTRAN_REG_MMA2_HALTS_ON_ZERO : FRACTRAN_REG_HALTING ⪯ MMA2_HALTS_ON_ZERO.
  Proof.
    exists f; intros (? & ? & ?); simpl.
    now apply fractran_reg_mma0_reductions.
  Qed.

End FRACTRAN_REG_MMA2_and_ON_ZERO.

Check FRACTRAN_REG_MMA2_HALTING.
Check FRACTRAN_REG_MMA2_HALTS_ON_ZERO.