Require Import Coq.Strings.Ascii Coq.Strings.String Coq.Lists.List.
Require Import Coq.QArith.QArith_base.
Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.OptionList.
Require Import Crypto.Util.Strings.ParseArithmetic.
Require Import Crypto.Util.Notations.
Import ListNotations.
Local Open Scope option_scope.
Local Open Scope list_scope.
Local Open Scope char_scope.
Local Open Scope string_scope.
Local Open Scope Z_scope.

Local Open Scope parse_scope.

(** From the Python:
<<
# given a string representing one term or "tap" in a prime, returns a pair of
# integers representing the weight and coefficient of that tap
#    "2 ^ y" -> [1, y]
#    "x * 2 ^ y" -> [x, y]
#    "x * y" -> [x*y,0]
#    "x" -> [x,0]
def parse_term(t) :
    if "*" not in t and "^" not in t:
        return [int(t),0]

    if "*" in t:
        if len(t.split("*")) > 2: # this occurs when e.g. [w - x * y] has been turned into [w + -1 * x * y]
            a1,a2,b = t.split("*")
            a = int(a1) * int(a2)
        else:
            a,b = t.split("*")
        if "^" not in b:
            return [int(a) * int(b),0]
    else:
        a,b = (1,t)

    b,e = b.split("^")
    if int(b) != 2:
        raise NonBase2Exception("Could not parse term, power with base other than 2: %s" %t)
    return [int(a),int(e)]
>> *)

(** given an expression representing one term or "tap" in a prime,
    returns a pair of integers representing the coefficient and weight
    of that tap:
    * "2 ^ y" -> Some (2^y, 1)
    * "x * 2 ^ y" -> Some (2^y, x)
    * "x * y" -> Some (1,x*y)
    * "x" -> Some (1,x)
    *)
Fixpoint parse_term_of_Qexpr (v : Qexpr) : option (Z * Z)
  := match v with
     | Qv x => q <- Q_to_Z_strict x; Some (1, q)
     | Qeopp a => v <- parse_term_of_Qexpr a; Some (fst v, -snd v)
     | Qeadd a b => None
     | Qesub a b => None
     | Qemul a b => b <- parse_term_of_Qexpr b;
                      a <- eval_Qexpr_strict a;
                      a <- Q_to_Z_strict a;
                      Some (fst b, a * snd b)
     | Qediv a b => None
     | Qepow b e => v <- eval_Qexpr_strict v; v <- Q_to_Z_strict v; Some (v, 1)
     end%option.

Fixpoint Qexpr_to_add_list (v : Qexpr) : list Qexpr
  := match v with
     | Qeadd a b => Qexpr_to_add_list a ++ Qexpr_to_add_list b
     | Qesub a b => Qexpr_to_add_list a ++ [Qeopp b]
     | v => [v]
     end.

(** Given a Qexpr which is a sequence of additions and subtractions,
    we return the value of the first component, and a list of the taps
    for the negation of the other components *)
Definition parse_prime_and_taps_of_Qexpr (v : Qexpr) : option (Z * list (Z * Z))
  := match Qexpr_to_add_list v with
     | nil => None
     | cons p taps
       => taps <- Option.List.lift (List.map (fun v => parse_term_of_Qexpr (Qeopp v)) taps);
            p <- eval_Qexpr_strict p;
            p <- Q_to_Z_strict p;
            Some (p, taps)
     end.

Definition parseZ_arith_to_taps (s : string) : option (Z * list (Z * Z))
  := v <- parseQexpr_arith s; parse_prime_and_taps_of_Qexpr v.

Local Coercion QArith_base.inject_Z : Z >-> Q.
Local Example parse_v25519 : parse_prime_and_taps_of_Qexpr (2^255 - 19) = Some (2^255, [(1,19)]) := eq_refl.
Local Example parse_25519 : parseZ_arith_to_taps "2^255 - 19" = Some (2^255, [(1,19)]) := eq_refl.
Local Example parse_p521 : parseZ_arith_to_taps "2^521 - 1" = Some (2^521, [(1,1)]) := eq_refl.
Local Example parse_p448 : parseZ_arith_to_taps "2^448 - 2^224 - 1" = Some (2^448, [(2^224,1); (1,1)]) := eq_refl.
Local Example parse_p256 : parseZ_arith_to_taps "2^256 - 2^224 + 2^192 + 2^96 - 1" = Some (2^256, [(2^224,1); (2^192,-1); (2^96,-1); (1,1)]) := eq_refl.
Local Example parse_p434 : parseZ_arith_to_taps "2^216 * 3^137 - 1" = Some (2^216 * 3^137, [(1,1)]) := eq_refl.


Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Classes.RelationClasses.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Tactics.Injection.

Set Implicit Arguments.
Set Strict Implicit.

Section Eqpair.
  Context {T U} (rT : relation T) (rU : relation U).

  Inductive Eqpair : relation (T * U) :=
  | Eqpair_both : forall a b c d, rT a b -> rU c d -> Eqpair (a,c) (b,d).

  Global Instance Reflexive_Eqpair {RrT : Reflexive rT} {RrU : Reflexive rU}
  : Reflexive Eqpair.
  Proof. red. destruct x. constructor; reflexivity. Qed.

  Global Instance Symmetric_Eqpair {RrT : Symmetric rT} {RrU : Symmetric rU}
  : Symmetric Eqpair.
  Proof. red. inversion 1; constructor; symmetry; assumption. Qed.

  Global Instance Transitive_Eqpair {RrT : Transitive rT} {RrU : Transitive rU}
  : Transitive Eqpair.
  Proof. red. inversion 1; inversion 1; constructor; etransitivity; eauto. Qed.

  Global Instance Injective_Eqpair a b c d : Injective (Eqpair (a,b) (c,d)) :=
  { result := rT a c /\ rU b d }.
  abstract (inversion 1; auto).
  Defined.
End Eqpair.

Section PairWF.
  Variables T U : Type.
  Variable RT : T -> T -> Prop.
  Variable RU : U -> U -> Prop.

  Inductive R_pair : T * U -> T * U -> Prop :=
  | L : forall l l' r r',
    RT l l' -> R_pair (l,r) (l',r')
  | R : forall l r r',
    RU r r' -> R_pair (l,r) (l,r').

  Hypothesis wf_RT : well_founded RT.
  Hypothesis wf_RU : well_founded RU.

  Theorem wf_R_pair : well_founded R_pair.
  Proof.
    red. intro x.
    destruct x. generalize dependent u.
    apply (well_founded_ind wf_RT (fun t => forall u : U, Acc R_pair (t, u))) .
    do 2 intro.

    apply (well_founded_ind wf_RU (fun u => Acc R_pair (x,u))). intros.
    constructor. destruct y.
    remember (t0,u). remember (x,x0). inversion 1; subst;
    inversion H4; inversion H3; clear H4 H3; subst; eauto.
  Defined.
End PairWF.

Section PairParam.
  Variable T : Type.
  Variable eqT : T -> T -> Prop.
  Variable U : Type.
  Variable eqU : U -> U -> Prop.

  Variable EDT : RelDec eqT.
  Variable EDU : RelDec eqU.

  Global Instance RelDec_equ_pair : RelDec (fun x y => eqT (fst x) (fst y) /\ eqU (snd x) (snd y)) :=
  { rel_dec := fun x y =>
    if rel_dec (fst x) (fst y) then
      rel_dec (snd x) (snd y)
    else false }.

  Variable EDCT : RelDec_Correct EDT.
  Variable EDCU : RelDec_Correct EDU.

  Global Instance RelDec_Correct_equ_pair : RelDec_Correct RelDec_equ_pair.
  Proof.
    constructor; destruct x; destruct y; split; simpl in *; intros;
      repeat match goal with
               | [ H : context [ rel_dec ?X ?Y ] |- _ ] =>
                 consider (rel_dec X Y); intros; subst
               | [ |- context [ rel_dec ?X ?Y ] ] =>
                 consider (rel_dec X Y); intros; subst
             end; intuition.
  Qed.
End PairParam.

Section PairEq.
  Variable T : Type.
  Variable U : Type.

  Variable EDT : RelDec (@eq T).
  Variable EDU : RelDec (@eq U).

  (** Specialization for equality **)
  Global Instance RelDec_eq_pair : RelDec (@eq (T * U)) :=
  { rel_dec := fun x y =>
    if rel_dec (fst x) (fst y) then
      rel_dec (snd x) (snd y)
    else false }.

  Variable EDCT : RelDec_Correct EDT.
  Variable EDCU : RelDec_Correct EDU.

  Global Instance RelDec_Correct_eq_pair : RelDec_Correct RelDec_eq_pair.
  Proof.
    constructor; destruct x; destruct y; split; simpl in *; intros;
      repeat match goal with
               | [ H : context [ rel_dec ?X ?Y ] |- _ ] =>
                 consider (rel_dec X Y); intros; subst
               | [ |- context [ rel_dec ?X ?Y ] ] =>
                 consider (rel_dec X Y); intros; subst
             end; congruence.
  Qed.
End PairEq.

Global Instance Injective_pair T U (a :T) (b:U) c d : Injective ((a,b) = (c,d)) :=
{| result := a = c /\ b = d |}.
Proof. abstract (inversion 1; intuition). Defined.


Require Import Coq.Program.Tactics.
Require Import ProofIrrelevance.

Set Primitive Projections.

Record Magma {T : Type} :=
  { mu : T -> T -> T
  }.

(* Possibly separate this out at some point. *)

(** * Magma homomorphisms.

Must obey this law:
\(f (a * b) = f(a) * f(b)\)
*)
Record MagmaHomomorphism {A B} (M : @Magma A) (N : @Magma B) :=
  { magma_hom : A -> B;
    magma_hom_law :
      forall (a b : A),
        magma_hom (mu M a b) = mu N (magma_hom a) (magma_hom b)
  }.

(** * Composition of maps. *)
Program Definition magma_hom_composition
        {T U V : Type}
        {A : @Magma T}
        {B : @Magma U}
        {C : @Magma V}
        (map1 : MagmaHomomorphism A B)
        (map2 : MagmaHomomorphism B C) :
  MagmaHomomorphism A C :=
  {| magma_hom := fun a => (magma_hom B C map2) ((magma_hom A B map1) a) |}.
Next Obligation.
Proof.
  destruct A, B, C, map1, map2.
  simpl in *.
  rewrite magma_hom_law0.
  rewrite magma_hom_law1.
  trivial.
Qed.

(** * Equality of maps, assuming proof irrelevance. *)
Theorem magma_hom_eq : forall A B F G (N M : MagmaHomomorphism F G),
    @magma_hom A B F G N = @magma_hom A B F G M ->
    N = M.
Proof.
  intros.
  destruct N, M.
  simpl in *.
  subst.
  f_equal.
  intros.
  apply proof_irrelevance.
Qed.

(** * Associativity of composition of maps. *)
Program Definition magma_hom_composition_assoc
        {T : Type}
        {A B C D : @Magma T}
        (f : MagmaHomomorphism A B)
        (g : MagmaHomomorphism B C)
        (h : MagmaHomomorphism C D) :
  magma_hom_composition f (magma_hom_composition g h) =
  magma_hom_composition (magma_hom_composition f g) h.
Proof.
  destruct f, g, h.
  apply magma_hom_eq.
  simpl.
  reflexivity.
Qed.

(** * Identity map. *)
Program Definition magma_hom_id
        {A : Type}
        {M : @Magma A} :
  MagmaHomomorphism M M :=
  {| magma_hom := fun a => a |}.


Require Import MSets MSetAVL ZArith Omega.
Open Scope Z_scope.
Set Implicit Arguments.

(** For the purpose of the demo, let's show how basic things are defined,
    without interfering with Coq's stdlib, thanks to the following module. *)
Module THIS_ALREADY_EXISTS_IN_STDLIB_SO_LETS_NOT_INTERFERE.

(** * Ordered types *)

(* Starting point: the OrderedType interface of Ocaml:

module type OrderedType =
  sig
    type t
    val compare : t -> t -> int
  end
*)

(* The corresponding OrderedType in Coq: *)

(*excerpt from OrderedType.v *)
Print comparison.
(* Inductive comparison := Eq | Lt | Gt. *)

Print CompSpec.

Module Type OrderedType.

  (* The "Ocaml part" *)

  Parameter t : Type.
  Parameter compare : t -> t -> comparison.

  (* The logical specification:
     [compare] is required to give correct answers with respect to some
     particular equivalence relation [eq] and strict order [lt]. *)

  Parameter eq : t -> t -> Prop.
  Parameter lt : t -> t -> Prop.
  Declare Instance eq_equiv : Equivalence eq. (* reflexive, symmetric, transitive *)
  Declare Instance lt_strorder : StrictOrder lt. (* irreflexive, transitive *)
  Declare Instance lt_compat : Proper (eq==>eq==>iff) lt. (* rewriting w.r.t. eq in lt *)
  Axiom compare_spec : forall x y : t, CompSpec eq lt x y (compare x y).

  (* Artificially, we asks for another function, for OrderedType to be
     coercible to another interface (see DecidableType).  *)

  Parameter eq_dec : forall x y, { eq x y }+{ ~eq x y }.

End OrderedType.
(*/excerpt*)

(** * An example of OrderedType : *)
(** [Z] integers seen as Orderered Types : Z_as_OT *)

(* excerpt from OrderedTypeEx.v *)
Module Z_as_OT <: OrderedType.

  Definition t := Z.
  Definition compare := Zcompare.

  Definition eq := @eq Z.
  Definition lt := Zlt.
  Instance eq_equiv : Equivalence eq := {}.
  Instance lt_strorder : StrictOrder lt := {}.
  Instance lt_compat : Proper (eq==>eq==>iff) lt.
  Proof. intros x x' Hx y y' Hy; rewrite Hx, Hy; split; auto. Qed.
  Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
  Proof. exact Zcompare_spec. Qed.

  Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }.
  Proof. exact Z_eq_dec. Qed.

End Z_as_OT.
(* /excerpt *)

Extraction Z_as_OT.

End THIS_ALREADY_EXISTS_IN_STDLIB_SO_LETS_NOT_INTERFERE.

(** * Let's now build some sets of [Z] integers ... *)

Module M := MSetAVL.Make(Z_as_OT).

(* This module M provides plenty of functions on Z-sets *)
Check M.add.

(* Let's play with them : *)
Definition ens1 := M.add 3 (M.add 0 (M.add 2 (M.empty))).
Definition ens2 := M.add 0 (M.add 2 (M.add 4 (M.empty))).
Definition ens3 := M.inter ens1 ens2.
Eval compute in (M.mem 2 ens3).
Eval compute in (M.elements ens3).

(* M also provides some basic properties, for instance: *)

Check (M.elements_spec1 ens3).
(* elements returns a lists with the same content
   as the initial set. *)

Check (M.elements_spec2 ens3).
(* elements always returns a sorted list
   with respect to the underlying order. *)

(* The M.t type for sets is meant to be used as an abstract type
   since it will vary amongst the different implementations of FSets.
   An M.t can and should always be inspected by using [mem], [elements], etc.
   But for once, let's have a look at the raw aspect of a set: *)
Set Printing Implicit.
Import M.Raw.
Eval compute in ens1.
(* Here for FSetAVL, a set is a pair of a tree (see 1st line) and some proofs *)
Eval compute in ens3. (* The proofs parts can grow quite fast *)
Unset Printing Implicit.

(* Here, in order to avoid the continuous expansion of proofs parts,
   we can work on "pure" or "raw" datatypes
   (i.e. without built-in invariants). *)
Module R:=M.Raw.

Definition raw1 := R.add 3 (R.add 0 (R.add 2 R.empty)).
Definition raw2 := R.add 0 (R.add 2 (R.add 4 R.empty)).
Definition raw3 := R.inter raw1 raw2.

Eval compute in raw3.
Eval compute in (R.elements raw3).

(* ... but then there is more work for deriving properties. *)

Instance raw3_ok : Ok raw3. Proof. unfold raw3, raw1, raw2; auto with *. Qed.

Check (@R.elements_spec2 raw3 raw3_ok).

(** * union *)

(* This function is now based on a structural recursion.
   It used to be a well-founded one (via Function's measure),
   for this version see FSetFullAVL. *)
Eval vm_compute in (@R.union raw1 raw2).

(*TODO: assert failure
  Extraction M. *)

(** * Some sets of sets ... *)

Module MM := MSetAVL.Make(M).

Definition eens1 := MM.add ens1 (MM.add ens2 (MM.empty)).

(* ... that can now computes in Coq (due to the new [compare]) *)
Eval vm_compute in List.map M.elements (MM.elements eens1).

(** * Some more intense tests. *)

Fixpoint multiples (m:Z)(start:Z)(n:nat) {struct n} : list Z :=
  match n with
   | O => nil
   | S n => start::(multiples m (m+start) n)
  end.

Eval compute in (multiples 2 0 200%nat).

Definition bigens1 := fold_right M.add M.empty (multiples 2 0 400%nat).
Definition bigens2 := fold_right M.add M.empty (multiples 3 0 400%nat).
Time Eval compute in (M.elements (M.inter bigens1 bigens2)).
(* takes a few seconds, but we can also take advantage of Coq new virtual
    machine (VM), that performs the same job in almost no time. *)
Time Eval vm_compute in (M.elements (M.inter bigens1 bigens2)).

Definition bigens3 := fold_right M.add M.empty (multiples 2 0 (100*100)%nat).
Definition bigens4 := fold_right M.add M.empty (multiples 3 0 (100*100)%nat).
Time Eval vm_compute in (M.elements (M.inter bigens3 bigens4)).
(* 11s for this intersection of 2 sets of 10000 elements !!
   In fact, 5s per construction of each bigens, but the inter
   is done in no time:
*)
Time Eval vm_compute in (M.elements (M.inter bigens3 bigens4)).
(* 0.8s *)

(** * Proving with FSets : the facts/properties functors *)

(* The properties provided by FSetAVL are deliberately minimalistic.
   They correspond to the minimal specifications present in FSetInterface.
   This way, building new implementations is fairly simple.
   Now, lots of additional facts can be derived from this common interface. *)

(* Simple ones are locating in the functor FSetFacts.Facts *)
Module MF := MSetFacts.Facts M.

(* It contains mainly rephrasing of the specifications in alternative styles
  like equivalences or boolean *)
Check MF.add_1.
Check MF.add_iff.
Check MF.add_b.

(* More complex properties are located in the functors FSetProperties.Properties *)
Module MP := MSetProperties.Properties M.

(* For instance: usual stuff about set operations: *)
Check MP.union_inter_1.

(* Also useful: one induction principle (in fact several) *)
Check MP.set_induction.

(* And lot of stuff concerning the hard-to-handle [fold] function *)
Check MP.fold_add.

(* Most advance property: the law on cardinal of unions *)
Check MP.union_inter_cardinal.

(* TODO: MAPS NOT READY YET

(** * What about maps ? it's the same ! *)

Require Import FMapAVL.

(* Now, the elements of the OrderedType will serve as keys for the maps. *)
Module F := FMapAVL.Make(Z_as_OT).

(* And as in Ocaml, maps contains data whose type is polymorphic: *)
Check F.add.

(* Let's for instance define a map with Z keys and lists as data *)
Definition map1 :=
  F.add 2 (1::2::nil)
   (F.add 3 nil
     (F.add 1 (0::nil)
       (F.empty _))).

Eval compute in (F.find 1 map1).
Eval compute in (F.mem 1 map1).

Eval compute in (F.map (@length _) map1).(F.this).

(* Not in Ocaml's map: [elements] *)

Eval compute in (F.elements (F.map (@length _) map1)).

(* ... and [map2] *)

Check F.map2.

(* Unlike keys, we need no particular structure over datas.
    Only two exceptions: [equal] and [compare]. *)

Check F.equal.

(* Concerning [compare], we need a ternary decidable comparison
 over datas. We hence diverge slightly apart from Ocaml, by placing
 this [compare] in a separate functor requiring 2 [OrderedType],
 one for the keys and one for the datas, see FMapAVL.Make_ord *)

(* FMaps also come with additional properties in the same spirit as for
   FSets, see file FMapFacts.v *)

*)

(** How to get more efficient AVL trees after extraction :
     the [Int] module to get rid of [Z] not-so-fast integers. *)

(* [FSetAVL] now uses an abstract [Int] structure for every height of trees.
   This gives a first [FSetAVL.IntMake(I:Int)(X:OrderedType)].
   Then the [Int] part can either be filled with [Z_as_Int] for computing
   in Coq, giving the above [FSetAVL.Make], or instead extracted as is,
   and filled after extraction by some fast ocaml code based on machine
   integers.
*)

Print R.tree.
Eval compute in Int.Z_as_Int.t.

(*excerpt from Int.v*)
Module Type Int.

 Parameter t : Set.

 Parameter i2z : t -> Z.

 Parameter _0 : t.
 Parameter _1 : t.
 Parameter plus : t -> t -> t.
 Parameter opp : t -> t.
 Parameter minus : t -> t -> t.
 Parameter mult : t -> t -> t.
 Parameter max : t -> t -> t.

(* Concerning logical relations, there is no need for additional
   parameters: we take directly advantage of the [Z] ones, via
   [i2z]. This simplifies the writing of translation tactics from
   [t] to [Z].  *)

 Notation "x == y" := (i2z x = i2z y)
   (at level 70, y at next level, no associativity) : Int_scope.
 Notation "x <= y" := (Zle (i2z x) (i2z y)): Int_scope.
 Notation "x < y" := (Zlt (i2z x) (i2z y)) : Int_scope.
 Notation "x >= y" := (Zge (i2z x) (i2z y)) : Int_scope.
 Notation "x > y" := (Zgt (i2z x) (i2z y)): Int_scope.

 (* We also need some decidability facts. *)

 Open Scope Int_scope.
 Parameter gt_le_dec : forall x y: t, {x > y} + {x <= y}.
 Parameter ge_lt_dec :  forall x y : t, {x >= y} + {x < y}.
 Parameter eq_dec : forall x y : t, { x == y } + {~ x==y }.
 Open Scope Z_scope.

 (* Specification of previous parameters. *)

 (* First, [i2z] is an injection. *)

 Axiom i2z_eq : forall n p, n == p -> n = p.

 (* Then, all the operators are morphisms. *)

 Axiom i2z_0 : i2z _0 = 0.
 Axiom i2z_1 : i2z _1 = 1.
 Axiom i2z_plus : forall n p, i2z (plus n p) = i2z n + i2z p.
 Axiom i2z_opp : forall n, i2z (opp n) = -i2z n.
 Axiom i2z_minus : forall n p, i2z (minus n p) = i2z n - i2z p.
 Axiom i2z_mult : forall n p, i2z (mult n p) = i2z n * i2z p.
 Axiom i2z_max : forall n p, i2z (max n p) = Zmax (i2z n) (i2z p).

End Int.
(*/excerpt*)

(** * The Weak Sets and Maps *)

(* Sometimes, one may need finite sets and maps over a base type
   that does not come with a decidable order. As long as this type
   can still be equipped with a decidable equality, the FSetWeak and
   FMapWeak counterparts of FSets and FMap provides such structures.
*)

Module W := MSetWeakList.Make (Z_as_DT).

(* Of course, we cannot provide efficient functions anymore : the
   underlying structure is unsorted lists (but without redundancies). *)

Eval compute in (W.elements (W.add 1 (W.add 3 (W.add 2 W.empty)))).

(* Apart from efficiency questions and the lack of order-related functions
   like [min_elt], FSetWeak/FMapWeak are as close as possible
   to FSet/FMap (same function signatures, same properties, etc).
*)


Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Lists.List.
Require Import Coq.Program.Basics.

Lemma ex_iff: forall {A: Type} P Q, (forall x: A, P x <-> Q x) -> (ex P <-> ex Q).
Proof.
  intros.
  split; intros [x ?]; exists x; firstorder.
Qed.

Lemma forall_iff: forall {A: Type} P Q, (forall x: A, P x <-> Q x) -> ((forall x, P x) <-> (forall x, Q x)).
Proof. intros. firstorder. Qed.

Lemma and_iff_split: forall A B C D : Prop, (A <-> B) -> (C <-> D) -> (A /\ C <-> B /\ D).
Proof. intros. tauto. Qed.

Lemma and_iff_compat_l_weak: forall A B C : Prop, (A -> (B <-> C)) -> (A /\ B <-> A /\ C).
Proof. intros. tauto. Qed.

Lemma and_iff_compat_r_weak: forall A B C : Prop, (A -> (B <-> C)) -> (B /\ A <-> C /\ A).
Proof. intros. tauto. Qed.

Lemma and_or_distr_r: forall P Q R, P /\ (Q \/ R) <-> (P /\ Q) \/ (P /\ R).
Proof.
  intros.
  tauto.
Qed.

Lemma demorgan_weak: forall P Q: Prop, P \/ ~ P -> (~ (P /\ Q) <-> ~ P \/ ~ Q).
Proof.
  intros.
  destruct H; tauto.
Qed.

Lemma demorgan_weak': forall P Q: Prop, P \/ ~ P -> (~ (~ P /\ Q) <-> P \/ ~ Q).
Proof.
  intros.
  destruct H; tauto.
Qed.

Lemma eq_sym_iff: forall {A} (x y: A), x = y <-> y = x.
Proof.
  intros.
  split; intro; congruence.
Qed.

Lemma sumbool_weaken_right: forall P Q Q': Prop, (Q -> Q') -> ({P} + {Q}) -> ({P} + {Q'}).
Proof.
  intros.
  destruct H0; [left | right]; auto.
Qed.

Lemma sumbool_weaken_left: forall P P' Q: Prop, (P -> P') -> ({P} + {Q}) -> ({P'} + {Q}).
Proof.
  intros.
  destruct H0; [left | right]; auto.
Qed.

Definition Prop_join {A} (X Y Z: A -> Prop): Prop :=
  (forall a, Z a <-> X a \/ Y a) /\ (forall a, X a -> Y a -> False).

Definition Decidable (P: Prop) := {P} + {~ P}.

Lemma decidable_prop_decidable: forall P: Prop, Decidable P -> P \/ ~ P.
Proof.
  intros.
  destruct H; [left | right]; auto.
Qed.

Definition DecidablePred (A: Type): Type := {P : A -> Prop & forall a, {P a} + {~ P a}}.

Definition app_DecidablePred {A: Type} (P: DecidablePred A) (a: A) := projT1 P a.

Coercion app_DecidablePred: DecidablePred >-> Funclass.

Tactic Notation "spec" hyp(H) :=
  match type of H with ?a -> _ =>
    let H1 := fresh in (assert (H1: a); [|generalize (H H1); clear H H1; intro H]) end.
Tactic Notation "disc" := (try discriminate).
Tactic Notation "contr" := (try contradiction).
Tactic Notation "congr" := (try congruence).
Tactic Notation "inv" hyp(H) := inversion H; clear H; subst.
Tactic Notation  "icase" constr(v) := (destruct v; disc; contr; auto).
Tactic Notation "copy" hyp(H) := (generalize H; intro).

(* TODO: This tactic is now duplicated here and in VST.msl.Coqlib2. *)
Ltac super_pattern t x :=
  let t0 := fresh "t" in
  set (t0 := t);
  pattern x in t0;
  cbv beta in (type of t0);
  subst t0.

Record bijective {A B} (f: A -> B) (invf: B -> A) : Prop :=
  {
    injective: forall x y, f x = f y -> x = y;
    surjective: forall x, f (invf x) = x;
  }.

Lemma bijective_refl: forall {A: Type}, @bijective A A id id.
Proof. intros. split; auto. Qed.

Lemma bijective_sym: forall {A B} (f: A -> B) (invf: B -> A),
    bijective f invf -> bijective invf f.
Proof.
  intros. destruct H as [?H ?H]. split; intros.
  - rewrite <- (H0 x), <- (H0 y), H1, H0. reflexivity.
  - apply H, H0.
Qed.

Lemma bijective_trans:
  forall {A B C} (f: A -> B) (g: B -> C) (invf: B -> A) (invg: C -> B),
    bijective f invf -> bijective g invg ->
    bijective (compose g f) (compose invf invg).
Proof.
  intros. destruct H, H0. split; intros; unfold compose in *.
  - apply injective0, injective1. assumption.
  - rewrite surjective0. apply surjective1.
Qed.

Lemma bijective_map: forall {A B} (f: A -> B) (g: B -> A),
    bijective f g -> bijective (map f) (map g).
Proof.
  intros. destruct H. split; intros.
  - revert y H. induction x; intros; destruct y; simpl in H; [|inversion H..]; auto.
    f_equal. 1: apply injective0; auto. apply IHx; assumption.
  - induction x; simpl; auto. rewrite IHx. f_equal. apply surjective0.
Qed.

Definition idempotent {A} (f: A -> A): Prop := forall x, f (f x) = f x.


From Hammer Require Import Hammer.

From compcert Require Import Raux.
From compcert Require Import Defs.
From compcert Require Import Float_prop.

Set Implicit Arguments.
Set Strongly Strict Implicit.

Section Float_ops.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Arguments Float {beta}.

Definition Falign (f1 f2 : float beta) :=
let '(Float m1 e1) := f1 in
let '(Float m2 e2) := f2 in
if Zle_bool e1 e2
then (m1, (m2 * Zpower beta (e2 - e1))%Z, e1)
else ((m1 * Zpower beta (e1 - e2))%Z, m2, e2).

Theorem Falign_spec :
forall f1 f2 : float beta,
let '(m1, m2, e) := Falign f1 f2 in
F2R f1 = @F2R beta (Float m1 e) /\ F2R f2 = @F2R beta (Float m2 e).
Proof. hammer_hook "Operations" "Operations.Falign_spec".
unfold Falign.
intros (m1, e1) (m2, e2).
generalize (Zle_cases e1 e2).
case (Zle_bool e1 e2) ; intros He ; split ; trivial.
now rewrite <- F2R_change_exp.
rewrite <- F2R_change_exp.
apply refl_equal.
omega.
Qed.

Theorem Falign_spec_exp:
forall f1 f2 : float beta,
snd (Falign f1 f2) = Z.min (Fexp f1) (Fexp f2).
Proof. hammer_hook "Operations" "Operations.Falign_spec_exp".
intros (m1,e1) (m2,e2).
unfold Falign; simpl.
generalize (Zle_cases e1 e2);case (Zle_bool e1 e2); intros He.
case (Zmin_spec e1 e2); intros (H1,H2); easy.
case (Zmin_spec e1 e2); intros (H1,H2); easy.
Qed.

Definition Fopp (f1 : float beta) : float beta :=
let '(Float m1 e1) := f1 in
Float (-m1)%Z e1.

Theorem F2R_opp :
forall f1 : float beta,
(F2R (Fopp f1) = -F2R f1)%R.
intros (m1,e1).
apply F2R_Zopp.
Qed.

Definition Fabs (f1 : float beta) : float beta :=
let '(Float m1 e1) := f1 in
Float (Z.abs m1)%Z e1.

Theorem F2R_abs :
forall f1 : float beta,
(F2R (Fabs f1) = Rabs (F2R f1))%R.
intros (m1,e1).
apply F2R_Zabs.
Qed.

Definition Fplus (f1 f2 : float beta) : float beta :=
let '(m1, m2 ,e) := Falign f1 f2 in
Float (m1 + m2) e.

Theorem F2R_plus :
forall f1 f2 : float beta,
F2R (Fplus f1 f2) = (F2R f1 + F2R f2)%R.
Proof. hammer_hook "Operations" "Operations.F2R_plus".
intros f1 f2.
unfold Fplus.
generalize (Falign_spec f1 f2).
destruct (Falign f1 f2) as ((m1, m2), e).
intros (H1, H2).
rewrite H1, H2.
unfold F2R. simpl.
rewrite plus_IZR.
apply Rmult_plus_distr_r.
Qed.

Theorem Fplus_same_exp :
forall m1 m2 e,
Fplus (Float m1 e) (Float m2 e) = Float (m1 + m2) e.
Proof. hammer_hook "Operations" "Operations.Fplus_same_exp".
intros m1 m2 e.
unfold Fplus.
simpl.
now rewrite Zle_bool_refl, Zminus_diag, Zmult_1_r.
Qed.

Theorem Fexp_Fplus :
forall f1 f2 : float beta,
Fexp (Fplus f1 f2) = Z.min (Fexp f1) (Fexp f2).
Proof. hammer_hook "Operations" "Operations.Fexp_Fplus".
intros f1 f2.
unfold Fplus.
rewrite <- Falign_spec_exp.
now destruct (Falign f1 f2) as ((p,q),e).
Qed.

Definition Fminus (f1 f2 : float beta) :=
Fplus f1 (Fopp f2).

Theorem F2R_minus :
forall f1 f2 : float beta,
F2R (Fminus f1 f2) = (F2R f1 - F2R f2)%R.
Proof. hammer_hook "Operations" "Operations.F2R_minus".
intros f1 f2; unfold Fminus.
rewrite F2R_plus, F2R_opp.
ring.
Qed.

Theorem Fminus_same_exp :
forall m1 m2 e,
Fminus (Float m1 e) (Float m2 e) = Float (m1 - m2) e.
Proof. hammer_hook "Operations" "Operations.Fminus_same_exp".
intros m1 m2 e.
unfold Fminus.
apply Fplus_same_exp.
Qed.

Definition Fmult (f1 f2 : float beta) : float beta :=
let '(Float m1 e1) := f1 in
let '(Float m2 e2) := f2 in
Float (m1 * m2) (e1 + e2).

Theorem F2R_mult :
forall f1 f2 : float beta,
F2R (Fmult f1 f2) = (F2R f1 * F2R f2)%R.
Proof. hammer_hook "Operations" "Operations.F2R_mult".
intros (m1, e1) (m2, e2).
unfold Fmult, F2R. simpl.
rewrite mult_IZR, bpow_plus.
ring.
Qed.

End Float_ops.


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

(*i $Id: Mergesort.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** A modular implementation of mergesort (the complexity is O(n.log n) in
   the length of the list) *)

(* Initial author: Hugo Herbelin, Oct 2009 *)

Require Import List Setoid Permutation Sorted Orders.

(** Notations and conventions *)

Local Notation "[ ]" := nil.
Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..).

Open Scope bool_scope.

Local Coercion is_true : bool >-> Sortclass.

(** The main module defining [mergesort] on a given boolean
    order [<=?]. We require minimal hypotheses : this boolean
    order should only be total: [forall x y, (x<=?y) \/ (y<=?x)].
    Transitivity is not mandatory, but without it one can
    only prove [LocallySorted] and not [StronglySorted].
*)

Module Sort (Import X:Orders.TotalLeBool').

Fixpoint merge l1 l2 :=
  let fix merge_aux l2 :=
  match l1, l2 with
  | [], _ => l2
  | _, [] => l1
  | a1::l1', a2::l2' =>
      if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge_aux l2'
  end
  in merge_aux l2.

(** We implement mergesort using an explicit stack of pending mergings.
    Pending merging are represented like a binary number where digits are
    either None (denoting 0) or Some list to merge (denoting 1). The n-th
    digit represents the pending list to be merged at level n, if any.
    Merging a list to a stack is like adding 1 to the binary number
    represented by the stack but the carry is propagated by merging the
    lists. In practice, when used in mergesort, the n-th digit, if non 0,
    carries a list of length 2^n. For instance, adding singleton list
    [3] to the stack Some [4]::Some [2;6]::None::Some [1;3;5;5]
    reduces to propagate the carry [3;4] (resulting of the merge of [3]
    and [4]) to the list Some [2;6]::None::Some [1;3;5;5], which reduces
    to propagating the carry [2;3;4;6] (resulting of the merge of [3;4] and
    [2;6]) to the list None::Some [1;3;5;5], which locally produces
    Some [2;3;4;6]::Some [1;3;5;5], i.e. which produces the final result
    None::None::Some [2;3;4;6]::Some [1;3;5;5].

    For instance, here is how [6;2;3;1;5] is sorted:

<<
       operation             stack                list
       iter_merge            []                   [6;2;3;1;5]
    =  append_list_to_stack  [ + [6]]             [2;3;1;5]
    -> iter_merge            [[6]]                [2;3;1;5]
    =  append_list_to_stack  [[6] + [2]]          [3;1;5]
    =  append_list_to_stack  [ + [2;6];]          [3;1;5]
    -> iter_merge            [[2;6];]             [3;1;5]
    =  append_list_to_stack  [[2;6]; + [3]]       [1;5]
    -> merge_list            [[2;6];[3]]          [1;5]
    =  append_list_to_stack  [[2;6];[3] + [1]     [5]
    =  append_list_to_stack  [[2;6] + [1;3];]     [5]
    =  append_list_to_stack  [ + [1;2;3;6];;]     [5]
    -> merge_list            [[1;2;3;6];;]        [5]
    =  append_list_to_stack  [[1;2;3;6];; + [5]]  []
    -> merge_stack           [[1;2;3;6];;[5]]
    =                                             [1;2;3;5;6]
>>
    The complexity of the algorithm is n*log n, since there are
    2^(p-1) mergings to do of length 2, 2^(p-2) of length 4, ..., 2^0
    of length 2^p for a list of length 2^p. The algorithm does not need
    explicitly cutting the list in 2 parts at each step since it the
    successive accumulation of fragments on the stack which ensures
    that lists are merged on a dichotomic basis.
*)

Fixpoint merge_list_to_stack stack l :=
  match stack with
  | [] => [Some l]
  | None :: stack' => Some l :: stack'
  | Some l' :: stack' => None :: merge_list_to_stack stack' (merge l' l)
  end.

Fixpoint merge_stack stack :=
  match stack with
  | [] => []
  | None :: stack' => merge_stack stack'
  | Some l :: stack' => merge l (merge_stack stack')
  end.

Fixpoint iter_merge stack l :=
  match l with
  | [] => merge_stack stack
  | a::l' => iter_merge (merge_list_to_stack stack [a]) l'
  end.

Definition sort := iter_merge [].

(** The proof of correctness *)

Local Notation Sorted := (LocallySorted leb) (only parsing).

Fixpoint SortedStack stack :=
  match stack with
  | [] => True
  | None :: stack' => SortedStack stack'
  | Some l :: stack' => Sorted l /\ SortedStack stack'
  end.

Local Ltac invert H := inversion H; subst; clear H.

Fixpoint flatten_stack (stack : list (option (list t))) :=
  match stack with
  | [] => []
  | None :: stack' => flatten_stack stack'
  | Some l :: stack' => l ++ flatten_stack stack'
  end.

Theorem Sorted_merge : forall l1 l2,
  Sorted l1 -> Sorted l2 -> Sorted (merge l1 l2).
Proof.
induction l1; induction l2; intros; simpl; auto.
  destruct (a <=? a0) as ()_eqn:Heq1.
    invert H.
      simpl. constructor; trivial; rewrite Heq1; constructor.
      assert (Sorted (merge (b::l) (a0::l2))) by (apply IHl1; auto).
      clear H0 H3 IHl1; simpl in *.
      destruct (b <=? a0); constructor; auto || rewrite Heq1; constructor.
    assert (a0 <=? a) by
      (destruct (leb_total a0 a) as [H'|H']; trivial || (rewrite Heq1 in H'; inversion H')).
    invert H0.
      constructor; trivial.
      assert (Sorted (merge (a::l1) (b::l))) by auto using IHl1.
      clear IHl2; simpl in *.
      destruct (a <=? b); constructor; auto.
Qed.

Theorem Permuted_merge : forall l1 l2, Permutation (l1++l2) (merge l1 l2).
Proof.
  induction l1; simpl merge; intro.
    assert (forall l, (fix merge_aux (l0 : list t) : list t := l0) l = l)
    as -> by (destruct l; trivial). (* Technical lemma *)
    apply Permutation_refl.
  induction l2.
    rewrite app_nil_r. apply Permutation_refl.
    destruct (a <=? a0).
      constructor; apply IHl1.
      apply Permutation_sym, Permutation_cons_app, Permutation_sym, IHl2.
Qed.

Theorem Sorted_merge_list_to_stack : forall stack l,
  SortedStack stack -> Sorted l -> SortedStack (merge_list_to_stack stack l).
Proof.
  induction stack as [|[|]]; intros; simpl.
    auto.
    apply IHstack. destruct H as (_,H1). fold SortedStack in H1. auto.
      apply Sorted_merge; auto; destruct H; auto.
      auto.
Qed.

Theorem Permuted_merge_list_to_stack : forall stack l,
  Permutation (l ++ flatten_stack stack) (flatten_stack (merge_list_to_stack stack l)).
Proof.
  induction stack as [|[]]; simpl; intros.
    reflexivity.
    rewrite app_assoc.
    etransitivity.
      apply Permutation_app_tail.
      etransitivity.
        apply Permutation_app_comm.
      apply Permuted_merge.
    apply IHstack.
    reflexivity.
Qed.

Theorem Sorted_merge_stack : forall stack,
  SortedStack stack -> Sorted (merge_stack stack).
Proof.
induction stack as [|[|]]; simpl; intros.
  constructor; auto.
  apply Sorted_merge; tauto.
  auto.
Qed.

Theorem Permuted_merge_stack : forall stack,
  Permutation (flatten_stack stack) (merge_stack stack).
Proof.
induction stack as [|[]]; simpl.
  trivial.
  transitivity (l ++ merge_stack stack).
    apply Permutation_app_head; trivial.
    apply Permuted_merge.
  assumption.
Qed.

Theorem Sorted_iter_merge : forall stack l,
  SortedStack stack -> Sorted (iter_merge stack l).
Proof.
  intros stack l H; induction l in stack, H |- *; simpl.
    auto using Sorted_merge_stack.
    assert (Sorted [a]) by constructor.
    auto using Sorted_merge_list_to_stack.
Qed.

Theorem Permuted_iter_merge : forall l stack,
  Permutation (flatten_stack stack ++ l) (iter_merge stack l).
Proof.
  induction l; simpl; intros.
    rewrite app_nil_r. apply Permuted_merge_stack.
    change (a::l) with ([a]++l).
    rewrite app_assoc.
    etransitivity.
      apply Permutation_app_tail.
    etransitivity.
    apply Permutation_app_comm.
    apply Permuted_merge_list_to_stack.
    apply IHl.
Qed.

Theorem Sorted_sort : forall l, Sorted (sort l).
Proof.
intro; apply Sorted_iter_merge. constructor.
Qed.

Corollary LocallySorted_sort : forall l, Sorted.Sorted leb (sort l).
Proof. intro; eapply Sorted_LocallySorted_iff, Sorted_sort; auto. Qed.

Theorem Permuted_sort : forall l, Permutation l (sort l).
Proof.
intro; apply (Permuted_iter_merge l []).
Qed.

Corollary StronglySorted_sort : forall l,
  Transitive leb -> StronglySorted leb (sort l).
Proof. auto using Sorted_StronglySorted, LocallySorted_sort. Qed.

End Sort.

(** An example *)

Module NatOrder <: TotalLeBool.
  Definition t := nat.
  Fixpoint leb x y :=
    match x, y with
    | 0, _ => true
    | _, 0 => false
    | S x', S y' => leb x' y'
    end.
  Infix "<=?" := leb (at level 35).
  Theorem leb_total : forall a1 a2, a1 <=? a2 \/ a2 <=? a1.
  Proof.
    induction a1; destruct a2; simpl; auto.
  Qed.
End NatOrder.

Module Import NatSort := Sort NatOrder.

Example SimpleMergeExample := Eval compute in sort [5;3;6;1;8;6;0].


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

(* The syntax of types is independent of the syntax of terms, because terms
   do not refer to types (they are not annotated with types) and types do
   not refer to terms (there is no dependency). *)

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

(* The syntax of types. *)

Inductive ty :=

  (* [TyEpsilon] is the type of a memory range of length zero. *)

| TyEpsilon: ty

  (* [TyConsecutive] is a concatenation operator for types that describe
     memory ranges. *)

| TyConsecutive: ty -> ty -> ty

  (* [TyUnique T] is the type of a unique pointer to a memory block whose
     content is described by [T]. Only a base address (i.e., an address
     whose offset component is zero) can receive this type. *)

| TyUnique: ty -> ty

  (* [TyBorrowed l T] is the type of a borrowed pointer to a range of
     memory described by [T]. An arbitrary address (i.e., not just a
     base address) can receive this type. The parameter [l] is a lifetime
     variable. *)

| TyBorrowed: nat -> ty -> ty

  (* [TyLent l T] is the type of a memory area that has been lent out.
     The parameter [l] is a lifetime variable. *)

| TyLent: nat -> ty -> ty

.

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

(* The size of types. *)

Fixpoint sizeof_ty (T : ty) : nat :=
  match T with
  | TyEpsilon =>
      0
  | TyConsecutive T U =>
      sizeof_ty T + sizeof_ty U
  | TyUnique _ =>
      1
  | TyBorrowed _ _ =>
      1
  | TyLent _ T =>
      sizeof_ty T
  end.

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

(* Some types are duplicable; some types are not (i.e., they are linear). *)

Fixpoint duplicable (T : ty) : Prop :=
  match T with
  | TyEpsilon =>
      True
  | TyConsecutive T U =>
      duplicable T /\ duplicable U
  | TyUnique _ =>
      False
  | TyBorrowed _ _ =>
      True
  | TyLent _ T =>
      duplicable T
  end.


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

Require Import List Arith Wellfounded.

Set Implicit Arguments.

Section list_length_rect.

  Variables (X : Type) (P : list X -> Type).

  Hypothesis HP : forall l, (forall m, length m < length l -> P m) -> P l.

  Theorem list_length_rect : forall l, P l.
  Proof.
    apply well_founded_induction_type
      with (R := fun l m => length l < length m); auto.
    apply wf_inverse_image, lt_wf.
  Qed.

End list_length_rect.


(* Status: success *)

Require Export ArithRing.
Require Export Compare_dec.
Require Export Wf_nat.
Require Export Arith.
Require Export Omega.

Theorem minus_minus : forall a b c : nat, a - b - c = a - (b + c).
intros a; elim a; auto.
intros n' Hrec b; case b; auto.
Qed.

Remark expand_mult2 : forall x : nat, 2 * x = x + x.
intros x; ring.
Qed.

Theorem lt_neq : forall x y : nat, x < y -> x <> y.
unfold not in |- *; intros x y H H1; elim (lt_irrefl x);
 pattern x at 2 in |- *; rewrite H1; auto.
Qed.
Hint Resolve lt_neq.

Theorem monotonic_inverse :
 forall f : nat -> nat,
 (forall x y : nat, x < y -> f x < f y) ->
 forall x y : nat, f x < f y -> x < y.
intros f Hmon x y Hlt; case (le_gt_dec y x); auto.
intros Hle; elim (le_lt_or_eq _ _ Hle).
intros Hlt'; elim (lt_asym _ _ Hlt); apply Hmon; auto.
intros Heq; elim (lt_neq _ _ Hlt); rewrite Heq; auto.
Qed.

Theorem mult_lt : forall a b c : nat, c <> 0 -> a < b -> a * c < b * c.
intros a b c; elim c.
intros H; elim H; auto.
intros c'; case c'.
intros; omega.
intros c'' Hrec Hneq Hlt;
 repeat rewrite <- (fun x : nat => mult_n_Sm x (S c'')).
auto with *.
Qed.

Remark add_sub_square_identity :
 forall a b : nat,
 (b + a - b) * (b + a - b) = (b + a) * (b + a) + b * b - 2 * ((b + a) * b).
intros a b; rewrite minus_plus.
repeat rewrite mult_plus_distr_r || rewrite <- (mult_comm (b + a)).
replace (b * b + a * b + (b * a + a * a) + b * b) with
 (b * b + a * b + (b * b + a * b + a * a)); try (ring; fail).
rewrite expand_mult2; repeat rewrite minus_plus; auto with *.
Qed.

Theorem sub_square_identity :
 forall a b : nat, b <= a -> (a - b) * (a - b) = a * a + b * b - 2 * (a * b).
intros a b H; rewrite (le_plus_minus b a H); apply add_sub_square_identity.
Qed.

Theorem square_monotonic : forall x y : nat, x < y -> x * x < y * y.
intros x; case x.
intros y; case y; simpl in |- *; auto with *.
intros x' y Hlt; apply lt_trans with (S x' * y).
rewrite (mult_comm (S x') y); apply mult_lt; auto.
apply mult_lt; omega.
Qed.

Theorem root_monotonic : forall x y : nat, x * x < y * y -> x < y.
exact (monotonic_inverse (fun x : nat => x * x) square_monotonic).
Qed.

Remark square_recompose : forall x y : nat, x * y * (x * y) = x * x * (y * y).
intros; ring.
Qed.

Remark mult2_recompose : forall x y : nat, x * (2 * y) = x * 2 * y.
intros; ring.
Qed.
Section sqrt2_decrease.
Variables (p q : nat) (pos_q : 0 < q) (hyp_sqrt : p * p = 2 * (q * q)).

Theorem sqrt_q_non_zero : 0 <> q * q.
generalize pos_q; case q.
intros H; elim (lt_n_O 0); auto.
intros n H.
simpl in |- *; discriminate.
Qed.
Hint Resolve sqrt_q_non_zero.

Ltac solve_comparison :=
  apply root_monotonic; repeat rewrite square_recompose; rewrite hyp_sqrt;
   rewrite mult2_recompose; apply mult_lt; auto with arith.

Theorem comparison1 : q < p.
replace q with (1 * q); try ring.
replace p with (1 * p); try ring.
solve_comparison.
Qed.

Theorem comparison2 : 2 * p < 3 * q.
solve_comparison.
Qed.

Theorem comparison3 : 4 * q < 3 * p.
solve_comparison.
Qed.
Hint Resolve comparison1 comparison2 comparison3: arith.

Theorem comparison4 : 3 * q - 2 * p < q.
apply plus_lt_reg_l with (2 * p).
rewrite <- le_plus_minus; try (simple apply lt_le_weak; auto with arith).
replace (3 * q) with (2 * q + q); try ring.
apply plus_lt_le_compat; auto.
repeat rewrite (mult_comm 2); apply mult_lt; auto with arith.
Qed.

Remark mult_minus_distr_l : forall a b c : nat, a * (b - c) = a * b - a * c.
intros a b c; repeat rewrite (mult_comm a); apply mult_minus_distr_r.
Qed.

Remark minus_eq_decompose :
 forall a b c d : nat, a = b -> c = d -> a - c = b - d.
intros a b c d H H0; rewrite H; rewrite H0; auto.
Qed.

Theorem new_equality :
 (3 * p - 4 * q) * (3 * p - 4 * q) = 2 * ((3 * q - 2 * p) * (3 * q - 2 * p)).
repeat rewrite sub_square_identity; auto with arith.
repeat rewrite square_recompose; rewrite mult_minus_distr_l.
apply minus_eq_decompose; try rewrite hyp_sqrt; ring.
Qed.
End sqrt2_decrease.
Hint Resolve lt_le_weak comparison2: sqrt.

Theorem sqrt2_not_rational :
 forall p q : nat, q <> 0 -> p * p = 2 * (q * q) -> False.
intros p q; generalize p; clear p; elim q using (well_founded_ind lt_wf).
clear q; intros q Hrec p Hneq; generalize (neq_O_lt _ (sym_not_equal Hneq));
 intros Hlt_O_q Heq.
apply (Hrec (3 * q - 2 * p) (comparison4 _ _ Hlt_O_q Heq) (3 * p - 4 * q)).
apply sym_not_equal; apply lt_neq; apply plus_lt_reg_l with (2 * p);
 rewrite <- plus_n_O; rewrite <- le_plus_minus; auto with *.
apply new_equality; auto.
Qed.


Require Import Arith.
Require Import Arith Omega.
Require Import NAxioms NSub NZDiv.
Require Import region.
Require Import option.
Require Import clist.
Require Import listlist.

(* Permet d'ajouter le prefixe d'une region à l'ensemble des élements d'une liste de region.
   Exemple: prefix_list (II Z) [OO Z, IO Z] => [ II OO Z, II IO Z] *)
Fixpoint prefix_list(r: region)(l:clist region): clist region :=
match l with
| nil => l
| cons n l' => cons (concat_region r n) (prefix_list r l')
end.

Fixpoint suffix_list(r: region)(l:clist region): clist region :=
match l with
| nil => l
| cons n l' => cons (concat_region n r) (suffix_list r l')
end.

(* Fixpoint prefix_list_bis(r: region -> region)(l:clist region): clist region :=
match l with
| nil => l
| cons n l' => cons (r n) (prefix_list_bis r l')
end. *)

Eval compute in prefix_list (II Z) [OO Z, IO Z].

Fixpoint prefix_mat(r: region)(m:listlist region): listlist region :=
match m with
| lnil => m
| lcons v m' => lcons (prefix_list r v) (prefix_mat r m')
end.

Fixpoint suffix_mat(r: region)(m:listlist region): listlist region :=
match m with
| lnil => m
| lcons v m' => lcons (suffix_list r v) (suffix_mat r m')
end.

Eval compute in prefix_mat (II Z) '{[OO Z, IO Z],[OI Z]}.

(* Fixpoint prefix_mat_bis(r: region -> region)(m:listlist region): listlist region :=
match m with
| lnil => m
| lcons v m' => lcons (prefix_list_bis r v) (prefix_mat_bis r m')
end. *)

(* Permet d'effectuer la rotation des régions à chaque partitionnement du plan.
   Voir la fonction f(x) du poly. *)
Definition rot_nat (n : nat) : region -> region :=
    match n mod 4 with
    | 0 => OO
    | 1 => OI
    | 2 => II
    | 3 => IO
    | _ => OO
    end.

(* Quel que soit le niveau de partionnement, on peut récupérer la plus petite matrice
   contenant 4 regions élementaires. Cette matrice à donc 2 lignes et 2 colonnes.
   On a deux possibilités pour partionner le plan:
   - on peut partir de cette matrice pour partionner le plan (approche bottom-up).
   - on peut partir du partionnement de niveau n et construire le partionnement n+1 en concatenant
   le préfixe de chaque région élémentaire à la matrice base_matrix (approche top-down). *)
Definition get_base_matrix(n:nat) : listlist region :=
'{[ (rot_nat n) Z, rot_nat (n+3) Z ], [(rot_nat (n+1)) Z, (rot_nat (n+2)) Z ] }.

(* Equivalent à:
(vertcat   (horcat '{[((rot_nat n) Z)]}   '{[(rot_nat (n+1)) Z ]} )
           (horcat '{[(rot_nat (n+3) Z)]} '{[(rot_nat (n+2)) Z]}  )).
*)

Eval compute in get_base_matrix 0.

(* Approche bottom-up: On part de la matrice de base de niveau n. En concatenant cette matrice
   sur les 4 quarts d'une nouvelle matrice et en ajoutant à chaque quart la région appopriée de
   la matrice de base de niveau n-1, on obtient un partitionnement pour la matrice de niveau n-1.
   En effectuant cette opération n fois on obtient le partitionnement de niveau n.

   Le parametre r correspond à la première region du partitionnement (soit OO, OI, II ou IO).
   La fonction auxiliaire sert à différencier le cas n=0 et n= S n.
   Dans le cas n=0 on renvoi seulement la première region. Dans le cas n=S n on met en place la recursivité
   sur la matrice de base de niveau n *)
Definition mat_part_bup (n:nat)(r: region):listlist region :=
match n with
| O => '{[r]}
| S n' => suffix_mat r ((fix from_n_to_0 (n:nat)(m:listlist region):listlist region :=
          match n with
          | O => m
          | S n' => let base := get_base_matrix n' in (
                    from_n_to_0 n' (vertcat (horcat (suffix_mat (option_elim Z (base _[0,0])) m) (suffix_mat (option_elim Z (base _[0,1])) m ))
                                            (horcat (suffix_mat (option_elim Z (base _[1,0])) m) (suffix_mat (option_elim Z (base _[1,1])) m ))) )
          end) n' (get_base_matrix n'))
end.

Eval compute in mat_part_bup 2 (OO Z).

(* Approche top-down: On remplace chaque element d'une matrice correspondant à
   un partitionnement de niveau n-1 par la matrice de base de niveau n. Cette
   nouvelle matrice correspond au partitionnement de niveau n.

   On commence par définir une fonction qui transforme une liste en une matrice
   en concatenant le prefixe de chaque élement de la liste à la matrice base_matrix. *)
Fixpoint parse_list (l:clist region)(n:nat): listlist region :=
match l with
| nil => lnil
| cons r l' => vertcat (suffix_mat r (get_base_matrix n)) (parse_list l' n)
end.

Eval compute in parse_list [OO (OO Z)] 0.
Eval compute in parse_list [OO Z] 0.

(* On définit une fonction qui transforme la matrice correspondant à un partionnement
   de niveau n, en une matrice correspondant à un partionnement de niveau n+1.  *)
Fixpoint parse_mat (m:listlist region)(n:nat): listlist region :=
match m with
| lnil => lnil
| lcons v m' => horcat (parse_list v n) (parse_mat m' n)
end.

Eval compute in parse_mat '{[OO Z, OI Z],[IO Z, II Z]} 0.
Eval compute in parse_mat '{[OO Z]} 0.

(* Enfin, on définit la fonction inductive de partionnement du plan *)
Definition mat_part_tdown (n:nat)(m:listlist region):listlist region :=
(* La fonction sub sert uniquement à cacher le compteur dans les paramètres de mat_part_tdown *)
(fix sub(n acc:nat)(m:listlist region):listlist region :=
match n with
| O => m
| S n' => sub n' (acc+1) (parse_mat m acc)
end) n 0 m.

Eval compute in mat_part_tdown 1 '{[OO Z]}.
Eval compute in mat_part_tdown 2 '{[OO Z]}.

(* Implementation de l'algo du poly. Probleme à détailler. *)
Definition mat_part_tdown_poly (n:nat)(m:listlist region):listlist region :=
  let sub := (fix sub(n acc:nat)(m:listlist region):listlist region :=
    match n with
    | O => m
    | S n' => let upright := (prefix_mat ((rot_nat (acc+3)) Z) m) in (
              let upleft := (prefix_mat ((rot_nat (acc)) Z) m) in (
              let downright := (prefix_mat ((rot_nat (acc+2)) Z) m) in(
              let downleft := (prefix_mat ((rot_nat (acc+1)) Z) m) in (
                sub (n') (acc+1) (vertcat (horcat upleft upright) (horcat downleft downright))
              ) ) ) )
    end )
    in sub n 0 m.

Eval compute in mat_part_tdown_poly 2 '{[OO Z]}.

(* Liste des regions voisines d'une région contenue dans une liste de regions. *)
Definition voisins_list (l:clist region)(r:region):clist region :=
if is_in_list l r then
(* on peut se permettre de mettre une valeur par défaut de 0 puisqu'on a vérifié
   que r était dans l. La valeur par défaut ne sera donc jamais utilisée. *)
  let row := option_elim 0 (get_row_region l r) in (
            match (0 <? row), (row+1 <? list_count l) with
            | true, true => [ get_list_reg l (row-1), get_list_reg l (row+1) ]
            | true, false => [ get_list_reg l (row-1) ]
            | false, true => [ get_list_reg l (row+1) ]
            | false, false => nil
            end)
else
  nil.

(* le match est equivalent à:
            if andb (0 <? row) (row <? ((list_count l)-1)) then
              get_list_reg l (row-1) :: get_list_reg l (row+1) :: nil
            else if 0 <? row then
              [ get_list_reg l (row-1) ]
            else if row <? ((list_count l)-1) then
              [ get_list_reg l (row+1) ]
            else
              nil )
*)

(* Liste des regions voisines de l'élement situé à la position row d'une liste de regions.
   La différence avec la fonction ci-dessus est que l'élement à la postion row est inclus
   dans la liste de regions voisines.
   Cette distinction est utile pour la fonction ci-après. *)
Definition voisins_list_row (l:clist region)(row:nat):clist region :=
if row <? (list_count l)  then
           match (0 <? row), (row+1 <? list_count l) with
            | true, true => [ get_list_reg l (row-1), get_list_reg l row, get_list_reg l (row+1) ]
            | true, false => [ get_list_reg l (row-1), get_list_reg l row ]
            | false, true => [ get_list_reg l row, get_list_reg l (row+1) ]
            | false, false => [ get_list_reg l row ]
            end
else
  nil.

(* le match equivaut à:
            if andb (0 <? row) (row <? ((list_count l)-1)) then
              get_list_reg l (row-1) :: get_list_reg l row :: get_list_reg l (row+1) :: nil
            else if 0 <? row then
              get_list_reg l (row-1) :: get_list_reg l row :: nil
            else if row <? ((list_count l)-1) then
              get_list_reg l row :: get_list_reg l (row+1) :: nil
            else
              get_list_reg l row
  *)

Eval compute in voisins_list [OO Z, OI Z, II Z, IO Z] (II Z).
Eval compute in voisins_list [OO Z, OI Z, II Z, IO Z] (IO Z).
Eval compute in voisins_list_row [OO Z, OI Z, II Z, IO Z] 3.

(* Liste des regions voisines d'une région contenue dans le plan. *)
Fixpoint voisins_mat (m:listlist region)(r:region):clist region :=
if is_in_mat m r then
  let col := option_elim 0 (get_col_region m r) in (
    let row := option_elim 0 (get_row_region (get_col m col) r) in (
      match (0 <? col), (col+1 <? mat_count m) with
      | true, true => voisins_list_row (get_col m (col-1)) row ++ voisins_list (get_col m col) r ++ voisins_list_row (get_col m (col+1)) row
      | true, false => voisins_list_row (get_col m (col-1)) row ++ voisins_list (get_col m col) r
      | false, true => voisins_list (get_col m col) r ++ voisins_list_row (get_col m (col+1)) row
      | false, false => voisins_list (get_col m col) r
      end ) )
else nil.

(* le match equivaut à :
    if andb (0 <? col) (col <? ((mat_count m)-1)) then
      voisins_list_row (get_col m (col-1)) row ++ voisins_list (get_col m col) r ++ voisins_list_row (get_col m (col+1)) row
    else if 0 <? col then
              voisins_list_row (get_col m (col-1)) row ++ voisins_list (get_col m col) r
    else if col <? ((mat_count m)-1) then
              voisins_list (get_col m col) r ++ voisins_list_row (get_col m (col+1)) row
    else
              voisins_list (get_col m col) r ))
  *)

Eval compute in voisins_mat '{[OO Z, II Z, OO Z],[II Z, OI Z, OO Z], [II Z, OO Z, II Z]} (OI Z).

Definition est_voisin (r1 r2:region)(m:listlist region): bool :=
is_in_list (voisins_mat m r1) r2.

Definition diff (n m:nat): nat :=
if (n<?m) then m-n
else n-m.

Eval compute in diff 2 5.

(* Calcul du nombre de regions élementaires maximum qui séparent 2 régions appartenant à la matrice des régions.
   Ce maximum est calculé selon l'axe vertical et l'axe horizontal de la matrice.
   L'interêt de cette fonction est de calculer la largeur minimum du carré contenant 2 régions du plan.
   La largeur de ce carré permettra de déterminer si une region r1 est dans A0 par rapport à une autre region r2. *)
Fixpoint distance_regions_elem (r1 r2:region)(m: listlist region): option :=
  let (col1, row1) := get_col_row_region m r1 in (
  let (col2, row2) := get_col_row_region m r2 in (
    match col1, col2, row1, row2 with
    | Some c1, Some c2, Some r1, Some r2 => Some (Nat.max (diff c1 c2) (diff r1 r2))
    | _, _, _, _ => None
    end
  )).

Eval compute in (mat_part_tdown 2 '{[OO Z]}).
Eval compute in distance_regions_elem (OO(OO(OI Z))) (OO(OI(IO Z))) (mat_part_tdown 2 '{[OO Z]}).

(* ############# Preuves diverses ############### *)

Check plus_comm.
Check plus_assoc.

Lemma mod_exhaustive (n m:nat):
m <> 0 -> ((n + m) mod m) = (n mod m).
intros.
rewrite Nat.add_mod.
rewrite Nat.mod_same.
rewrite plus_0_r.
rewrite Nat.mod_mod.
reflexivity.
assumption.
assumption.
assumption.
Qed.

Theorem rot_nat_mod_4 (n:nat):
rot_nat (4+n) = rot_nat n.
Proof.
  unfold rot_nat.
  rewrite plus_comm.
  rewrite mod_exhaustive.
  reflexivity.
  discriminate.
Qed.

(* Preuve de l'auto-similarité de la disposition des numéros : toutes les quatre itérations du processus
de partitionnement, on obtient la même disposition des numéros pour les regions élementaires. *)
Theorem base_matrix_mod_4 (n:nat):
get_base_matrix n = get_base_matrix (n+4).
Proof.
  unfold get_base_matrix.
  simpl.
  rewrite <- (plus_comm 4).
  rewrite <- ?plus_assoc.
  rewrite ?rot_nat_mod_4.
  reflexivity.
Qed.
(* TODO: Montrer qu'une partition est formée à partir de base_matrix ? evident ? *)

Check nat_ind.

(*
Theorem foo {A:Type}(m1 m2:listlist A):
vertcat m1 m2 = { } -> (m1 = lnil) /\ (m2 = lnil) .
Proof.
  Admitted. *)

Theorem base_matrix_is_square (n:nat):
is_square_matrix (get_base_matrix n) = true.
Proof.
  reflexivity.
Qed.

(* TODO: Preuve que le partionnement est une matrice carré si on commence par OO Z ou n'importe qu'elle matrice carré *)
Theorem is_partition_square (n:nat)(m:listlist region): is_square_matrix m = true -> is_square_matrix (mat_part_tdown n m) = true .
Proof.
   Admitted.

(* Check Nat.sub_0_r.

Theorem get_col_lcons {A:Type}(m:listlist A)(l:clist A)(col:nat):
get_col (lcons l m)  (S col) = get_col m col .
Proof.
  simpl.
  reflexivity.
Qed.

Theorem get_col_0_lcons {A:Type}(m:listlist A)(l:clist A):
get_col (lcons l m) 0 = l .
Proof.
  reflexivity.
Qed.

Lemma add_l_0 n : n + 0 = n.
  rewrite plus_comm.
  apply Nat.add_0_l.
Qed.

Lemma O_lt_Sn (n:nat): 0 < S n.
Proof.
  rewrite Nat.lt_succ_r.
  apply Nat.le_0_l.
Qed.

Lemma O_lt_Sn_bis (n:nat): 0 <? S n = true.
  rewrite Nat.ltb_lt.
  apply O_lt_Sn.
Qed. *)


Require Import Arith.

(** ** reflexivity

reflexivity は X = X という命題を証明する tactic です。

SSReflect ではふつう <<by []>> などで済ますのであまり使いませんが、
等式の扱いの説明をするのに都合がいいので説明しましょう。

*)

Goal 0 = 0.
Proof.
  reflexivity.
  Show Proof.
(**
<<
eq_refl
>>

なんか、省略されているっぽいので Display all low-level contents を有効にして
Show Proof をやり直すと、以下のようになります。

<<
(@eq_refl nat O)
>>

O というのは 0 です。

Coq の theories/Init/Logic.v をみると、eq は以下のように定義されています。

<<
Inductive eq (A:Type) (x:A) : A -> Prop :=
    eq_refl : x = x :>A
where "x = y :> A" := (@eq A x y) : type_scope.
Notation "x = y" := (x = y :>_) : type_scope.
>>

ちょっといろいろと複雑ですが、これは eq という型と
eq 型の値を構成する eq_refl というコンストラクタを定義しています。
ただし、パラメータがついているので
単にひとつの型とコンストラクタを定義しているわけではありません。

About で eq 定義を調べてみましょう。
(Display implicit arguments を有効、Display notations を無効にしておきます)
*)
About eq.
(**
<<
eq : forall (A : Type) (_ : A) (_ : A), Prop
>>

これをみると、eq は A という型と、A型の値ふたつを受け取って、
命題を返す関数であることがわかります。

コンストラクタの eq_refl も調べてみましょう。
*)
About eq_refl.
(**
<<
eq_refl : forall (A : Type) (x : A), @eq A x x
>>

eq_refl は A という型と A 型の値 x を受け取って @eq A x x という型の値を返す関数
であることがわかります。

カリーハワード対応により命題と型は同型なので、
eq が命題を返すというのと、
@eq A x x が型というのは同じことです。

さて、eq は 3つのパラメータをとるので、
@eq A a b というように 3つパラメータを与えれば具体的な型になります。
たとえば、@eq nat 1 2 はひとつの具体的な型です。
それに対して、コンストラクタが返す値の型は @eq A x x なので、
必ず x と y は等しくなります。
つまり、@eq_refl nat 1 という値の型は @eq nat 1 1 という型であり、
eq_refl で @eq nat 1 2 という型の値を作ることはできません。

そして、eq_refl 以外で eq 型の値を作ることはできません。
（Inductive というのは帰納ということで、帰納的に定義する、というのはそういうことです。
まじめに帰納的定義を書くときには「以上のやりかたで作れるものだけがうんたら」などと書きますよね。）

ついでにいえば、リストの cons みたいな
（リスト型の値を引数として受け取る）コンストラクタと違って、
eq_refl は eq 型の値を受け取る引数を持たないので、
eq 型の値を作るには eq_refl を一回使う以外の方法はありません。

結局、@eq A a b という型は、
a と b が等しい場合は eq_refl によって構成されるただひとつの値を持ちます。
そして、a と b が等しくない場合はまったく値をもちません。

この性質により、@eq A a b という型に対してその型に適合する値を作れるならば、
a と b は等しいということがいえるわけです。
つまり、a と b が等しいという命題や証明を eq 型で実現できるわけです。
*)
Qed.

(**
さて、ここで問題は「等しい」というのはいったいどういう意味か、という点です。
まぁ、最初の 0 = 0 のように、完全に同じ形であれば等しいのはそうでしょうが、
異なる形でも等しいことはないのでしょうか。
たとえば、2 + 4 = 5 + 1 はどうでしょうか。

ということで、試してみましょう。
*)

Goal 2 + 4 = 5 + 1.
Proof.
  reflexivity.
  Show Proof.
(**
<<
(@eq_refl nat (5 + 1))
>>

どうやら問題なく証明できてしまうようです。
証明項は (@eq_refl nat (5 + 1)) です。

どうも、reflexivity は等式の右辺を eq_refl の引数にする感じです。

そうでない証明項は許されるのか、exact で証明項を与えて試してみましょう。
*)
Qed.

Goal 2 + 4 = 5 + 1.
Proof.
  exact (eq_refl 6).
  Show Proof.
(**
<<
(@eq_refl nat 6)
>>
*)
Qed.

(**
とくに問題なく証明できました。

つまり、eq_refl 6 という項は
@eq nat (2 + 4) (5 + 1) という型の値として正しく受け付けられるというわけです。

「eq_refl は A という型と A 型の値 x を受け取って @eq A x x という型の値を返す関数」
と上で述べましたが、ここで eq_refl の引数として指定した x は 6 です。
したがって、eq_refl 6 は @eq nat 6 6 型の値なわけですが、
Coq はここで、この型が @eq nat (2 + 4) (5 + 1) 型と等しいかどうか確認します。
具体的には、計算を進めて同じ項になるかどうかを確認します。
2 + 4 や 5 + 1 は変数が入っていないので計算を最後まで行うことができ、その結果は 6 です。
そのため、Coq は @eq nat 6 6 型と @eq nat (2 + 4) (5 + 1) 型が等しいことを確認でき、
erefl 6 が @eq nat (2 + 4) (5 + 1) 型の要素であることを判断できます。

この、「計算を進めて同じ項になる」ようなものを convertible といいます。
正確な定義は
% Coq Reference Manual, 4.3 Conversion rules %
# Coq Reference Manual, 4.3 Conversion rules #
に書いてあります。

*)

(**
計算を進めても等しさを確認できない場合もあります。
*)

Section AddComm.

Variable n : nat.

Goal n + 1 = 1 + n.
Proof.
  Fail reflexivity.
(**
ここでは n という自然数の変数があって、n + 1 と 1 + n が等しいことを証明しようとしています。
ところが、残念なことに、reflexivity は失敗します。

Coq で n + 1 と 1 + n がどこまで計算を進められるか、Compute というコマンドで
実際に計算を行って確かめてみましょう。
*)
  Compute n + 1.
(**
<<
     = (fix Ffix (x x0 : nat) {struct x} : nat :=
          match x with
          | 0 => x0
          | S x1 => S (Ffix x1 x0)
          end) n 1
     : nat
>>
n + 1 というのは、なにか fix とかいうもので始まる関数が展開されて、
そこで止まってしまいました。
この関数は加算の関数で、最初の引数が 0 かそれ以外かで場合分けを行って計算を行います。
ところが、最初の引数は変数の n であり、これが 0 かどうかは不明です。
そのため、計算がここで止まってしまうのです。

逆に、最初の引数が変数ではなく、具体的な自然数が与えられれば、計算を進めることができます。
1 + n はその例であり、こちらはもっと計算が進みます。
*)
  Compute 1 + n.
(**
<<
     = S n
     : nat
>>
1 + n では、かなり単純な項になるまで計算が進んでいます。

というわけで、n + 1 と 1 + n では、計算を進めても同じ項にたどり着けないので、
reflexivity は失敗してしまうのです。
*)
Abort.

End AddComm.

(**
あと、いちおう注意しておくと、
reflexivity は完全に計算を進めるわけではありません。
*)
Goal 2 ^ 100 = 2 ^ 100.
Proof.
  reflexivity.
  Show Proof.
(**
<<
(@eq_refl nat (2 ^ 100))
>>

2 ^ 100 というのは 2 の 100乗で、本当に計算しようとすると、メモリがあふれてしまいます。
（Coq の自然数はペアノの自然数なので、2^100 を計算すると、
S を 2^100 個メモリに並べる必要がありますが、
これを素朴に実装すると 64ビットのメモリ空間でも足りません。
そして、Coq はいまのところ素朴に実装しているのです。
どうにかしてほしいところですが。）

しかし、ここの reflexivity でメモリがあふれないことからわかるように、
計算を進めなくても同じ項であることがわかるなら、それは問題なく判断してくれます。
*)
Qed.


(*******************************************************************************)
(* Chapter 7.8: Equivalent Categories                                          *)
(*******************************************************************************)

Generalizable All Variables.
Require Import Notations.
Require Import Categories_ch1_3.
Require Import Functors_ch1_4.
Require Import Isomorphisms_ch1_5.
Require Import NaturalIsomorphisms_ch7_5.

(* Definition 7.24 *)
Class EquivalentCategories `(C:Category)`(D:Category){Fobj}{Gobj}(F:Functor C D Fobj)(G:Functor D C Gobj) :=
{ ec_forward  : F >>>> G ≃ functor_id C
; ec_backward : G >>>> F ≃ functor_id D
}.

(* FIXME *)
(* Definition 7.25: TFAE: F is an equivalence of categories, F is full faithful and essentially surjective *)


Require Import Nijn.Nijn.
Open Scope poly_scope.

Inductive base_types :=
| Ca
| Clist.

Global Instance decEq_base_types : decEq base_types.
Proof.
  decEq_finite.
Defined.

Definition a := Base Ca.
Definition list := Base Clist.

Inductive fun_symbols :=
| Tcons
| Tmap
| Tnil.

Global Instance decEq_fun_symbols : decEq fun_symbols.
Proof.
  decEq_finite.
Defined.

Definition fn_arity fn_symbols :=
  match fn_symbols with
  | Tcons  =>  a ⟶ list ⟶ list
  | Tmap  =>  list ⟶ (a ⟶ a) ⟶ list
  | Tnil => list
  end.

Definition cons {C} : tm fn_arity C _ := BaseTm Tcons.
Definition map {C} : tm fn_arity C _ := BaseTm Tmap.
Definition nil {C} : tm fn_arity C _ := BaseTm Tnil.

Program Definition rule_0 :=
  make_rewrite
    (_ ,, ∙) _
    (map · nil ·  V 0)
    nil.

Program Definition rule_1 :=
  make_rewrite
    (_ ,, _ ,, _ ,, ∙) _
    (map · (cons ·  V 0 ·  V 1) ·  V 2)
    (cons · ( V 2 ·  V 0) · (map ·  V 1 ·  V 2)).

Definition trs :=
  make_afs
    fn_arity
    (rule_0 :: rule_1 :: List.nil).

Definition map_fun_poly fn_symbols : poly ∙ (arity trs fn_symbols) :=
  match fn_symbols with
  | Tnil => to_Poly (P_const 3)
  | Tcons  => λP λP let y1 := P_var Vz in
    to_Poly (P_const 3
             + P_const 2 * y1)
  | Tmap  =>  λP let y0 := P_var (Vs Vz) in λP let G1 := P_var Vz in
    to_Poly (P_const 3 * y0
             + P_const 3 * y0 * (G1 ·P (y0)))
  end.

Definition  trs_isSN : isSN trs.
Proof.
  solve_poly_SN map_fun_poly.
Qed.


Require Import HoTT.
Require Import structures basics.

Export Ring_pr Relation_pr OrderedMagma_pr.
Import minus1Trunc.

Open Scope nat_scope.

(* used to avoid polluting with extra instances
eg left_cancel, right_cancel and cancel when just cancel suffices *)
Section LocalInstances.

Fixpoint nplus (n m : nat) : nat := match n with
  | S k => S (nplus k m)
  | 0 => m
  end.

Definition npred (n : nat) : nat := match n with
  | S k => k
  | _ => 0
  end.

Fixpoint nmult (n m : nat) : nat := match n with
  | S k => nplus m (nmult k m)
  | 0 => 0
  end.

Inductive nle (n : nat) : nat -> Type :=
  | nle_n : nle n n
  | nle_S : forall m : nat, nle n m -> nle n (S m).

Definition nlt n := nle (S n).

Canonical Structure nat_LLRRR : PreringFull nat
 := BuildLLRRR_Class nat nplus nmult neq nle nlt.
Global Existing Instance nat_LLRRR.

Lemma S_0_neq : forall n, S n = 0 -> Empty.
Proof.
intros. exact (transport (fun s => match s with
  | 0 => Empty | _ => Unit end) H tt).
Defined.

Definition eq_nat_dec : DecidablePaths nat.
Proof.
red.
induction x,y.

- left;reflexivity.

- right. exact (fun H => transport (fun s => match s with
 | 0 => Unit | _ => Empty end) H tt).

- right. exact (fun H => transport (fun s => match s with
 | 0 => Empty | _ => Unit end) H tt).

- destruct (IHx y). left. apply ap;assumption.
  right. intro;apply n.
  exact (ap npred H).
Defined.

Global Instance nat_set : IsHSet nat.
Proof.
apply hset_decidable. exact eq_nat_dec.
Defined.

Lemma nplus_0_l : forall n, 0 + n = n.
Proof.
reflexivity.
Defined.

Lemma nplus_S_l : forall n m, (S n) + m = S (n + m).
Proof.
intros;reflexivity.
Defined.

Lemma nplus_0_r : forall n, n + 0 = n.
Proof.
induction n.
reflexivity.
apply (ap S). assumption.
Defined.

Lemma nplus_S_r : forall n m, n + (S m) = S (n + m).
Proof.
induction n;intros. reflexivity.
apply (ap S). apply IHn.
Defined.

Instance nplus_comm : Commutative (+).
Proof.
red. induction y. apply nplus_0_r.
unfold gop in *. change (x + S y = S (y+x)).
eapply concat;[| apply ap; apply IHy].
apply nplus_S_r.
Defined.

Instance nplus_assoc : Associative (+).
Proof.
red. induction x. intros;reflexivity.
intros;unfold gop. apply (ap S);apply IHx.
Defined.

Instance nplus_is_sg : IsSemigroup (+). split;apply _. Defined.

Instance n0_is_id : IsId (+) 0.
Proof.
split. intro;reflexivity.
exact nplus_0_r.
Defined.

Canonical Structure nplus_identity : Identity (+) := BuildIdentity _ _ _.
Existing Instance nplus_identity.

Instance nplus_ismono : IsMonoid (+)
 := BuildIsMonoid _ _ nplus_identity.

Instance nplus_left_cancel : forall n : nat, Lcancel (+) n.
Proof.
induction n;red;intros.
assumption.
unfold gop in H;simpl in H. apply IHn.
apply (ap npred H).
Defined.

Instance nplus_right_cancel : forall n : nat, Rcancel (+) n.
Proof.
induction n;red;intros.
eapply concat;[|eapply concat;[apply H|]].
apply inverse;apply nplus_0_r. apply nplus_0_r.
apply IHn.
assert (S (b + n) = S (c + n)).
eapply concat. symmetry. apply nplus_S_r. eapply concat. apply H.
apply nplus_S_r.
apply (ap npred X).
Defined.

Instance nplus_cancel : forall n : nat, Cancel (+) n.
Proof.
intros. split;apply _.
Defined.

Instance nplus_cmono : IsCMonoid (+) := BuildIsCMonoid _ _ _.

Definition nmult_0_l : forall m, 0 ° m = 0 := fun _ => idpath.

Lemma nmult_0_r : forall n, n ° 0 = 0.
Proof.
induction n.
reflexivity.
assumption.
Defined.

Lemma nmult_S_l : forall n m, (S n) ° m = m + (n ° m).
Proof.
intros;reflexivity.
Defined.

Lemma nmult_S_r : forall n m, n ° (S m) = (n ° m) + n.
Proof.
induction n;intros.
reflexivity.
eapply concat;[|symmetry;apply nplus_S_r].
eapply concat;[apply nmult_S_l|].
eapply concat;[apply nplus_S_l|].
apply ap.
eapply concat;[|apply nplus_assoc]. apply ap.
apply IHn.
Defined.

Instance nmult_comm : Commutative (°).
Proof.
red. induction y.
- simpl. apply nmult_0_r.
- simpl. eapply concat. apply nmult_S_r. eapply concat. apply nplus_comm.
  eapply concat;[|symmetry;apply nmult_S_l]. apply ap. assumption.
Defined.

Instance nat_distrib_left : Ldistributes nat_LLRRR.
Proof.
red. induction a;intros.
reflexivity.

eapply concat;[apply nmult_S_l|].
pattern (a ° (b+c)). eapply transport. symmetry;apply IHa.
path_via (b + (c + (a°b + a°c))).
eapply concat;[ symmetry;apply nplus_assoc |]. apply ap;apply ap.
apply IHa.

eapply concat;[| apply nplus_assoc]. fold nmult. apply ap.
eapply concat;[| apply nplus_comm].
eapply concat;[| apply nplus_assoc]. apply ap.
apply nplus_comm.
Defined.

Instance nat_distrib_right : Rdistributes nat_LLRRR.
Proof.
red. intros.
simpl.
eapply concat. apply nmult_comm.
eapply concat. apply nat_distrib_left.
apply ap11;[ apply ap |];apply nmult_comm.
Defined.

Instance nat_distrib : Distributes nat_LLRRR.
Proof.
split;apply _.
Defined.

Instance nmult_assoc : Associative (°).
Proof.
red. unfold gop. induction x;intros.
reflexivity.
eapply concat;[apply nmult_S_l|].
eapply concat;[| symmetry;apply nat_distrib]. fold nmult.
change nmult with mult.
apply ap. apply IHx.
Defined.

Instance nmult_issg : IsSemigroup (°) := BuildIsSemigroup _ _ _.

Instance nmult_1_l : Left_id (°) 1.
Proof.
red. simpl. apply nplus_0_r.
Defined.

Instance nmult_1_r : Right_id (°) 1.
Proof.
red. intros. eapply concat. apply nmult_comm.
apply nmult_1_l.
Defined.

Instance nmult_1_id : IsId (°) 1.
Proof.
split;apply _.
Defined.

Canonical Structure nmult_identity : Identity (°) := BuildIdentity _ _ _.
Existing Instance nmult_identity.

Instance nmult_ismono : IsMonoid (°) := BuildIsMonoid _ _ nmult_identity.

Global Instance nat_issemiring : IsSemiring nat_LLRRR.
Proof.
apply BuildIsSemiring;apply _.
Defined.

Lemma nplus_0_0_back : forall n m, n + m = 0 -> (n = 0) * (m = 0).
Proof.
intros.
destruct n. destruct m.
split;reflexivity.
apply Empty_rect.
exact (transport (fun s : nat => match s with
                                  | 0 => Empty
                                  | S _ => Unit
                                  end) H tt).
apply Empty_rect.
exact (transport (fun s : nat => match s with
                                  | 0 => Empty
                                  | S _ => Unit
                                  end) H tt).
Defined.

Lemma nmult_S_0_back : forall n m, mult (S n) m = 0 -> m = 0.
Proof.
intros.
compute in H. apply nplus_0_0_back in H. apply H.
Defined.

Lemma nmult_integral : forall n m, 0 = mult n m ->
(0 = n) + (0 = m).
Proof.
intros n m;intros. destruct n.
- left;reflexivity.
- right;symmetry;eapply nmult_S_0_back. symmetry;apply H.
Defined.

Instance nmult_strict_integral : IsStrictIntegral nat_LLRRR.
Proof.
red;intros;apply min1;apply nmult_integral;assumption.
Defined.

Instance nmult_left_cancel : forall n, Lcancel (°) (S n).
Proof.
intros n m;induction m;simpl in *;intros m' H.
assert (X:m' + (n°m') = 0). eapply concat. symmetry;apply H.
apply nmult_0_r.
apply nplus_0_0_back in X. symmetry;apply X.

destruct m'.
assert (X:(S n) ° (S m)=0). eapply concat. apply H. apply nmult_0_r.
apply inverse in X;apply nmult_integral in X.
destruct X as [X | X];apply inverse in X;apply S_0_neq in X;destruct X.

apply ap. apply IHm. unfold gop in *.
apply nplus_right_cancel with (S n). unfold gop.
eapply concat;[|eapply concat;[apply H|]].
unfold mult;simpl. change nmult with mult. change nplus with plus.
symmetry. eapply concat. apply ap. apply ap. apply nmult_S_r.
symmetry;eapply concat. apply nplus_S_r. apply (ap S).
symmetry;apply (associative (+) _).
eapply concat. unfold mult;simpl;apply ap;apply ap. apply nmult_S_r.
unfold mult;simpl.
change nplus with plus;change nmult with mult.
eapply concat;[|symmetry;apply nplus_S_r]. apply ap.
apply associative;apply _.
Defined.

Global Instance nmult_cancel : forall n, Cancel ((°)) (S n).
Proof.
intro;apply left_cancel_cancel. apply _.
Defined.

Instance nle_refl : Reflexive (<=) := nle_n.

Lemma nle_exists : forall n m : nat, n <= m -> exists k, k + n = m.
Proof.
intros n m H;induction H.
exists 0;reflexivity.
exists (S (projT1 IHnle)).
apply (ap S).
apply projT2.
Defined.

Lemma nplus_nle : forall n k : nat, n <= k + n.
Proof.
induction k.
apply nle_n.
simpl. apply nle_S. assumption.
Defined.

Definition exists_nle : forall n m : nat, (exists k, k + n = m) -> n <= m.
Proof.
intros.
destruct H as [k []].
apply nplus_nle.
Defined.

Lemma nle_exists_nle : forall n m H, nle_exists n m (exists_nle n m H) = H.
Proof.
intros n m H. destruct H as [k []].
simpl. clear m. induction k.
reflexivity.
path_via (nle_exists n (S (k + n)) (nplus_nle n (S k))).
simpl. fold nplus.
change nplus with plus;simpl.
rewrite IHk.
reflexivity.
Defined.

Instance nle_antisymm : Antisymmetric (<=).
Proof.
intros n m H H0.
apply nle_exists in H. apply nle_exists in H0.
destruct H as [k Hk];destruct H0 as [k' Hk'].
destruct k. apply Hk.
destruct k'. symmetry;apply Hk'.
simpl in *.
assert (H : S (k + S (k' + m)) = m).
pattern (S (k' + m)). eapply transport. symmetry;apply Hk'. apply Hk.
assert (H' : (S (S (k+ k'))) + m = 0 + m).
simpl. eapply concat;[|apply H].
apply (ap S). symmetry. eapply concat;[apply nplus_S_r|]. apply ap.
apply nplus_assoc.
apply nplus_right_cancel in H'.
apply S_0_neq in H'. destruct H'.
Defined.

Lemma nle_n_back : forall n (H : n <= n), H = nle_n n.
Proof.
assert (H: forall n m (H : n <= m) (p : m = n), transport _ p H = nle_n n).
induction H.
intros. assert (X : p = idpath). apply axiomK_hset. apply _.
pattern p. eapply transport. symmetry. apply X.
simpl. reflexivity.
intros.
assert (H' : n = m). apply nle_antisymm. assumption.
destruct p. apply nle_S. apply nle_n.
assert (H0 : 1 + m = 0 + m). simpl. path_via n.
clear H'. apply nplus_right_cancel in H0. apply S_0_neq in H0. destruct H0.

intros. apply (H n n H0 idpath).
Defined.

Lemma nle_S_n_n_not : forall n, ~ (S n) <= n.
Proof.
red;intros.
assert (H' : 1 + n = 0 + n).
simpl. apply nle_antisymm. assumption.
apply nle_S;apply nle_n.
apply nplus_right_cancel in H'. eapply S_0_neq;apply H'.
Defined.

Lemma nle_S_back : forall n m, n <= m -> forall H : n <= S m,
 exists H', H = nle_S _ _ H'.
Proof.
assert (X :forall n m (H : n <= m) m0 (p : m = S m0) (H0 : n <= m0),
 exists H' : n <= m0, transport _ p H = nle_S _ _ H').
induction H;intros.
apply Empty_rect. apply S_0_neq with 0.
apply nplus_right_cancel with m0. unfold gop.
apply nle_antisymm. pattern (1 + m0);eapply transport. apply p. assumption.
apply nle_S;apply nle_n.
assert (p' : m = m0). apply (ap npred p). destruct p'.
pattern p. eapply transport. symmetry. apply axiomK_hset. apply _.
simpl. exists H;reflexivity.

intros. apply (X n (S m) H0 m idpath H).
Defined.

Lemma exists_nle_exists : forall n m H, exists_nle n m (nle_exists n m H) = H.
Proof.
intros.
destruct (nle_exists n m H).
destruct p.
simpl.
induction x.
simpl.
symmetry;apply nle_n_back.
simpl.
simpl in H.

destruct (nle_S_back n (x+n) (nplus_nle _ _) H).
 pattern (nplus_nle n x). eapply transport. symmetry. apply IHx.
symmetry. apply p.
Defined.

Instance nle_exists_isequiv : forall n m, IsEquiv (nle_exists n m).
Proof.
intros. apply isequiv_adjointify with (exists_nle n m).
red;apply nle_exists_nle.
red;apply exists_nle_exists.
Defined.

Lemma nle_equiv_nplus : forall n m : nat, (n <= m) <~> (exists k, k + n = m).
Proof.
intros. eapply BuildEquiv. apply _.
Defined.

Instance nle_prop : forall n m : nat, IsHProp (n <= m).
Proof.
intros. eapply trunc_equiv'. apply symmetric_equiv.
apply nle_equiv_nplus.
apply hprop_inhabited_contr. intro X.
apply BuildContr with X. intro Y.
destruct X as [k Hk];destruct Y as [k' Hk'].
assert (p : k = k').
apply nplus_right_cancel with n. path_via m.
apply path_sigma with p.
apply nat_set.
Defined.

Lemma nle_0 : forall n, 0 <= n.
Proof.
induction n;constructor;auto.
Defined.

Lemma nle_S_S_back : forall n m, S n <= S m -> n <= m.
Proof.
intros. apply nle_exists in H. apply exists_nle.
destruct H as [k H]. exists k.
assert (X : S (k + n) = S m). path_via (k + S n). symmetry. apply nplus_S_r.
apply (ap npred X).
Defined.

Instance nle_trans : Transitive (<=).
Proof.
intros x y z H;revert z;induction H;intros. assumption.
destruct z.
refine (Empty_rect _ (S_0_neq m _)). apply nle_antisymm. assumption.
apply nle_0.
apply nle_S_S_back in H0. apply IHnle. apply nle_S. assumption.
Defined.

Lemma nlt_not_nle : forall n m : nat, n < m -> ~ m <= n.
Proof.
red;intros.
red in H. apply S_0_neq with 0. apply nplus_right_cancel with n.
simpl. apply nle_antisymm. eapply nle_trans. apply H. assumption.
apply nle_S;apply nle_n.
Defined.

Lemma nle_S_S : forall n m, n <= m -> (S n) <= (S m).
Proof.
intros n m H;induction H.
apply nle_n.
apply nle_S;assumption.
Defined.

Definition nle_nlt_dec : forall n m : nat, (n <= m) + (m < n).
Proof.
  intros n m.
  induction n in m |- *.
  left. apply nle_0.
  destruct m.
  right. apply nle_S_S. apply nle_0.
  destruct (IHn m).
  left. apply nle_S_S;assumption.
  right. apply nle_S_S;assumption.
Defined.

Lemma not_nle_nlt : forall n m : nat, ~ m <= n -> n < m.
Proof.
intros.
destruct (nle_nlt_dec m n). apply Empty_rect;auto.
assumption.
Defined.

Instance nle_dec : Decidable (<=).
Proof.
intros n m;destruct (nle_nlt_dec n m).
left;assumption.
right;apply nlt_not_nle;assumption.
Defined.

Instance nle_linear : ConstrLinear (<=).
Proof.
intros n m. destruct (nle_nlt_dec n m). left;assumption.
right. apply nle_trans with (S m). apply nle_S;apply nle_n.
assumption.
Defined.

Global Instance nle_total_order : ConstrTotalOrder (<=).
Proof.
constructor;[constructor|];apply _.
Defined.

Lemma nlt_iff_nle_neq : forall n m : nat, n<m <-> (n<=m /\ neq n m).
Proof.
intros;split;intros H.
change (nlt n m) in H. apply nle_exists in H.
destruct H as [k H].
assert (H' : (S k) + n = m). path_via (k + S n).
path_via (S (k+n)). symmetry. apply nplus_S_r. clear H. destruct H'.
split. apply nplus_nle.
intro H. change (O+n = S k + n) in H.
apply nplus_right_cancel in H.
eapply S_0_neq. apply inverse;apply H.
destruct H as [H H0].
apply nle_exists in H. destruct H as [k H].
destruct k. destruct H0.
assumption.
apply exists_nle. exists k.
path_via (S k + n). path_via (S (k+n)). apply nplus_S_r.
Defined.

Lemma nle_iff_nlt_eq : forall n m : nat, n<=m <-> (n<m \/ n=m).
Proof.
intros;split;intros H.
destruct H. right;reflexivity.
left. apply nle_S_S. assumption.
destruct H. apply transitivity with (S n). apply nle_S. apply nle_n.
assumption.
destruct p;apply nle_n.
Defined.

Lemma nle_iff_not_nlt_flip : forall n m:nat, n<=m <-> ~m<n.
Proof.
intros;split;intro H.
intro H'. eapply nlt_not_nle;[apply H'|apply H].
destruct (nle_nlt_dec n m). assumption.
destruct H;assumption.
Defined.

Instance nle_nplus_linvariant : IsLInvariant (+ <=).
Proof.
red;red. unfold gop;unfold rrel. simpl.
simpl.
intros. apply exists_nle. apply nle_exists in H.
destruct H as [k []]. exists k.
path_via ((k+z)+x). apply associative;apply _.
path_via ((z+k)+x). apply (ap (fun g => g + _)). apply commutative;apply _.
symmetry;apply associative;apply _.
Defined.

Global Instance nplus_nle_invariant : IsInvariant (+ <=).
Proof.
apply linvariant_invariant; apply _.
Defined.

Global Instance nplus_nle_compat : IsCompat (+ <=).
Proof.
apply invariant_compat; apply _.
Defined.

Global Instance nplus_nle_regular : forall z, IsRegular (+ <=) z.
Proof.
assert (forall z, IsLRegular (+ <=) z). red;red.
unfold rrel;unfold gop;simpl.
intros ? ? ? H.
apply nle_exists in H;apply exists_nle.
destruct H as [k H].
exists k. apply nplus_cancel with z.
path_via (k + (z+x)).
path_via ((z+k)+x). apply associative;apply _.
path_via ((k+z)+x). apply (ap (fun g => g + _)). apply commutative;apply _.
symmetry;apply associative;apply _.

intros;split. apply _.
red;red.
intros. apply H with z.
unfold gop;simpl.
apply (@transport _ (fun k => k ~> z+y) (x+z)).
apply commutative;apply _.
apply (@transport _ (fun k => _ ~> k) (y+z)).
apply commutative;apply _.
assumption.
Defined.

Lemma not_nlt_nle : forall n m : nat, ~ n < m -> m <= n.
Proof.
intros.
destruct (nle_nlt_dec m n). assumption.
destruct X;assumption.
Defined.

Lemma nlt_nle : forall n m : nat, n < m -> n <= m.
Proof.
intros. apply nle_trans with (S n). apply nle_S;apply nle_n.
assumption.
Defined.

Global Instance nat_trichotomic : Trichotomic nat_LLRRR.
Proof.
red. intros.
destruct (nle_nlt_dec y x). right. destruct (nle_nlt_dec x y).
left. apply nle_antisymm;assumption.
right;assumption.
left;assumption.
Defined.

Global Instance nat_fullpseudoorder : FullPseudoOrder nat_LLRRR.
Proof.
split.
split.
apply neq_apart. apply eq_nat_dec.
intros;apply iff_refl.
intros. apply nlt_not_nle in H0. apply H0.
apply nlt_nle. assumption.

red. unfold rrel. intros. apply min1.
destruct (nle_nlt_dec z x).
destruct (nle_nlt_dec y z).
apply nlt_not_nle in H. destruct H. apply nle_trans with z;assumption.
right;assumption.
left;assumption.

intros. split;intro H.
destruct (nat_trichotomic x y) as [H' | [H' | H']];auto.
destruct H;assumption.
intro H'. destruct H'.
destruct H as [H|H];apply nlt_iff_nle_neq in H;apply H;reflexivity.

intros. split.
intros H H';eapply nlt_not_nle;eauto.
apply not_nlt_nle.
Defined.

Lemma nle_not_nlt : forall n m : nat, n <= m -> ~ m < n.
Proof.
intros ? ? H H'. eapply nlt_not_nle.
apply H'. apply H.
Defined.

Lemma nle_n_S_n : forall n : nat, n <= S n.
Proof.
intros;apply nle_S;apply nle_n.
Defined.

Global Instance nat_fullpseudo : FullPseudoOrder nat_LLRRR.
Proof.
split;try apply _.

split. apply nle_not_nlt.
apply not_nlt_nle.
Defined.

End LocalInstances.

Section nat_to_semiring.

Context {A:Type}.
Variable (L : Prering A).
Context {Hg : IsSemiring L}.

Fixpoint nat_embed (n : nat) : A := match n with
  | S k => OneV + (nat_embed k)
  | 0 => ZeroV
  end.

Global Instance nat_embed_add_morph : Magma.IsMorphism (+) (+) nat_embed.
Proof.
red.
induction x;intros.
- symmetry. apply Zero.
- simpl. eapply concat.
  apply ap. apply IHx.
  apply (@associative _ (+) _).
Defined.

Global Instance nat_embed_mult_morph : Magma.IsMorphism (°) (°) nat_embed.
Proof.
red.
induction x.
- intros. simpl.
  apply inverse. apply rmult_0_l.
- intros. unfold gop. simpl.
  eapply concat. apply nat_embed_add_morph.
  eapply concat. apply ap. apply IHx.
  path_via ((OneV ° nat_embed y) + nat_embed x ° nat_embed y).
  unfold gop.
  apply (@ap _ _ (fun g => g + (nat_embed x ° nat_embed y)) (nat_embed y)).
  apply inverse. apply One.
  apply inverse. apply rdistributes;apply _.
Defined.

End nat_to_semiring.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat.
From Categories Require Import Functor.Main.
From Categories Require Import Basic_Cons.Product.

Local Open Scope morphism_scope.

(**
Given two objects a and b the exponential (bᵃ, denoted 'Exponential a b' below)
is intuitively the internal representation of homomorphisms from a to b – it is
sometimes referred to as the internal hom. The notion of exponential is a
generalization of the notion function space from set theory.

Definition: bᵃ is an object equipped with an evaluation function eval: bᵃ×a -> b
such that for any other object z with arrow f : z×a -> b, we have a unique arrow
f^ that makes the following diagram commute:

#
<pre>
               eval
        bᵃ×a ——————————> b
         ↑             ↗
  bᵃ     |            /
  ↑      | <f^,idₐ>  /
  |      |          /
  |∃!f̂ ^  |         /
  |      |        / f
  z      |       /
         |      /
         |     /
         |    /
         |   /
         |  /
         z×a
</pre>
#
where <f, g> is the arrow map of the product functor.
*)
Record Exponential {C : Category} {HP : Has_Products C} (c d : Obj) : Type :=
{
  exponential : C;

  eval : ((×ᶠⁿᶜ C) _o (exponential, c))%object –≻ d;

  Exp_morph_ex : ∀ (z : C), (((×ᶠⁿᶜ C) _o (z, c))%object –≻ d) → (z –≻ exponential);

  Exp_morph_com : ∀ (z : C) (f : ((×ᶠⁿᶜ C) _o (z, c))%object –≻ d),
      f = (eval ∘ ((×ᶠⁿᶜ C) @_a (_, _) (_, _) (Exp_morph_ex z f, id c)))%morphism;

  Exp_morph_unique : ∀ (z : C) (f : ((×ᶠⁿᶜ C) _o (z, c))%object –≻ d)
                       (u u' : z –≻ exponential),
      f = (eval ∘ ((×ᶠⁿᶜ C) @_a (_, _) (_, _) (u, id c)))%morphism →
      f = (eval ∘ ((×ᶠⁿᶜ C) @_a (_, _) (_, _) (u', id c)))%morphism →
      u = u'
}.

Coercion exponential : Exponential >-> Obj.

Arguments Exponential _ {_} _ _, {_ _} _ _.

Arguments exponential {_ _ _ _} _, {_ _} _ _ {_}.
Arguments eval {_ _ _ _} _, {_ _} _ _ {_}.
Arguments Exp_morph_ex {_ _ _ _} _ _ _, {_ _} _ _ {_} _ _.
Arguments Exp_morph_com {_ _ _ _} _ _ _, {_ _} _ _ {_} _ _.
Arguments Exp_morph_unique {_ _ _ _} _ _ _ _ _ _ _, {_ _} _ _ {_} _ _ _ _ _ _.

Notation "a ⇑ b" := (Exponential a b) : object_scope.

(** Exponentials are unique up to isomorphism. *)
Theorem Exponential_iso {C : Category} {HP : Has_Products C} (c d : C)
        (E E' : (c ⇑ d)%object) : (E ≃ E')%isomorphism.
Proof.
  eapply
    (
      Build_Isomorphism
        _
        _
        _
        (Exp_morph_ex E' _ (eval E))
        (Exp_morph_ex E _ (eval E'))
    );
  eapply Exp_morph_unique; eauto;
  simpl_ids;
  match goal with
      [|- (_ ∘ ?M)%morphism = _] =>
      match M with
        (?U _a (?A ∘ ?B, ?C))%morphism =>
        assert (M = (U @_a (_, _) (_, _) (A, C))
                          ∘ (U @_a (_, _) (_, _) (B, C)))%morphism as HM;
          [simpl_ids; rewrite <- F_compose; simpl; simpl_ids; trivial|rewrite HM]
      end
  end;
  rewrite <- assoc;
  repeat rewrite <- Exp_morph_com; auto.
Qed.

Definition Has_Exponentials (C : Category) {HP : Has_Products C} :=
  ∀ a b, (a ⇑ b)%object.

Existing Class Has_Exponentials.

Section Curry_UnCurry.
  Context (C : Category) {HP : Has_Products C} {HE : Has_Exponentials C}.

  (** Given a arrow f: a×b -> c in a category with exponentials, the curry of f
      is f̂f^ in the definition of Exponential above. *)
  Definition curry :
    forall {a b c : C},
      (((×ᶠⁿᶜ C) _o (a, b))%object –≻ c) → (a –≻ (HE b c)) :=
    fun {a b c : C} (f : ((×ᶠⁿᶜ C) _o (a, b))%object –≻ c) =>
      Exp_morph_ex (HE b c) _ f.

  (** Given an arrow f: a -> cᵇ, uncurry of f is the arrow
      (eval_cᵇ ∘ <id_b, f>): a×b -> c.
      See definition of Exponential above for details. *)
  Definition uncurry : forall {a b c : C},
      (a –≻ (HE b c)) → (((×ᶠⁿᶜ C) _o (a, b))%object –≻ c) :=
    fun {a b c : C} (f : a –≻ (HE b c)) =>
      ((eval (HE b c)) ∘ ((×ᶠⁿᶜ C) @_a (_, _) (_, _) (f, id C b)))%morphism.

  Section inversion.
    Context {a b c : C}.

    (** See definition of curry and uncurry above for details.
        Frollows immediately from the definition of Exponential above. *)
    Theorem curry_uncurry (f : a –≻ (HE b c)) : curry (uncurry f) = f.
    Proof.
      unfold curry, uncurry.
      eapply Exp_morph_unique; trivial.
      rewrite <- Exp_morph_com; trivial.
    Qed.

    (** See definition of curry and uncurry above for details.
        Follows immediately from the definition of Exponential above. *)
    Theorem uncurry_curry (f : ((×ᶠⁿᶜ C) _o (a, b))%object –≻ c) :
      uncurry (curry f) = f.
    Proof.
      unfold curry, uncurry.
      rewrite <- Exp_morph_com; trivial.
    Qed.

  End inversion.

  Section injectivity.
    Context {a b c : C}.

    (** See definition of curry above for details. Follows immediately from
        uncurry_curry above. *)
    Theorem curry_injective (f g : ((×ᶠⁿᶜ C) _o (a, b))%object –≻ c) :
      curry f = curry g → f = g.
    Proof.
      intros H.
      rewrite <- (uncurry_curry f); rewrite <- (uncurry_curry g).
      rewrite H; trivial.
    Qed.

    (** See definition of uncurry above for details.
        Follows immediately from curry_uncurry above. *)
    Theorem uncurry_injective (f g : a –≻ (HE b c)) :
      uncurry f = uncurry g → f = g.
    Proof.
      intros H.
      rewrite <- (curry_uncurry f); rewrite <- (curry_uncurry g).
      rewrite H; trivial.
    Qed.

  End injectivity.

  Section curry_compose.
    Context {a b c : C}.

    (** composing with curry is equivalent to compose and then curry: *)
    Lemma curry_compose (f : ((×ᶠⁿᶜ C) _o (a, b))%object –≻ c)
          {z : C} (g : z –≻ a)
      : (curry f) ∘ g = curry (f ∘ (Prod_morph_ex _ _ (g ∘ Pi_1) Pi_2)).
    Proof.
      unfold curry.
      eapply Exp_morph_unique; eauto.
      rewrite <- Exp_morph_com.
      match goal with
          [|- ((_ ∘ (_ _a) ?M) ∘ _)%morphism = _] =>
          match M with
              ((?N ∘ ?x)%morphism, id ?y) =>
              replace M with
              (compose (_ × _) (_, _) (_, _) (_, _) (x, id y) (N,id y)) by
                  (cbn; auto)
          end
      end.
      rewrite F_compose.
      cbn; simpl_ids.
      rewrite assoc_sym.
      match goal with
          [|- (?A ∘ ?B = ?C ∘ ?B)%morphism] => cutrewrite (A = C); trivial
      end.
      transitivity (uncurry (curry f));
        [unfold curry, uncurry; cbn; auto|apply uncurry_curry].
    Qed.

  End curry_compose.

End Curry_UnCurry.


Require Import Basics.
Require Import Pointed.Core.
Require Import Types.
Require Import Colimits.Pushout.
Require Import Cubical.

Local Open Scope pointed_scope.
Local Open Scope dpath_scope.

(* Definition of smash product *)

Definition sum_to_prod (X Y : pType) : X + Y -> X * Y
  := sum_ind _ (fun x => (x, point Y)) (fun y => (point X, y)).

Definition sum_to_bool X Y : X + Y -> Bool
  := sum_ind _ (fun _ => false) (fun _ => true).

Definition Smash (X Y : pType) : pType
  := [Pushout (sum_to_prod X Y) (sum_to_bool X Y), pushl (point X, point Y)].

Section Smash.

  Context {X Y : pType}.

  Definition sm (x : X) (y : Y) : Smash X Y := pushl (x, y).

  Definition auxl : Smash X Y := pushr false.

  Definition auxr : Smash X Y := pushr true.

  Definition gluel (x : X) : sm x pt = auxl
    := pglue (f:=sum_to_prod X Y) (g:=sum_to_bool X Y) (inl x).

  Definition gluer (y : Y) : sm pt y = auxr
    := pglue (f:=sum_to_prod X Y) (g:=sum_to_bool X Y) (inr y).

  Definition gluel' (x x' : X) : sm x pt = sm x' pt
    := gluel x @ (gluel x')^.

  Definition gluer' (y y' : Y) : sm pt y = sm pt y'
    := gluer y @ (gluer y')^.

  Definition glue (x : X) (y : Y) : sm x pt = sm pt y
    := gluel' x pt @ gluer' pt y.

  Definition glue_pt_left (y : Y) : glue pt y = gluer' pt y.
  Proof.
    refine (_ @ concat_1p _).
    apply whiskerR, concat_pV.
  Defined.

  Definition glue_pt_right (x : X) : glue x pt = gluel' x pt.
  Proof.
    refine (_ @ concat_p1 _).
    apply whiskerL, concat_pV.
  Defined.

  Definition ap_sm_left {x x' : X} (p : x = x')
    : ap (fun t => sm t pt) p = gluel' x x'.
  Proof.
    destruct p.
    symmetry.
    apply concat_pV.
  Defined.

  Definition ap_sm_right {y y' : Y} (p : y = y')
    : ap (sm pt) p = gluer' y y'.
  Proof.
    destruct p.
    symmetry.
    apply concat_pV.
  Defined.

  Definition Smash_ind {P : Smash X Y -> Type}
    (Psm : forall a b, P (sm a b)) (Pl : P auxl) (Pr : P auxr)
    (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl)
    (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr)
    : forall x : Smash X Y, P x.
  Proof.
    srapply Pushout_ind.
    + intros [a b].
      apply Psm.
    + apply (Bool_ind _ Pr Pl).
    + srapply sum_ind; intro; apply dp_path_transport^-1.
      - apply Pgl.
      - apply Pgr.
  Defined.

  Definition Smash_ind_beta_gluel {P : Smash X Y -> Type}
    {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr}
    (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl)
    (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (a : X)
    : dp_apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluel a) = Pgl a.
  Proof.
    apply dp_apD_path_transport.
    refine (Pushout_ind_beta_pglue P _ _ _ (inl a) @ _).
    unfold sum_ind.
    by apply ap.
  Qed.

  Definition Smash_ind_beta_gluer {P : Smash X Y -> Type}
    {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr}
    (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl)
    (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (b : Y)
    : dp_apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluer b) = Pgr b.
  Proof.
    apply dp_apD_path_transport.
    refine (Pushout_ind_beta_pglue P _ _ _ (inr b) @ _).
    unfold sum_ind.
    by apply ap.
  Qed.

  Definition Smash_ind_beta_gluel' {P : Smash X Y -> Type}
    {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr}
    (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl)
    (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (a b : X)
    : dp_apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluel' a b)
    = (Pgl a) @Dp ((Pgl b)^D).
  Proof.
    unfold gluel'.
    rewrite dp_apD_pp, dp_apD_V.
    by rewrite 2 Smash_ind_beta_gluel.
  Qed.

  Definition Smash_ind_beta_gluer' {P : Smash X Y -> Type}
    {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr}
    (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl)
    (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (a b : Y)
    : dp_apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluer' a b)
    = (Pgr a) @Dp ((Pgr b)^D).
  Proof.
    unfold gluer'.
    rewrite dp_apD_pp, dp_apD_V.
    by rewrite 2 Smash_ind_beta_gluer.
  Qed.

  Definition Smash_ind_beta_glue {P : Smash X Y -> Type}
    {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr}
    (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl)
    (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (a : X) (b : Y)
    : dp_apD (Smash_ind Psm Pl Pr Pgl Pgr) (glue a b)
    = ((Pgl a) @Dp ((Pgl pt)^D)) @Dp ((Pgr pt) @Dp ((Pgr b)^D)).
  Proof.
    by rewrite dp_apD_pp, Smash_ind_beta_gluel', Smash_ind_beta_gluer'.
  Qed.

  Definition Smash_rec {P : Type} (Psm : X -> Y -> P) (Pl Pr : P)
    (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr)
    : Smash X Y -> P := Smash_ind Psm Pl Pr
      (fun x => dp_const (Pgl x)) (fun x => dp_const (Pgr x)).

  Local Open Scope path_scope.

  (* Version of smash_rec that forces (Pgl pt) and (Pgr pt) to be idpath *)
  Definition Smash_rec' {P : Type} {Psm : X -> Y -> P}
    (Pgl : forall a, Psm a pt = Psm pt pt) (Pgr : forall b, Psm pt b = Psm pt pt)
    (ql : Pgl pt = 1) (qr : Pgr pt = 1)
    : Smash X Y -> P := Smash_rec Psm (Psm pt pt) (Psm pt pt) Pgl Pgr.

  Definition Smash_rec_beta_gluel {P : Type} {Psm : X -> Y -> P} {Pl Pr : P}
    (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (a : X)
    : ap (Smash_rec Psm Pl Pr Pgl Pgr) (gluel a) = Pgl a.
  Proof.
    refine (_ @ eissect dp_const (Pgl a)).
    apply moveL_equiv_V.
    unfold Smash_rec.
    refine ((dp_apD_const (Smash_ind Psm Pl Pr (fun x : X => dp_const (Pgl x))
      (fun x : Y => dp_const (Pgr x))) (gluel a))^ @ _).
    rapply Smash_ind_beta_gluel.
  Qed.

  Definition smash_rec_beta_gluer {P : Type} {Psm : X -> Y -> P} {Pl Pr : P}
    (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (b : Y)
    : ap (Smash_rec Psm Pl Pr Pgl Pgr) (gluer b) = Pgr b.
  Proof.
    refine (_ @ eissect dp_const (Pgr b)).
    apply moveL_equiv_V.
    unfold Smash_rec.
    refine ((dp_apD_const (Smash_ind Psm Pl Pr (fun x : X => dp_const (Pgl x))
      (fun x : Y => dp_const (Pgr x))) (gluer b))^ @ _).
    rapply Smash_ind_beta_gluer.
  Qed.

  Definition Smash_rec_beta_gluel' {P : Type} {Psm : X -> Y -> P} {Pl Pr : P}
    (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (a b : X)
    : ap (Smash_rec Psm Pl Pr Pgl Pgr) (gluel' a b) = Pgl a @ (Pgl b)^.
  Proof.
    rewrite ap_pp, ap_V.
    by rewrite 2 Smash_rec_beta_gluel.
  Qed.

  Definition Smash_rec_beta_gluer' {P : Type} {Psm : X -> Y -> P} {Pl Pr : P}
    (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (a b : Y)
    : ap (Smash_rec Psm Pl Pr Pgl Pgr) (gluer' a b) = Pgr a @ (Pgr b)^.
  Proof.
    rewrite ap_pp, ap_V.
    by rewrite 2 smash_rec_beta_gluer.
  Qed.

  Definition smash_rec_beta_glue {P : Type} {Psm : X -> Y -> P} {Pl Pr : P}
    (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (a : X)
    (b : Y) : ap (Smash_rec Psm Pl Pr Pgl Pgr) (glue a b)
    = ((Pgl a) @ (Pgl pt)^) @ (Pgr pt @ (Pgr b)^).
  Proof.
    by rewrite ap_pp, Smash_rec_beta_gluel', Smash_rec_beta_gluer'.
  Defined.

  Arguments sm : simpl never.
  Arguments auxl : simpl never.
  Arguments gluel : simpl never.
  Arguments gluer : simpl never.

End Smash.


Require Export XR_R.
Require Export XR_Rle.
Require Export XR_Rlt_trans.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rle_trans : forall r1 r2 r3,
  r1 <= r2 -> r2 <= r3 -> r1 <= r3.
Proof.
  intros x y z.
  intros hxy hyz.
  unfold "<=" in hxy, hyz.
  unfold "<=".
  destruct hxy as [ hxy | heq ].
  {
    destruct hyz as [ hyz | heq ].
    {
      left.
      apply Rlt_trans with y.
      { exact hxy. }
      { exact hyz. }
    }
    {
      subst z.
      left.
      exact hxy.
    }
  }
  {
    subst y.
    exact hyz.
  }
Qed.


(* Software Foundations *)
(* Exercice 3 stars, gen_dep_practice_more *)

Require Import Coq.Lists.List.
Import ListNotations.

Fixpoint snoc{X: Type}(l: list X)(v: X):=
    match l with
    |nil  => [v]
    |h::t => h::(snoc t v)
    end.

Theorem length_snoc''': forall (n : nat) (X : Type)(v : X) (l : list X),
    length l = n -> length (snoc l v) = S n.
Proof.
    intros.
    generalize dependent n.
    induction l as [|h t].
    destruct n as [|n'].
    intros. simpl. reflexivity.
    intros contra. simpl in contra. inversion contra.
    simpl. intros. apply f_equal.
    induction n as [|n'].
    inversion H.
    inversion H. apply IHt in H1. rewrite <- H in H1. apply H1.
Qed.