Set Implicit Arguments.
Require Import DblibTactics.
Require Import DeBruijn.
Require Import Environments.

(* ---------------------------------------------------------------------------- *)

(* Kinds. *)

Inductive kind :=
| ADDR       (* Addresses. A subset of values. *)
| VALUE      (* Values. Can be stored in the heap. *)
| STATEMENT  (* Expressions that produce no result. *)
| LVALUE     (* Expressions that produce an address. *)
| RVALUE.    (* Expressions that write a multi-word result to a destination. *)

(* ---------------------------------------------------------------------------- *)

(* Auxiliary syntactic elements. *)

(* A de Bruijn index. *)

Definition var :=
  nat.

(* A size (or an offset), expressed in words. *)

Definition size :=
  nat.

Definition offset :=
  size.

(* A base address is the base address of a memory block. *)

Definition base :=
  nat.

(* The combination of a base address and an offset forms an address that can
   be used to access memory (for reading or writing). We adopt this
   representation because we wish to allow address arithmetic within a block
   and disallow it across blocks. Thus, address arithmetic allows altering the
   offset component of an address, but does not allow altering its base
   component. *)

Definition address :=
  (base * offset)%type.

(* ---------------------------------------------------------------------------- *)

(* Syntax. *)

Inductive syntax :=

(* Variables. A priori, a variable can have an arbitrary kind, although, for
   the moment, we use only variables of kind [ADDR], i.e., variables that
   stand for addresses. *)

(* In this intermediate language, variables are immutable. When an address
   [SAddr a] is substituted for a variable [x], this means that this address
   is the *value* of the variable [x]. However, in order to avoid confusion,
   one must keep in mind how the source language (Rust) is translated down to
   this intermediate language. A stack allocation expression { var x : z; st }
   is translated (see [SStackAlloc] below) in such a way that the variable [x]
   becomes bound to the *address* of a new memory area of size [z]. In other
   words, the (immutable) variable that is known as [x] after the translation
   holds the *address* of the (possibly mutable) variable that is known as [x]
   before the translation. *)

| SVar: var -> syntax

(* Addresses have kind [ADDR]. *)

| SAddr: address -> syntax

(* Values have kind [VALUE]. A value is a thing that can be stored in a
   one-word cell in the heap. The values include the memory locations (above)
   as well as a special garbage value, which denotes uninitialized memory. *)

| SGarbage: syntax

(* Statements have kind [STATEMENT]. They can be thought of as expressions
   that produce no result. As a consequence, their evaluation does not require
   specifying a destination address. *)

| SSkip: syntax
| SSequence: syntax -> syntax -> syntax
| SAssignment: syntax -> syntax -> syntax
| SLetLValue: syntax -> syntax -> syntax
| SDelete: syntax -> syntax

(* LValues have kind [LVALUE]. They include the addresses (above) as well as
   the following constructs. They can be thought of as expressions whose
   evaluation produces a memory location (if it succeeds). They appear on the
   left-hand side of [SLetValue], and nowhere else. *)

| SFieldProj: syntax -> size -> syntax
| SDeref: syntax -> syntax
| SNew: size -> syntax

(* RValues have kind [RVALUE]. They can be thought of as expressions whose
   evaluation produces a multi-word result, which is written to a destination
   address. They appear either as the right-hand side of an assignment or
   nested within a composite rvalue (this is permitted by [SConsecutive]).
   They include the addresses (above) as well as the following constructs. *)

| SCopy: size -> syntax -> syntax
| SNothing: syntax
| SConsecutive: syntax -> syntax -> syntax

.

(* ---------------------------------------------------------------------------- *)

(* The binding structure of our syntax. *)

Instance Var_syntax : Var syntax := {
  var := SVar
}.

Fixpoint traverse_syntax (f : nat -> nat -> syntax) l t :=
  match t with
  | SVar x =>
      (* variable occurrence *)
      f l x
  | SAddr a =>
      SAddr a
  | SGarbage =>
      SGarbage
  | SSkip =>
      SSkip
  | SSequence st1 st2 =>
      SSequence (traverse_syntax f l st1) (traverse_syntax f l st2)
  | SAssignment lv rv =>
      SAssignment (traverse_syntax f l lv) (traverse_syntax f l rv)
  | SLetLValue lv st =>
      (* one more variable is bound in [st] *)
      SLetLValue (traverse_syntax f l lv) (traverse_syntax f (l + 1) st)
  | SDelete lv =>
      SDelete (traverse_syntax f l lv)
  | SFieldProj lv z =>
      SFieldProj (traverse_syntax f l lv) z
  | SDeref lv =>
      SDeref (traverse_syntax f l lv)
  | SNew z =>
      SNew z
  | SCopy z lv =>
      SCopy z (traverse_syntax f l lv)
  | SNothing =>
      SNothing
  | SConsecutive rv1 rv2 =>
      SConsecutive (traverse_syntax f l rv1) (traverse_syntax f l rv2)
  end.

Instance Traverse_syntax : Traverse syntax syntax := {
  traverse := traverse_syntax
}.

Instance TraverseVarInjective_syntax : @TraverseVarInjective syntax _ syntax _.
Proof.
  constructor. prove_traverse_var_injective.
Qed.

Instance TraverseFunctorial_syntax : @TraverseFunctorial syntax _ syntax _.
Proof.
  constructor. prove_traverse_functorial.
Qed.

Instance TraverseRelative_syntax : @TraverseRelative syntax syntax _.
Proof.
  constructor. prove_traverse_relative.
Qed.

Instance TraverseIdentifiesVar_syntax : @TraverseIdentifiesVar syntax _ _.
Proof.
  constructor. prove_traverse_identifies_var.
Qed.

Instance TraverseVarIsIdentity_syntax : @TraverseVarIsIdentity syntax _ syntax _.
Proof.
  constructor. prove_traverse_var_is_identity.
Qed.

(* ---------------------------------------------------------------------------- *)

(* Stack allocation, { var x : z; st }, can be viewed as sugar for
   allocating a block of size [z] in the heap, binding [x] to the
   address of this block, executing [st], and de-allocating. This
   is written "let x = new z in (st; delete x)". *)

Notation SStackAlloc z st :=
  (SLetLValue (SNew z) (SSequence st (SDelete (SVar 0)))).

(* ---------------------------------------------------------------------------- *)

(* Tactics. *)

Ltac da (* destruct_addresses *) :=
  intros;
  repeat match goal with a: address |- _ =>
    let b := fresh "b" in
    let o := fresh "o" in
    destruct a as [ b o ]
  end.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e384m2e128m2e96p2e32m1_12limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


(************************************************************************)
(*                          Icharate Toolkit                            *)
(*                            Houda ANOUN                               *)
(*                          Pierre CASTERAN                             *)
(*                            2003 -2004                                *)
(*                              LaBRI                                   *)
(************************************************************************)

(* derived rule for medial extraction in natural deduction system *)
Set Implicit Arguments.
Require Export tacticsDed.
Require Export struct_ex.

Section medialMeta.
Variables I
          J
          A
          W:Set.
Variable eqdecI:eqdec I.
Variable eqdecJ :eqdec J.
Variable ext:extension I J.
Variable i:I.
Variable j:J.
Hypothesis MA_ij: in_extension (MA2Diam i j) ext.
Hypothesis MP_ij: in_extension (MP1Diam i j) ext.

(*  D ,i ((D \i B) /i C ,i ((D \i B) \i (D \i B))) |- B /i <>j[]j C *)
Definition medialExtraction: forall
                           (D B C:Form I J A)(r1 r2 r3:resource W),
                            (natded eqdecI eqdecJ ext (Comma i (res r1 D)
                                                              (Comma i (res r2 (Slash i (Backslash i D B) C))
                                                                       (res r3 (Backslash i (Backslash i D B)
                                                                                (Backslash i D B)))))
                                                      (Slash i B (Diamond j (Box j C)))).

 intros.
 slashI  0.
 elimDiam 1.
 eapply StructRule with (Ru:=(MA2Diam i j)).
 auto.
 here.
 autorewrite with ctl_db;auto.
 eapply StructRule.
 eexact MP_ij.
 constructor 3.
 constructor 1; autorewrite with ctl_db;auto.
 eapply BackE; [ constructor 1 | idtac ].
 eapply BackE; [ idtac | constructor 1 ].
 eapply SlashE.
 constructor 1.
 eapply BoxE; constructor 1.
Defined.

End  medialMeta.
Ltac extract_med:=apply medialExtraction;inExt.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.

Local Open Scope logic_base.
Local Open Scope syntax.

Class Adjointness (L: Language) {minL: MinimumLanguage L} (Gamma: Provable L) (prodp funcp: expr -> expr -> expr): Prop := {
  adjoint: forall x y z, |-- prodp x y --> z <-> |-- x --> (funcp y z)
}.

Class Commutativity (L: Language) {minL: MinimumLanguage L} (Gamma: Provable L) (prodp: expr -> expr -> expr): Prop := {
  prodp_comm_impp: forall x y, |-- prodp x y --> prodp y x
}.

Class Monotonicity (L: Language) {minL: MinimumLanguage L} (Gamma: Provable L) (prodp: expr -> expr -> expr): Prop := {
  prodp_mono: forall x1 y1 x2 y2, |-- x1 --> x2 -> |-- y1 --> y2 -> |-- prodp x1 y1 --> prodp x2 y2
}.

Class Associativity (L: Language) {minL: MinimumLanguage L} (Gamma: Provable L) (prodp: expr -> expr -> expr): Prop := {
  prodp_assoc1: forall x y z, |-- prodp x (prodp y z) --> prodp (prodp x y) z;
  prodp_assoc2: forall x y z, |-- prodp (prodp x y) z --> prodp x (prodp y z)
}.

Class LeftUnit (L: Language) {minL: MinimumLanguage L} (Gamma: Provable L) (e: expr) (prodp: expr -> expr -> expr): Prop := {
  left_unit1: forall x, |-- prodp e x --> x;
  left_unit2: forall x, |-- x --> prodp e x
}.

Class RightUnit (L: Language) {minL: MinimumLanguage L} (Gamma: Provable L) (e: expr) (prodp: expr -> expr -> expr): Prop := {
  right_unit1: forall x, |-- prodp x e --> x;
  right_unit2: forall x, |-- x --> prodp x e
}.

Class LeftDistr (L: Language) {minL: MinimumLanguage L} (Gamma: Provable L) (prodp sump: expr -> expr -> expr): Prop := {
  left_distr1: forall x y z, |-- prodp x (sump y z) --> sump (prodp x y) (prodp x z);
  left_distr2: forall x y z, |-- sump (prodp x y) (prodp x z) --> prodp x (sump y z);
}.

Class RightDistr (L: Language) {minL: MinimumLanguage L} (Gamma: Provable L) (prodp sump: expr -> expr -> expr): Prop := {
  right_distr1: forall x y z, |-- prodp (sump y z) x --> sump (prodp y x) (prodp z x);
  right_distr2: forall x y z, |-- sump (prodp y x) (prodp z x) --> prodp (sump y z) x;
}.

Section AdjointTheorems.

Context {L: Language}
        {minL: MinimumLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {prodp funcp: expr -> expr -> expr}
        {Adj: Adjointness L Gamma prodp funcp}.

Lemma prodp_mono1: forall x1 x2 y, |-- x1 --> x2 -> |-- prodp x1 y --> prodp x2 y.
Proof.
  intros.
  apply adjoint.
  rewrite H.
  apply adjoint.
  apply provable_impp_refl.
Qed.

Lemma funcp_mono2: forall x y1 y2, |-- y1 --> y2 -> |-- funcp x y1 --> funcp x y2.
Proof.
  intros.
  apply adjoint.
  rewrite <- H.
  apply adjoint.
  apply provable_impp_refl.
Qed.

Lemma adjoint_modus_ponens:
  forall x y, |-- prodp (funcp x y) x --> y.
Proof.
  intros.
  apply adjoint.
  apply provable_impp_refl.
Qed.

Lemma adjoint_iter:
  forall x xs y,
    |-- fold_left prodp xs x --> y <-> |-- x --> (fold_right funcp y xs).
Proof.
  intros.
  revert x; induction xs; intros; simpl in *.
  + reflexivity.
  + rewrite <- adjoint.
    auto.
Qed.

Section AdjointCommutativeTheorems.

Context {Comm: Commutativity L Gamma prodp}.

Lemma Adjoint2Mono: Monotonicity L Gamma prodp.
Proof.
  constructor.
  intros.
  apply aux_minimun_rule02 with (prodp x2 y1).
  + apply prodp_mono1; auto.
  + rewrite (prodp_comm_impp x2 y1).
    rewrite <- (prodp_comm_impp y2 x2).
    apply prodp_mono1; auto.
Qed.

End AdjointCommutativeTheorems.

Section AdjointMonoTheorems.

Context {Mono: Monotonicity L Gamma prodp}.

Lemma funcp_mono: forall x1 y1 x2 y2, |-- x2 --> x1 -> |-- y1 --> y2 -> |-- funcp x1 y1 --> funcp x2 y2.
Proof.
  intros.
  apply adjoint.
  rewrite <- H0.
  rewrite <- (adjoint_modus_ponens x1 y1) at 2.
  apply prodp_mono.
  + apply provable_impp_refl.
  + auto.
Qed.

End AdjointMonoTheorems.

End AdjointTheorems.

Section MonoTheorems.

Context {L: Language}
        {minL: MinimumLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {prodp: expr -> expr -> expr}
        {Mono: Monotonicity L Gamma prodp}.

(* TODO: Maybe this should be abstracted to non-logic level about generic "Proper" vs. fold_left? *)
Lemma fold_left_mono: forall x1 x2 xs1 xs2,
  (Forall2 (fun x1 x2 => |-- x1 --> x2) xs1 xs2) ->
  |-- x1 --> x2 ->
  |-- fold_left prodp xs1 x1 --> fold_left prodp xs2 x2.
Proof.
  intros.
  revert x1 x2 H0.
  induction H; intros.
  + simpl; auto.
  + simpl.
    apply IHForall2.
    apply prodp_mono; auto.
Qed.

Lemma fold_right_mono: forall x1 x2 xs1 xs2,
  (Forall2 (fun x1 x2 => |-- x1 --> x2) xs1 xs2) ->
  |-- x1 --> x2 ->
  |-- fold_right prodp x1 xs1 --> fold_right prodp x2 xs2.
Proof.
  intros.
  induction H; intros.
  + simpl; auto.
  + simpl.
    apply prodp_mono; auto.
Qed.

Lemma fold_left_mono2: forall x1 x2 xs,
  |-- x1 --> x2 ->
  |-- fold_left prodp xs x1 --> fold_left prodp xs x2.
Proof.
  intros.
  apply fold_left_mono; auto.
  induction xs.
  + constructor.
  + constructor; auto.
    apply provable_impp_refl.
Qed.

Lemma fold_right_mono2: forall x1 x2 xs,
  |-- x1 --> x2 ->
  |-- fold_right prodp x1 xs --> fold_right prodp x2 xs.
Proof.
  intros.
  apply fold_right_mono; auto.
  induction xs.
  + constructor.
  + constructor; auto.
    apply provable_impp_refl.
Qed.

End MonoTheorems.

Section AssocTheorems.

Context {L: Language}
        {minL: MinimumLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {prodp: expr -> expr -> expr}
        {e: expr}
        {Mono: Monotonicity L Gamma prodp}
        {Assoc: Associativity L Gamma prodp}
        {LU: LeftUnit L Gamma e prodp}
        {RU: RightUnit L Gamma e prodp}.

(* Since the left unit and right unit can only be identical, we can just assume that directly. *)

Lemma assoc_fold_left_cons: forall x xs,
  |-- fold_left prodp xs (prodp e x) --> prodp x (fold_right prodp e xs).
Proof.
  intros.
  revert x; induction xs; intros.
  + simpl.
    rewrite left_unit1.
    rewrite <- right_unit2.
    apply provable_impp_refl.
  + simpl.
    rewrite <- prodp_assoc2.
    eapply aux_minimun_rule02; [| apply IHxs].
    apply fold_left_mono2.
    apply prodp_assoc2.
Qed.

Lemma assoc_fold_right_cons: forall x xs,
  |-- prodp x (fold_right prodp e xs) --> fold_left prodp xs (prodp e x).
Proof.
  intros.
  revert x; induction xs; intros.
  + simpl.
    rewrite <- left_unit2.
    rewrite right_unit1.
    apply provable_impp_refl.
  + simpl.
    rewrite prodp_assoc1.
    eapply aux_minimun_rule02; [apply IHxs |].
    apply fold_left_mono2.
    apply prodp_assoc1.
Qed.

Lemma assoc_fold_left_fold_right: forall xs,
  |-- fold_left prodp xs e --> fold_right prodp e xs.
Proof.
  intros.
  induction xs.
  + simpl.
    apply provable_impp_refl.
  + simpl.
    apply assoc_fold_left_cons.
Qed.

Lemma assoc_fold_right_fold_left: forall xs,
  |-- fold_right prodp e xs --> fold_left prodp xs e.
Proof.
  intros.
  induction xs.
  + simpl.
    apply provable_impp_refl.
  + simpl.
    apply assoc_fold_right_cons.
Qed.

Lemma assoc_prodp_fold_left: forall xs1 xs2,
  |-- prodp (fold_left prodp xs1 e) (fold_left prodp xs2 e) --> fold_left prodp (xs1 ++ xs2) e.
Proof.
  intros.
  eapply aux_minimun_rule02; [apply prodp_mono; apply assoc_fold_left_fold_right |].
  rewrite <- assoc_fold_right_fold_left.
  induction xs1.
  + simpl.
    rewrite left_unit1.
    apply provable_impp_refl.
  + simpl.
    rewrite prodp_assoc2.
    apply prodp_mono; [apply provable_impp_refl |].
    auto.
Qed.

Lemma assoc_fold_left_app: forall xs1 xs2,
  |-- fold_left prodp (xs1 ++ xs2) e --> prodp (fold_left prodp xs1 e) (fold_left prodp xs2 e).
Proof.
  intros.
  eapply aux_minimun_rule02; [| apply prodp_mono; apply assoc_fold_right_fold_left].
  rewrite assoc_fold_left_fold_right.
  induction xs1.
  + simpl.
    rewrite <- left_unit2.
    apply provable_impp_refl.
  + simpl.
    rewrite <- prodp_assoc1.
    apply prodp_mono; [apply provable_impp_refl |].
    auto.
Qed.

End AssocTheorems.

Section DistrCommTheorems.

Context {L: Language}
        {minL: MinimumLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {prodp sump: expr -> expr -> expr}
        {Comm: Commutativity L Gamma prodp}
        {Mono: Monotonicity L Gamma sump}.

Lemma LeftDistr2RightDistr {LDistr: LeftDistr L Gamma prodp sump}:
      RightDistr L Gamma prodp sump.
Proof.
  constructor.
  + intros.
    rewrite (prodp_comm_impp _ x).
    pose proof prodp_comm_impp x y.
    pose proof prodp_comm_impp x z.
    pose proof prodp_mono _ _ _ _ H H0.
    rewrite <- H1.
    apply left_distr1.
  + intros.
    rewrite <- (prodp_comm_impp x (sump y z)).
    pose proof prodp_comm_impp y x.
    pose proof prodp_comm_impp z x.
    pose proof prodp_mono _ _ _ _ H H0.
    rewrite H1.
    apply left_distr2.
Qed.

Lemma RightDistr2LeftDistr {RDistr: RightDistr L Gamma prodp sump}:
      LeftDistr L Gamma prodp sump.
Proof.
  constructor.
  + intros.
    rewrite (prodp_comm_impp x (sump y z)).
    pose proof prodp_comm_impp y x.
    pose proof prodp_comm_impp z x.
    pose proof prodp_mono _ _ _ _ H H0.
    rewrite <- H1.
    apply right_distr1.
  + intros.
    rewrite <- (prodp_comm_impp (sump y z) x).
    pose proof prodp_comm_impp x y.
    pose proof prodp_comm_impp x z.
    pose proof prodp_mono _ _ _ _ H H0.
    rewrite H1.
    apply right_distr2.
Qed.

End DistrCommTheorems.

Section CommForSimpleAssocConstruction.

Context {L: Language}
        {minL: MinimumLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {prodp: expr -> expr -> expr}
        {Comm: Commutativity L Gamma prodp}
        {Mono: Monotonicity L Gamma prodp}.

Lemma Build_Associativity1:
      (forall x y z, |-- prodp x (prodp y z) --> prodp (prodp x y) z) ->
      Associativity L Gamma prodp.
Proof.
  intros.
  constructor; auto.
  intros.
  rewrite <- (prodp_comm_impp (prodp y z) x).
  rewrite (prodp_comm_impp (prodp x y) z).
  pose proof prodp_comm_impp x y.
  pose proof provable_impp_refl z.
  pose proof prodp_mono _ _ _ _ H1 H0.
  rewrite H2.
  clear H0 H1 H2.
  pose proof prodp_comm_impp z y.
  pose proof provable_impp_refl x.
  pose proof prodp_mono _ _ _ _ H0 H1.
  rewrite <- H2.
  clear H0 H1 H2.
  apply H.
Qed.

Lemma Build_Associativity2:
      (forall x y z, |-- prodp (prodp x y) z --> prodp x (prodp y z)) ->
      Associativity L Gamma prodp.
Proof.
  intros.
  constructor; auto.
  intros.
  rewrite <- (prodp_comm_impp z (prodp x y)).
  rewrite (prodp_comm_impp x (prodp y z)).
  pose proof prodp_comm_impp y z.
  pose proof provable_impp_refl x.
  pose proof prodp_mono _ _ _ _ H0 H1.
  rewrite H2.
  clear H0 H1 H2.
  pose proof prodp_comm_impp y x.
  pose proof provable_impp_refl z.
  pose proof prodp_mono _ _ _ _ H1 H0.
  rewrite <- H2.
  clear H0 H1 H2.
  apply H.
Qed.

End CommForSimpleAssocConstruction.


From Coq Require Import ssreflect ssrfun.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import Vectors.VectorDef.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Program.Equality.
Require Import Coq.Arith.Compare_dec.

Inductive A_nat (A : Type) (f : A -> A) : A -> Type :=
                              |As : forall {x : _}, A_nat f x -> A_nat f (f x)
                              |AZero : forall (x_ : _), A_nat f x_.

Definition FZero {T} (x : T) (f : T -> T) : T := x.
Definition Sn {T} (f : T -> (T -> T) -> T) (x : T) (a : T -> T) : T := f (a x) a.
Definition Sn_arith {T} (f : (T -> T) -> T) (a : (T -> T)) := f a.

Definition one {X} (t : X) (w : X -> X) := (Sn FZero t w).
Definition A_one {X} (t : X) (w : X -> X) := (As (AZero w t)).

Definition ind_r {B} {A : B} {f : B -> B} (x : A_nat f A) := A.

Inductive Maybe (A : Type) := |Surely : A -> Maybe A | Nothing.

Fixpoint n_ {A : Type} {f : A -> A} {c : A} (a : A_nat f c) :=
  match a with
    |As s => n_ s
    |AZero _ v => v
  end.

Compute Sn.
Inductive N_corrseq {T} (G : T -> T) : forall (x : T), A_nat G x -> (T -> (T -> T) -> T) -> Type  :=
 |Eq_Correspodence : forall {q} {y} {d : A_nat G y}, (ind_r d) = q (n_ d) G -> N_corrseq d q -> N_corrseq (As d) (Sn q)
 |Base_case : forall (y : T) (b : T -> (T -> T) -> T), (ind_r (AZero G y)) = b (n_ (AZero G y)) G -> N_corrseq (As (AZero G y)) (Sn FZero).

Theorem A_one_eq_one : forall {A} (t : A) (k : A -> A), one t k = ind_r (A_one t k).
intros.
unfold A_one.
unfold one.
compute.
reflexivity.
Qed.

Definition Sn_nat {A : Type} {f : A -> A} {c : A} (a : A_nat f c) : A -> (A -> A) -> A :=
  let fix sn_ {c : A} (a : A_nat f c) := (match a with
    |@As _ _ d xs => Sn (sn_ xs)
    |@AZero _ _ v => FZero
  end) in (sn_ a).

Compute Sn_nat.
Compute ind_r (As (AZero (plus 1) 0)).
Compute (Sn_arith (Sn_nat (As (AZero (plus 1) 0)) 0)) (plus 1).
Compute (fun {y v} (s' : A_nat y v) => ind_r (As (As s')) = Sn_nat (As (As s')) (n_ (As (As s'))) y) _ _ (AZero (plus 1) 0).

Compute (fun {y v} (s' : A_nat y v) => Sn_nat s' (n_ s') y = v) _ _ (AZero (plus 1) 0).

Definition one_nat_correspond : forall {A : Type} (w : A) (n : A -> A), N_corrseq (As (As (As (AZero n w)))) (Sn (Sn (Sn FZero))).
 refine (fun {A : Type} (w : A) (n : A -> A) => (Eq_Correspodence _ (Eq_Correspodence _ (@Base_case _ n w FZero eq_refl)))).
compute; by [].
trivial.
Qed.

Theorem functor_apply_nat : forall {T} {x : T} {k : T -> T} (s' : A_nat k x), x = Sn_nat s' (n_ s') k -> k x = k x.
move => A p d z; case => P.
by [].
Qed.

Definition just_partial {A} {f : A -> A} {x' : A} (x : A_nat f x') : Maybe (A_nat f x') :=
  match x with
    |@As _ _ _ s => Surely (As s)
    |AZero _ _ => Nothing _
  end.

Theorem naturals_can_be_partials: forall {A} {f : A -> A} (c : A) (x : A_nat f c), just_partial x = Surely x \/ just_partial x = Nothing _.
move => s k g' v'.
destruct v'.
apply : or_introl.
trivial.
apply : or_intror.
trivial.
Qed.

Compute (fun (A : Type) (d : A -> A) (x : A) (f : A_nat d x) =>
 Sn (Sn_nat f) (n_ f) d = d (Sn_nat f (n_ f) d)) _ _ _ (As (AZero (plus 2) 0)).

(*P = (Sn x) f.
P (f x) = f (P x) *)

Fixpoint r_nat {A : Type} (a : nat) : A -> (A -> A) -> A :=
  match a with
    |S n => fun (x0 : A) (a0 : A -> A) => r_nat n (a0 x0) a0
    |0 => fun (x0 : A) (_ : A -> A) => x0
  end.

Theorem nat_homomorphism : forall T (f : T -> T) (h : T) (x : A_nat f h) (t' : T), (Sn_nat x (f t') f) = f ((Sn_nat x) t' f).
move => k d g'; elim => [H' h HP].
move => t; by move : HP; by apply.
by [].
Qed.

Theorem apply_inSnat_Sym : forall (T : Type) (f' : T -> T) (y : T) (v' : A_nat f' y), Sn_nat v' (f' (n_ v')) f' = f' (Sn_nat v' (n_ v') f').
intros.
induction v'.
set nat_proof := (nat_homomorphism (As v') (n_ (As v'))).
rewrite nat_proof; by symmetry.
trivial.
Qed.

Theorem afterAs_is_composition : forall (A : Type) (d : A -> A) (x : A) (f : A_nat d x), Sn_nat f (n_  f) d = x -> Sn_nat (As f) (n_ (As f)) d = d x.
intros.
apply eq_sym in H.
simpl; simpl in H.
replace (d x) with (d (Sn_nat f (n_ f) d)).
unfold Sn.
apply apply_inSnat_Sym.
apply eq_sym in H.
trivial; by replace (Sn_nat f (n_ f) d) with x by H.
Qed.

Theorem nat_composition_is_just_application : forall {A} {c : A} {k : A -> A} (s' : A_nat k c), (Sn_nat s' (n_ s') k = c).
move => T c d f.
induction f.
 + apply afterAs_is_composition; symmetry; rewrite IHf; by apply : eq_refl.
 + by [].
Qed.

Theorem nextNatEqH : forall {A} {c : A} {k : A -> A} (s' : A_nat k c), ind_r s' = Sn_nat s' (n_ s') k -> ind_r (As s') = Sn_nat (As s') (n_ (As s')) k.
intros.
unfold ind_r; unfold ind_r in H.
set certification_of_just_composition := nat_composition_is_just_application (As s').
by []; by symmetry; by simpl.
Qed.

Fixpoint NAT_case_Correspodence {N} {x : N} {y : N -> N} (b : A_nat y x) {struct b} : N_corrseq (As b) (Sn_nat (As b)).
  refine (match b as q return N_corrseq (As q) (Sn_nat (As q)) with
    |@As _ _ a s => @Eq_Correspodence _ y (Sn_nat (As s)) (y a) (As s) _ (NAT_case_Correspodence N a y s)
    |@AZero _ _ x_  => @Base_case N y x_ (Sn_nat (AZero _ _)) eq_refl
  end).

elim :s => [H s' q].
move : q.
elim : b => [D s f g].
destruct f;destruct g.
reflexivity.
reflexivity.
move => S n.
move : n; by apply nextNatEqH.
auto; by compute.
assumption.
trivial.
Qed.

Definition add {A : Type} (fc : (A -> (A -> A) -> A) -> ((A -> (A -> A) -> A) -> (A -> (A -> A) -> A)) -> (A -> (A -> A) -> A)) (b : (A -> (A -> A) -> A)) := fc b (fun f => Sn f).

Compute (add FZero FZero) 0 (plus 1).

Theorem Zero_add_0_is_0_church_encoding : forall {Z} (x : Z -> Z) (y : Z), (add FZero FZero) y x = y.
compute; by [].
Show Proof.
Qed.

Fixpoint applications_func_Anat {T} {y : T -> T} {x g : T} (c : A_nat y x) (y' : A_nat y g) : T :=
  match y' with
    |As s => y g
    |AZero _ _ => g
  end.

Record IndPair (A B : Set) : Set := Do_Pair {
  fst_pair : A;
  snd_pair : B;
  }.

Notation "{ | x | | y | }" := (forall r : Type, (x -> y -> r) -> r) (at level 100, right associativity).

Definition Pair (A : Type) (B : Type) (x : A) (y : B) : { |A| |B| } := (fun (r : Type) (f : A -> B -> r) => f x y).
Notation "| x | | y |" := (Pair x y) (at level 100, right associativity, only parsing).

Definition fst {A T} (pair : forall r : Type, (A -> T -> r) -> r) :=
  pair A (fun x y => x).

Definition snd {A T} (pair : forall r : Type, (A -> T -> r) -> r) :=
  pair T (fun x y => y).

Theorem pair_is_correspond : forall {A B : Set} (x : A) (y : B), fst_pair (Do_Pair x y) = fst (|x| |y|) /\ snd_pair (Do_Pair x y) = snd (|x| |y |).
move => a b k' c'.
apply : conj.
reflexivity; by unfold fst_pair.
reflexivity; by unfold snd_pair.
Show Proof.
Qed.

(*that's proof can be easily made in gallinia way*)
Definition pair_is_correspond2 {A B : Set} (x : A) (y : B) : fst_pair (Do_Pair x y) = fst (|x| |y|) /\ snd_pair (Do_Pair x y) = snd (|x| |y |) :=
  conj (eq_refl (fst_pair (Do_Pair x y))) (eq_refl (snd_pair (Do_Pair x y))).

Inductive bool {T' : Type} : T' -> Type :=
                 |true : forall (a b : T'), bool a
                 |false : forall (a b : T'), bool b.

Definition church_true {A : Type} := (fun x y : A => x).
Definition church_false {A : Type} := (fun x y : A => y).

Definition v'_bool {A} {y : A} (b : bool y) := y.

(*church_bool_inductive_bool_correspond is a extremely easily proof*)
Theorem church_bool_inductive_bool_correspond : forall {T} {y z : T}, v'_bool (true y z) = church_true y z /\ v'_bool (false y z) = church_false y z.
intuition.
Qed.

(*bool_sym b' b = bool b' c = bool b', (b = c) -> (c = b).
  just move => H C P d. by elim : d. Qed. *)

Definition revert_boolean {A : Type} {y : A} (x : bool y) : bool y :=
  match x with
    |true a b => false b a
    |false a b => true b a
  end.

(*if x then q else q' so = if not x then q' else q) *)

Theorem dif_p_p : forall (A : Type) {x : A} (p : bool x), v'_bool p = v'_bool (revert_boolean p).
move => p k'.
case; by [].
Qed.

Definition cmp_bool {A} {x' : A} (b : bool x') : A :=
  match b with
    |true a b => a
    |false a b => b
  end.

Definition just_compare_boolean {A} (x' y' : A) (x : bool x') (y : bool y') : bool x' :=
  match (x, y) with
    |(true _ _ , false _ _) => true x' y'
    |(false _ _, false _ _) => true x' y'
    |_ => false y' x'
  end.

Theorem eq_p_p : forall {A} {x y : A} (p : bool x), (p = true x y) -> (p <> false y x).
intros.
destruct p.
induction H.
discriminate.
discriminate H.
Qed.

Theorem or_dif : forall {A} (x y : A) (b : bool x) (c : bool x), (b = true x y \/ b = false y x) /\ (c = true x y \/ c = false y x) -> (b <> c) -> (c = true x y /\ b = false y x) \/ (c = false y x /\ b = true x y).
intros.
destruct H.
induction H.
induction H1.
apply eq_sym in H.
replace b with (true x y) in H0 by H ;replace c with (true x y) in H0 by H.
move : H0; by case; by reflexivity.
apply : or_intror.
pose (conj H1 H); by assumption.
case : H1 H.
move => a b'.
apply : or_introl; by pose (conj a b'); by assumption.
move => a' b'; apply : or_introl; apply : conj.
case : H0.
apply eq_sym in a'.
rewrite b'; rewrite a'.
apply : eq_refl.
replace b with (false y x) by a'.
trivial.
Qed.

Definition t_list (T : Type) := (T -> T -> T) -> T -> T.
Definition nil {A : Type} (f : A -> A -> A) (d : A) := d.
Definition cons {A : Type} (v' : A) (c_cons : t_list _) (f : A -> A -> A) (v'' : A) :=
  f v' (c_cons f v'').

Inductive list (A : Type) (f : A -> A -> A) : A -> Type :=
  |Acons : forall (x : A) (y' : A) (cons' : list f y'), list f (f x y')
  |Anil : forall (x: A) (y : A), list f (f x y).

(*Fixpoint foldable_nat_list {f : nat -> nat -> nat} {y : nat} (A : list f y) :=
  match A with
   |Acons x y => x + (foldable_nat_list
   |Anil _ x y => x + y
  end. *)

Compute Acons 4 (Acons 2 (Anil (plus) 3 3)).

Definition v'_list {X} {f : X -> X -> X} {y : X} (A : list f y) := y.

Compute v'_list (Acons 2 (Anil (plus) 2 3)).
Compute (cons 2 (cons 2 nil)) (plus) 0.

Fixpoint curry_list {A} {y : A} {z' : A -> A -> A} (l : list z' y) : t_list A :=
match l return t_list A with
  |Acons x y => cons x (@curry_list _ _ _ y)
  |Anil _ x _  => cons x nil
end.

Fixpoint minimal_case {A} {y' : A} {functor : A -> A -> A} (a : list functor y') {struct a} : A :=
  match a with
    |Acons x y => @minimal_case _ _ _ y
    |Anil _ _ y => y
   end.

Definition list_correspodence {A} {y : A} {z' : A -> A -> A} (xs : list z' y) : A :=
  (@curry_list _ _ _ xs) z' (@minimal_case _ _ _ xs).

Compute (Acons 3 (Acons 2 (Anil (plus) 2 3))).

Compute (list_correspodence ((Acons 2 (Anil (fun x y => if (leb x y) then y else x) 0 2)))).
Compute (fun {A} {Y : A} (z: A -> A -> A) (x : list z Y) (v' : A) =>
 (v'_list x) = (list_correspodence x)) _ _ _ (Acons 4 (Acons 2 (Anil (fun x y => if (leb y x) then y else x) 0 3))).

Theorem list_composition : forall {A} (z : A -> A -> A) (x0 x'' y' : A) (l : list z (z x0 x'')), z x0 x'' = list_correspodence l -> z (z x0 x'') y' = z (list_correspodence l) y'.
intros.
replace (z (z x0 x'') y') with (z (list_correspodence l) y').
auto.
move : H.
generalize (list_correspodence l).
intros.
replace a with (z x0 x'') by H.
trivial.
Qed.

Definition test (A : Type) (z : A -> A -> A) (d' n : A) (x : list z (z d' n)) (y' : A)
 := z (list_correspodence x) y' = list_correspodence (Acons y' x).

Theorem func_is_just_listed_appplication : forall (A : Type) (z : A -> A -> A) (d' n : A) (x : list z (z d' n)) (y' : A), z y' (list_correspodence x) = list_correspodence (Acons y' x).
intros.
reflexivity.
Qed.

Theorem test1 : forall (z: nat -> nat -> nat), v'_list (Acons 20 (Acons 2 (Anil z 3 4))) = list_correspodence (Acons 20 (Acons 2 (Anil z 3 4))).
auto.
Qed.

Theorem church_list_correspodence_ind_list : forall (A : Type) (z: A -> A -> A) (x' : A) (x : list z x'), v'_list x = list_correspodence x.
induction x.
unfold v'_list in *; unfold list_correspodence in *.
unfold curry_list in *.
unfold cons in *.
move : IHx.
unfold minimal_case in *.
fold (minimal_case x0).
generalize ((fix
    curry_list (A0 : Type) (y : A0) (z' : A0 -> A0 -> A0)
               (l : list z' y) {struct l} : t_list A0 :=
      match l with
      | @Acons _ _ x1 y'0 y0 =>
          fun (f : A0 -> A0 -> A0) (v'' : A0) =>
          f x1 (curry_list A0 y'0 z' y0 f v'')
      | Anil _ x1 _ =>
          fun (f : A0 -> A0 -> A0) (v'' : A0) => f x1 (nil f v'')
      end) A y' z x0 z (minimal_case x0)). (*more know in brazilian knowledge 'gambiarra'*)
move => h' H.
replace y' with h' by H.
reflexivity.
auto.
Qed.

Inductive monoid (T : Type) (p' : T -> T -> T) : Prop :=
  monoidT : forall {x : T}, {x' | p' x x' = p' x' x} -> monoid p'.

Theorem nat_plus_is_monoid : forall (x : nat), monoid plus.
refine (fun x : nat =>
  (@monoidT nat plus 0 (exist (fun x' => plus 0 x' = plus x' 0) x _))).

(*hand mode*)
induction x.
trivial.
simpl in *.
replace (x + 0) with x by IHx.
by [].
(*end*)

(* or just *)
(*trivial.*)
(*end*)
Qed.

Theorem monoid_list_correspond : nat -> monoid (fun x x' => list_correspodence (Anil plus x x')) /\ monoid (fun x x' => v'_list (Anil plus x x')).
unfold list_correspodence.
unfold curry_list.
unfold cons;unfold minimal_case; unfold nil.
intros; apply : conj.
move : H.
refine (fun x : nat =>
  (@monoidT nat plus 0 (exist (fun x' => list_correspodence (Anil plus 0 x') = list_correspodence (Anil plus x' 0)) x _))).
cbv.
fold (plus x 0); trivial.
move : H; refine (fun x : nat =>
  (@monoidT nat plus 0 (exist (fun x' => v'_list (Anil plus 0 x') = v'_list (Anil plus x' 0)) x _))).
cbv.
fold (plus x 0); trivial.
Qed.

Definition id {A} (x : A) := x.
Inductive identity_lambda {A} (u' : A) : (id u' = u') -> Prop :=
  |Unique : identity_lambda eq_refl.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Axioms                                                                  *
**************************************************************************)

Set Implicit Arguments.

(** This file is used to extend Coq with standard axioms from classical,
    non-constructive higher-order logic. (Such axioms are provided by
    default in other theorem provers like Isabelle/HOL or HOL4.) *)

(** Three axioms taken are: functional extensionality, and propositional
    extensionality and indefinite description.

    All other comomn axioms are derivable, including: the excluded middle,
    the strong excluded middle, propositional degenerency, proof irrelevance,
    injectivity of equality on dependent pairs, predicate extensionality,
    definite description, and all the versions of the axiom of choice. *)

(* ********************************************************************** *)
(** * Functional extensionality *)

(** Two functions that yield equal results on equal arguments are equal. *)

Axiom fun_ext_dep : forall (A : Type) (B : A->Type) (f g : forall x, B x),
  (forall x, f x = g x) ->
  f = g.

(* ********************************************************************** *)
(** * Propositional extensionality *)

(** Two propositions that are equivalent can be considered to be equal. *)

Axiom prop_ext : forall (P Q : Prop),
  (P <-> Q) ->
  P = Q.

(* ********************************************************************** *)
(** * Indefinite description *)

(** Proofs of existence can be reified from [Prop] to [Type]. The lemma
    below is a concise statement for [(exists x, P x) -> { x : A | P x }]. *)

Axiom indefinite_description : forall (A : Type) (P : A->Prop),
  ex P ->
  sig P.


(**

  XP.v

  Fixed Price, as a mech.v instance.

  Proofs of rationality, truthfulness and Pareto-optimality.

  Pierre Jouvelot (7/2021).

  Licence: CeCILL-B.

*)

From Coq Require Import Unicode.Utf8.
From mathcomp Require Import all_ssreflect all_algebra perm.

From mech.lib Require Import lib mech.

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

Variable n : nat.     (* number of bidders *)

Variable b : nat.     (* max value of bid *)

Variable fixed_price : nat.

Section Algorithm.

Variable bids : n.-tuple 'I_b.

Variable i : agent.type n.

Definition is_winner := fixed_price <= tnth bids i.

Definition price := fixed_price.

End Algorithm.

Definition m := mech.new (fun bs => map_tuple (is_winner bs) (agent.agents n)).

Definition a := auction.new (fun (o : mech.O m) i => if tnth o i then Some price else None).

Variable v : agent.type n -> 'I_b.

Definition p := auction.prefs a v.

Section Properties.

(** XP is rational if one bids one's true value `v`. *)

Notation bids := (n.-tuple 'I_b).

Lemma rational (bs : bids) (i : agent.type n) (i_wins : is_winner  bs i) :
  tnth bs i = v i -> price <= v i.
Proof. by move=> <-. Qed.

Lemma truthful_XP : truthful p.
Proof.
rewrite /truthful => bs bs' i tv /=.
rewrite /action_on /auction.U /auction.p /= !tnth_map !tnth_ord_tuple => <-.
have [] := boolP (is_winner bs' i) => [_|] //.
have [] := boolP (is_winner bs i) => [//|niw].
rewrite /is_winner -ltnNge in niw.
by rewrite leq_eqVlt subn_eq0 (ltnW niw).
Qed.

Lemma Pareto_optimal_XP : Pareto_optimal p (true_value_strategy p).
Proof.
rewrite /Pareto_optimal /action_on => s' i.
set U := (X in X < _); set U' := (X in _ < X) => ltUU'.
move: (ltUU').
have -> // : 0 < U' -> U' = U; last by rewrite (@leq_ltn_trans U).
  rewrite /U /U' /mech.U /prefs.U /= /auction.U /= !tnth_map /= !tnth_ord_tuple => lt0U'.
  case: ifP => [/eqP iw'|niw']; last by move: lt0U'; rewrite niw'.
  case: ifP => [/eqP iw //|niw].
  apply/eqP; rewrite subn_eq0 /price.
  move: niw.
  rewrite /is_winner /actions tnth_map tnth_ord_tuple leqNgt => /negbFE.
  exact: ltnW.
by rewrite ltnn.
Qed.

Theorem anonymous_XP : auction.anonymous a.
Proof.
rewrite /auction.anonymous => bs i1 i2 w1.
rewrite /auction.is_winner /= !tnth_map tnth_ord_tuple /is_winner in w1 *.
rewrite /auction.price /= !tnth_map !tnth_ord_tuple apermE tpermR.
split=> //; split=> // i [nei1 nei2].
by rewrite !tnth_map !tnth_ord_tuple apermE tpermD 1?eq_sym.
Qed.

End Properties.

(* Print Assumptions truthful_XP. *)
(* Check truthful_XP. *)


Require Import FP.Core.Relations.

Inductive rfunction A B `{! Eqv A ,! Lte A ,! Eqv B ,! Lte B } := RFunction
  { rfun : A -> B
  ; rfun_proper : proper (eqv v⇉ eqv) rfun
  ; rfun_monotonic : proper (lte v⇉ lte) rfun
  }.
Arguments RFunction {A B _ _ _ _} _ _ _.
Arguments rfun {A B _ _ _ _} _ _.
Arguments rfun_proper {A B _ _ _ _} _ x y _.
Arguments rfun_monotonic {A B _ _ _ _} _ x y _.
Infix "r⇒" := rfunction (at level 60, right associativity).
Notation "'rλ'  x .. y → e" :=
  (RFunction (fun x => .. (RFunction (fun y => e) _ _) ..) _ _)
  (x binder, y binder, at level 200, right associativity).

Definition rapply {A B} `{! Eqv A ,! Lte A ,! Eqv B ,! Lte B } (f:A r⇒ B) (x:A) : B := rfun f x.
Infix "r∙" := rapply (at level 20, left associativity).

Definition rrespectful {A B} `{! Eqv A ,! Lte A ,! Eqv B ,! Lte B } (R1:relation A) (R2:relation B) (f g:A r⇒ B) :=
  forall x y, R1 x y -> R2 (f r∙ x) (g r∙ y).
Infix "r⇉" := rrespectful (at level 60, right associativity).

Ltac rproper1 :=
  match goal with
  | [ |- ?x ≃ ?x ] => LibReflexivity
  | [ |- ?x ⊑ ?x ] => Reflexivity ; LibReflexivity
  | [ |- ?f r∙ _ ≃ ?f r∙ _ ] => apply (rfun_proper f)
  | [ |- ?f r∙ _ ⊑ ?f r∙ _ ] => apply (rfun_monotonic f)
  | [ |- (eqv v⇉ eqv) _ _ ] => unfold vrespectful ; intros
  | [ |- (lte v⇉ lte) _ _ ] => unfold vrespectful ; intros
  | [ |- (eqv r⇉ eqv) _ _ ] => unfold rrespectful ; intros
  | [ |- (lte r⇉ lte) _ _ ] => unfold rrespectful ; intros
  | [ H : ?f ≃ ?g |- ?f r∙ _ ≃ ?g r∙ _ ] => apply H
  | [ H : ?f ⊑ ?g |- ?f r∙ _ ⊑ ?g r∙ _ ] => apply H
  | [ H : (eqv r⇉ eqv) ?f ?g |- ?f r∙ _ ≃ ?g r∙ _ ] => apply H
  | [ H : (lte r⇉ lte) ?f ?g |- ?f r∙ _ ⊑ ?g r∙ _ ] => apply H
  | [ H : ?R ?x ?y |- ?R ?x ?y ] => exact H
  end.
Ltac rproper := repeat (simpl ; intros ; repeat rproper1).

Instance : forall A B `{! Eqv A ,! Lte A ,! Eqv B ,! Lte B }, Eqv (A r⇒ B) :=
  { eqv := (eqv r⇉ eqv) }.
Proof.
  constructor ; rproper.
  - Symmetry ; rproper ; Symmetry ; rproper.
  - Transitivity (y r∙ x0) ; rproper.
Defined.

Instance : forall A B `{! Eqv A ,! Lte A ,! Eqv B ,! Lte B }, Lte (A r⇒ B) :=
  { lte := (lte r⇉ lte) }.
Proof.
  constructor ; rproper.
  - Transitivity (y r∙ x0) ; rproper.
    Reflexivity ; rproper.
  - Transitivity (y r∙ x0) ; rproper.
Defined.

Definition rproper_intro {A B} `{! Eqv A ,! Lte A ,! Eqv B ,! Lte B } (f g:A r⇒ B) (p:(eqv r⇉ eqv) f g)
: eqv f g := p.
Definition rproper_elim {A B} `{! Eqv A ,! Lte A ,! Eqv B ,! Lte B } (f g:A r⇒ B) (p:eqv f g)
: (eqv r⇉ eqv) f g := p.

Definition rmonotonic_intro {A B} `{! Eqv A ,! Lte A ,! Eqv B ,! Lte B } (f g:A r⇒ B) (p:(lte r⇉ lte) f g)
: lte f g := p.
Definition rmonotonic_elim {A B} `{! Eqv A ,! Lte A ,! Eqv B ,! Lte B } (f g:A r⇒ B) (p:lte f g)
: (lte r⇉ lte) f g := p.

Ltac rproper2 :=
  rproper1 ||
  match goal with
  | [ |- (rλ _ → _) ≃ _ ] => apply rproper_intro ; unfold "r⇉" ; intros ; simpl
  | [ |- _ ≃ (rλ _ → _) ] => apply rproper_intro ; unfold "r⇉" ; intros ; simpl
  | [ |- (rλ _ → _) ⊑ _ ] => apply rmonotonic_intro ; unfold "r⇉" ; intros ; simpl
  | [ |- _ ⊑ (rλ _ → _) ] => apply rmonotonic_intro ; unfold "r⇉" ; intros ; simpl
  end.
Ltac rproper ::= repeat (simpl ; intros ; repeat rproper2).

Ltac rproper_elim :=
  repeat
  match goal with
  | [ |- _ r∙ _ ≃ _ r∙ _ ] => apply rproper_elim
  | [ |- _ r∙ _ ⊑ _ r∙ _ ] => apply rmonotonic_elim
  end.

Definition rcompose {A B C} `{! Eqv A ,! Lte A ,! Eqv B ,! Lte B ,! Eqv C ,! Lte C }
: ((B r⇒ C) r⇒ (A r⇒ B) r⇒ (A r⇒ C)).
refine( rλ g f x → g r∙ (f r∙ x) ) ; rproper.
Grab Existential Variables. rproper. rproper. rproper. rproper.
Defined.
Infix "r⊙" := rcompose (at level 60, right associativity).

Definition rid {A} `{! Eqv A ,! Lte A } : A r⇒ A.
refine( rλ x → x ) ; rproper.
Defined.
Definition rconst {A B} `{! Eqv A ,! Lte A ,! Eqv B ,! Lte B } : A r⇒ B r⇒ A.
refine( rλ y _ → y ) ; rproper.
Grab Existential Variables. rproper. rproper.
Defined.


(* This  is all definitions for the Y-part of the model and the two days,  to be imported by coqmodel. *)

Inductive Days := d1 | d2.

(*
The Y model!
==========================================================================================
 *)

Inductive VY := y0 | y1.
Inductive EdgeY := y0y0 | y0y1 | y1y0 | y1y1| k.

Inductive TriangleY :=
| y0y0_y0y0_y0y0
| y0y1_y0y1_y0y0
| y1y0_y0y0_y0y1
| y1y1_y0y1_y0y1
| k_y0y1_y0y1
| y0y0_y1y0_y1y0
| y0y1_y1y1_y1y0
| y0y1_k_y1y0
| y1y1_y1y1_y1y1
| y1y1_k_y1y1
| k_y1y1_y1y1
| k_k_y1y1
| y1y0_y1y0_k
| y1y1_y1y1_k
| y1y1_k_k
| k_y1y1_k
| k_k_k
| de
| fi.

(* Y simplical functions *)
Function sY (v1 :VY) := match v1 with
                          | y0 => y0y0
                          | y1 => y1y1
                        end.

Function d0Y (e1 :EdgeY) := match e1 with
                              | y0y0 => y0
                              | y0y1 => y1
                              | y1y0 => y0
                              | y1y1 => y1
                              | k => y1
                            end.

Function d1Y (e1 :EdgeY) := match e1 with
                              | y0y0 => y0
                              | y0y1 => y0
                              | y1y0 => y1
                              | y1y1 => y1
                              | k => y1
                            end.

Function se0Y (e1 :EdgeY) :=
  match e1 with
    | k => k_k_y1y1
    | y0y0 => y0y0_y0y0_y0y0
    | y0y1 => y0y1_y0y1_y0y0
    | y1y0 => de
    | y1y1 => y1y1_y1y1_y1y1
  end.

Function se1Y (e1 :EdgeY) :=
  match e1 with
    | k => y1y1_k_k
    | y0y0 => y0y0_y0y0_y0y0
    | y0y1 => y1y1_y0y1_y0y1
    | y1y0 => y0y0_y1y0_y1y0
    | y1y1 => y1y1_y1y1_y1y1
  end.

Function dp0Y (t1 :TriangleY) :=
  match t1 with
    | y0y0_y0y0_y0y0 => y0y0
    | y0y1_y0y1_y0y0 => y0y1
    | y1y0_y0y0_y0y1 => y1y0
    | y1y1_y0y1_y0y1 => y1y1
    | k_y0y1_y0y1 => k
    | y0y0_y1y0_y1y0 => y0y0
    | y0y1_y1y1_y1y0 => y0y1
    | y0y1_k_y1y0 => y0y1
    | de => y1y0
    | y1y1_y1y1_y1y1 => y1y1
    | y1y1_k_y1y1 => y1y1
    | k_y1y1_y1y1 => k
    | k_k_y1y1 => k
    | y1y0_y1y0_k => y1y0
    | y1y1_y1y1_k => y1y1
    | y1y1_k_k => y1y1
    | k_y1y1_k => k
    | k_k_k => k
    | fi => y1y0
  end.

Function dp1Y (t1 :TriangleY) :=
  match t1 with
    | y0y0_y0y0_y0y0 => y0y0
    | y0y1_y0y1_y0y0 => y0y1
    | y1y0_y0y0_y0y1 => y0y0
    | y1y1_y0y1_y0y1 => y0y1
    | k_y0y1_y0y1 => y0y1
    | y0y0_y1y0_y1y0 => y1y0
    | y0y1_y1y1_y1y0 => y1y1
    | y0y1_k_y1y0 => k
    | de => y1y0
    | y1y1_y1y1_y1y1 => y1y1
    | y1y1_k_y1y1 => k
    | k_y1y1_y1y1 => y1y1
    | k_k_y1y1 => k
    | y1y0_y1y0_k => y1y0
    | y1y1_y1y1_k => y1y1
    | y1y1_k_k => k
    | k_y1y1_k => y1y1
    | k_k_k => k
    | fi => y1y0
  end.

Function dp2Y (t1 :TriangleY) :=
  match t1 with
    | y0y0_y0y0_y0y0 => y0y0
    | y0y1_y0y1_y0y0 => y0y0
    | y1y0_y0y0_y0y1 => y0y1
    | y1y1_y0y1_y0y1 => y0y1
    | k_y0y1_y0y1 => y0y1
    | y0y0_y1y0_y1y0 => y1y0
    | y0y1_y1y1_y1y0 => y1y0
    | y0y1_k_y1y0 => y1y0
    | de => y1y1
    | y1y1_y1y1_y1y1 => y1y1
    | y1y1_k_y1y1 => y1y1
    | k_y1y1_y1y1 => y1y1
    | k_k_y1y1 => y1y1
    | y1y0_y1y0_k => k
    | y1y1_y1y1_k => k
    | y1y1_k_k => k
    | k_y1y1_k => k
    | k_k_k => k
    | fi => y1y1
  end.

(* Y equality. It has to come below the simplicial functions since it is defined in day 2 using them*)
Function eqVY (day : Days)(v1 v2 :VY) :=
  match v1, v2 with
    | y0, y0 => true
    | y0, y1 => false
    | y1, y0 => false
    | y1, y1 => true
  end.

Lemma eqEdgeYDec : forall e1 e2 : EdgeY, {e1 = e2} + {e1 <> e2}.
Proof.
  decide equality.
Defined.

Function sameConstructorEdgeY (e1 e2 :EdgeY) := if (eqEdgeYDec e1 e2) then true else false.

Function eqEdgeY (day : Days)(e1 e2 :EdgeY) :=
  match day with
    | d1 => sameConstructorEdgeY e1 e2
    | d2 =>
      match e1,e2 with
        | y1y1,k | k,y1y1 => true
        | _,_ => sameConstructorEdgeY e1 e2
      end
  end.

Lemma eqtriangleYDec : forall b1 b2 : TriangleY, {b1 = b2} + {b1 <> b2}.
Proof.
  decide equality.
Defined.

Function sameConstructorTriangleY (t1 t2 :TriangleY) := if (eqtriangleYDec t1 t2) then true else false.

Function eqTriangleY (day : Days)(t1 t2 :TriangleY) :=
  match day with
    | d1 => sameConstructorTriangleY t1 t2
    | d2 =>
      match t1,t2 with
        | de,de => true
        | de,_ | _,de => false
        | _,_ => andb (eqEdgeY d2 (dp0Y t1) (dp0Y t2))  (andb (eqEdgeY d2 (dp1Y t1) (dp1Y t2))   (eqEdgeY d2 (dp2Y t1) (dp2Y t2)))
      end
  end.

(* Y filler functions *)

Function fill12Y (e1 e2 :EdgeY) :=
  match e1,e2 with
    |   y0y0,  y1y0=> y0y0_y1y0_y1y0
    |   y1y1,  y0y1=> y1y1_y0y1_y0y1
    |   y0y1,  k=> y0y1_k_y1y0
    |   k,  k=> k_k_y1y1
    |   y1y0,  y1y0=> fi
    |   y0y0,  y0y0=> y0y0_y0y0_y0y0
    |   k,  y1y1=> k_y1y1_y1y1
    |   y1y0,  y0y0=> y1y0_y0y0_y0y1
    |   y0y1,  y0y1=> y0y1_y0y1_y0y0
    |   k,  y0y1=> k_y0y1_y0y1
    |   y0y1,  y1y1=> y0y1_y1y1_y1y0
    |   y1y1,  k=> y1y1_k_y1y1
    |   y1y1,  y1y1=> y1y1_y1y1_y1y1
    | _ ,_ => y0y0_y0y0_y0y0
  end.

Function fill11Y (e1 e2 :EdgeY) :=
  match e1,e2 with
    |   y0y0,  y1y0=> y0y0_y1y0_y1y0
    |   y1y1,  y0y1=> y1y1_y0y1_y0y1
    |   k,  k=> k_y1y1_k
    |   y0y1,  y0y0=> y0y1_y0y1_y0y0
    |   y1y0,  y0y1=> y1y0_y0y0_y0y1
    |   y1y0,  y1y1=> fi
    |   y0y0,  y0y0=> y0y0_y0y0_y0y0
    |   y1y0,  k=> y1y0_y1y0_k
    |   k,  y1y1=> k_y1y1_y1y1
    |   k,  y0y1=> k_y0y1_y0y1
    |   y1y1,  k=> y1y1_y1y1_k
    |   y1y1,  y1y1=> y1y1_y1y1_y1y1
    |   y0y1,  y1y0=> y0y1_y1y1_y1y0
    | _ ,_ => y0y0_y0y0_y0y0
  end.

Function fill10Y (e1 e2 :EdgeY) :=
  match e1,e2 with
    |   k,  k=> y1y1_k_k
    |   y0y1,  y0y0=> y0y1_y0y1_y0y0
    |   y0y0,  y0y1=> y1y0_y0y0_y0y1
    |   k,  y1y0=> y0y1_k_y1y0
    |   y1y0,  y1y0=> y0y0_y1y0_y1y0
    |   y1y0,  y1y1=> fi
    |   y0y0,  y0y0=> y0y0_y0y0_y0y0
    |   y1y0,  k=> y1y0_y1y0_k
    |   k,  y1y1=> y1y1_k_y1y1
    |   y0y1,  y0y1=> y1y1_y0y1_y0y1
    |   y1y1,  k=> y1y1_y1y1_k
    |   y1y1,  y1y1=> y1y1_y1y1_y1y1
    |   y1y1,  y1y0=> y0y1_y1y1_y1y0
    | _ ,_ => y0y0_y0y0_y0y0
  end.

(* Maps triangle-compatible edges a b c to a triangle t which have d0 t = a, d1 t = b and
d2t = c. For the choice between de and fi it maps to fi. It maps every tupple of
non-compatible edges to y0y0_y0y0_y0y0 for no particular reason. *)

Function edgesToTriangle(d0 d1 d2 :EdgeY) :=
  match d0,d1,d2 with
    | y0y0, y0y0, y0y0 => y0y0_y0y0_y0y0
    | y0y1, y0y1, y0y0 => y0y1_y0y1_y0y0
    | y1y0, y0y0, y0y1 => y1y0_y0y0_y0y1
    | y1y1, y0y1, y0y1 => y1y1_y0y1_y0y1
    | k, y0y1, y0y1 => k_y0y1_y0y1
    | y0y0, y1y0, y1y0 => y0y0_y1y0_y1y0
    | y0y1, y1y1, y1y0 => y0y1_y1y1_y1y0
    | y0y1, k, y1y0 => y0y1_k_y1y0
    | y1y1, y1y1, y1y1 => y1y1_y1y1_y1y1
    | y1y1, k, y1y1 => y1y1_k_y1y1
    | k, y1y1, y1y1 => k_y1y1_y1y1
    | k, k, y1y1 => k_k_y1y1
    | y1y0, y1y0, k => y1y0_y1y0_k
    | y1y1, y1y1, k => y1y1_y1y1_k
    | y1y1, k, k => y1y1_k_k
    | k, y1y1, k => k_y1y1_k
    | k, k, k => k_k_k
    | y1y0, y1y0, y1y1 => fi
    |  _,  _,_ => y0y0_y0y0_y0y0
  end.

Function fill20Y (t1 t2 t3 :TriangleY) := (edgesToTriangle (dp0Y t1) (dp0Y t2) (dp0Y t3)).
Function fill21Y (t1 t2 t3 :TriangleY) := (edgesToTriangle (dp0Y t1) (dp1Y t2) (dp1Y t3)).
Function fill22Y (t1 t2 t3 :TriangleY) := (edgesToTriangle (dp1Y t1) (dp1Y t2) (dp2Y t3)).
Function fill23Y (t1 t2 t3 :TriangleY) := (edgesToTriangle (dp2Y t1) (dp2Y t2) (dp2Y t3)).

(* End Y model *)


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**
   fermat.
   Fermat's little theorem.

   @author Martijn Oostdijk
   @version $Revision: 788 $
 *)

Require Import Arith.
Require Import ZArith.

Require Import lemmas.
Require Import natZ.
Require Import dec.
Require Import list.
Require Import exp.
Require Import divides.
Require Import prime.
Require Import modulo.
Require Import modprime.

(** * No double elements modulo p. *)

Definition nodoubles (p : nat) (l : Zlist) : Prop :=
  forall x : Z,
  inlist Z x l -> forall y : Z, inlist Z y (zdrop x l) -> ~ Mod x y p.

Lemma nodoubles_nil : forall p : nat, nodoubles p (Nil Z).
Proof.
   unfold nodoubles in |- *. simpl in |- *. intros. elim H0.
Qed.

Lemma nodoubles_drop :
 forall (p : nat) (l : Zlist) (x : Z),
 nodoubles p l -> nodoubles p (zdrop x l).
Proof.
   unfold nodoubles in |- *. intros. apply H.
   apply zdrop_inlist_weak with x. assumption.
   apply zdrop_inlist_weak with x. rewrite zdrop_swap. assumption.
Qed.

Lemma nodoubles_ind :
 forall (p : nat) (h : Z) (t : Zlist),
 (forall x : Z, inlist Z x t -> ~ Mod h x p) ->
 nodoubles p t -> nodoubles p (Cons Z h t).
Proof.
   intros. unfold nodoubles in |- *. intros.
   elim (zeqdec x h).
   intro. rewrite zdrop_head_eq in H2.
   rewrite H3. apply (H y). assumption. assumption.
   intro. rewrite zdrop_head_neq in H2.
   elim (zeqdec y h).
   intro. rewrite H4. intro. elim (H x).
   elim (inlist_head_neq Z x h t). intros.
   apply H6. assumption. assumption.
   apply mod_sym. assumption.
   intro. unfold nodoubles in H0.
   apply (H0 x).
   elim (inlist_head_neq Z x h t). intros.
   apply H5. assumption. assumption.
   elim (inlist_head_neq Z y h (zdrop x t)). intros.
   apply H5. assumption. assumption.
   assumption.
Qed.

(** * All elements from l1 occur in l2 modulo p. *)

Definition allex (p : nat) (l0 l1 : Zlist) : Prop :=
  forall x : Z, inlist Z x l0 -> exists y : Z, inlist Z y l1 /\ Mod x y p.

Lemma allex_nodoubles_drop :
 forall (p : nat) (l0 l1 : Zlist) (x0 x1 : Z),
 Prime p ->
 Mod x0 x1 p ->
 inlist Z x0 l0 ->
 inlist Z x1 l1 ->
 nodoubles p l0 -> allex p l0 l1 -> allex p (zdrop x0 l0) (zdrop x1 l1).
Proof.
   intros.
   unfold allex in |- *. intros x Hx.
   elim (H4 x). intros y Hy.
   elim Hy. intros.
   split with y.
   split. apply zdrop_neq_inlist.
   intro. rewrite H7 in H6.
   elim H3 with x x0.
   apply zdrop_inlist_weak with x0. assumption.
   apply zdrop_inlist_swap. assumption. assumption.
   apply mod_trans with x1. assumption.
   apply mod_sym. assumption.
   assumption. assumption.
   apply zdrop_inlist_weak with x0. assumption.
Qed.

(** * The list of integers between 1 and n (inclusive) *)

Fixpoint until (n : nat) : Zlist :=
  match n with
  | O => Nil Z
  | S n => Cons Z (Z_of_nat (S n)) (until n)
  end.

Lemma until_ok :
 forall (n : nat) (x : Z), (0 < x <= Z_of_nat n)%Z -> inlist Z x (until n).
Proof.
   simple induction n.
   simpl in |- *. intros. elim H. intros.
   elim (Zle_not_lt x 0). assumption. assumption.
   intros m IH. intros. elim H. intros.
   elim (Zle_lt_or_eq x (Z_of_nat (S m))).
   intros. unfold inlist in |- *. simpl in |- *. right. unfold inlist in IH.
   apply IH. split. assumption.
   apply Zlt_succ_le. rewrite <- Znat.inj_S. assumption.
   intro. rewrite H2. unfold inlist in |- *.
   simpl in |- *. left. reflexivity. assumption.
Qed.

Lemma until_mod_all :
 forall (p : nat) (x : Z),
 0 < p ->
 ~ Mod x 0 p -> exists y : Z, inlist Z y (until (pred p)) /\ Mod x y p.
Proof.
   intros.
   elim (zdiv_rem (Z_of_nat p) x).
   intro q. intros.
   elim H1. intro r. intros.
   elim H2. intros. elim H3. intros.
   elim (Zle_lt_or_eq 0 r).

   (* case 0 < r *)
   intro. split with r. split.
   apply until_ok. split.
   assumption.
   apply Zlt_succ_le. rewrite <- Znat.inj_S. rewrite <- (S_pred p 0).
   assumption. assumption.
   split with q. rewrite Zplus_comm. rewrite Zmult_comm. assumption.

   (* case 0 = r *)
   intro. elim H0. split with q.
   rewrite H7. rewrite Zplus_comm. rewrite Zmult_comm. assumption.

   assumption.
   change (Z_of_nat p > Z_of_nat 0)%Z in |- *. apply Znat.inj_gt. assumption.
Qed.

Lemma until_pos : forall (n : nat) (x : Z), inlist Z x (until n) -> (0 < x)%Z.
Proof.
   simple induction n.
   unfold inlist in |- *. simpl in |- *. intros. elim H.
   intros m IH. intros. unfold inlist in H. simpl in H. elim H. intros.
   rewrite H0. unfold Zlt in |- *. simpl in |- *. reflexivity.
   intros. apply IH. assumption.
Qed.

Lemma until_le_n :
 forall (n : nat) (x : Z), inlist Z x (until n) -> (x <= Z_of_nat n)%Z.
Proof.
   simple induction n.
   unfold inlist in |- *. simpl in |- *. intros. elim H.
   intros m IH. intros. unfold inlist in H. simpl in H. elim H. intros.
   rewrite H0. apply Zle_refl.
   intros. apply Zle_trans with (Z_of_nat m).
   apply IH. assumption. apply Znat.inj_le. apply le_S. apply le_n.
Qed.

Lemma until_not_0mod :
 forall (p : nat) (x : Z),
 0 < p -> inlist Z x (until (pred p)) -> ~ Mod x 0 p.
Proof.
   intros. apply mod_repr_non_0. split.
   apply (until_pos (pred p) x). assumption.
   rewrite (S_pred p 0). rewrite Znat.inj_S.
   apply Zle_lt_succ. apply until_le_n.
   assumption. assumption.
Qed.

Lemma untiln_prod_not_0modp :
 forall p n : nat,
 0 < n -> n < p -> Prime p -> ~ Mod (zproduct (until n)) 0 p.
Proof.
   simple induction n.
   intro. elim (lt_irrefl 0). assumption.
   intros m IH H0m Hmp Hp.
   change (~ Mod (Z_of_nat (S m) * zproduct (until m)) 0 p) in |- *.
   intro. elim (mod_mult_0 p (Z_of_nat (S m)) (zproduct (until m))).
   intro. elim (mod_repr_non_0 p (Z_of_nat (S m))). split.
   change (Z_of_nat 0 < Z_of_nat (S m))%Z in |- *.
   apply Znat.inj_lt. assumption.
   apply Znat.inj_lt. assumption.
   assumption.
   intro. elim (le_lt_or_eq 0 m). intro.
   elim IH. assumption. apply lt_trans with (S m).
   apply lt_n_Sn. assumption. assumption.
   assumption. intro. rewrite <- H1 in H. simpl in H.
   elim mod_0not1 with p. elim Hp. intros. assumption.
   apply mod_sym. assumption.
   apply le_O_n. assumption.
   assumption.
Qed.

Lemma until_prod_not_0mod :
 forall p : nat, Prime p -> ~ Mod (zproduct (until (pred p))) 0 p.
Proof.
   intros. elim H. intros.
   apply untiln_prod_not_0modp; auto with arith.
Qed.

Lemma until_mapmult_exp :
 forall (a : Z) (n : nat),
 zproduct (mapmult a (until n)) = (Exp a n * zproduct (until n))%Z.
Proof.
   simple induction n.
   simpl in |- *. reflexivity.
   intros m IH.
   replace (mapmult a (until (S m))) with
    (Cons Z (a * Z_of_nat (S m))%Z (mapmult a (until m))).
   rewrite exp_S.
   replace (zproduct (Cons Z (a * Z_of_nat (S m))%Z (mapmult a (until m))))
    with (a * Z_of_nat (S m) * zproduct (mapmult a (until m)))%Z.
   rewrite IH. rewrite Zmult_assoc_reverse.
   rewrite (Zmult_assoc (Z_of_nat (S m)) (Exp a m)).
   rewrite (Zmult_comm (Z_of_nat (S m))).
   rewrite Zmult_assoc. rewrite Zmult_assoc.
   replace (zproduct (until (S m))) with
    (Z_of_nat (S m) * zproduct (until m))%Z.
   rewrite Zmult_assoc. reflexivity.
   reflexivity. reflexivity. reflexivity.
Qed.

Lemma until_mapmult_allex :
 forall (p : nat) (a : Z),
 Prime p ->
 ~ Mod a 0 p -> allex p (until (pred p)) (mapmult a (until (pred p))).
Proof.
   unfold allex in |- *.
   intros p a Hprime Ha0 x Hx. elim Hprime. intros Hp Hp1.
   elim (mod_mult_inv_r a p). intros ra Hra.
   elim (zdiv_rem (Z_of_nat p) (ra * x)). intros q Hq. elim Hq.
   intros r Hr. elim Hr. intros. elim H. intros.
   split with (a * r)%Z.
   split. apply mapmult_image. apply until_ok.
   split. elim (Zle_lt_or_eq 0 r). intro. assumption.
   intro. rewrite <- H3 in H0. rewrite <- Zplus_0_r_reverse in H0.
   elim until_not_0mod with p x.
   apply lt_trans with 1. apply lt_n_Sn. assumption.
   assumption.
   apply mod_mult_cancel_r with (a * ra)%Z. assumption.
   intro. elim mod_0not1 with p. assumption.
   apply mod_trans with (a * ra)%Z. apply mod_sym. assumption. assumption.
   rewrite (Zmult_comm a ra). rewrite Zmult_assoc. rewrite (Zmult_comm x ra).
   rewrite H0. simpl in |- *. unfold Mod in |- *. split with (q * a)%Z. simpl in |- *.
   rewrite Zmult_assoc. rewrite (Zmult_comm q). reflexivity.
   assumption. apply Zlt_succ_le.
   rewrite <- Znat.inj_S. rewrite <- (S_pred p 1). assumption.
   assumption.
   apply mod_mult_cancel_r with ra. assumption.
   intro. elim mod_0not1 with p. assumption.
   apply mod_trans with (ra * a)%Z. change (Mod (0 * a) (ra * a) p) in |- *.
   apply mod_mult_compat. apply mod_sym. assumption.
   apply mod_refl. rewrite (Zmult_comm ra a). assumption.
   rewrite (Zmult_comm x ra). rewrite H0.
   rewrite (Zmult_comm a r). rewrite (Zmult_assoc_reverse r a ra).
   apply mod_trans with r. split with q.
   rewrite Zplus_comm. rewrite Zmult_comm. reflexivity.
   pattern r at 1 in |- *. rewrite <- Zmult_1_l with r.
   rewrite (Zmult_comm 1 r). apply mod_mult_compat.
   apply mod_refl. apply mod_sym. assumption.
   change (Z_of_nat p > Z_of_nat 0)%Z in |- *. apply Znat.inj_gt.
   apply gt_trans with 1. assumption. apply gt_Sn_n.
   assumption. assumption.
Qed.

Lemma until_nodoubles1 :
 forall p : nat, Prime p -> forall n : nat, n < p -> nodoubles p (until n).
Proof.
   simple induction n.
   intros. simpl in |- *. apply nodoubles_nil.
   intros m IH Hb.
   change (nodoubles p (Cons Z (Z_of_nat (S m)) (until m))) in |- *.
   apply nodoubles_ind. intros.
   intro. elim (Zlt_not_le x (Z_of_nat (S m))).
   rewrite Znat.inj_S. apply Zle_lt_succ. apply until_le_n.
   assumption. apply Zeq_le. apply mod_repr_eq with p.
   elim H. intros. apply lt_trans with 1. apply lt_n_Sn. assumption.
   split. change (Z_of_nat 0 < Z_of_nat (S m))%Z in |- *. apply Znat.inj_lt.
   apply lt_O_Sn. apply Znat.inj_lt. assumption.
   split. apply until_pos with m. assumption.
   apply Zle_lt_trans with (Z_of_nat m).
   apply until_le_n. assumption.
   apply Znat.inj_lt. apply le_lt_trans with (S m).
   apply le_n_Sn. assumption.
   assumption.
   apply IH. apply le_lt_trans with (S m).
   apply le_n_Sn. assumption.
Qed.

Lemma until_nodoubles :
 forall p : nat, Prime p -> nodoubles p (until (pred p)).
Proof.
   intros. apply until_nodoubles1. assumption.
   apply lt_pred_n_n. apply lt_trans with 1.
   apply lt_n_Sn. elim H. intros. assumption.
Qed.

(** * Permutations modulo p. *)

Fixpoint permmod (p : nat) (l1 : Zlist) {struct l1} :
 Zlist -> Prop :=
  fun l2 : Zlist =>
  match l1 with
  | Nil => l2 = Nil Z
  | Cons x t =>
      exists y : Z, inlist Z y l2 /\ Mod x y p /\ permmod p t (zdrop y l2)
  end.

Lemma permmod_nil : forall p : nat, permmod p (Nil Z) (Nil Z).
Proof.
   simpl in |- *. intro. reflexivity.
Qed.

Lemma permmod_drop :
 forall (p : nat) (x1 x2 : Z) (l1 l2 : Zlist),
 Mod x1 x2 p ->
 inlist Z x1 l1 ->
 inlist Z x2 l2 -> permmod p (zdrop x1 l1) (zdrop x2 l2) -> permmod p l1 l2.
Proof.
   simple induction l1.
   simpl in |- *. intros. elim H0.
   intros h t IH. intros l2 Hm.
   elim (zeqdec x1 h).
   intros. simpl in |- *. split with x2.
   split. assumption.
   split. rewrite <- H. assumption.
   rewrite H in H2. rewrite zdrop_head_eq in H2.
   assumption. reflexivity.
   intro.
   rewrite zdrop_head_neq.
   intros. elim H2. intros y Hy.
   elim Hy. intros. elim H4. intros.
   split with y. split.
   apply zdrop_inlist_weak with x2. assumption.
   split. assumption.
   rewrite zdrop_swap in H6.
   apply IH. assumption.
   elim (inlist_head_neq Z x1 h t). intros. apply H7. assumption.
   assumption.
   elim (zeqdec x2 y).
   intro. rewrite H7. rewrite H7 in H3. assumption.
   intro. apply zdrop_neq_inlist. assumption. assumption.
   assumption. assumption.
Qed.

Lemma permmod_drop_cons :
 forall (p : nat) (x1 x2 : Z) (t1 l2 : Zlist),
 Mod x1 x2 p ->
 inlist Z x2 l2 -> permmod p t1 (zdrop x2 l2) -> permmod p (Cons Z x1 t1) l2.
Proof.
   intros. apply permmod_drop with x1 x2.
   assumption.
   apply inlist_head_eq. reflexivity.
   assumption.
   rewrite zdrop_head_eq. assumption.
   reflexivity.
Qed.

Lemma permmod_cons_extend :
 forall (p : nat) (x1 x2 : Z) (l1 l2 : Zlist),
 permmod p l1 l2 -> Mod x1 x2 p -> permmod p (Cons Z x1 l1) (Cons Z x2 l2).
Proof.
   intros.
   apply permmod_drop with x1 x2.
   assumption.
   apply inlist_head_eq. reflexivity.
   apply inlist_head_eq. reflexivity.
   rewrite zdrop_head_eq. rewrite zdrop_head_eq.
   assumption. reflexivity. reflexivity.
Qed.

Lemma permmod_length :
 forall (p : nat) (l1 l2 : Zlist),
 permmod p l1 l2 -> length Z l1 = length Z l2.
Proof.
   simple induction l1.
   simpl in |- *. intros. rewrite H. simpl in |- *. reflexivity.
   intros h t IH. simpl in |- *. intros.
   elim H. intros y Hy.  elim Hy. intros.
   elim H1. intros.
   rewrite (IH (zdrop y l2)).
   rewrite zdrop_length with y l2.
   reflexivity. assumption. assumption.
Qed.

Lemma permmod_refl : forall (p : nat) (l : Zlist), permmod p l l.
Proof.
   simple induction l.
   simpl in |- *. reflexivity.
   intros h t IH. split with h.
   split. apply inlist_head_eq. reflexivity.
   split. apply mod_refl.
   rewrite zdrop_head_eq. assumption. reflexivity.
Qed.

Lemma permmod_sym :
 forall (p : nat) (l1 l2 : Zlist), permmod p l1 l2 -> permmod p l2 l1.
Proof.
   simple induction l1.
   simpl in |- *. intros. rewrite H. apply permmod_nil.
   intros h1 t1 IH1.
   intros. elim H. intros y Hy.
   elim Hy. intros. elim H1. intros.
   apply permmod_drop with y h1.
   apply mod_sym. assumption.
   assumption.
   apply inlist_head_eq. reflexivity.
   rewrite zdrop_head_eq. apply IH1.
   assumption.
   reflexivity.
Qed.

Lemma permmod_product :
 forall (l0 l1 : Zlist) (p : nat),
 permmod p l0 l1 -> Mod (zproduct l0) (zproduct l1) p.
Proof.
   simple induction l0.
   simpl in |- *. intros. rewrite H. simpl in |- *. apply mod_refl.
   intros h t IH. intros.
   elim H. intros. elim H0. intros. elim H2. intros.
   simpl in |- *. rewrite <- zdrop_product with x l1.
   apply mod_mult_compat.
   assumption.
   apply IH. assumption.
   assumption.
Qed.

Lemma allex_permmod :
 forall (p : nat) (l0 l1 : Zlist),
 length Z l0 = length Z l1 ->
 (forall x0 : Z,
  inlist Z x0 l0 ->
  exists x1 : Z,
    inlist Z x1 l1 /\ Mod x0 x1 p /\ permmod p (zdrop x0 l0) (zdrop x1 l1)) ->
 permmod p l0 l1.
Proof.
   simple induction l0.
   simple induction l1.
   intros. apply permmod_nil.
   intros. discriminate H0.
   intros h0 t0 IH0. intros.
   elim (H0 h0). intro x1. intros.
   elim H1. intros. elim H3. intros.
   rewrite zdrop_head_eq in H5.
   apply permmod_drop_cons with x1.
   assumption. assumption. assumption.
   reflexivity.
   apply inlist_head_eq. reflexivity.
Qed.

Lemma permmod_allex :
 forall (p : nat) (l0 l1 : Zlist),
 permmod p l0 l1 ->
 forall x : Z,
 inlist Z x l0 ->
 exists y : Z,
   inlist Z y l1 /\ Mod x y p /\ permmod p (zdrop x l0) (zdrop y l1).
Proof.
   simple induction l0.
   intros. elim H0.
   intros h0 t0 IH0. intros.
   elim H. intros h1 Hh1.
   elim Hh1. intros. elim H2. intros.
   elim (zeqdec x h0).
   intro. split with h1.
   split. assumption.
   split. rewrite H5. assumption.
   rewrite zdrop_head_eq. assumption. assumption.
   intro. elim (IH0 (zdrop h1 l1) H4 x).
   intros y Hy. elim Hy. intros. elim H7. intros.
   split with y.
   split. apply zdrop_inlist_weak with h1. assumption.
   split. assumption.
   rewrite zdrop_head_neq. split with h1.
   split. elim (zeqdec h1 y).
   intro. rewrite H10 in H6. rewrite H10. assumption.
   intro. apply zdrop_neq_inlist. assumption. assumption.
   split. assumption. rewrite zdrop_swap. assumption.
   assumption. elim (inlist_head_neq Z x h0 t0).
   intros. apply H6. assumption. assumption.
Qed.

Lemma permmod_trans1 :
 forall (n p : nat) (l0 l1 l2 : Zlist),
 length Z l0 = n ->
 length Z l1 = n ->
 length Z l2 = n -> permmod p l0 l1 -> permmod p l1 l2 -> permmod p l0 l2.
Proof.
   simple induction n.
   intros.
   rewrite length_0 with Z l0.
   rewrite length_0 with Z l2.
   apply permmod_nil. assumption. assumption.
   intros m IH.
   intros p l0 l1 l2 Hl0 Hl1 Hl2 H01 H12.
   apply allex_permmod. transitivity (length Z l1).
   apply permmod_length with p. assumption.
   apply permmod_length with p. assumption.
   intros x0 Hx0.
   elim (permmod_allex p l0 l1 H01 x0). intros x1 H0.
   elim H0. intros Hx1 H1. elim H1. intros Hm01 Hd01.
   elim (permmod_allex p l1 l2 H12 x1). intros x2 H2.
   elim H2. intros Hx2 H3. elim H3. intros Hm12 Hd12.
   split with x2.
   split. assumption.
   split. apply mod_trans with x1. assumption. assumption.
   apply IH with (zdrop x1 l1).
   apply S_inj. rewrite zdrop_length. assumption. assumption.
   apply S_inj. rewrite zdrop_length. assumption. assumption.
   apply S_inj. rewrite zdrop_length. assumption. assumption.
   assumption. assumption.
   assumption. assumption.
Qed.

Lemma permmod_trans :
 forall (p : nat) (l0 l1 l2 : Zlist),
 permmod p l0 l1 -> permmod p l1 l2 -> permmod p l0 l2.
Proof.
   intros. apply permmod_trans1 with (length Z l0) l1.
   reflexivity.
   symmetry  in |- *. apply permmod_length with p. assumption.
   symmetry  in |- *. transitivity (length Z l1).
   apply permmod_length with p. assumption.
   apply permmod_length with p. assumption.
   assumption. assumption.
Qed.

Lemma permmod_drop_drop1 :
 forall (n p : nat) (x y : Z) (l : Zlist),
 n = length Z l ->
 Mod x y p ->
 inlist Z x l -> inlist Z y l -> permmod p (zdrop x l) (zdrop y l).
Proof.
   simple induction n.
   intros. rewrite length_0 with Z l.
   simpl in |- *. reflexivity. symmetry  in |- *. assumption.
   intros m IH. intros.
   elim (zeqdec x y).
   intro. rewrite H3. apply permmod_refl.
   intro. apply allex_permmod.
   apply S_inj.
   rewrite zdrop_length. rewrite zdrop_length.
   reflexivity. assumption. assumption.
   intros z Hz.
   elim (zeqdec y z).
   intro. split with x.
   split. apply zdrop_neq_inlist. assumption. assumption.
   split. rewrite <- H4. apply mod_sym. assumption.
   rewrite H4. rewrite zdrop_swap. apply permmod_refl.
   intro. split with z.
   split. apply zdrop_neq_inlist.
   intro. apply H4. symmetry  in |- *. assumption.
   apply zdrop_inlist_weak with x. assumption.
   split. apply mod_refl.
   rewrite (zdrop_swap z). rewrite (zdrop_swap z).
   apply (IH p x y (zdrop z l)).
   apply S_inj. rewrite zdrop_length. assumption.
   apply zdrop_inlist_weak with x. assumption.
   assumption.
   apply zdrop_inlist_swap. assumption. assumption.
   apply zdrop_neq_inlist. assumption. assumption.
Qed.

Lemma permmod_drop_drop :
 forall (p : nat) (x y : Z) (l : Zlist),
 Mod x y p ->
 inlist Z x l -> inlist Z y l -> permmod p (zdrop x l) (zdrop y l).
Proof.
   intros. apply permmod_drop_drop1 with (length Z l).
   reflexivity. assumption. assumption. assumption.
Qed.

Lemma permmod_drop_rev :
 forall (p : nat) (l0 l1 : Zlist) (x0 x1 : Z),
 Mod x0 x1 p ->
 inlist Z x0 l0 ->
 inlist Z x1 l1 -> permmod p l0 l1 -> permmod p (zdrop x0 l0) (zdrop x1 l1).
Proof.
   intros. elim (permmod_allex p l0 l1 H2 x0).
   intros y Hy. elim Hy. intros. elim H4. intros.
   apply permmod_trans with (zdrop y l1). assumption.
   apply permmod_drop_drop.
   apply mod_trans with x0. apply mod_sym. assumption.
   assumption. assumption. assumption. assumption.
Qed.

Lemma nodoubles_allex_permmod1 :
 forall (n p : nat) (l0 l1 : Zlist),
 n = length Z l0 ->
 n = length Z l1 ->
 Prime p ->
 length Z l0 = length Z l1 ->
 nodoubles p l0 -> allex p l0 l1 -> permmod p l0 l1.
Proof.
   simple induction n.
   intros.
   rewrite length_0 with Z l0.
   rewrite length_0 with Z l1.
   apply permmod_nil.
   symmetry  in |- *. assumption. symmetry  in |- *. assumption.
   intros m IH. intros.
   apply allex_permmod.
   assumption.
   intros x Hx. elim H4 with x.
   intros y Hy. elim Hy. intros.
   split with y.
   split. assumption.
   split. assumption.
   apply IH.
   apply S_inj. rewrite zdrop_length. assumption.
   assumption.
   apply S_inj. rewrite zdrop_length. assumption.
   assumption.
   assumption.
   apply S_inj. rewrite zdrop_length.
   rewrite zdrop_length. assumption.
   assumption. assumption.
   apply nodoubles_drop. assumption.
   apply allex_nodoubles_drop.
   assumption. assumption. assumption. assumption.
   assumption. assumption. assumption.
Qed.

Lemma nodoubles_allex_permmod :
 forall (p : nat) (l0 l1 : Zlist),
 Prime p ->
 length Z l0 = length Z l1 ->
 nodoubles p l0 -> allex p l0 l1 -> permmod p l0 l1.
Proof.
   intros. apply nodoubles_allex_permmod1 with (length Z l0).
   reflexivity. assumption. assumption. assumption.
   assumption. assumption.
Qed.

Lemma until_mapmult_permmod :
 forall (p : nat) (a : Z),
 Prime p ->
 ~ Mod a 0 p -> permmod p (until (pred p)) (mapmult a (until (pred p))).
Proof.
   intros.
   apply nodoubles_allex_permmod.
   assumption. unfold mapmult in |- *. apply map_length.
   apply until_nodoubles. assumption.
   unfold allex in |- *. intros.
   apply (until_mapmult_allex p a H H0).
   assumption.
Qed.

(** * Fermat's Little Theorem. *)

Theorem flt :
 forall (a : Z) (p : nat), Prime p -> ~ Mod a 0 p -> Mod (Exp a (pred p)) 1 p.
Proof.
   intros. apply mod_sym.
   apply mod_mult_cancel_r with (zproduct (until (pred p))).
   assumption. apply until_prod_not_0mod. assumption.
   rewrite <- until_mapmult_exp. rewrite Zmult_1_l.
   apply permmod_product. apply until_mapmult_permmod.
   assumption. assumption.
Qed.