From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype tuple.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Prop and Type *)

Lemma sig_exists A (P : A -> Prop) :
  {x : A | P x} -> exists x : A, P x.
Proof.
case=> x px.
by exists x.
Qed.

Definition exists_sig A (P : A -> Prop) :
  (exists x : A, P x) ->
  {x : A | P x}.
Proof.
Fail case=> x px.
(**
Error: ...
Case analysis on sort [Type] is not allowed
for inductive definition [ex].
*)
Abort.
(** Recall that [exists x : A, P x] is a notation
    for [ex P] *)
Check ex :  forall A : Type, (A -> Prop) -> Prop.
Check sig : forall A : Type, (A -> Prop) -> Type.

(** This happens because [ex] lives in [Prop] --
    the universe of logical proposititons and
    [sig] belongs to [Type] -- the universe of
    computations.
    If Coq wants to stay compatible with classical
    logic it needs to prohibit information flow
    from [Prop] to [Type].
    In other words, one can use proofs _only_ to
    build other proofs.
*)

(** ** But why exactly this restriction? *)

(** First of all, we should mention that [Prop]
    is _impredicative_, meaning the following
    typechecks just fine:
 *)
Section Impredicativity.

Check (forall P : Prop, P) : Prop.

(**
This formula quantifies over all formulas,
including itself:
 *)

Variable p : (forall P : Prop, P).
Check p (forall P : Prop, P).

End Impredicativity.

Section TypeInType.
(** But what about [Type]? Doesn't it have
    the same property?  *)

Check (forall P : Type, P) : Type.

(** Well, no. [Type] is not a primitive universe,
    in fact, it's a family of indexed universes
    but the indices are hidden by default.
    We can recover those like so: *)

Set Printing Universes.
Check (forall P : Type, P) : Type.
(**
(forall P : Type@{Top.246}, P) : Type@{Top.245}
     : Type@{Top.245}
(* {Top.246 Top.245} |= Top.246 < Top.245 *)
*)

(** To make this more readable we can declare
    explicit universe levels: *)
Universe i j.
Check (forall P : Type@{i}, P) : ( Type@{j} ).
(** Coq infers [i < j] in this case, so following
    predictably fails: *)
Fail Check (forall P : Type@{i}, P) : ( Type@{i} ).
(**
universe inconsistency:
Cannot enforce i < i because i = i.
*)

(** This restriction prevents us from getting
    the so-called "type-in-type" paradox --
    had we not introduced this hierarchy of
    universes we would get
    [Type : Type] which leads to inconsistency
    as famously shown by Girard.
 *)

Check Type@{i}.
(** Type@{i} : Type@{i+1} *)

(** Some more examples: *)

Check nat.
(** nat : Set *)

Check Set.
(** Set : Type@{Set+1} *)

Check Prop.
(** Prop : Type@{Set+1} *)

Unset Printing Universes.
End TypeInType.

(** * Large elimination *)

(**
Next, let's look at _large elimination_
Large elimination is the ability to build values
of type [Type] by eliminating an inductive value.

We used it to prove the disjointness of constructors
in Lecture 03:
*)

Definition false_implies_False_term :
  false = true -> False
:=
  fun     eq :  false = true =>
    match eq in (_    = b)
             return (if b then False else True)
                    (* ^^^^^^^^^^^^^^^^^^^^^^^ *)
                    (* large elimination       *)
    with
    | erefl => I
    end.

(** Now, Coq is known to be consistent with the
    Law of Excluded Middle, i.e. the following
    axiom can be safely added
 *)

Axiom LEM : forall P : Prop, P \/ ~ P.

(** But, as shown by Berardi in the 1990s,
  impredicativity + excluded middle
  => proof irrelevance

See the paper "Proof-irrelevance out of
Excluded-middle and Choice in the Calculus of
Constructions" - F. Barbanera, S. Berardi(1996)
 *)

(** Had we not prohibited large elimination for
    the impredicative universe [Prop],
    we would get a means to proving disjointness
    of constructors, i.e. that proofs can differ
    from each other. *)
Inductive Bool : Prop := T : Bool | F : Bool.

Fail Definition prf_rel_Bool (Eq : T = F) : False :=
  match Eq in (_ = y)
        return (match y with
                | T => True
                | F => False
                end)
  with
  | eq_refl => I
  end.

(** no large elimination for [Prop] *)
Fail Check match F with T => True | F => False end.

(** no such restriction for [Type] *)
Check
  match false with true => True | false => False end.

(**
  Upshot:
  proof irrelevance + large elimination
  => False

  Hence
  impredicative [Prop] + large elimination + excluded middle
  => False

  Overall, this lets [Prop] be impredicative
  and Coq compatible with the law of excluded
  middle, which is commonly used in mathematics.

  See also https://github.com/FStarLang/FStar/issues/360

*)

(** It's now easy to see that some exceptions
    that won't result in proof _relevance_
    are fine:
 *)
Definition False_to_nat (prf : False) : nat :=
  match prf with end.

Definition true_to_nat (prf : True) : nat :=
  match prf with | I => 0 end.

(** The above examples work because
    the corresponding inductive types have only
    zero or one constructors, i.e. not enough
    to prove the disjointness *)

Fail Definition or_to_nat (prf : True \/ True) : nat :=
  match prf with
  | or_introl _ => 0
  | or_intror _ => 1
  end.
(**
Incorrect elimination of "prf" in the inductive type "or":
the return type has sort "Set" while it should be "Prop".
Elimination of an inductive object of sort Prop
is not allowed on a predicate in sort Set
because proofs can be eliminated only to build proofs.
*)

(** * Totality and termination *)

(** There is a plugin to control
    - the guardedness check,
    - strict positivity rule, and
    - universe inconsistency check
    It's not needed with the latest
    versions of Coq (8.10+).
    For Coq versions 8.7 - 8.9 it can be installed
    with opam package manager:
      opam install coq-typing-flags
    or compiled manually using instructions from
    the plugin's homepage:
    https://github.com/SimonBoulier/TypingFlags
    To start using the plugin in a Coq file:
      From TypingFlags Require Import Loader.
    This adds
    Set Type In Type / Unset Type In Type
    and
    Set Guard Checking / Unset Guard Checking.
    vernacular commands.
 *)

From TypingFlags Require Import Loader.

(** We already mentioned earlier that
    Coq is a total language.
    This ensures its consistency as a logic
    because it rules out things like the following:
 *)

(** Disable termination checker *)
Unset Guard Checking.

Fixpoint proof_of_False (n : nat) : False :=
  proof_of_False n.

Check proof_of_False 0 : False.

(** The following vernacular reveals that
    the proof of falsehood was obtained due to
    bypassing of one of the checkers *)
Print Assumptions proof_of_False.
(** Axioms:
    proof_of_False is positive. *)

(** Remark: Coq's implementation does not enforce
    _strong_ normalization, only weak one *)

(** Enable termination checker again *)
Set Guard Checking.

Fixpoint weak_normalization (n : nat) : nat :=
  let bar := weak_normalization n in
  0.

Print Assumptions weak_normalization.
(** [Closed under the global context]
    This means neither axioms were used nor any checker was disabled *)

(** * Intermezzo: [interleave] function *)

(** ** Elegant, but non-structurally recursive [interleave] function *)

Unset Guard Checking.
Fixpoint interleave_ns {T} (xs ys : seq T)
           {struct xs} : seq T :=
  if xs is (x :: xs') then x :: interleave_ns ys xs'
  else ys.

(** A simple unit test. *)
Check erefl :
interleave_ns [:: 1; 3] [:: 2; 4] = [:: 1; 2; 3; 4].
(** As you can see the evaluator does not care
    if the function passes the guardedness check
    or not *)

Print Assumptions interleave_ns.
(**
  Axioms:
  interleave_ns is positive.
*)

(** Here is how [interleave] can be actually defined in Coq: *)
Set Guard Checking.
Fixpoint interleave {T} (xs ys : seq T) : seq T :=
  match xs, ys with
  | (x :: xs'), (y :: ys') =>
       x :: y :: interleave xs' ys'
  | [::], _ => ys
  | _, [::] => xs
  end.

(** We can even prove the two implementations
    are "the same" *)
Lemma interleave_ns_eq_interleave {T} :
  (@interleave_ns T) =2 (@interleave T).
Proof.
by elim=> // x xs IHxs [|y ys] //=; rewrite IHxs.
Qed.

(** Coq offers more ways of defining [interleave]
    function *)

(** ** 1. Using the builtin [Function] plugin *)

(** Activate [Function] plugin,
    this makes available a new piece of vernacular:
    [Function] *)
From Coq Require Import Recdef.

Definition sum_len {T} (xs_ys : seq T * seq T) : nat :=
  length xs_ys.1 + length xs_ys.2.

Function interleave_f' {T} (xs_ys : (seq T * seq T))
         {measure sum_len xs_ys} : seq T :=
  if xs_ys is (x :: xs', ys) then
    x :: interleave_f' (ys, xs')
  else [::].
Proof.
move=> X xs_ys xs ys x xs' _ _.
by rewrite /sum_len /= addnC.
Qed.
(**
Notice a bunch of autogenerated definitions:

interleave_f'_tcc is defined
interleave_f'_terminate is defined
interleave_f'_ind is defined
interleave_f'_rec is defined
interleave_f'_rect is defined
R_interleave_f'_correct is defined
R_interleave_f'_complete is defined
 *)

Fail Check erefl :
  interleave_f' ([:: 1; 3], [:: 2; 4]) =
  [:: 1; 2; 3; 4].
Eval hnf in interleave_f' ([:: 1; 3], [:: 2; 4]).
(**
The above gets stuck on:
  = let (v, _) :=
      interleave_f'_terminate ([:: 1; 3], [:: 2; 4])
    in v
  : seq nat
*)
About interleave_f'_terminate.
(**
...
interleave_f'_terminate is opaque
...
 *)

(** First, we are going to fix evaluation
    by making [interleave_f_terminate]
    transparent: *)
Function interleave_f {T} (xs_ys : (seq T * seq T))
         {measure sum_len xs_ys} : seq T :=
  if xs_ys is (x :: xs', ys) then
    x :: interleave_f (ys, xs')
  else [::].
Proof.
move=> X xs_ys xs ys x xs' _ _.
by rewrite /sum_len /= addnC.
(** [Defined] makes [interleave_f_terminate]
    transparent *)
Defined.

(** Now evaluation works: *)
Check erefl :
  interleave_f ([:: 1; 3], [:: 2; 4]) =
  [:: 1; 2; 3; 4].
About interleave_f_terminate.
(**
...
interleave_f_terminate is transparent
...
*)

(** Now let us see how [interleave_f] is built *)
Print interleave_f.
(**
interleave_f =
fun (x : Type) (x0 : seq x * seq x) =>
  let (v, _) := interleave_f_terminate x0 in v
     : forall x : Type, seq x * seq x -> seq x
*)
About interleave_f_terminate.
(**
interleave_f_terminate :
forall (T : Type) (xs_ys : seq T * seq T),
{v : seq T |
exists p : nat,
  forall k : nat,
  (p < k)%coq_nat ->
  forall def : forall T0 : Type,
                 seq T0 * seq T0 -> seq T0,
  iter (forall T0 : Type, seq T0 * seq T0 -> seq T0)
       k
       interleave_f_F
       def
       T
       xs_ys
  = v}
*)

(** Under the hood [interleave_f_terminate]
    is (of course) a structurally recursive function.
    To understand what type we do recursion over,
    let's print the definition of the function and
    search for [fix] *)
Print interleave_f_terminate.
(**
...
fix hrec (T0 : Type) (xs_ys0 : seq T0 * seq T0)
         (Acc_xs_ys0 : Acc (Wf_nat.ltof
                              (seq T0 * seq T0)
                              [eta sum_len])
                           xs_ys0)
         {struct Acc_xs_ys0} :
...
*)

(** Here we meet the accessibility predicate [Acc]
    which can be used to define well-founded
    induction principles *)
Print Acc.
(**
Inductive Acc (A : Type)
              (R : A -> A -> Prop)
              (x : A) : Prop :=
  | Acc_intro :
      (forall y : A, R y x -> Acc R y) -> Acc R x

[Acc R x] can be read as "x is accessible under
relation R if all elements staying in relation R
with it are also accessible"
*)

(** Notice that Coq allows us do structural
    recursion on a term of type [Acc]
    which lives in [Prop] while building
    a term of a type living in [Type].
    (structural recursion involves pattern-matching).
    But the accessibility predicate is defined
    to be non-informative (one constructor!).
 *)

(** ** More on choice operator *)
Section Find.

(** Getting a concrete value from
    an abstract existence proof. *)

Variable (P : pred nat).

(** This construction lets us count up *)
Inductive acc_nat i : Prop :=
| AccNat0 of P i
| AccNatS of acc_nat i.+1.

Lemma find_ex :
  (exists n, P n) -> {m | P m}.
Proof.
move=> exP.

have: acc_nat 0.
  case exP => n; rewrite -(addn0 n); elim: n 0 => [|n IHn] j; first by left.
  by rewrite addSnnS; right; apply: IHn.

move: 0.
fix find_ex 2 => m IHm.
case Pm: (P m).
- by exists m.
apply: find_ex m.+1 _.
case: IHm.
- by rewrite Pm.
by [].
Defined.

End Find.

(** ** 2. Using the builtin [Program] mechanism *)

From Coq Require Import Program.

Program Fixpoint interleave_p {A} (xs ys : seq A)
  {measure (length xs + length ys)} : list A :=
  if xs is (x :: xs') then
    x :: interleave_p ys xs'
  else ys.
Next Obligation. by rewrite addnC. Qed.

Check erefl :
  interleave_p [:: 1; 3] [:: 2; 4] =
  [:: 1; 2; 3; 4].

(** [Program] also relies on [Acc] predicate *)

Print Assumptions interleave_p.
(** [Closed under the global context]

    But sometimes [Program] relies on
    [JMeq_eq] axiom to do dependent pattern
    matching.
 *)
Check JMeq_eq.
(**
JMeq_eq : forall (A : Type) (x y : A),
            x ~= y -> x = y
*)
Print JMeq.
(**
"JMeq" means "John Major equality", a.k.a.
heterogenous equality.

Inductive JMeq (A : Type) (x : A) :
  forall B : Type, B -> Prop :=
| JMeq_refl : x ~= x

[~=] is a notation for [JMeq]
*)

(** ** 3. Using the [Equations] plugin *)

(** The plugin can be installed via opam:
      opam install coq-equations *)

From Equations Require Import Equations.

Equations interleave_e {T} (xs ys : seq T) : seq T
  by wf (length xs + length ys) lt :=
interleave_e (x :: xs) ys :=
  x :: (interleave_e ys xs);
interleave_e [::] ys :=
  ys.
Next Obligation. by rewrite addnC. Qed.

Check erefl :
  interleave_e [:: 1; 3] [:: 2; 4] =
  [:: 1; 2; 3; 4].

(** One more trick to teach Coq termination:
    nested [fix] *)

(** Ackermann's function *)

Fixpoint ack (n m : nat) : nat :=
  if n is n'.+1 then
    let fix ackn (m : nat) :=
        if m is m'.+1 then ack n' (ackn m')
        else ack n' 1
    in ackn m
  else m.+1.

(** * Strict positivity rule *)

Print Typing Flags.

Fail Inductive prop :=
  RemoveNegation of (prop -> False).
(**
Non strictly positive occurrence of "prop" in
"(prop -> False) -> prop".
*)

Unset Guard Checking.
Print Typing Flags.

Inductive prop :=
  RemoveNegation of (prop -> False).
Print Assumptions prop.
(**
Axioms:
prop is positive.
*)

Definition not_prop (p : prop) : False :=
  let '(RemoveNegation not_p) := p in not_p p.
Check not_prop : prop -> False.

Check RemoveNegation not_prop : prop.

Definition yet_another_proof_of_False : False :=
  not_prop (RemoveNegation not_prop).

Print Assumptions yet_another_proof_of_False.
(**
Axioms:
yet_another_proof_of_False is positive.
not_prop is positive.
prop is positive.
*)
Set Guard Checking.

(**
Roughly, the positivity condition says that
constructors for an inductive data type can
only depend on maps to the data type but not on
maps from it.
*)

(** * Bonus: Universe polymorphism *)

Definition idf {A} : A -> A := fun x => x.
Fail Definition selfidfun := idf (@idf).
(**
The term "@idf" has type "forall A : Type, A -> A"
while it is expected to have type "?A"
(unable to find a well-typed instantiation for "?A": cannot ensure that
"Type@{Top.1849+1}" is a subtype of "Type@{Top.1849}").
*)

Set Universe Polymorphism.

Definition idf' {A} : A -> A := fun x => x.
Definition selfidfun' := idf' (@idf').
Print selfidfun'.

(** See more examples in the Coq Reference Manual *)


(*

Require Export cat_INDEXED_TYPE.

Set Implicit Arguments.
Unset Strict Implicit.
(* *)
Section pcf_syntax.

(*Inductive base_type := Bool | Nat.*)

Inductive TY :=
 | Bool : TY
 | Nat : TY
 | arrow: TY -> TY -> TY.

Inductive PCF_consts : TY -> Type :=
 | Nats : nat -> PCF_consts Nat
 | tt : PCF_consts Bool
 | ff : PCF_consts Bool
 | succ : PCF_consts (arrow Nat Nat)
 | zero : PCF_consts (arrow Nat Bool)
 | condN: PCF_consts (arrow Bool (arrow Nat (arrow Nat Nat)))
 | condB: PCF_consts (arrow Bool (arrow Bool (arrow Bool Bool))).

Inductive PCF (V:TY -> Type) : TY -> Type:=
 | Bottom: forall t, PCF V t
 | Const : forall t, PCF_consts t -> PCF V t
 | PCFVar : forall t, V t -> PCF V t
 | PApp : forall t s, PCF V (arrow s t) -> PCF V s -> PCF V t
 | PLam : forall t s, PCF (opt_T t V) s -> PCF V (arrow t s)
 | PRec : forall t, PCF V (arrow t t) -> PCF V t.

Definition PCF_varmap (V W: TY -> Type) :=
        forall t:TY, V t -> W t.

Fixpoint PCF_rename (V W:TY -> Type) (f:PCF_varmap V W)
         (t:TY)(v:PCF V t): PCF W t :=
    match v with
    | Bottom t => Bottom W t
    | Const t c => Const W c
    | PCFVar t v => PCFVar (f t v)
    | PApp t s u v => PApp (PCF_rename f u) (PCF_rename f v)
    | PLam t s u => PLam (PCF_rename (lift (M:=opt_T_monad _ )(*u:=t*) f) u)
    | PRec t u => PRec (PCF_rename f u)
    end.

Lemma PCF_rename_eq (V:TY -> Type)(t:TY)(v: PCF V t)
  (W: TY -> Type) (f g: PCF_varmap V W)(H: forall t x, f t x = g t x):
           PCF_rename f v = PCF_rename g v.
Proof. intros V t v; induction v; simpl; auto.

       intros; rewrite H; auto.

       intros. rewrite (IHv1 W f g); auto.
               rewrite (IHv2 W f g); auto.

       intros.
       apply f_equal.
       set (H':=IHv (opt_T t W) (lift (M:=opt_T_monad _ ) f)
                                (lift (M:=opt_T_monad _ ) g)).
       simpl in *. rewrite H'; auto.
       set (H'':= lift_eq (opt_T_monad t )).
       simpl in *. apply H''; auto.

       intros; rewrite (IHv W f g H); auto.
Qed.

Lemma PCF_rename_id (V:TY -> Type)(t:TY)(v: PCF V t)
  (f: PCF_varmap V V)(H: forall t x, f t x = x):
           PCF_rename f v = v.
Proof. intros V t v; induction v; simpl; auto.
       intros f H; rewrite H; auto.
       intros f H; rewrite IHv1; try rewrite IHv2; auto.
       intros f H; rewrite IHv; auto.
       unfold lift. unfold kleisli. simpl.
       intros t0 x; destruct x; simpl;
       try rewrite H; auto.
       intros f H; rewrite IHv; auto.
Qed.

Lemma PCF_rename_comp (V:TY -> Type) (t: TY) (v: PCF V t)
      (W X: TY -> Type) (f: PCF_varmap V W) (g: PCF_varmap W X):
      PCF_rename (fun t x => g t (f t x)) v =
           PCF_rename g (PCF_rename f v).
Proof. intros V t v; induction v; simpl; auto.
       intros W X f g; rewrite IHv1; rewrite IHv2; auto.
       intros W X f g. apply f_equal.
       rewrite <- (IHv _ (opt_T t X)).
       apply PCF_rename_eq.
       intros to x.
       set (H:= lift_lift (opt_T_monad t)).
       simpl in *. rewrite H; auto.
       intros W X f g; rewrite IHv; auto.
Qed.

(* injection of terms into terms with one variable more, of type u *)
Definition PCF_inj(u:TY)(V:TY -> Type)(t:TY)(v:PCF V t):
           PCF (opt_T u V) t :=
    PCF_rename (@Some_T TY u V) v.

Definition PCF_shift (u:TY) (V W:TY -> Type)(f: forall t:TY, V t-> PCF W t)
              (t:TY) (v: opt_T u V t): PCF (opt_T u W) t :=
            match v in opt_T _ _ t' return PCF (opt_T u W) t' with
            | None_T => PCFVar (None_T u W)
            | Some_T t v => PCF_inj u (f t v)
            end.

Lemma PCF_shift_eq (u:TY) (V:TY -> Type)(t:TY)(v:opt_T u V t)
          (W:TY -> Type)(f g: forall t, V t -> PCF W t)
          (H: forall t x, f t x = g t x):
          PCF_shift f v = PCF_shift g v.
Proof. intros u V t v; induction v; simpl; intros; try rewrite H; auto.
Qed.

Lemma PCF_shift_var (u:TY)(V:TY -> Type)(t:TY)(v: opt_T u V t):
       PCF_shift (fun t x => PCFVar x) v = PCFVar v.
Proof. induction v; intros; simpl; auto. Qed.

Lemma PCF_var_lift_shift_eq (u:TY) (V: TY -> Type) (t: TY) (v: opt_T u V t)
               (W:TY -> Type) (f: forall t, V t -> W t):
    PCFVar (lift (M:=opt_T_monad u) f _ v) =
         PCF_shift (fun t x0 => PCFVar (f t x0)) v.
Proof. induction v; simpl; intros; auto. Qed.

Lemma PCF_shift_lift (u:TY) (V: TY -> Type) (t:TY)(v:opt_T u V t)
           (W:TY -> Type)(f: forall t, V t -> W t) (X: TY -> Type)
                    (g: forall t, W t -> PCF X t):
   PCF_shift g (lift (M:=opt_T_monad u) f _ v) =
         PCF_shift (fun t x0 => g t (f t x0)) v.
Proof. induction v; simpl; intros; auto. Qed.

Fixpoint PCF_subst (V W: TY -> Type) (t:TY) (v: PCF V t)
       (f: forall t, V t -> PCF W t) : PCF W t :=
    match v with
    | Bottom t => Bottom W t
    | Const t c => Const W c
    | PCFVar t v => f t v
    | PApp t s u v => PApp (PCF_subst u f) (PCF_subst v f)
    | PLam t s u => PLam (PCF_subst u (PCF_shift (*u:=t*) f))
    | PRec t u => PRec (PCF_subst u f)
    end.

Definition PCF_substar (u:TY)(V: TY -> Type) (t:TY)(v:PCF (opt_T u V) t)
      (M:PCF V u): PCF V t := PCF_subst (*V:= opt_T u V*) v
  (fun t x => match x with
            | None_T => M
            | Some_T _ v => PCFVar v
            end) .

Lemma PCF_subst_eq (V:TY -> Type)(t:TY)(v:PCF V t) (W:TY -> Type)
       (f g: forall t, V t -> PCF W t)
       (H: forall t x, f t x = g t x) :
       PCF_subst v f = PCF_subst v g.
Proof. induction v; intros; simpl;  auto.

       try rewrite (IHv1 W f g);
       try rewrite (IHv2 W f g);
       try rewrite (IHv W f g); auto.

       rewrite (IHv _ (PCF_shift f) (PCF_shift g)); auto.
       intros; apply PCF_shift_eq; auto.

       rewrite (IHv W f g); auto.
Qed.

Lemma PCF_subst_var (V:TY -> Type)(t:TY)(v:PCF V t):
       PCF_subst v (fun t x0 => PCFVar x0) = v.
Proof. induction v; intros; simpl; auto.
       rewrite IHv1. rewrite IHv2; auto.
       rewrite <- IHv at 2.
       apply f_equal. apply PCF_subst_eq.
       intros; apply PCF_shift_var.
       rewrite IHv; auto.
Qed.

Lemma PCF_subst_eq_rename (V:TY -> Type)(t:TY)(v:PCF V t)(W:TY->Type)
           (f:forall t, V t -> W t):
        PCF_rename f v = PCF_subst v (fun t x0 => PCFVar (f t x0)).
Proof. induction v; intros; simpl; auto.
       rewrite IHv1; rewrite IHv2; auto.
       rewrite IHv. apply f_equal. apply PCF_subst_eq.
       intros; apply PCF_var_lift_shift_eq.
       rewrite IHv; auto.
Qed.

Lemma PCF_rename_term_inj (u:TY)(V:TY -> Type)(t:TY)(v:PCF V t)
    (W:TY -> Type) (g: forall t, V t -> W t):
       PCF_rename (opt_T_map (u:=u) g) (PCF_inj u v) =
                  PCF_inj u (PCF_rename g v).
Proof. induction v; simpl; intros; auto.
       rewrite IHv1; rewrite IHv2; auto.
       unfold PCF_inj. simpl.
       apply f_equal.
       rewrite <- PCF_rename_comp.
       rewrite <- PCF_rename_comp.
       apply PCF_rename_eq.
       induction x; simpl; auto.
       rewrite IHv. unfold PCF_inj. simpl. auto.
Qed.

Lemma PCF_rename_subst (V:TY -> Type) (t:TY)(v: PCF V t) (W:TY -> Type)
     (f:forall t, V t -> PCF W t)(X:TY -> Type)(g:forall t, W t -> X t):
   PCF_rename g (PCF_subst v f) =
           PCF_subst v (fun t x => PCF_rename g (f t x)).
Proof. induction v; intros; simpl; auto.
       rewrite IHv1; rewrite IHv2; auto.

       rewrite IHv. apply f_equal. apply PCF_subst_eq.
       induction x; simpl; auto.
       apply PCF_rename_term_inj.

       rewrite IHv. auto.
Qed.

Lemma PCF_subst_rename (V:TY -> Type) (t:TY)(v: PCF V t) (W:TY -> Type)
     (f:forall t, V t -> W t)(X:TY -> Type)(g:forall t, W t -> PCF X t):
   PCF_subst (PCF_rename f v) g =
           PCF_subst v (fun t x =>  g t (f t x)).
Proof. induction v; simpl; intros; auto.
       rewrite IHv1; rewrite IHv2; auto.

       rewrite IHv. apply f_equal.
       apply PCF_subst_eq. intros.
       apply PCF_shift_lift.

       rewrite IHv. auto.
Qed.

Lemma PCF_subst_term_inj (u:TY)(V:TY -> Type)(t:TY)(v:PCF V t)(W:TY -> Type)
      (g:forall t, V t -> PCF W t):
    PCF_subst (PCF_inj u v) (PCF_shift g) = PCF_inj u (PCF_subst v g).
Proof. induction v; simpl; intros; auto.
       rewrite IHv1; rewrite IHv2; auto.

       unfold PCF_inj. simpl. apply f_equal.
       rewrite PCF_rename_subst.
       rewrite PCF_subst_rename.
       apply PCF_subst_eq.
       induction x; simpl; auto.
       rewrite PCF_rename_term_inj. auto.

       rewrite IHv; auto.
Qed.

Lemma PCF_subst_shift_shift (u:TY) (V:TY -> Type) (t:TY)(v:opt_T u V t)
 (W:TY -> Type)
 (f: forall t, V t -> PCF W t) (X:TY -> Type)(g:forall t, W t -> PCF X t):
  PCF_subst (PCF_shift f v) (PCF_shift g) =
          PCF_shift (fun t x0 => PCF_subst (f t x0) g) v.
Proof. induction v; simpl; intros; try apply PCF_subst_term_inj; auto.
Qed.

Lemma PCF_subst_subst (V:TY -> Type)(t:TY)(v:PCF V t) (W X: TY -> Type)
         (f:forall t, V t -> PCF W t)(g:forall t, W t -> PCF X t):
PCF_subst (PCF_subst v f) g = PCF_subst v (fun t x0 => PCF_subst (f t x0) g).
Proof. induction v; simpl; intros; auto.
       rewrite IHv1; rewrite IHv2; auto.

       rewrite IHv. apply f_equal.
       apply PCF_subst_eq.
       intros; simpl.
       apply PCF_subst_shift_shift.

       rewrite IHv; auto.
Qed.

Require Export monad_haskell.

Program Instance syntax_monad_h: Monad_struct (ITYPE TY)
        (fun V => PCF V) := {
  weta V t v:= PCFVar v;
  kleisli V W f := fun t x => PCF_subst x f
}.

  Next Obligation.
    Proof. unfold Proper; red.
           intros. apply PCF_subst_eq. auto.
    Qed.

  (*Next Obligation.
    Proof.
           simpl. auto.
    Qed.
*)
  Next Obligation.
    Proof.
           intros; apply PCF_subst_var.
    Qed.

  Next Obligation.
    Proof.
           intros; apply PCF_subst_subst.
    Qed.

End pcf_syntax.

*)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv.

(** * Euclidean Division for integers, Euclid convention

    We use here the "usual" formulation of the Euclid Theorem
    [forall a b, b<>0 -> exists b q, a = b*q+r /\ 0 < r < |b| ]

    The outcome of the modulo function is hence always positive.
    This corresponds to convention "E" in the following paper:

    R. Boute, "The Euclidean definition of the functions div and mod",
    ACM Transactions on Programming Languages and Systems,
    Vol. 14, No.2, pp. 127-144, April 1992.

    See files [ZDivTrunc] and [ZDivFloor] for others conventions.

    We simply extend NZDiv with a bound for modulo that holds
    regardless of the sign of a and b. This new specification
    subsume mod_bound_pos, which nonetheless stays there for
    subtyping. Note also that ZAxiomSig now already contain
    a div and a modulo (that follow the Floor convention).
    We just ignore them here.
*)

Module Type EuclidSpec (Import A : ZAxiomsSig')(Import B : DivMod' A).
 Axiom mod_always_pos : forall a b, b ~= 0 -> 0 <= a mod b < abs b.
End EuclidSpec.

Module Type ZEuclid (Z:ZAxiomsSig) := NZDiv.NZDiv Z <+ EuclidSpec Z.
Module Type ZEuclid' (Z:ZAxiomsSig) := NZDiv.NZDiv' Z <+ EuclidSpec Z.

Module ZEuclidProp
 (Import A : ZAxiomsSig')
 (Import B : ZMulOrderProp A)
 (Import C : ZSgnAbsProp A B)
 (Import D : ZEuclid' A).

 Module Import NZDivP := Nop <+ NZDivProp A D B.

(** Another formulation of the main equation *)

Lemma mod_eq :
 forall a b, b~=0 -> a mod b == a - b*(a/b).
Proof.
intros.
rewrite <- add_move_l.
symmetry. now apply div_mod.
Qed.

Ltac pos_or_neg a :=
 let LT := fresh "LT" in
 let LE := fresh "LE" in
 destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT].

(** Uniqueness theorems *)

Theorem div_mod_unique : forall b q1 q2 r1 r2 : t,
  0<=r1<abs b -> 0<=r2<abs b ->
  b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2.
Proof.
intros b q1 q2 r1 r2 Hr1 Hr2 EQ.
pos_or_neg b.
rewrite abs_eq in * by trivial.
apply div_mod_unique with b; trivial.
rewrite abs_neq' in * by auto using lt_le_incl.
rewrite eq_sym_iff. apply div_mod_unique with (-b); trivial.
rewrite 2 mul_opp_l.
rewrite add_move_l, sub_opp_r.
rewrite <-add_assoc.
symmetry. rewrite add_move_l, sub_opp_r.
now rewrite (add_comm r2), (add_comm r1).
Qed.

Theorem div_unique:
 forall a b q r, 0<=r<abs b -> a == b*q + r -> q == a/b.
Proof.
intros a b q r Hr EQ.
assert (Hb : b~=0).
 pos_or_neg b.
 rewrite abs_eq in Hr; intuition; order.
 rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order.
destruct (div_mod_unique b q (a/b) r (a mod b)); trivial.
now apply mod_always_pos.
now rewrite <- div_mod.
Qed.

Theorem mod_unique:
 forall a b q r, 0<=r<abs b -> a == b*q + r -> r == a mod b.
Proof.
intros a b q r Hr EQ.
assert (Hb : b~=0).
 pos_or_neg b.
 rewrite abs_eq in Hr; intuition; order.
 rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order.
destruct (div_mod_unique b q (a/b) r (a mod b)); trivial.
now apply mod_always_pos.
now rewrite <- div_mod.
Qed.

(** Sign rules *)

Lemma div_opp_r : forall a b, b~=0 -> a/(-b) == -(a/b).
Proof.
intros. symmetry.
apply div_unique with (a mod b).
rewrite abs_opp; now apply mod_always_pos.
rewrite mul_opp_opp; now apply div_mod.
Qed.

Lemma mod_opp_r : forall a b, b~=0 -> a mod (-b) == a mod b.
Proof.
intros. symmetry.
apply mod_unique with (-(a/b)).
rewrite abs_opp; now apply mod_always_pos.
rewrite mul_opp_opp; now apply div_mod.
Qed.

Lemma div_opp_l_z : forall a b, b~=0 -> a mod b == 0 ->
 (-a)/b == -(a/b).
Proof.
intros a b Hb Hab. symmetry.
apply div_unique with (-(a mod b)).
rewrite Hab, opp_0. split; [order|].
pos_or_neg b; [rewrite abs_eq | rewrite abs_neq']; order.
now rewrite mul_opp_r, <-opp_add_distr, <-div_mod.
Qed.

Lemma div_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 ->
 (-a)/b == -(a/b)-sgn b.
Proof.
intros a b Hb Hab. symmetry.
apply div_unique with (abs b -(a mod b)).
rewrite lt_sub_lt_add_l.
rewrite <- le_add_le_sub_l. nzsimpl.
rewrite <- (add_0_l (abs b)) at 2.
rewrite <- add_lt_mono_r.
destruct (mod_always_pos a b); intuition order.
rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r.
rewrite sgn_abs.
rewrite add_shuffle2, add_opp_diag_l; nzsimpl.
rewrite <-opp_add_distr, <-div_mod; order.
Qed.

Lemma mod_opp_l_z : forall a b, b~=0 -> a mod b == 0 ->
 (-a) mod b == 0.
Proof.
intros a b Hb Hab. symmetry.
apply mod_unique with (-(a/b)).
split; [order|now rewrite abs_pos].
now rewrite <-opp_0, <-Hab, mul_opp_r, <-opp_add_distr, <-div_mod.
Qed.

Lemma mod_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 ->
 (-a) mod b == abs b - (a mod b).
Proof.
intros a b Hb Hab. symmetry.
apply mod_unique with (-(a/b)-sgn b).
rewrite lt_sub_lt_add_l.
rewrite <- le_add_le_sub_l. nzsimpl.
rewrite <- (add_0_l (abs b)) at 2.
rewrite <- add_lt_mono_r.
destruct (mod_always_pos a b); intuition order.
rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r.
rewrite sgn_abs.
rewrite add_shuffle2, add_opp_diag_l; nzsimpl.
rewrite <-opp_add_distr, <-div_mod; order.
Qed.

Lemma div_opp_opp_z : forall a b, b~=0 -> a mod b == 0 ->
 (-a)/(-b) == a/b.
Proof.
intros. now rewrite div_opp_r, div_opp_l_z, opp_involutive.
Qed.

Lemma div_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 ->
 (-a)/(-b) == a/b + sgn(b).
Proof.
intros. rewrite div_opp_r, div_opp_l_nz by trivial.
now rewrite opp_sub_distr, opp_involutive.
Qed.

Lemma mod_opp_opp_z : forall a b, b~=0 -> a mod b == 0 ->
 (-a) mod (-b) == 0.
Proof.
intros. now rewrite mod_opp_r, mod_opp_l_z.
Qed.

Lemma mod_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 ->
 (-a) mod (-b) == abs b - a mod b.
Proof.
intros. now rewrite mod_opp_r, mod_opp_l_nz.
Qed.

(** A division by itself returns 1 *)

Lemma div_same : forall a, a~=0 -> a/a == 1.
Proof.
intros. symmetry. apply div_unique with 0.
split; [order|now rewrite abs_pos].
now nzsimpl.
Qed.

Lemma mod_same : forall a, a~=0 -> a mod a == 0.
Proof.
intros.
rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag.
Qed.

(** A division of a small number by a bigger one yields zero. *)

Theorem div_small: forall a b, 0<=a<b -> a/b == 0.
Proof. exact div_small. Qed.

(** Same situation, in term of modulo: *)

Theorem mod_small: forall a b, 0<=a<b -> a mod b == a.
Proof. exact mod_small. Qed.

(** * Basic values of divisions and modulo. *)

Lemma div_0_l: forall a, a~=0 -> 0/a == 0.
Proof.
intros. pos_or_neg a. apply div_0_l; order.
apply opp_inj. rewrite <- div_opp_r, opp_0 by trivial. now apply div_0_l.
Qed.

Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0.
Proof.
intros; rewrite mod_eq, div_0_l; now nzsimpl.
Qed.

Lemma div_1_r: forall a, a/1 == a.
Proof.
intros. symmetry. apply div_unique with 0.
assert (H:=lt_0_1); rewrite abs_pos; intuition; order.
now nzsimpl.
Qed.

Lemma mod_1_r: forall a, a mod 1 == 0.
Proof.
intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag.
apply neq_sym, lt_neq; apply lt_0_1.
Qed.

Lemma div_1_l: forall a, 1<a -> 1/a == 0.
Proof. exact div_1_l. Qed.

Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1.
Proof. exact mod_1_l. Qed.

Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a.
Proof.
intros. symmetry. apply div_unique with 0.
split; [order|now rewrite abs_pos].
nzsimpl; apply mul_comm.
Qed.

Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0.
Proof.
intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag.
Qed.

(** * Order results about mod and div *)

(** A modulo cannot grow beyond its starting point. *)

Theorem mod_le: forall a b, 0<=a -> b~=0 -> a mod b <= a.
Proof.
intros. pos_or_neg b. apply mod_le; order.
rewrite <- mod_opp_r by trivial. apply mod_le; order.
Qed.

Theorem div_pos : forall a b, 0<=a -> 0<b -> 0<= a/b.
Proof. exact div_pos. Qed.

Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b.
Proof. exact div_str_pos. Qed.

Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> 0<=a<abs b).
Proof.
intros a b Hb.
split.
intros EQ.
rewrite (div_mod a b Hb), EQ; nzsimpl.
now apply mod_always_pos.
intros. pos_or_neg b.
apply div_small.
now rewrite <- (abs_eq b).
apply opp_inj; rewrite opp_0, <- div_opp_r by trivial.
apply div_small.
rewrite <- (abs_neq' b) by order. trivial.
Qed.

Lemma mod_small_iff : forall a b, b~=0 -> (a mod b == a <-> 0<=a<abs b).
Proof.
intros.
rewrite <- div_small_iff, mod_eq by trivial.
rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l.
rewrite eq_sym_iff, eq_mul_0. tauto.
Qed.

(** As soon as the divisor is strictly greater than 1,
    the division is strictly decreasing. *)

Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a.
Proof. exact div_lt. Qed.

(** [le] is compatible with a positive division. *)

Lemma div_le_mono : forall a b c, 0<c -> a<=b -> a/c <= b/c.
Proof.
intros a b c Hc Hab.
rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ];
 [|rewrite EQ; order].
rewrite <- lt_succ_r.
rewrite (mul_lt_mono_pos_l c) by order.
nzsimpl.
rewrite (add_lt_mono_r _ _ (a mod c)).
rewrite <- div_mod by order.
apply lt_le_trans with b; trivial.
rewrite (div_mod b c) at 1 by order.
rewrite <- add_assoc, <- add_le_mono_l.
apply le_trans with (c+0).
nzsimpl; destruct (mod_always_pos b c); try order.
rewrite abs_eq in *; order.
rewrite <- add_le_mono_l. destruct (mod_always_pos a c); order.
Qed.

(** In this convention, [div] performs Rounding-Toward-Bottom
    when divisor is positive, and Rounding-Toward-Top otherwise.

    Since we cannot speak of rational values here, we express this
    fact by multiplying back by [b], and this leads to a nice
    unique statement.
*)

Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a.
Proof.
intros.
rewrite (div_mod a b) at 2; trivial.
rewrite <- (add_0_r (b*(a/b))) at 1.
rewrite <- add_le_mono_l.
now destruct (mod_always_pos a b).
Qed.

(** Giving a reversed bound is slightly more complex *)

Lemma mul_succ_div_gt: forall a b, 0<b -> a < b*(S (a/b)).
Proof.
intros.
nzsimpl.
rewrite (div_mod a b) at 1; try order.
rewrite <- add_lt_mono_l.
destruct (mod_always_pos a b). order.
rewrite abs_eq in *; order.
Qed.

Lemma mul_pred_div_gt: forall a b, b<0 -> a < b*(P (a/b)).
Proof.
intros a b Hb.
rewrite mul_pred_r, <- add_opp_r.
rewrite (div_mod a b) at 1; try order.
rewrite <- add_lt_mono_l.
destruct (mod_always_pos a b). order.
rewrite <- opp_pos_neg in Hb. rewrite abs_neq' in *; order.
Qed.

(** NB: The three previous properties could be used as
    specifications for [div]. *)

(** Inequality [mul_div_le] is exact iff the modulo is zero. *)

Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0).
Proof.
intros.
rewrite (div_mod a b) at 1; try order.
rewrite <- (add_0_r (b*(a/b))) at 2.
apply add_cancel_l.
Qed.

(** Some additionnal inequalities about div. *)

Theorem div_lt_upper_bound:
  forall a b q, 0<b -> a < b*q -> a/b < q.
Proof.
intros.
rewrite (mul_lt_mono_pos_l b) by trivial.
apply le_lt_trans with a; trivial.
apply mul_div_le; order.
Qed.

Theorem div_le_upper_bound:
  forall a b q, 0<b -> a <= b*q -> a/b <= q.
Proof.
intros.
rewrite <- (div_mul q b) by order.
apply div_le_mono; trivial. now rewrite mul_comm.
Qed.

Theorem div_le_lower_bound:
  forall a b q, 0<b -> b*q <= a -> q <= a/b.
Proof.
intros.
rewrite <- (div_mul q b) by order.
apply div_le_mono; trivial. now rewrite mul_comm.
Qed.

(** A division respects opposite monotonicity for the divisor *)

Lemma div_le_compat_l: forall p q r, 0<=p -> 0<q<=r -> p/r <= p/q.
Proof. exact div_le_compat_l. Qed.

(** * Relations between usual operations and mod and div *)

Lemma mod_add : forall a b c, c~=0 ->
 (a + b * c) mod c == a mod c.
Proof.
intros.
symmetry.
apply mod_unique with (a/c+b); trivial.
now apply mod_always_pos.
rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
now rewrite mul_comm.
Qed.

Lemma div_add : forall a b c, c~=0 ->
 (a + b * c) / c == a / c + b.
Proof.
intros.
apply (mul_cancel_l _ _ c); try order.
apply (add_cancel_r _ _ ((a+b*c) mod c)).
rewrite <- div_mod, mod_add by order.
rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
now rewrite mul_comm.
Qed.

Lemma div_add_l: forall a b c, b~=0 ->
 (a * b + c) / b == a + c / b.
Proof.
 intros a b c. rewrite (add_comm _ c), (add_comm a).
 now apply div_add.
Qed.

(** Cancellations. *)

(** With the current convention, the following isn't always true
    when [c<0]: [-3*-1 / -2*-1 = 3/2 = 1] while [-3/-2 = 2] *)

Lemma div_mul_cancel_r : forall a b c, b~=0 -> 0<c ->
 (a*c)/(b*c) == a/b.
Proof.
intros.
symmetry.
apply div_unique with ((a mod b)*c).
(* ineqs *)
rewrite abs_mul, (abs_eq c) by order.
rewrite <-(mul_0_l c), <-mul_lt_mono_pos_r, <-mul_le_mono_pos_r by trivial.
now apply mod_always_pos.
(* equation *)
rewrite (div_mod a b) at 1 by order.
rewrite mul_add_distr_r.
rewrite add_cancel_r.
rewrite <- 2 mul_assoc. now rewrite (mul_comm c).
Qed.

Lemma div_mul_cancel_l : forall a b c, b~=0 -> 0<c ->
 (c*a)/(c*b) == a/b.
Proof.
intros. rewrite !(mul_comm c); now apply div_mul_cancel_r.
Qed.

Lemma mul_mod_distr_l: forall a b c, b~=0 -> 0<c ->
  (c*a) mod (c*b) == c * (a mod b).
Proof.
intros.
rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))).
rewrite <- div_mod.
rewrite div_mul_cancel_l by trivial.
rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
apply div_mod; order.
rewrite <- neq_mul_0; intuition; order.
Qed.

Lemma mul_mod_distr_r: forall a b c, b~=0 -> 0<c ->
  (a*c) mod (b*c) == (a mod b) * c.
Proof.
 intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l.
Qed.

(** Operations modulo. *)

Theorem mod_mod: forall a n, n~=0 ->
 (a mod n) mod n == a mod n.
Proof.
intros. rewrite mod_small_iff by trivial.
now apply mod_always_pos.
Qed.

Lemma mul_mod_idemp_l : forall a b n, n~=0 ->
 ((a mod n)*b) mod n == (a*b) mod n.
Proof.
 intros a b n Hn. symmetry.
 rewrite (div_mod a n) at 1 by order.
 rewrite add_comm, (mul_comm n), (mul_comm _ b).
 rewrite mul_add_distr_l, mul_assoc.
 rewrite mod_add by trivial.
 now rewrite mul_comm.
Qed.

Lemma mul_mod_idemp_r : forall a b n, n~=0 ->
 (a*(b mod n)) mod n == (a*b) mod n.
Proof.
 intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l.
Qed.

Theorem mul_mod: forall a b n, n~=0 ->
 (a * b) mod n == ((a mod n) * (b mod n)) mod n.
Proof.
 intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r.
Qed.

Lemma add_mod_idemp_l : forall a b n, n~=0 ->
 ((a mod n)+b) mod n == (a+b) mod n.
Proof.
 intros a b n Hn. symmetry.
 rewrite (div_mod a n) at 1 by order.
 rewrite <- add_assoc, add_comm, mul_comm.
 now rewrite mod_add.
Qed.

Lemma add_mod_idemp_r : forall a b n, n~=0 ->
 (a+(b mod n)) mod n == (a+b) mod n.
Proof.
 intros. rewrite !(add_comm a). now apply add_mod_idemp_l.
Qed.

Theorem add_mod: forall a b n, n~=0 ->
 (a+b) mod n == (a mod n + b mod n) mod n.
Proof.
 intros. now rewrite add_mod_idemp_l, add_mod_idemp_r.
Qed.

(** With the current convention, the following result isn't always
    true with a negative intermediate divisor. For instance
    [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ] and
    [ 3/(-2)/2 = -1 <> 0 = 3 / (-2*2) ]. *)

Lemma div_div : forall a b c, 0<b -> c~=0 ->
 (a/b)/c == a/(b*c).
Proof.
 intros a b c Hb Hc.
 apply div_unique with (b*((a/b) mod c) + a mod b).
 (* begin 0<= ... <abs(b*c) *)
 rewrite abs_mul.
 destruct (mod_always_pos (a/b) c), (mod_always_pos a b); try order.
 split.
 apply add_nonneg_nonneg; trivial.
 apply mul_nonneg_nonneg; order.
 apply lt_le_trans with (b*((a/b) mod c) + abs b).
 now rewrite <- add_lt_mono_l.
 rewrite (abs_eq b) by order.
 now rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l.
 (* end 0<= ... < abs(b*c) *)
 rewrite (div_mod a b) at 1 by order.
 rewrite add_assoc, add_cancel_r.
 rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
 apply div_mod; order.
Qed.

(** Similarly, the following result doesn't always hold when [b<0].
    For instance [3 mod (-2*-2)) = 3] while
    [3 mod (-2) + (-2)*((3/-2) mod -2) = -1]. *)

Lemma mod_mul_r : forall a b c, 0<b -> c~=0 ->
 a mod (b*c) == a mod b + b*((a/b) mod c).
Proof.
 intros a b c Hb Hc.
 apply add_cancel_l with (b*c*(a/(b*c))).
 rewrite <- div_mod by (apply neq_mul_0; split; order).
 rewrite <- div_div by trivial.
 rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l.
 rewrite <- div_mod by order.
 apply div_mod; order.
Qed.

(** A last inequality: *)

Theorem div_mul_le:
 forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a/b) <= (c*a)/b.
Proof. exact div_mul_le. Qed.

(** mod is related to divisibility *)

Lemma mod_divides : forall a b, b~=0 ->
 (a mod b == 0 <-> (b|a)).
Proof.
intros a b Hb. split.
intros Hab. exists (a/b). rewrite (div_mod a b Hb) at 2.
 rewrite Hab; now nzsimpl.
intros (c,Hc).
rewrite <- Hc, mul_comm.
now apply mod_mul.
Qed.

End ZEuclidProp.


(* Exercise 105 *)

Require Import BenB.

Variables A B C D : Prop.

(* de Morgan's conjunction law *)

Theorem exercise_105 : ~(A /\ B) -> (~A \/ ~B).
Proof.
imp_i a1.
neg_e' (A /\ B) a2.
hyp a1.
con_i.
neg_e' (~A \/ ~B) a3.
hyp a2.
dis_i1.
hyp a3.
neg_e' (~A \/ ~B) a3.
hyp a2.
dis_i2.
hyp a3.
Qed.


Require Import Arith.
Import Nat.

Fixpoint evenb (n: nat): bool :=
  match n with
    | O => true
    | S p => negb (evenb p)
  end.

(* Some useful lemmas from the standard library. *)
Check even_succ: forall n, even (S n) = odd n.
Check negb_even: forall n, negb (even n) = odd n.

Lemma evenb_even:
  forall n, evenb n = even n.
Proof.

Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (x : natural) (lf1 : natural) (y : natural) : natural :=
  plus Zero (mult y x).


(** Anthony Bordg, February 2017 ************************************************

Contents:

- The ring of endomorphisms of an abelian group ([rngofendabgr])
- (left) modules over a ring ([module]) and module homomorphisms ([modulefun])
- Submodules of a module ([submodule])
- Univalence for modules over a ring ([modules_univalence])
- Precategory of modules over a ring ([Mod])
- Category of modules over a ring ([category_Mod])
- Mod is a univalent category ([Mod_is_univalent])

***************************************************)

Require Import UniMath.Algebra.Rigs_and_Rings.
Require Import UniMath.Algebra.Monoids_and_Groups.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.Foundations.PartA.
Require Import UniMath.Foundations.Preamble.
Require Import UniMath.Algebra.Domains_and_Fields.
Require Import UniMath.Foundations.PartD.
Require Import Types_and_groups_with_operators.v
Require Import UniMath.CategoryTheory.Categories.

Local Open Scope addmonoid_scope.

(** * The ring of endomorphisms of an abelian group *)

(** Two binary operations on the set of endomorphisms of an abelian group *)

Definition monoidfun_to_isbinopfun {G : abgr} (f : monoidfun G G) : isbinopfun f := pr1 (pr2 f).

Definition rngofendabgr_op1 {G: abgr} : binop (monoidfun G G).
Proof.
  intros f g.
  apply (@monoidfunconstr _ _ (λ x : G, f x + g x)).
  apply tpair.
  - intros x x'.
    rewrite (monoidfun_to_isbinopfun f).
    rewrite (monoidfun_to_isbinopfun g).
    apply (abmonoidrer G).
  - rewrite (monoidfununel f).
    rewrite (monoidfununel g).
    rewrite (lunax G).
    reflexivity.
Defined.

Definition rngofendabgr_op2 {G : abgr} : binop (monoidfun G G).
Proof.
  intros f g.
  apply (monoidfuncomp f g).
Defined.

Notation "f + g" := (rngofendabgr_op1 f g) : abgr_scope.

(** the composition below uses the diagrammatic order following the general convention used in UniMath *)

Notation "f ∘ g" := (rngofendabgr_op2 f g) : abgr_scope.

(** The underlying set of the ring of endomorphisms of an abelian group *)

Definition setofendabgr (G : abgr) : hSet :=
   hSetpair (monoidfun G G) (isasetmonoidfun G G).

(** A few access functions *)

Definition pr1setofendabgr {G : abgr} (f : setofendabgr G) : G -> G := pr1 f.

Definition pr2setofendabgr {G : abgr} (f : setofendabgr G) : ismonoidfun (pr1 f) := pr2 f.

Definition setofendabgr_to_isbinopfun {G : abgr} (f : setofendabgr G) : isbinopfun (pr1setofendabgr f) := pr1 (pr2 f).

Definition setofendabgr_to_unel {G : abgr} (f : setofendabgr G) : pr1setofendabgr f 0 = 0 := pr2 (pr2setofendabgr f).

(** We endow setofendabgr with the two binary operations defined above *)

Definition setwith2binopofendabgr (G : abgr) : setwith2binop :=
   setwith2binoppair (setofendabgr G) (dirprodpair (rngofendabgr_op1) (rngofendabgr_op2)).

(** rngofendabgr_op1 G and rngofendabgr_op2 G are ring operations *)

(** rngofendabgr_op1 is a monoid operation *)

Local Open Scope abgr_scope.

Definition isassoc_rngofendabgr_op1 {G : abgr} : isassoc (@rngofendabgr_op1 G).
Proof.
   intros f g h.
   use total2_paths_f.
   - apply funextfun.
     intro.
     apply (pr2 G).
   - apply isapropismonoidfun.
Defined.

Definition setofendabgr_un0 {G: abgr} : monoidfun G G.
Proof.
   apply (@monoidfunconstr _ _ (λ x : G, 0)).
   apply dirprodpair.
     - intros x x'.
       rewrite (lunax G).
       reflexivity.
     - reflexivity.
Defined.

Definition islunit_setofendabgr_un0 {G : abgr} : islunit (@rngofendabgr_op1 G) setofendabgr_un0.
Proof.
   intro f.
   use total2_paths_f.
   - apply funextfun. intro x.
     apply (lunax G (pr1setofendabgr f x)).
   - apply isapropismonoidfun.
Defined.

Definition isrunit_setofendabgr_un0 {G : abgr} : isrunit (@rngofendabgr_op1 G) setofendabgr_un0.
Proof.
   intros f.
   use total2_paths_f.
   - apply funextfun. intro x.
     apply (runax G (pr1setofendabgr f x)).
   - apply isapropismonoidfun.
Defined.

Definition isunit_setofendabgr_un0 {G : abgr} : isunit (@rngofendabgr_op1 G) setofendabgr_un0 :=
  isunitpair islunit_setofendabgr_un0 isrunit_setofendabgr_un0.

Definition isunital_rngofendabgr_op1 {G : abgr} : isunital (@rngofendabgr_op1 G) :=
  isunitalpair setofendabgr_un0 isunit_setofendabgr_un0.

Definition ismonoidop_rngofendabgr_op1 {G : abgr} : ismonoidop (@rngofendabgr_op1 G) :=
   mk_ismonoidop isassoc_rngofendabgr_op1 isunital_rngofendabgr_op1.

Local Close Scope abgr_scope.

(** rngofendabgr_op1 is a group operation *)

Definition setofendabgr_inv {G : abgr} : monoidfun G G -> monoidfun G G.
Proof.
   intro f.
   apply (@monoidfunconstr G G (λ x : G, grinv G (pr1setofendabgr f x))).
   apply dirprodpair.
   - intros x x'.
     rewrite (setofendabgr_to_isbinopfun f).
     rewrite (grinvop G).
     apply (commax G).
   - rewrite (setofendabgr_to_unel f).
     apply (grinvunel G).
Defined.

Local Open Scope abgr_scope.

Definition islinv_setofendabgr_inv {G : abgr} : islinv (@rngofendabgr_op1 G) setofendabgr_un0 setofendabgr_inv.
Proof.
   intro f.
   use total2_paths_f.
   - apply funextfun. intro x.
     apply (grlinvax G).
   - apply isapropismonoidfun.
Defined.

Definition isrinv_setofendabgr_inv {G : abgr} : isrinv (@rngofendabgr_op1 G) setofendabgr_un0 setofendabgr_inv.
Proof.
   intro f.
   use total2_paths_f.
   - apply funextfun. intro x.
     apply (grrinvax G).
   - apply isapropismonoidfun.
Defined.

Definition isinv_setofendabgr_inv {G : abgr} : isinv (@rngofendabgr_op1 G) (unel_is (@ismonoidop_rngofendabgr_op1 G)) setofendabgr_inv :=
  mk_isinv islinv_setofendabgr_inv isrinv_setofendabgr_inv.

Definition invstruct_setofendabgr_inv {G : abgr} : invstruct (@rngofendabgr_op1 G) ismonoidop_rngofendabgr_op1 :=
   mk_invstruct (@setofendabgr_inv G) (@isinv_setofendabgr_inv G).

Definition isgrop_rngofendabgr_op1 {G : abgr} : isgrop (@rngofendabgr_op1 G) :=
   isgroppair ismonoidop_rngofendabgr_op1 invstruct_setofendabgr_inv.

Definition iscomm_rngofendabgr_op1 {G : abgr} : iscomm (@rngofendabgr_op1 G).
Proof.
   intros f g.
   use total2_paths_f.
   - apply funextfun. intro x.
     apply (commax G).
   - apply (isapropismonoidfun).
Defined.

Definition isabgrop_rngofendabgr_op1 {G : abgr} : isabgrop (@rngofendabgr_op1 G) :=
  mk_isabgrop isgrop_rngofendabgr_op1 iscomm_rngofendabgr_op1.

(** rngofendabgr_op2 is a monoid operation *)

Definition isassoc_rngofendabgr_op2 {G : abgr} : isassoc (@rngofendabgr_op2 G).
Proof.
  intros f g h.
  use total2_paths_f.
  - apply funcomp_assoc.
  - apply isapropismonoidfun.
Defined.

Definition setofendabgr_un1 {G: abgr} : monoidfun G G.
Proof.
   apply (@monoidfunconstr _ _ (idfun G)).
   apply dirprodpair.
   - intros x x'. reflexivity.
   - reflexivity.
Defined.

Definition islunit_setofendabgr_un1 {G : abgr} : islunit (@rngofendabgr_op2 G) setofendabgr_un1.
Proof.
   intro f.
   use total2_paths_f.
   - apply funextfun. intro x. reflexivity.
   - apply isapropismonoidfun.
Defined.

Definition isrunit_setofendabgr_un1 {G : abgr} : isrunit (@rngofendabgr_op2 G) setofendabgr_un1.
Proof.
   intros f.
   use total2_paths_f.
   - apply funextfun. intro x. reflexivity.
   - apply isapropismonoidfun.
Defined.

Definition isunit_setofendabgr_un1 {G : abgr} : isunit (@rngofendabgr_op2 G) setofendabgr_un1 :=
  isunitpair islunit_setofendabgr_un1 isrunit_setofendabgr_un1.

Definition isunital_rngofendabgr_op2 {G : abgr} : isunital (@rngofendabgr_op2 G) :=
  isunitalpair setofendabgr_un1 isunit_setofendabgr_un1.

Definition ismonoidop_rngofendabgr_op2 {G : abgr} : ismonoidop (@rngofendabgr_op2 G) :=
   mk_ismonoidop isassoc_rngofendabgr_op2 isunital_rngofendabgr_op2.

(** rngofendabgr_op2 is distributive over rngofendabgr_op1 *)

Definition isldistr_setofendabgr_op {G : abgr} : isldistr (@rngofendabgr_op1 G) (@rngofendabgr_op2 G).
Proof.
   intros f g h.
   use total2_paths_f.
   - apply funextfun. intro x. reflexivity.
   - apply isapropismonoidfun.
Defined.

Definition isrdistr_setofendabgr_op {G : abgr} : isrdistr (@rngofendabgr_op1 G) (@rngofendabgr_op2 G).
Proof.
   intros f g h.
   use total2_paths_f.
   - apply funextfun. intro x.
     apply (setofendabgr_to_isbinopfun h).
   - apply isapropismonoidfun.
Defined.

Definition isdistr_setofendabgr_op {G : abgr} : isdistr (@rngofendabgr_op1 G) (@rngofendabgr_op2 G) :=
   dirprodpair isldistr_setofendabgr_op isrdistr_setofendabgr_op.

Definition isrngops_setofendabgr_op {G : abgr} : isrngops (@rngofendabgr_op1 G) (@rngofendabgr_op2 G) :=
   mk_isrngops isabgrop_rngofendabgr_op1 ismonoidop_rngofendabgr_op2 isdistr_setofendabgr_op.

(** The set of endomorphisms of an abelian group is a ring *)

Definition rngofendabgr (G : abgr) : rng :=
   @rngpair (setwith2binopofendabgr G) (@isrngops_setofendabgr_op G).

(** * The definition of the small type of (left) R-modules over a ring R *)

Definition module_struct (R : rng) (G : abgr) : UU := rngfun R (rngofendabgr G).

Definition module (R : rng) : UU := ∑ G, module_struct R G.

Definition pr1module {R : rng} (M : module R) : abgr := pr1 M.

Coercion pr1module : module >-> abgr.

Definition pr2module {R : rng} (M : module R) : module_struct R (pr1module M) := pr2 M.

Identity Coercion id_module_struct : module_struct >-> rngfun.

Definition modulepair {R : rng} (G : abgr) (f : module_struct R G) : module R := tpair _ G f.

(** The multiplication defined from a module *)

Definition module_mult {R : rng} (M : module R) : R -> M -> M := λ r : R, λ x : M, (pr1setofendabgr (pr2module M r) x).

Notation "r * x" := (module_mult _ r x) : module_scope.

Delimit Scope module_scope with module.

Local Open Scope rig_scope.

Definition rigfun_to_unel_rigaddmonoid {X Y : rig} (f : rigfun X Y) : f 0 = 0 := pr2 (pr1 (pr2 f)).

Local Close Scope rig_scope.

Local Open Scope module.

Definition module_mult_0_to_0 {R : rng} {M : module R} (x : M) : rngunel1 * x = @unel M.
Proof.
   unfold module_mult. cbn.
   assert (pr2module M rngunel1 = @rngunel1 (rngofendabgr M)).
   - exact (rigfun_to_unel_rigaddmonoid (pr2module M)).
   - rewrite X.
     reflexivity.
Defined.

(** To construct a module from a left action satisfying four axioms *)

Local Open Scope addmonoid.

Definition mult_isldistr_wrt_grop {R : rng} {G : abgr} (m : R -> G -> G) : UU := ∏ r : R, ∏ x y : G, m r (x + y) = (m r x) + (m r y).

Definition mult_isrdistr_wrt_rngop1 {R : rng} {G : abgr} (m : R -> G -> G) : UU := ∏ r s : R, ∏ x : G, m (op1 r s) x = (m r x) + (m s x).

Definition mult_isrdistr_wrt_rngop2 {R : rng} {G : abgr} (m : R -> G -> G) : UU := ∏ r s : R, ∏ x : G, m (op2 r s) x = m s (m r x).

Definition mult_unel {R : rng} {G : abgr} (m : R -> G -> G) : UU := ∏ x : G, m rngunel2 x = x.

Local Close Scope addmonoid.

Definition mult_to_rngofendabgr {R : rng} {G : abgr} {m : R -> G -> G} (ax1 : mult_isldistr_wrt_grop m) (r : R) : rngofendabgr G.
Proof.
    use monoidfunconstr.
    intro x. exact (m r x).
    apply dirprodpair.
    + intros x y. apply ax1.
    + apply (grlcan G (m r (unel G))).
      rewrite runax.
      rewrite <- (ax1 r (unel G) (unel G)).
      rewrite runax.
      apply idpath.
Defined.

Definition mult_to_module_struct {R : rng} {G : abgr} {m : R -> G -> G} (ax1 : mult_isldistr_wrt_grop m) (ax2 : mult_isrdistr_wrt_rngop1 m)
  (ax3 : mult_isrdistr_wrt_rngop2 m) (ax4 : mult_unel m) : module_struct R G.
Proof.
  split with (λ r : R, mult_to_rngofendabgr ax1 r).
  apply dirprodpair.
  - apply dirprodpair.
    + intros r s.
      use total2_paths2_f.
      * apply funextfun. intro x. apply ax2.
      * apply isapropismonoidfun.
    + use total2_paths2_f.
      * apply funextfun. intro x. change (m rngunel1 x = unel G). apply (grlcan G (m (rngunel1) x)). rewrite runax.
        rewrite <- (ax2 rngunel1 rngunel1 x). rewrite rngrunax1. apply idpath.
      * apply isapropismonoidfun.
  -  apply dirprodpair.
     + intros r s.
       use total2_paths2_f.
       * apply funextfun. intro x. apply ax3.
       * apply isapropismonoidfun.
     + use total2_paths2_f.
       * apply funextfun. intro x. apply ax4.
       * apply isapropismonoidfun.
Defined.

Definition mult_to_module {R : rng} {G : abgr} {m : R -> G -> G} (ax1 : mult_isldistr_wrt_grop m) (ax2 : mult_isrdistr_wrt_rngop1 m)
  (ax3 : mult_isrdistr_wrt_rngop2 m) (ax4 : mult_unel m) : module R := modulepair G (mult_to_module_struct ax1 ax2 ax3 ax4).

(** (left) R-module homomorphism *)

Definition islinear {R : rng} {M N : module R} (f : M -> N) :=
  ∏ r : R, ∏ x : M, f (r * x) = r * (f x).

Definition isaprop_islinear {R : rng} {M N : module R} (f : M -> N) : isaprop (islinear f).
Proof.
   use impred. intro r.
   use impred. intro x.
   apply setproperty.
Defined.

Definition islinear_id {R : rng} (M : module R) : islinear (idfun M).
Proof.
  intros r x.
  unfold idfun. apply idpath.
Defined.

Definition linearfun {R : rng} (M N : module R) : UU := ∑ f : M -> N, islinear f.

Definition linearfunpair {R : rng} {M N : module R} (f : M -> N) (is : islinear f) : linearfun M N := tpair _ f is.

Definition pr1linearfun {R : rng} {M N : module R} (f : linearfun M N) : M -> N := pr1 f.

Coercion pr1linearfun : linearfun >-> Funclass.

Definition islinearfuncomp {R : rng} {M N P : module R} (f : linearfun M N) (g : linearfun N P) : islinear (funcomp (pr1 f) (pr1 g)).
Proof.
  intros r x.
  unfold funcomp.
  rewrite (pr2 f).
  rewrite (pr2 g).
  apply idpath.
Defined.

Definition linearfuncomp {R : rng} {M N P : module R} (f : linearfun M N) (g : linearfun N P) : linearfun M P :=
  tpair _ (funcomp f g) (islinearfuncomp f g).

Definition ismodulefun {R : rng} {M N : module R} (f : M -> N) : UU :=
   (isbinopfun f) × (islinear f).

Lemma isapropismodulefun {R : rng} {M N : module R} (f : M -> N) : isaprop (ismodulefun f).
Proof.
   refine (@isofhleveldirprod 1 (isbinopfun f) (islinear f) _ _).
   exact (isapropisbinopfun f).
   exact (isaprop_islinear f).
Defined.

Definition ismodulefun_id {R : rng} (M : module R) : ismodulefun (idfun M).
Proof.
  apply dirprodpair.
  - intros x y. apply idpath.
  - intros. apply  islinear_id.
Defined.

Definition modulefun {R : rng} (M N : module R) : UU := ∑ f : M -> N, ismodulefun f.

Definition modulefunpair {R : rng} {M N : module R} (f : M -> N) (is : ismodulefun f) : modulefun M N :=
   tpair _ f is.

Definition pr1modulefun {R : rng} {M N : module R} (f : modulefun M N) : M -> N := pr1 f.

Coercion pr1modulefun : modulefun >-> Funclass.

Definition modulefun_to_isbinopfun {R : rng} {M N : module R} (f : modulefun M N) : isbinopfun (pr1modulefun f) := pr1 (pr2 f).

Definition modulefun_to_binopfun {R : rng} {M N : module R} (f : modulefun M N) : binopfun M N :=
  binopfunpair (pr1modulefun f) (modulefun_to_isbinopfun f).

Definition modulefun_to_islinear {R : rng} {M N : module R} (f : modulefun M N): islinear (pr1modulefun f) := pr2 (pr2 f).

Definition modulefun_to_linearfun {R : rng} {M N : module R} (f : modulefun M N) : linearfun M N :=
  linearfunpair f (modulefun_to_islinear f).

Definition modulefun_unel {R : rng} {M N : module R} (f : modulefun M N) : f (unel M) = unel N.
Proof.
   rewrite <- (module_mult_0_to_0 (unel M)).
   rewrite ((modulefun_to_islinear f) rngunel1 (unel M)).
   rewrite (module_mult_0_to_0 _).
   reflexivity.
Defined.

(** From modules to abelian groups with operators *)

Definition module_to_grwithaction {R : rng} (M : module R) : grwithaction R := tpair (λ G : gr, action R G) (pr1module M) (module_mult M).

Definition module_to_ishdistr_action {R : rng} (M : module R) :
  ishdistr_action (@op (gr_to_typewithbinop M)) (module_mult M).
Proof.
  intros r x y.
  apply (pr1 (pr2 (pr2 M r))).
Defined.

Definition module_to_grwithoperators {R : rng} (M : module R) : grwithoperators R :=
  tpair _ (module_to_grwithaction M) (module_to_ishdistr_action M).

Coercion module_to_grwithoperators : module >-> grwithoperators .

(** Submodules of a module *)

Definition submodule {R : rng} (M : module R) : UU := stable_subgr M.

Definition submodule_to_gr {R : rng} {M : module R} (N : submodule M) : gr := stable_subgr_to_gr N.

Definition submodule_to_abgr {R : rng} {M : module R} (N : submodule M) : abgr.
Proof.
  use abgrpair.
  - exact (pr1 (submodule_to_gr N)).
  - apply dirprodpair.
    + exact (pr2 (submodule_to_gr N)).
    + intros x y. use total2_paths_f.
      * apply (dirprod_pr2 (pr2 (pr1module M))).
      * apply propproperty.
Defined.

Definition submodule_to_module_struct {R : rng} {M : module R} (N : submodule M) : module_struct R (submodule_to_abgr N).
Proof.
  use rngfunconstr.
  - intro r.
    use monoidfunconstr.
    + intro x.
      split with (module_mult M r (pr1 x)).
      apply (pr2 (pr2 N) r (pr1 x)).
      apply (pr2 x).
    + apply dirprodpair.
      * intros x y.
        use total2_paths2_f.
        apply (pr1 (pr2 (pr2 M r))).
        apply propproperty.
      * use total2_paths2_f.
        apply (pr2 (pr2 (pr2 M r))).
        apply propproperty.
  - apply dirprodpair.
    + apply dirprodpair.
      * intros r s.
        use total2_paths2_f.
        apply funextfun. intro x.
        use total2_paths2_f.
        assert (p : pr1 (pr1 (pr2 M) (@op1 R r s)) ~ pr1 (@op1 (rngofendabgr (pr1 M)) (pr1 (pr2 M) r) (pr1 (pr2 M) s))).
        use eqtohomot. apply (base_paths _ _ (dirprod_pr1 (dirprod_pr1 (pr2 (pr2 M))) r s)).
        apply (p (pr1 x)).
        apply propproperty.
        apply isapropismonoidfun.
      * use total2_paths2_f.
        apply funextfun. intro x.
        use total2_paths2_f.
        assert (p : pr1 (pr1 (pr2 M) (@rngunel1 R)) ~ pr1 (@rngunel1 (rngofendabgr (pr1 M)))).
        use eqtohomot. apply (base_paths _ _ (dirprod_pr2 (dirprod_pr1 (pr2 (pr2 M))))).
        apply (p (pr1 x)).
        apply propproperty.
        apply isapropismonoidfun.
    + apply dirprodpair.
      * intros r s.
        use total2_paths2_f.
        apply funextfun. intro x.
        use total2_paths2_f.
        assert (p : pr1 (pr1 (pr2 M) (@op2 R r s)) ~ pr1 (@op2 (rngofendabgr (pr1 M)) (pr1 (pr2 M) r) (pr1 (pr2 M) s))).
        use eqtohomot. apply (base_paths _ _ (dirprod_pr1 (dirprod_pr2 (pr2 (pr2 M))) r s)).
        apply (p (pr1 x)).
        apply propproperty.
        apply isapropismonoidfun.
      * use total2_paths2_f.
        apply funextfun. intro x.
        use total2_paths2_f.
        assert (p : pr1 (pr1 (pr2 M) (@rngunel2 R)) ~ pr1 (@rngunel2 (rngofendabgr (pr1 M)))).
        use eqtohomot. apply (base_paths _ _ (dirprod_pr2 (dirprod_pr2 (pr2 (pr2 M))))).
        apply (p (pr1 x)).
        apply propproperty.
        apply isapropismonoidfun.
Defined.

Definition submodule_to_module {R : rng} {M : module R} (N : submodule M) : module R :=
  modulepair (submodule_to_abgr N) (submodule_to_module_struct N).

(** * Univalence for R-modules *)

Definition moduleiso {R : rng} (M N : module R) : UU := ∑ w : M ≃ N, ismodulefun w.

Definition moduleiso_to_modulefun {R : rng} (M N : module R) : moduleiso M N -> modulefun M N.
Proof.
   intro f.
   exact (tpair _ (pr1weq (pr1 f)) (pr2 f)).
Defined.

Coercion moduleiso_to_modulefun : moduleiso >-> modulefun.

Definition pr1moduleiso {R : rng} {M N : module R} (f : moduleiso M N) : M ≃ N := pr1 f.

Coercion pr1moduleiso : moduleiso >-> weq.

Definition moduleisopair {R : rng} {M N : module R} (f : M ≃ N) (is : ismodulefun f) : moduleiso M N :=
   tpair _ f is.

Definition idmoduleiso {R : rng} (M : module R) : moduleiso M M.
Proof.
   use moduleisopair.
   - exact (idweq (pr1module M)).
   - apply dirprodpair.
     + intros x y. apply idpath.
     + intros r x. apply idpath.
Defined.

Definition isbinopfuninvmap {R : rng} {M N : module R} (f : moduleiso M N) : isbinopfun (invmap f).
Proof.
   intros x y.
   apply (invmaponpathsweq f).
   rewrite (homotweqinvweq f (op x y)).
   symmetry.
   transitivity (op ((pr1moduleiso f) (invmap f x)) ((pr1moduleiso f) (invmap f y))).
   apply (modulefun_to_isbinopfun f (invmap f x) (invmap f y)).
   rewrite 2 (homotweqinvweq f).
   apply idpath.
Defined.

Definition islinearinvmap {R : rng} {M N : module R} (f : moduleiso M N) : islinear (invmap f).
Proof.
   intros r x.
   apply (invmaponpathsweq f).
   transitivity (module_mult N r x).
   exact (homotweqinvweq f (module_mult N r x)).
   transitivity (module_mult N r (pr1 f (invmap (pr1 f) x))).
   rewrite (homotweqinvweq (pr1 f) x).
   apply idpath.
   symmetry.
   apply (pr2 (pr2 f) r (invmap f x)).
Defined.

Definition invmoduleiso {R : rng} {M N : module R} (f : moduleiso M N) : moduleiso N M.
Proof.
   use moduleisopair.
   - exact (invweq f).
   - apply dirprodpair.
     + exact (isbinopfuninvmap f).
     + exact (islinearinvmap f).
Defined.

Definition moduleiso' {R : rng} (M N : module R) : UU := ∑ w : monoidiso (pr1module M) (pr1module N), islinear w.

Definition moduleiso_to_moduleiso' {R : rng} (M N : module R) : moduleiso M N -> moduleiso' M N.
Proof.
   intro w.
   use tpair.
   - use tpair.
     + exact w.
     + use tpair.
       * exact (modulefun_to_isbinopfun w).
       * apply (modulefun_unel w).
   - exact (modulefun_to_islinear w).
Defined.

Definition moduleiso'_to_moduleiso {R : rng} (M N : module R) : moduleiso' M N -> moduleiso M N.
Proof.
   intro w.
   use tpair.
   - exact (pr1 w).
   - apply dirprodpair.
     + exact (pr1 (pr2 (pr1 w))).
     + exact (pr2 w).
Defined.

Lemma modulefun_unel_uniqueness {R : rng} {M N : module R} {f : pr1module M -> pr1module N} {is: ismodulefun f}
       (p : f (@unel (pr1module M)) = @unel (pr1module N)) : modulefun_unel (f,,is) = p.
Proof.
   apply (setproperty (pr1module N)).
Defined.

Definition moduleiso'_to_moduleiso_isweq {R : rng} (M N : module R) : isweq (moduleiso'_to_moduleiso M N).
Proof.
   use (gradth _ (moduleiso_to_moduleiso' M N)). intro w.
   unfold moduleiso'_to_moduleiso, moduleiso_to_moduleiso'. cbn.
   rewrite (modulefun_unel_uniqueness (dirprod_pr2 (pr2 (pr1 w)))).
   apply idpath.
   intro w. apply idpath.
Defined.

Definition moduleiso'_to_moduleiso_weq {R : rng} (M N : module R) : (moduleiso' M N) ≃ (moduleiso M N) :=
   weqpair (moduleiso'_to_moduleiso M N) (moduleiso'_to_moduleiso_isweq M N).

(* The next lemma below should be moved to Rigs_and_Rings.v *)

Lemma isaset_rngfun (X Y : rng) : isaset (rngfun X Y).
Proof.
   apply (isofhleveltotal2 2).
   - use impred_isaset. intro x.
     apply setproperty.
   - intro f.
     apply (isasetaprop (isapropisrigfun f)).
Defined.

Definition modules_univalence_weq {R : rng} (M N : module R) : (M ╝ N) ≃ (moduleiso' M N).
Proof.
   use weqbandf.
   - apply abgr_univalence.
   - intro e.
     use invweq.
     induction M. induction N. cbn in e. induction e.
     use weqimplimpl.
     + intro i.
       use total2_paths2_f.
       * use funextfun. intro r.
         use total2_paths2_f.
           apply funextfun. intro x. exact (i r x).
           apply isapropismonoidfun.
       * apply isapropisrigfun.
     + intro i. cbn.
       intros r x.
       unfold idmonoidiso. cbn in i.
       induction i.
       apply idpath.
     + apply isaprop_islinear.
     + apply isaset_rngfun.
Defined.

Definition modules_univalence_map {R : rng} (M N : module R) : (M = N) -> (moduleiso M N).
Proof.
   intro p.
   induction p.
   exact (idmoduleiso M).
Defined.

Definition modules_univalence_map_isweq {R : rng} (M N : module R) : isweq (modules_univalence_map M N).
Proof.
   use isweqhomot.
   - exact (weqcomp (weqcomp (total2_paths_equiv _ M N) (modules_univalence_weq M N)) (moduleiso'_to_moduleiso_weq M N)).
   - intro p.
     induction p.
     apply (pathscomp0 weqcomp_to_funcomp_app).
     apply idpath.
   - apply weqproperty.
Defined.

Definition modules_univalence {R : rng} (M N : module R) : (M = N) ≃ (moduleiso M N).
Proof.
   use weqpair.
   - exact (modules_univalence_map M N).
   - exact (modules_univalence_map_isweq M N).
Defined.

Section univalent_category_modules.

(** * The precategory of (left) R-modules and R-modules homomorphisms *)

Variable R : rng.

Definition precategory_ob_mor_module : precategory_ob_mor :=
   precategory_ob_mor_pair (module R) (λ M N, modulefun M N).

Local Open Scope Cat.

Definition modulefun_id : ∏ M : precategory_ob_mor_module, M --> M.
Proof.
  intro M.
  exists (idfun (pr1module M)).
  exact (ismodulefun_id M).
Defined.

Definition ismodulefun_comp {M N P : precategory_ob_mor_module} (f : M --> N) (g : N --> P) :
  ismodulefun (funcomp (pr1modulefun f) (pr1modulefun g)) :=
    dirprodpair (isbinopfuncomp (modulefun_to_binopfun f) (modulefun_to_binopfun g))
                (islinearfuncomp (modulefun_to_linearfun f) (modulefun_to_linearfun g)).

Definition modulefun_comp : ∏ M N P : precategory_ob_mor_module, M --> N → N --> P → M --> P.
Proof.
    intros  M N P f g.
    exists (funcomp (pr1modulefun f) (pr1modulefun g)).
    exact (ismodulefun_comp f g).
Defined.

Definition precategory_id_comp_module : precategory_id_comp (precategory_ob_mor_module) :=
  dirprodpair (modulefun_id) (modulefun_comp).

Definition precategory_data_module : precategory_data :=
   tpair _ (precategory_ob_mor_module) (precategory_id_comp_module).

Definition is_precategory_precategory_data_module : is_precategory (precategory_data_module).
Proof.
   apply dirprodpair.
   - apply dirprodpair.
     + intros M N f.
       use total2_paths_f.
       * apply funextfun. intro x. apply idpath.
       * apply isapropismodulefun.
     + intros M N f.
       use total2_paths_f.
       * apply funextfun. intro x. apply idpath.
       * apply isapropismodulefun.
   - intros M N P Q f g h.
     use total2_paths_f.
     + apply funextfun. intro x.
       unfold compose. cbn.
       rewrite funcomp_assoc.
       apply idpath.
     + apply isapropismodulefun.
Defined.

Definition Mod : precategory :=
   mk_precategory (precategory_data_module) (is_precategory_precategory_data_module).

(** * The category of (left) R-modules and R-modules homomorphisms *)

(** The precategory of R-modules has homsets *)

Definition has_homsets_Mod : has_homsets Mod.
Proof.
   intros M N. unfold isaset. intros f g. unfold isaprop.
   apply (isofhlevelweqb 1 (total2_paths_equiv (λ x :  pr1module M ->  pr1module N, ismodulefun x) f g)).
   refine (isofhleveltotal2 1 _ _ _).
   - assert (p : isofhlevel 2 (pr1module M ->  pr1module N)).
     + apply impred. intro.
       exact (setproperty (pr1module N)).
     + exact (p (pr1 f) (pr1 g)).
   - intro p.
     assert (q : isaset (ismodulefun (pr1 g))).
     + exact (isasetaprop (isapropismodulefun (pr1 g))).
     + apply q.
Defined.

Definition category_Mod : category := category_pair Mod has_homsets_Mod.

(** * The univalent category of (left) R-modules and R-modules homomorphisms *)

(** Equivalence between isomorphisms and moduleiso in Mod R *)

Lemma iso_isweq {M N : ob Mod} (f : iso M N) : isweq (pr1 (pr1 f)).
Proof.
   use (gradth (pr1 (pr1 f))).
   - exact (pr1 (inv_from_iso f)).
   - intro x.
     set (T:= iso_inv_after_iso f).
     apply subtypeInjectivity in T.
     + set (T':= toforallpaths _ _ _ T).
       apply T'.
     + intro g.
       apply isapropismodulefun.
   - intro y.
     set (T:= iso_after_iso_inv f).
     apply subtypeInjectivity in T.
     + set (T':= toforallpaths _ _ _ T).
       apply T'.
     + intro g.
       apply isapropismodulefun.
Defined.

Lemma iso_moduleiso (M N : ob Mod) : iso M N -> moduleiso M N.
Proof.
   intro f.
   use moduleisopair.
   - use weqpair.
     + exact (pr1 (pr1 f)).
     + exact (iso_isweq f).
   - exact (pr2 (pr1 f)).
Defined.

Lemma moduleiso_is_iso {M N : ob Mod} (f : moduleiso M N) : @is_iso Mod M N (modulefunpair f (pr2 f)).
Proof.
   apply (is_iso_qinv (C:= Mod) _ (modulefunpair (invmoduleiso f) (pr2 (invmoduleiso f)))).
   split.
   - use total2_paths_f.
     + apply funextfun. intro x.
       unfold funcomp, idfun.
       apply homotinvweqweq.
     + apply isapropismodulefun.
   - use total2_paths_f.
     + apply funextfun. intro y.
       apply homotweqinvweq.
     + apply isapropismodulefun.
Defined.

Lemma moduleiso_iso (M N : ob Mod) : moduleiso M N -> iso M N.
Proof.
   intro f.
   use isopair.
   - use tpair.
     + exact f.
     + exact (pr2 f).
   - exact (moduleiso_is_iso f).
Defined.

Lemma moduleiso_iso_isweq (M N : ob Mod) : isweq (@moduleiso_iso M N).
Proof.
   apply (gradth _ (iso_moduleiso M N)).
   - intro f.
     apply subtypeEquality.
     + intro w.
       apply isapropismodulefun.
     + unfold moduleiso_iso, iso_moduleiso.
       use total2_paths_f.
       * apply idpath.
       * apply isapropisweq.
   - intro f.
     unfold iso_moduleiso, moduleiso_iso.
     use total2_paths_f.
     + apply idpath.
     + apply isaprop_is_iso.
Defined.

Definition moduleiso_iso_weq (M N : Mod) : (moduleiso M N) ≃ (iso M N) :=
   weqpair (moduleiso_iso M N) (moduleiso_iso_isweq M N).

Definition Mod_idtoiso_isweq : ∏ M N : ob Mod, isweq (fun p : M = N => idtoiso p).
Proof.
   intros M N.
   use (isweqhomot (weqcomp (modules_univalence M N) (moduleiso_iso_weq M N)) _).
   - intro p.
     induction p.
     use (pathscomp0 weqcomp_to_funcomp_app). cbn.
     use total2_paths_f.
     + apply idpath.
     + apply isaprop_is_iso.
   - apply weqproperty.
Defined.

Definition Mod_is_univalent : is_univalent Mod :=
  mk_is_univalent Mod_idtoiso_isweq has_homsets_Mod.

Definition univalent_category_Mod : univalent_category := mk_category Mod Mod_is_univalent.

End univalent_category_modules.


(*
 Copyright 2022 ZhengPu Shi
  This file is part of coq-matrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : auxiliary library for sequence.
  author    : ZhengPu Shi
  date      : 2022.06
*)

Require Import Nat PeanoNat Lia Bool.
Require Import FieldStruct.

(* ######################################################################### *)
(** * Sequence by function, f : nat -> X *)

Module Sequence (F : FieldSig).

  Module Export FieldThyInst := FieldThy F.

  Open Scope nat.
  Open Scope X_scope.

  (* ======================================================================= *)
  (** ** Equality of sequence *)
  Section Equality.

    (** Equality of two sequence *)
    Definition seqeq n (f g : nat -> X) := forall i, i < n -> f i = g i.

    (** seqeq of Sn has a equivalent form. *)
    Lemma seqeq_Sn : forall n (f g : nat -> X),
      seqeq (S n) f g <->
      (seqeq n f g) /\ (f n = g n).
    Proof.
      split.
      - intros. split; auto. unfold seqeq. auto.
      - unfold seqeq. intros. destruct H. destruct (i =? n)%nat eqn : E1.
        + apply Nat.eqb_eq in E1. subst; auto.
        + apply Nat.eqb_neq in E1. apply H. lia.
    Qed.

    (** Boolean equality of two sequence *)
    Fixpoint seqeqb n (f g : nat -> X) : bool :=
      match n with
      | O => true
      | 1 => Xeqb (f 0)%nat (g 0)%nat
      | S n' => (seqeqb n' f g) && Xeqb (f n') (g n')
      end.

    (** seqeqb of Sn has a equivalent form. *)
    Lemma seqeqb_Sn : forall {n} (f g : nat -> X),
      seqeqb (S n) f g = (seqeqb n f g) && (Xeqb (f n) (g n)).
    Proof. intros. destruct n; auto. Qed.

    (** seqeqb = true <-> seqeq *)
    Lemma seqeqb_true_iff : forall n f g, seqeqb n f g = true <-> seqeq n f g.
    Proof.
      induction n; intros.
      - unfold seqeqb, seqeq. split; intros; auto. lia.
      - rewrite seqeqb_Sn. rewrite seqeq_Sn.
        rewrite andb_true_iff.
        (* s1 <-> t1 -> s2 <-> t2 -> s1 /\ s2 <-> t1 /\ t2 *)
        apply ZifyClasses.and_morph; auto.
        apply Xeqb_true_iff.
    Qed.

    (** seqeqb = false <-> ~seqeq *)
    Lemma seqeqb_false_iff : forall n f g,
      seqeqb n f g = false <-> ~(seqeq n f g).
    Proof.
      induction n; intros.
      - unfold seqeqb, seqeq. split; intros; try easy. destruct H. easy.
      - rewrite seqeqb_Sn. rewrite seqeq_Sn.
        rewrite andb_false_iff.
        rewrite IHn. rewrite Xeqb_false_iff. split; intros H.
        + apply Classical_Prop.or_not_and; auto.
        + apply Classical_Prop.not_and_or in H; auto.
    Qed.

    (** seqeq is decidable *)
    Lemma seqeq_dec : forall n f g, {@seqeq n f g} + {~(@seqeq n f g)}.
    Proof.
      intros. destruct (seqeqb n f g) eqn:E1.
      - left. apply seqeqb_true_iff in E1. auto.
      - right. apply seqeqb_false_iff in E1. auto.
    Qed.

  End Equality.

  (* ======================================================================= *)
  (** ** Equality of sequence with two index *)
  Section Equality2.

    (** Equality of two sequence *)
    Definition seq2eq r c (f g : nat -> nat -> X) :=
      forall ri ci, ri < r -> ci < c -> f ri ci = g ri ci.

    (** seq2eq of Sr has a equivalent form. *)
    Lemma seq2eq_Sr : forall r c (f g : nat -> nat -> X),
      seq2eq (S r) c f g <->
      (seq2eq r c f g) /\ (seqeq c (f r) (g r)).
    Proof.
      split.
      - intros. split; auto.
        + unfold seq2eq in *. intros. apply H; auto.
        + unfold seq2eq, seqeq in *. intros. auto.
      - unfold seq2eq,seqeq. intros. destruct H.
        destruct (ri =? r)%nat eqn : E1.
        + apply Nat.eqb_eq in E1. subst; auto.
        + apply Nat.eqb_neq in E1. apply H; auto. lia.
    Qed.

    (** Boolean equality of two sequence *)
    Fixpoint seq2eqb r c (f g : nat -> nat -> X) : bool :=
      match r with
      | O => true
      | 1 => seqeqb c (f 0)%nat (g 0)%nat
      | S r' => (seq2eqb r' c f g) && (seqeqb c (f r') (g r'))
      end.

    (** seq2eqb of Sr has a equivalent form. *)
    Lemma seq2eqb_Sr : forall r c (f g : nat -> nat -> X),
      seq2eqb (S r) c f g = (seq2eqb r c f g) && (seqeqb c (f r) (g r)).
    Proof. intros. destruct r; auto. Qed.

    (** seq2eqb = true <-> seq2eq *)
    Lemma seq2eqb_true_iff : forall r c f g,
      seq2eqb r c f g = true <-> seq2eq r c f g.
    Proof.
      induction r; intros.
      - unfold seq2eqb, seq2eq. split; intros; auto. lia.
      - rewrite seq2eqb_Sr. rewrite seq2eq_Sr.
        rewrite andb_true_iff.
        (* s1 <-> t1 -> s2 <-> t2 -> s1 /\ s2 <-> t1 /\ t2 *)
        apply ZifyClasses.and_morph; auto.
        apply seqeqb_true_iff.
    Qed.

    (** seq2eqb = false <-> ~seq2eq *)
    Lemma seq2eqb_false_iff : forall r c f g,
      seq2eqb r c f g = false <-> ~(seq2eq r c f g).
    Proof.
      induction r; intros.
      - unfold seq2eqb, seq2eq. split; intros; try easy. destruct H. easy.
      - rewrite seq2eqb_Sr. rewrite seq2eq_Sr.
        rewrite andb_false_iff.
        rewrite IHr. rewrite seqeqb_false_iff. split; intros H.
        + apply Classical_Prop.or_not_and; auto.
        + apply Classical_Prop.not_and_or in H; auto.
    Qed.

    (** seq2eq is decidable *)
    Lemma seq2eq_dec : forall r c f g, {seq2eq r c f g} + {~(seq2eq r c f g)}.
    Proof.
      intros. destruct (seq2eqb r c f g) eqn:E1.
      - left. apply seq2eqb_true_iff in E1. auto.
      - right. apply seq2eqb_false_iff in E1. auto.
    Qed.

  End Equality2.

  (* ======================================================================= *)
  (** ** Sum of a sequence *)
  Section Sum.

    (** Same sequence and same index get same element *)
    Lemma f_equal_gen : forall {X B} (f g : X -> B) a b,
      f = g -> a = b -> f a = g b.
    Proof. intros. subst. reflexivity. Qed.

    (** Sum of a sequence *)
    Fixpoint seqsum (f : nat -> X) (n : nat) : X :=
      match n with
      | O => X0
      | S n' => seqsum f n' + f n'
      end.

    (** Sum of a sequence which every element is zero get zero. *)
    Lemma seqsum_seq0 : forall (f : nat -> X) (n : nat),
      (forall i, (i < n) -> f i = X0) -> seqsum f n = X0.
    Proof.
      intros f n H. induction n; auto.
      simpl. rewrite H; auto. rewrite IHn; auto. ring.
    Qed.

    (** Corresponding elements of two sequences are equal, imply the sum are
      equal. *)
    Lemma seqsum_eq : forall (f g : nat -> X) (n : nat),
      (forall i, i < n -> f i = g i) ->
      seqsum f n = seqsum g n.
    Proof.
      intros f g n H.
      induction n; simpl; auto.
      rewrite H, IHn; auto.
    Qed.

    (** Sum with plus of two sequence equal to plus with two sum. *)
    Lemma seqsum_plusSeq : forall (f g : nat -> X) (n : nat),
      seqsum (fun i => f i + g i) n = seqsum f n + seqsum g n.
    Proof.
      intros f g n. induction n; simpl. ring.
      rewrite IHn. ring.
    Qed.

    (** Constant left multiply to the sum of a sequence. *)
    Lemma seqsum_cmul_l : forall c (f : nat -> X) (n : nat),
      c * seqsum f n = seqsum (fun i => c * f i) n.
    Proof.
      intros c f n. induction n; simpl; try ring.
      ring_simplify. rewrite IHn. ring.
    Qed.

    (** Constant right multiply to the sum of a sequence. *)
    Lemma seqsum_cmul_r : forall c (f : nat -> X) (n : nat),
      seqsum f n * c = seqsum (fun i => f i * c) n.
    Proof.
      intros c f n. induction n; simpl; try ring.
      ring_simplify. rewrite IHn. ring.
    Qed.

    (** Sum a sequence which only one item in nonzero, then got this item. *)
    Lemma seqsum_unique : forall (f : nat -> X) (k : X) (n i : nat),
      (i < n) -> f i = k -> (forall j, i <> j -> f j = X0) ->
      seqsum f n = k.
    Proof.
      (* key idea: induction n, and case {x =? n} *)
      intros f k n. induction n; intros. easy. simpl.
      destruct (i =? n)%nat eqn : E1.
      - apply Nat.eqb_eq in E1. subst.
        assert (seqsum f n = X0).
        { apply seqsum_seq0. intros. apply H1. subst. lia. }
        rewrite H0. ring.
      - apply Nat.eqb_neq in E1.
        assert (f n = X0).
        { apply H1; auto. }
        assert (seqsum f n = k).
        { apply IHn with i; auto. lia. }
        rewrite H3,H2. ring.
    Qed.

    (** Add the sum and a tail element *)
    Lemma seqsum_extend_r : forall n f,
      seqsum f n + f n = seqsum f (S n).
    Proof. reflexivity. Qed.

    (** Add a head element and the sum *)
    Lemma seqsum_extend_l : forall n f,
      f O + seqsum (fun i => f (S i)) n = seqsum f (S n).
    Proof.
      intros n f. induction n.
      - simpl. ring.
      - simpl. ring_simplify. rewrite IHn. simpl. ring.
    Qed.

    (** Sum the m+n elements equal to plus of two parts.
      Σ[i,0,(m+n)] f(i) = Σ[i,0,m] f(i) + Σ[i,0,n] f(m + i). *)
    Lemma seqsum_plusIdx : forall m n f, seqsum f (m + n) =
      seqsum f m + seqsum (fun i => f (m + i)%nat) n.
    Proof.
      intros m n f.
      induction m.
      - simpl. ring_simplify. auto.
      - simpl. rewrite IHm.
        rewrite ?add_assoc. f_equal.
        remember (fun x => f (m + x)%nat) as g.
        replace (f (m + n)%nat) with (g n).
        2:{ subst. auto. }
        replace (f m) with (g 0%nat).
        2:{ subst. f_equal. auto. }
        rewrite seqsum_extend_r.
        replace (seqsum (fun x : nat => f (S (m + x))) n) with
                (seqsum (fun x : nat => g (S x)) n).
        2:{ subst. apply seqsum_eq. intros. f_equal. auto. }
        rewrite seqsum_extend_l.
        auto.
    Qed.

    (** Product two sum equal to sum of products.
      Σ[i,0,m] f(i) * Σ[i,0,n] g(i) = Σ[i,0,m*n] f(i/n)*g(i%n).

      For example:
        (a + b + c) * (x + y) = a*x + a*y + b*x + b*y + c*x + c*y
    *)
    Lemma seqsum_product : forall m n f g, n <> O ->
      seqsum f m * seqsum g n =
      seqsum (fun i => f (i / n)%nat * g (i mod n)%nat) (m * n).
    Proof.
      intros.
      induction m.
      - simpl. ring.
      - simpl. ring_simplify. rewrite IHm. clear IHm.
        remember ((fun i : nat => f (i / n)%nat * g (i mod n)%nat)) as h.
        rewrite seqsum_cmul_l.
        (* Σ[i,0,n] f(m)*g(i) = Σ[i,0,n] f((m*n+i)/n)*g((m*n+i)%n) *)
        replace (seqsum (fun i : nat => f m * g i) n)
           with (seqsum (fun i : nat => h ((m * n) + i)%nat) n).
        + rewrite <- seqsum_plusIdx. f_equal. apply Nat.add_comm.
        + subst.
          apply seqsum_eq.
          intros i Hi. f_equal.
          * f_equal.
            (* (m * n + i) / n = m *)
            rewrite Nat.div_add_l; auto.  (* a * b + c) / b = a + c / b *)
            rewrite Nat.div_small; auto.  (* a < b -> a / b = 0 *)
          * f_equal.
            (* (m * n + i) % n = i *)
            rewrite Nat.add_mod; auto.  (* (a + b) % n = a % n + b % n) % n *)
            rewrite Nat.mod_mul; auto.  (* (a * b) mod b = 0 *)
            rewrite Nat.add_0_l.
            repeat rewrite Nat.mod_small; auto. (* a < b -> a % b = 0 *)
    Qed.

  End Sum.

End Sequence.

Module Sequence_test.

  Import Reals.
  Module Import SequenceR := Sequence (FieldR.FieldDefR).
  Open Scope R_scope.

(*   Example seq1 := fun n => R_of_ Z.of_nat n. *)
(*   Compute seqsum seq1 3. *)

(*   Print Aeqb. *)
(*   Eval simpl in seqeqb 5 seq1 seq1. *)
(*   Compute seqeqb 5 seq1 seq1. *)

(*   Example seq2 := fun i j => Z.of_nat i + Z.of_nat j. *)
(*   Eval simpl in seq2eqb 2 3 seq2 seq2. *)
(*   Compute seq2eqb 2 3 seq2 seq2. *)

End Sequence_test.


From mathcomp Require Import all_ssreflect.

Module Test_ssrnat.
  Fixpoint sum n :=
    if n is m.+1 then n + sum m else 0.

  Theorem double_sum n : 2 * sum n = n * n.+1.
  Proof.
    elim: n => [|n IHn] //=.
    rewrite -[n.+2]addn2 !mulnDr.
    rewrite addnC !(mulnC n.+1).
    by rewrite IHn.
  Qed.
End Test_ssrnat.

Print reflect.

Module Test_ssrbool.
  Variables a b c : bool.
  Print andb.

  Lemma andb_intro : a -> b -> a && b.
  Proof.
    move=> a b.
    rewrite a.
    move=> /=.
    done.
    Restart.
    by move ->.
  Qed.

  Lemma andbC : a && b -> b && a.
  Proof.
    case: a => /=.
      by rewrite andbT.
      done.
      Restart.
      by case: a => //= ->.
      Restart.
      by case: a; case: b.
  Qed.

  Lemma orbC : a || b -> b || a.
  Proof.
    case: a => /=.
      by rewrite orbT.
      by rewrite orbF.
      Restart.
      move/orP => H.
      apply/orP.
      move: H => [Ha|Hb].
      by right.
      by left.
      Restart.
        by case: a; case: b.
  Qed.

  Lemma test_if x : if x == 3 then x*x == 9 else x !=3.
  Proof.
    case Hx: (x == 3).
    by rewrite (eqP Hx).
    done.
    Restart.
    case: ifP.
    by move/eqP ->.
    move/negbT. done.
  Qed.
End Test_ssrbool.

(* 自己反映があると自然数の証明もスムーズになる．*)
Theorem avg_prod2 m n p : m+n = p+p -> (p - n) * (p - m) = 0.
Proof.
  move=> Hmn.
  have Hp0 q: p <= q -> p-q = 0.
  rewrite -subn_eq0. by move/eqP.
  suff /orP[Hpm|Hpn]: (p <= m) || (p <= n).
  - by rewrite (Hp0 m) // muln0.
  - by rewrite (Hp0 n).
    case: (leqP p m) => Hpm //=.
    case: (leqP p n) => Hpn //=.
    suff: m + n < p + p.
    by rewrite Hmn ltnn.
    by rewrite -addnS leq_add // ltnW.
Qed.

(* 練習問題 1.1 以下の等式を証明しなさい．タクティクは rewrite のみでできる．
  ssrnat_doc.v の補題でほぼ足りるが, leq_mul も便利．*)
Module Equalities.
  Theorem square_sum a b : (a + b)^2 = a^2 + 2 * a * b + b^2.
  Abort.

  Theorem diff_square m n : m >= n -> m^2 - n^2 = (m+n) * (m-n).
  Abort.

  Theorem square_diff m n : m >= n -> (m-n)^2 = m^2 + n^2 - 2 * m * n.
  Abort.
End Equalities.

Lemma test x : 1 + x = x + 1.
  Check [eta addnC].
  (*: ∀ x y : nat, x + y = y + x *)
  apply: addnC.
Abort.      (* 定理を登録せずに証明を終わらせる *)

(* Coq 本来の apply で変数が定まらないと，エラーになる．しかし，SSReflect の apply: や
apply/ を使えば，変数が残せる．*)
Lemma test x y z : x + y + z = z + y + x.
  Check etrans.
  (* : ∀ (A : Type) (x y z : A), x = y -> y = z -> x = z *)
  (* apply etrans.
     Error: Unable to find an instance for the variable y. *)
  apply: etrans. (* y が結論に現れないので，apply: に変える *)
  (* x + y + z = ?Goal *)
  apply: addnC.
  apply: etrans.
  Check f_equal.
  (* : ∀ (A B : Type) (f : A -> B) (x y : A), x = y -> f x = f y *)
  apply: f_equal. (* x + y = ?Goal0 *)
  apply: addnC.
  apply: addnA.
  Restart. (* 証明を元に戻す *)
  rewrite addnC. (* rewrite も単一化を使う *)
  rewrite (addnC x).
  apply: addnA.
Abort.

Goal
  (forall P : nat -> Prop, P 0 -> (forall n, P n -> P (S n)) -> forall n, P n) ->
forall n m, n + m = m + n.
  move=> H n m. (* 全ての変数を仮定に *)
  apply: H. (* n + m = 0 *)
  Restart.
  move=> H n m.
  pattern n. (* pattern で正しい述語を構成する *)
  apply: H. (* 0 + m = m + 0 *)
  Restart.
  move=> H n. (* forall n を残すとうまくいく *)
  apply: H. (* n + 0 = 0 + n *)
Abort.


Require Import List.
Require Import ZArith.

Section AUXLIST.

 Variable A:Set.
 Variable default:A.

 Definition hd l := match l with hd :: _ => hd | _ => default end.

 Definition tl (l: list A) := match l with _ :: tl => tl | _ => nil end.

 Fixpoint jump (p:positive) (l:list A) {struct p} : (list A) :=
  match p with
  | xH => tl l
  | xO p => jump p (jump p l)
  | xI p  => jump p (jump p (tl l))
  end.

 Fixpoint pos_nth (p:positive) (l:list A) {struct p} : A:=
  match p with
  | xH => hd l
  | xO p => pos_nth p (jump p l)
  | xI p => pos_nth p (jump p (tl l))
  end.

End AUXLIST.

Arguments pos_nth [A] _ _ _.

 Ltac Trev l :=
  let rec rev_append rev l :=
   match l with
   |  nil  => constr:(rev)
   | (cons ?h ?t) => let rev := constr:(cons h rev) in rev_append rev t
   end in
 match type of l with
  (list ?X) => rev_append (@nil X) l
 end.


Require Import List  Arith Omega.

Section mirror.

 Variable A : Type.

 Inductive remove_last (a:A) : list A -> list A -> Prop :=
   | remove_last_hd : remove_last a (a :: nil) nil
   | remove_last_tl :
       forall (b:A) (l m:list A),
         remove_last a l m -> remove_last a (b :: l) (b :: m).

 Inductive palindrome : list A -> Prop :=
   | empty_pal : palindrome nil
   | single_pal : forall a:A, palindrome (a :: nil)
   | cons_pal :
       forall (a:A) (l m:list A),
         palindrome l -> remove_last a m l -> palindrome (a :: m).

 Hint Constructors remove_last palindrome.

 Lemma ababa : forall a b:A, palindrome (a :: b :: a :: b :: a :: nil).
 Proof.
  eauto 7.
 Qed.

(* more about palindromes *)

Lemma remove_last_inv :
 forall (a:A) (l m:list A), remove_last a m l -> m = l ++ a :: nil.
Proof.
 intros a l m H; elim H; simpl; auto with datatypes.
 intros b l0 m0 H0 e; rewrite e; trivial.
Qed.

Lemma rev_app : forall l m:list A, rev (l ++ m) = rev m ++ rev l.
Proof.
 intros l m; elim l; simpl; auto with datatypes.
 intros a l0 H0; rewrite ass_app; rewrite H0; auto.
Qed.

Lemma palindrome_rev : forall l:list A, palindrome l -> rev l = l.
Proof.
 intros l H; elim H; simpl; auto with datatypes.
 intros a l0 m H0 H1 H2; generalize H1; inversion_clear H2.
 -  simpl; auto.
 -  rewrite (remove_last_inv _ _  _ H3); simpl; repeat (rewrite rev_app; simpl).
    intro eg; rewrite eg;  simpl; auto.
Qed.

(* A new induction principle for lists *)

(* preliminaries *)

Lemma length_app :
 forall l l':list A, length (l ++ l') = length l + length l'.
Proof.
  intro l; elim l; simpl; auto.
Qed.

Lemma fib_ind :
 forall P:nat -> Prop,
   P 0 ->
   P 1 ->
  (forall n:nat, P n -> P (S n) -> P (S (S n))) ->
  forall n:nat, P n.
Proof.
 intros P H0 H1 HSSn n.
 assert (H2 : P n /\ P (S n)).
 - induction n ;[tauto | ].
   destruct IHn;split;auto.
 -  destruct H2; auto.
Qed.

Section Proof_of_list_new_ind.
Variables (P : list A -> Prop).

Hypotheses (H0 : P nil)
           (H1 : forall a: A, P (a::nil))
           (H2 : forall (a b:A) (l:list A), P l -> P (a :: l ++ b :: nil)).

Lemma list_cut :
forall (l:list A) (x:A),
            exists b : A, exists l' : list A, x :: l = l' ++ b :: nil.
Proof.
intro l; elim l; simpl.
 intro x; exists x; exists (nil (A:=A)); auto.
 intros a1 l3 H x.
 case (H a1).
 intros x0 H7.
 case H7; intros b Hb.
 rewrite Hb.
 exists x0.
 exists (x :: b); auto.
Qed.

Lemma list_new_ind_length :
forall (n:nat) (l:list A), length l = n -> P l.
Proof.
intro n; pattern n; apply fib_ind.
  -  intro l; case l; [simpl; auto with datatypes |  discriminate].
  -  intro l; case l; simpl; [ discriminate | ].
     +  intros a l0; case l0; simpl; [auto | discriminate].
  -  intros n0 H3 H4 l; case l; simpl;[discriminate |].
     +  intros a l0 H5; generalize H5; case l0.
       *   simpl; discriminate 1.
       *   intros a0 l1 H6; destruct (list_cut l1 a0) as [x [l' Hx]];
           rewrite Hx; apply H2.
           apply H3.
           rewrite Hx in H6.
           rewrite length_app in H6.
           simpl in H6; omega.
Qed.

Lemma list_new_ind :
   forall l:list A, P l.
Proof.
 intro l; now apply list_new_ind_length with (length l).
Qed.

End Proof_of_list_new_ind.

Lemma app_left_reg : forall l l1 l2:list A, l ++ l1 = l ++ l2 -> l1 = l2.
Proof.
 intro l; elim l; simpl; auto.
 intros a l0 H0 l1 l2 H; injection H; auto.
Qed.

Lemma app_right_reg : forall l l1 l2:list A, l1 ++ l = l2 ++ l -> l1 = l2.
Proof.
 intros l l1 l2 e.
 assert (H: rev (l1 ++ l) = rev (l2 ++ l)).
 - now rewrite e.
 -  repeat rewrite rev_app in H.
    generalize (app_left_reg _ _ _ H).
    intro H1;  rewrite <- (rev_involutive  l1) ;
    rewrite <- (rev_involutive l2);
    rewrite H1; auto.
    Qed.

Theorem rev_pal : forall l:list A, rev l = l -> palindrome  l.
Proof.
 intro l; elim l using list_new_ind; auto.
 -  intros a b l0 H H0.
    apply cons_pal with l0.
   +  apply H;  simpl in H0;  rewrite rev_app in H0.
      simpl in H0; injection H0.
      intros H1 e; generalize H1; rewrite e.
      intro H2; generalize (app_right_reg _ _ _ H2); auto.
   +  simpl in H0; rewrite rev_app in H0; simpl in H0.
      injection H0; intros H1 H2; rewrite <- H2.
      generalize l0; intro l1; induction l1; simpl; auto.
Qed.

End mirror.


Module Play.

Inductive bool : Type :=
| true : bool
| false : bool.

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

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

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

Example test_nandb1 : (nandb true false) = true.
Proof. reflexivity. Qed.

Example test_nandb2 : (nandb false false) = true.
Proof. reflexivity. Qed.

Example test_nandb3 : (nandb false true) = true.
reflexivity. Qed.

Example test_nandb4 : (nandb true true) = false.
reflexivity. Qed.

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

Definition andb3 (b1 : bool) (b2 :bool) (b3 : bool) :bool :=
  andb2 (andb2 b1 b2) b3.

Example test_andb31: (andb3 true true true) = true.
reflexivity. Qed.

Example test_andb32: (andb3 false true true) = false.
reflexivity. Qed.

Example test_andb33: (andb3 true false true) = false.
reflexivity. Qed.

Example test_andb34: (andb3 true true false) = false.
reflexivity. Qed.