Require Export Coq.omega.Omega.
Section FiniteSet.

  Class FiniteSet (A : Type) :=
    {
      t : Type;
      contains : A -> t -> bool;
      add : A -> t -> t;
      union : t -> t -> t;
      cardinal : t -> nat;
      empty : t;
      add_idemp : forall a b s, contains a s = true -> contains a (add b s) = true;
      add_contains : forall a s, contains a (add a s) = true;
      cardinal_bound : forall s s', cardinal (union s s') <= cardinal s + cardinal s';
      empty_contains : forall a, contains a empty = false;
      add_cardinal_bound : forall a s, cardinal (add a s) <= 1 + cardinal s;
      cardinal_empty : cardinal empty = 0;
      cardinal_not_in : forall a s, contains a s = false -> cardinal (add a s) = 1 + cardinal s;
      union_empty : forall s, union s empty = s;
    }.
  Definition single {A } {FS : FiniteSet A} (a : A) := add a empty.
  Notation "s1 ∪ s2" := (union s1 s2) (at level 60).

  Lemma singleton_size : forall A (FS : FiniteSet A) a, cardinal (single a) = 1.
    Proof.
      intros. unfold single. specialize (cardinal_not_in a empty) as H.
      specialize (H (empty_contains a)). rewrite cardinal_empty in H. auto.
    Qed.

End FiniteSet.

Section PDL.
  Context (prog prop : Type).

  Notation "s1 ∪ s2" := (union s1 s2) (at level 60).
  Inductive pdl_formula :=
    | AtomF (p : prop)
    | Box (α : pdl_program) (φ : pdl_formula)
    | Imp (φ ψ : pdl_formula)
    | Bot
  with pdl_program :=
    | AtomP (p : prog)
    | Plus (α β : pdl_program)
    | Seq (α β : pdl_program)
    | Star (α : pdl_program)
    | TestP (φ : pdl_formula)
  .
  Context (FS : FiniteSet pdl_formula).

  Fixpoint formula_length (φ : pdl_formula) :=
    match φ with
    | AtomF _ => 1
    | Box α φ => 1 + program_length α + formula_length φ
    | Imp φ ψ => 1 + formula_length φ + formula_length ψ
    | Bot => 1
  end
  with program_length (α : pdl_program) :=
    match α with
    | AtomP _ => 1
    | Plus α β => 1 + program_length α + program_length β
    | Seq α β => 1 + program_length α + program_length β
    | Star α => 1 + program_length α
    | TestP φ => 1 + formula_length φ
  end.

  Definition max x y := if x <? y then y else x.

  Lemma max_le_plus : forall x y, max x y <= x + y.
  Proof.
    intros. unfold max. destruct (x <? y); omega.
  Qed.

  Fixpoint formula_height φ :=
    match φ with
    | AtomF _ | Bot => 1
    | Imp ϕ ψ => 1 + max (formula_height ϕ) (formula_height ψ)
    | Box α ψ => 1 + max (formula_height ψ) (program_height α) end
   with program_height α :=
    match α with
    | AtomP _ => 1
    | Plus α β => 1 + max (program_height α) (program_height β)
    | Seq α β  =>  1 + max (program_height α) (program_height β)
    | Star α => 1 + program_height α
    | TestP φ => 1 + formula_height φ end.

  Ltac solve_hs :=
    simpl;
    do 30 match goal with
    | |- context [ max ?x ?y  ] => unfold max
    | |- context [ ?x <? ?y  ] => destruct (x <? y)
    | _ => try omega end.

  Lemma height_le_size_pdl : forall φ, formula_height φ <= formula_length φ.
    Proof.
      induction φ; intros; solve_hs.
      enough (forall α, program_height α <= program_length α).
      - specialize (H α). solve_hs.
      - induction α0; solve_hs.
        (* this is basically our original goal... inducting won't give new information  *)
    Abort.

  Scheme pdl_formula_program := Induction for pdl_formula Sort Prop
                                                    with pdl_program_formula := Induction for pdl_program Sort Prop.
  Combined Scheme pdl_formula_program_mutind from pdl_formula_program, pdl_program_formula.

  (*So for one of the cases of formula, we needed a proposition on programs, and for one of the cases of
    program we needed one for formula. Cases like these often get solved with mutual induction*)

  Lemma height_le_size_pdl' : (forall φ, formula_height φ <= formula_length φ) /\
                             (forall α, program_height α <= program_length α).
    Proof.
      apply pdl_formula_program_mutind; intros; solve_hs.
    Qed.

  Lemma height_le_size_pdl : forall φ, formula_height φ <= formula_length φ.
  Proof.
    destruct height_le_size_pdl'. auto.
  Qed.

  Fixpoint fl_closure φ  : t :=
    match φ with
    | AtomF _ | Bot => single φ
    | Imp ϕ ψ => (single φ) ∪ (fl_closure ϕ) ∪ (fl_closure ψ)
    | Box α ψ => (fl_closure_box α ψ) ∪ fl_closure ψ
    end
  with fl_closure_box α φ:=
    single (Box α φ) ∪
    match α with
    | AtomP p => empty
    | Plus α β => fl_closure_box α φ ∪ fl_closure_box β φ
    | Seq α β => fl_closure_box α (Box β φ) ∪ fl_closure_box β φ
    | Star α => fl_closure_box α (Box (Star α) φ)
    | TestP ψ => fl_closure ψ
   end.

(*tactic that accomplishes basic finite set size reasoning for the following proofs*)

Ltac union_len :=
  simpl;
  do 30 match goal with
  | |- context [union ?s empty] => rewrite union_empty
  | |- context [ (single ?x)  ] =>
    specialize (singleton_size _ _ x); intros; remember (single x); try omega
  | |- cardinal (?s1 ∪ ?s2) <= _ => rewrite (cardinal_bound s1 s2)
  | |- context [union ?s1 ?s2] => specialize (cardinal_bound s1 s2); intros;
                                  remember (union s1 s2); try omega
  | _ => omega
end.

  (* write a tactic to do most reasoning  *)
  Lemma size_bound : forall φ, cardinal (fl_closure φ) <= formula_length φ.
    induction φ; try union_len.
    simpl.
    (*Now we need some condition bounding fl_closure_box α φ...*)
    enough (H : forall φ, cardinal (fl_closure_box α φ) <= program_length α); try ( specialize (H φ); union_len).
    (*  *)
    induction α; intros.
    - union_len.
    - specialize (IHα1 φ0); specialize (IHα2 φ0); union_len.
    - simpl. specialize (IHα1 (Box α2 φ0)). specialize (IHα2 φ0). union_len.
    - simpl. specialize (IHα (Box (Star α) φ0)). union_len.
    - simpl. rewrite cardinal_bound. rewrite singleton_size. simpl.
      (* This is our original  goal...*)
    Abort.

  Lemma size_bound' : (forall φ, cardinal (fl_closure φ) <= formula_length φ) /\
                      (forall α φ, cardinal (fl_closure_box α φ) <= program_length α).
    Proof.
      apply pdl_formula_program_mutind; intros; try union_len.
      (*Previously problematic box case*)
      - specialize (H φ). union_len.
      - specialize (H φ); specialize (H0 φ); union_len.
      - specialize (H (Box β φ)). specialize (H0 φ). union_len.
      - specialize (H (Box (Star α) φ)). union_len.
    Qed.

  Lemma size_bound : forall φ, cardinal (fl_closure φ) <= formula_length φ.
    Proof.
      destruct size_bound'. auto.
    Qed.

End PDL.

Section HiddenMutualInduction.
  Context (A : Type).

  Inductive Sexpr :=
    | SexprList (l : list Sexpr)
    | Atom (a : A) .

  Fixpoint sum l :=
    match l with
    | nil => 0
    | (h :: t)%list => h + sum t end.

  Fixpoint maxl l :=
    match l with
    | nil => 0
    | (h :: t)%list =>
      let m := maxl t in
      if (m <? h) then h else m end.

  Lemma max_lt_sum : forall l, maxl l <= sum l.
  Proof.
    induction l; auto. simpl. destruct (maxl l <? a); try omega.
  Qed.

  Fixpoint size (s : Sexpr) :=
    match s with
    | Atom _ => 1
    | SexprList l => 1 + sum (List.map size l) end.

  Fixpoint height (s : Sexpr) :=
    match s with
    | Atom _ => 1
    | SexprList l => 1 + maxl (List.map height l) end.

  Lemma height_le_size : forall s, height s <= size s.
    Proof.
      induction s; auto.
      induction l; auto. simpl. Fail omega.
      (*no information about the height or size of the elements of l*)
    Abort.
    (*based on Chlipala sort of*)
  Section sexpr_ind'.
    Variable (P : Sexpr -> Prop).

    Hypothesis (AtomCase : forall a, P (Atom a)).

    Hypothesis (ListCase : forall l, List.Forall P l -> P (SexprList l)).

    Fail Fixpoint sexpr_ind' (s : Sexpr) : P s :=
      match s with
      | Atom a => AtomCase a
      | SexprList l => ListCase l (list_sexpr_ind l) end
     with list_sexpr_ind (l : list Sexpr) : List.Forall P l :=
      match l with
      | nil => @List.Forall_nil Sexpr P
      | (h :: t)%list => @List.Forall_cons Sexpr P h t (sexpr_ind' h) (list_sexpr_ind t) end.

    Fixpoint sexpr_ind' (s : Sexpr) : P s :=
      match s with
      | Atom a => AtomCase a
      | SexprList l => ListCase l (
              (fix list_sexpr_ind (l : list Sexpr) :=
                   match l with
                   | nil => @List.Forall_nil Sexpr P
                   | (h :: t)%list => @List.Forall_cons Sexpr P h t (sexpr_ind' h) (list_sexpr_ind t) end
                                  ) l) end.
   End sexpr_ind'.

   Lemma height_le_size : forall s, height s <= size s.
   Proof.
     apply sexpr_ind'; auto.
     intros. induction l; auto. inversion H. subst.
     simpl. destruct (maxl (List.map height l) <? height a); try omega.
     specialize (IHl H3). simpl in IHl. omega.
   Qed.

End HiddenMutualInduction.


(* Implementation and correctness proof for insertion sort.
  Andrew W. Appel, January 2010. *)

Require Import Permutation.
Require Import List.
Require Import Compare_dec.

Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).

Locate le.
Print le.

Locate le_lt_dec.
Check le_lt_dec.

Print le_lt_dec.
Print sumbool.

Lemma le_lt_dec': forall n m, {n<=m}+{m<n}.
Proof.
induction n; destruct m; intros.
left. apply le_n.
left. apply le_S.
    induction m. apply le_n. apply le_S. auto.
right. clear. unfold lt. apply Le.le_n_S.
   apply Le.le_0_n.
destruct (IHn m).
left. apply Le.le_n_S. auto.
right. apply Lt.lt_n_S. auto.
Defined.

Locate le_lt_dec.
Print le_lt_dec'.
Print le_lt_dec.

Fixpoint select (i: nat) (l: list nat) : nat * list nat :=
match l with
|  nil => (i, nil)
|  h::t => if le_lt_dec i h
               then let (j, l') := select i t in (j, h::l')
               else let (j,l') := select h t in (j, i::l')
end.

Fixpoint selsort l n :=
match l, n with
| i::r, S n' => let (j,r') := select i r
               in j :: selsort r' n'
| _, _ => nil
end.

Definition selection_sort l := selsort l (length l).

Example sort_pi: selection_sort [3,1,4,1,5,9,2,6,5,3,5] = [1,1,2,3,3,4,5,5,5,6,9].
Proof.
unfold selection_sort.
simpl.
reflexivity.
Qed.

Lemma select_perm: forall i l,
  let (j,r) := select i l in
   Permutation (i::l) (j::r).
Proof.
intros i l; revert i.
induction l; intros; simpl in *.
apply Permutation_refl.
destruct (le_lt_dec i a).
specialize (IHl i).
destruct (select i l).
eapply perm_trans.
apply perm_swap.
apply Permutation_sym.
eapply perm_trans.
apply perm_swap.
apply Permutation_cons.
apply Permutation_sym.
apply IHl.
specialize (IHl a).
destruct (select a l).
apply Permutation_sym.
eapply perm_trans.
apply perm_swap.
apply Permutation_cons.
apply Permutation_sym.
apply IHl.
Qed.

Ltac inv H := inversion H; clear H; subst.

Lemma selsort_perm:
  forall n l, length l = n -> Permutation l (selsort l n).
Proof.
induction n; destruct l; intros; inv H.
simpl. apply Permutation_refl.
simpl.
assert (SP := select_perm n0 l).
destruct (select n0 l) as [j r].
eapply Permutation_trans; [ apply SP | ].
apply Permutation_cons.
apply IHn.
apply Permutation_length in SP.
simpl in SP.
inv SP.
auto.
Qed.

Theorem selection_sort_perm:
  forall l, Permutation l (selection_sort l).
Proof.
unfold selection_sort.
intro.
apply selsort_perm.
reflexivity.
Qed.

(* NOTE!  Proving that a sort function is correct has two parts:
  1.  The output is a permutation of the input
  2.  The output is in increasing order
 Only part 1 has been proved here.  The specification
  and proof of part 2 is missing.

*)


(**Some of the theorems are taken from Bertot and Casteran 2004**)
Require Import Omega.
(**Type Checking of the Universes**)
Check Prop.
Check Set.
Check Type.

(** Type Checking with Explicit Universes**)
Set Printing Universes.
Check Prop.
Check Set.
Check Type.
Check forall P:Prop, Prop.
Check Prop.
Check forall P:Type, Type.
Check nat.
Check 1.
Check plus.
Check plus 3.
Check plus 3 4.

(** Assumptions**)
Parameter H:Set.
Section H1.
Variable H1:Set.
End H1.
Hypothesis H2: Set.

(** Definition**)
Definition three:nat:= S (S(S((0)))).
Check three.
Theorem three3: 3 = three. cbv.  reflexivity. Qed.

Eval compute in  S (S(S((0)))).
Parameter Montague_Grammar: Set.
Definition MG:= Montague_Grammar.

(** Functions: simple function types and definitions using lambda abstraction**)
Parameter nat_1: nat->Prop.
Definition square:= fun n: nat=> n*n. (** fun is lambda. Note that Coq can infer the type nat->nat here.**)
Definition square1: nat->nat:= fun n: nat=> n*n.
Theorem SQUARE: square = square1.
cbv. reflexivity. Qed.
(** Define a function that takes two nat arguments and returns their sum multiplied by the first nat**)
Definition sum_times:= fun n m: nat=> (n+m)*n.
Eval compute in sum_times 2 3.

(** Inductive Types withour Recursion**)
Unset Printing Universes.
Check bool. Print bool.
Inductive bool1 : Set := true | false. Print bool1_rect.
Inductive nat1 : Set :=
| O : nat1
| S1 : nat1 -> nat1.
Print nat1_ind. Print nat1_rect. Print nat1_rec. (**Peano's induction**)

(** Propositional logic proofs**)
Variables A B P Q R: Prop.
Theorem trans: (P->Q)->(Q->R)->(P->R).
                                         intro. intro.
intro.
apply H1. apply H0. assumption. Qed.
Definition lem:= A \/ ~ A.
Definition Peirce:= ((A->B)->A)->A.
Theorem lemP: lem -> Peirce.
  unfold lem. unfold Peirce. intros.
elim H0.
intros. assumption.
intro. apply H1.
intro.   absurd A. assumption. assumption. Qed.

(**Tactics**)
Theorem CONJ: A/\B->A.
intro.  elim H0. (** applies the elimination rule for conjunction**) intros. assumption. Qed
.
Theorem CONJ2: B/\(A/\P)->A/\B.
intro.
elim  H0.
intros.
elim H3. intros. split.
assumption. assumption. Qed.
Theorem DISJ: (B\/(B\/P))/\(A/\B)->A\/B.
intro.
destruct H0. destruct H1.  left. (**or right**)  assumption. Qed.

Theorem IMPL: forall P: Prop, ( P -> Q) -> R -> P -> Q.
intros. apply   H0.
assumption.
Qed.

Theorem NAT: exists x: nat, le 0 x.
exists 1.
omega.  Qed.

(**Exact and Proof tactic**)
Theorem D: (P->P->Q)->P->Q.
exact (**or Proof**) (fun (H:P->P->Q)(p:P)=>H p p).
Qed.

(**Idtac and try**)
Theorem PQQ: P->Q->P.
intros.   try elim H0.   try apply H0. Qed.
Variable T: Prop.
Theorem PQPR: (P->Q)->(P->R)->(P->Q->R->T)->P->T.  intros H H0 H1 H2.  idtac.  apply H1; [idtac|idtac |idtac]; idtac. assumption.  apply H;[idtac]; assumption. apply H0. assumption. Qed.

Theorem PQPR2: (P->Q)->(P->R)->(P->Q->R->T)->P->T.
intros H H0 H1 H2. apply H1;[idtac|apply H|apply H0]; assumption. Qed.

Theorem PQPR3: (P->Q)->(P)->P. intros. assert Q. intuition. assumption. Qed.
(**Assert**)

Section assert.
Hypotheses (H : P -> Q)
(H0 : Q -> R)
(H1 : (P -> R) -> T -> Q)
(H2 : (P -> R) -> T).
Lemma L8 : Q.
assert (PR : P -> R). intro p; apply H0; apply H; assumption. apply H1; [ assumption | apply H2;assumption]. Qed. (**assert saves some time here, otherwise we would have to prove P->R twice**)
End assert.

Section generalize.
Hypotheses (x:nat)(y:nat).
Lemma GENERALIZE:   0 <= x + y + y.  omega. Qed.
End generalize.
Lemma GENERALIZE2: forall x y  :nat, 0 <=  x + y + y.
intro. intro. omega. Qed.

Section cut.
Hypotheses (H : P->Q)
(H0: Q->R)
(H1 : (P->R)->T->Q)
(H2 : (P->R)->T).

Theorem cut: Q.
cut (P->R). intros. apply H1. assumption. apply H2. assumption. intro. apply H0. apply H. assumption. Qed.
End cut.


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

Fixpoint plus (m n: nat): nat :=
  match m with
    | O => n
    | S p => S (plus p n)
  end.

Infix "+" := plus.

Lemma plus_comm:
  forall m n, m + n = n + m.
Proof.

Qed.


Module Poly.
From LF Require Export Lists.
From LF Require Export Basics1.
From LF Require Export Induction.

Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).

Check list.
Check nil.
Check cons.
Check (cons nat 3 (nil nat)) : list nat.

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | O => nil X
  | S count' => cons X x (repeat X x count')
  end.

(* make type param implicit *)
Arguments nil {X}.
Arguments cons {X}.
Arguments repeat {X}.

Fixpoint app {X : Type} (l1 l2 : list X) : list X :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Example test_rev1 : rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity. Qed.
Example test_rev2: rev (cons true nil) = cons true nil.
Proof. reflexivity. Qed.
Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity. Qed.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(* explicit type arg *)
Check @nil : forall X : Type, list X.

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
  intros X l.
  induction l as [| h t H ].
  - reflexivity.
  - simpl.
    rewrite -> H.
    reflexivity.
Qed.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros A l m n.
  induction l as [| h t H ].
  - reflexivity.
  - simpl.
    rewrite -> H.
    reflexivity.
Qed.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros X l1 l2.
  induction l1 as [| h t H ].
  - simpl.
    reflexivity.
  - simpl.
    rewrite -> H.
    reflexivity.
Qed.

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros X l1 l2.
  induction l1 as [| h t H ].
  - simpl.
    rewrite -> app_nil_r.
    reflexivity.
  - simpl.
    rewrite -> H.
    rewrite <- app_assoc.
    reflexivity.
Qed.

Theorem rev_involutive : forall (X : Type) (l : list X),
  rev (rev l) = l.
Proof.
  intros X l.
  induction l as [| h t H ].
  - reflexivity.
  - simpl.
    rewrite -> rev_app_distr.
    rewrite -> H.
    simpl.
    reflexivity.
Qed.

Inductive prod (X Y : Type) : Type :=
| pair (x : X) (y : Y).

Arguments pair {X} {Y}.

Notation "( x , y )" := (pair x y).

Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y): list (X * Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

Compute (combine [1;2] [false;false;true;true]).

Fixpoint split {X Y : Type} (l : list (X*Y)) : (list X) * (list Y) :=
  match l with
  | nil => (nil, nil)
  | cons (x,y) t =>
    match split t with
    | (lx, ly) => (x::lx, y::ly)
    end
  end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof. reflexivity. Qed.

Inductive option (X:Type) : Type :=
  | Some (x : X)
  | None.
Arguments Some {X}.
Arguments None {X}.

Fixpoint nth_error {X : Type} (l : list X) (n : nat): option X :=
  match l with
  | nil => None
  | a :: l' => match n with
               | O => Some a
               | S n' => nth_error l' n'
               end
  end.
Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [true] 2 = None.
Proof. reflexivity. Qed.

Definition hd_error {X : Type} (l : list X) : option X :=
  match l with
  | nil => None
  | cons h t => Some h
  end.

Check @hd_error : forall X : Type, list X -> option X.
Check hd_error.

Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_error2 : hd_error [[1];[2]] = Some [1].
Proof. reflexivity. Qed.

Definition doit3times {X : Type} (f : X -> X) (n : X) : X := f (f (f n)).

Check @doit3times : forall X : Type, (X -> X) -> X -> X.

Fixpoint filter {X: Type} (test: X -> bool) (l: list X) : list X :=
  match l with
  | []     => []
  | h :: t =>
    if test h
    then h :: (filter test t)
    else filter test t
  end.

(*
Definition countoddmembers' (l: list nat) : nat := length (filter odd l).
*)

Example test_anon_fun': doit3times (fun n => n * n) 2 = 256.
Proof. reflexivity. Qed.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun i => andb (negb (Induction.leb i 7)) (Induction.even i)) l.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof. reflexivity. Qed.
Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof. reflexivity. Qed.

Definition partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
                   : list X * list X :=
  (filter (fun i => test i) l, filter (fun i => negb (test i)) l).

Example test_partition1: partition (fun i => negb (Induction.even i)) [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity. Qed.

Fixpoint map {X Y : Type} (f : X -> Y) (l : list X) : list Y :=
  match l with
  | []     => []
  | h :: t => (f h) :: (map f t)
  end.

Lemma map_dist : forall (X Y : Type) (f : X -> Y) (l m : list X),
  map f (l ++ m) = map f l ++ map f m.
Proof.
  intros X Y f l m.
  induction l as [| h t H ].
  - simpl.
    reflexivity.
  - simpl.
    rewrite -> H.
    reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros X Y f l.
  induction l as [| h t H ].
  - simpl.
    reflexivity.
  - simpl.
    rewrite -> map_dist.
    simpl.
    rewrite -> H.
    reflexivity.
Qed.

Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X): list Y :=
  match l with
  | nil => nil
  | cons h t => f h ++ flat_map f t
  end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. reflexivity. Qed.

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X): option Y :=
  match xo with
  | None   => None
  | Some x => Some (f x)
  end.

Fixpoint map' (X Y : Type) (f : X -> Y) (l : list X) : list Y :=
  match l with
  | []     => []
  | h :: t => (f h) :: (map' X Y f t)
  end.

Fixpoint filter' (X: Type) (test: X -> bool) (l: list X) : list X :=
  match l with
  | []     => []
  | h :: t =>
    if test h
    then h :: (filter' X test t)
    else filter test t
  end.

Fixpoint fold {X Y: Type} (f : X -> Y -> Y) (l : list X) (b : Y): Y :=
  match l with
  | nil    => b
  | h :: t => f h (fold f t b)
  end.

Check (fold andb) : list bool -> bool -> bool.
Example fold_example1 : fold mult [1;2;3;4] 1 = 24.
Proof. reflexivity. Qed.
Example fold_example2 : fold andb [true;true;false;true] true = false.
Proof. reflexivity. Qed.
Example fold_example3 : fold app [[1];[];[2;3];[4]] [] = [1;2;3;4].
Proof. reflexivity. Qed.

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Example test_fold_length1 : fold_length [4;7;0] = 3.
Proof. reflexivity. Qed.

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
  intros X l.
  induction l as [| h t H ].
  - simpl.
    reflexivity.
  - simpl.
    rewrite <- H.
    reflexivity.
Qed.

Definition fold_map {X Y: Type} (f: X -> Y) (l: list X) : list Y :=
  fold (fun i a => [f i] ++ a ) l [].

Theorem fold_map_correct : forall X Y (f : X -> Y) (l : list X),
  fold_map f l = map f l.
Proof.
  intros X Y f l.
  induction l as [| h t H ].
  - reflexivity.
  - simpl.
    rewrite <- H.
    reflexivity.
Qed.

Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z :=
  match p with
  | (x, y) => f x y
  end.

Example test_map1': map (plus 3) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.

Check @prod_curry.
Check @prod_uncurry.
Theorem uncurry_curry : forall (X Y Z : Type)
                        (f : X -> Y -> Z) x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  intros X Y Z f x y.
  unfold prod_uncurry.
  unfold prod_curry.
  reflexivity.
Qed.

Theorem curry_uncurry : forall (X Y Z : Type)
                        (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  intros X Y Z f p.
  unfold prod_uncurry.
  unfold prod_curry.
  simpl.
  destruct p as [x y].
  - reflexivity.
Qed.

Fixpoint nth_error' {X : Type} (l : list X) (n : nat) : option X :=
  match l with
  | []      => None
  | a :: l' => if n =? O then Some a else nth_error' l' (pred n)
  end.

Lemma len_0_for_empty: forall {X : Type} (l : list X), length l = 0 -> l = nil.
Proof.
  intros X l.
  induction l as [| h t H ].
  - reflexivity.
  - simpl.
Admitted.

Theorem tst : forall X l n, length l = n -> @nth_error X l n = None.
Proof.
  intros X l n H.
Admitted.

Module Church.
Definition cnat := forall X : Type, (X -> X) -> X -> X.

Definition one  : cnat := fun (X : Type) (f : X -> X) (x : X) => f x.
Definition two  : cnat := fun (X : Type) (f : X -> X) (x : X) => f (f x).
Definition zero : cnat := fun (X : Type) (f : X -> X) (x : X) => x.

Definition three : cnat := @doit3times.

Definition succ (n : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (n X f x).

Example succ_1 : succ zero = one.
Proof. reflexivity. Qed.
Example succ_2 : succ one = two.
Proof. reflexivity. Qed.
Example succ_3 : succ two = three.
Proof. reflexivity. Qed.

Definition plus (n m : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => n X f (m X f x).

Example plus_1 : plus zero one = one.
Proof. reflexivity. Qed.
Example plus_2 : plus two three = plus three two.
Proof. reflexivity. Qed.
Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof. reflexivity. Qed.

Definition mult (n m : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => n X (m X f) x.
Example mult_1 : mult one one = one.
Proof. reflexivity. Qed.
Example mult_2 : mult zero (plus three three) = zero.
Proof. reflexivity. Qed.
Example mult_3 : mult two three = plus three three.
Proof. reflexivity. Qed.

Definition mult' (X : Type) (n m : (X -> X) -> X -> X) (f : X -> X) (x : X) := n (m f) x.

Definition exp (n m : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => (m _ (mult' X (n X)) (one X)) f x.

Example exp_1 : exp two two = plus two two.
Proof. reflexivity. Qed.
Example exp_2 : exp three zero = one.
Proof. reflexivity. Qed.
Example exp_3 : exp three two = plus (mult two (mult two two)) one.
Proof. reflexivity. Qed.

End Church.

End Poly.


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

(** * Subtyping *)

(** A subtype extends another type by adding
    a property. The new type has a richer theory.
    The new type should inherit all the original
    theory. *)

(* Let's define the type of homogeneous tuples *)

(** ** Standard [sig] type *)

Print sig.
(**
  Inductive sig (A : Type) (P : A -> Prop) : Type :=
    | exist : forall x:A, P x -> sig P.

  Notation "{ x : A  |  P }" :=
    (sig (A:=A) (fun x => P)) : type_scope.
*)

(** [sig] type is almost the same as the [ex] type encoding
    existential quantifier *)
Print ex.
(**
  Inductive ex (A : Type) (P : A -> Prop) : Prop :=
    | ex_intro : forall x:A, P x -> ex P.
 *)

(** simple definition relying on the existing [pred] function *)
Definition predecessor (x : {n | 0 < n}) : nat :=
  let: (exist m prf_m_gt_0) := x in
  m.-1.

(** The _convoy pattern_ : *)
Definition pred_dep (x : {n | 0 < n}) : nat :=
  let: (exist n prf_n_gt_0) := x in
  match n as n return (0 < n -> nat) with
  | 0 =>
      fun prf : 0 < 0 => False_rect _ (notF prf)
  | n'.+1 =>
      fun _ => n'
  end prf_n_gt_0.

(** ** Some issues *)

(** Proof irrelevance *)

Lemma eq_sig T (P : T -> Prop) x (px : P x) (px' : P x) :
  (exist P x px) = (exist P x px').
Proof.
Fail by done.
(** we are stuck: we need proof irrelevance here *)
Abort.

Axiom proof_irrelevance :
  forall (P : Prop) (pf1 pf2 : P), pf1 = pf2.

Lemma eq_sig T (P : T -> Prop) x (px : P x) (px' : P x) :
  (exist P x px) = (exist P x px').
Proof.
rewrite [px]proof_irrelevance.
done.
Qed.

(** Decidable propositions _are_ proof irrelevant *)

Check eq_irrelevance.
(**
eq_irrelevance
     : forall (T : eqType) (x y : T)
         (e1 e2 : x = y),
         e1 = e2

This special case of proof irrelevance is called
_Unicity of Identity Proofs_ principle (UIP).
*)

(** [sval] projection is injective for decidable propositions : *)
Lemma eq_n_gt0 (m n : {n | 0 < n}) :
  sval m = sval n ->
  m = n.
Proof.
case: m=> [m pfm]; case: n=> [n pfn] /=.
Fail move=> ->.  (* because of the dependencies *)
move=> eq_mn; move: eq_mn pfm pfn.
move=> -> *.
congr exist.
exact: eq_irrelevance.
Qed.

(** We cannot define [sval] (aka [proj1_sig]) as a coercion *)

(**
This is because we cannot specify the target
class of this tentative coercion:
  Coercion proj1_sig : sig >-> ???.
 *)

(** ** Mathcomp's [subType]
       (defined in [eqtype] library) *)

Print subType.
(**
  Structure subType (T : Type) (P : pred T) : Type :=
    SubType {
      (* new type *)
      sub_sort : Type;

      (* projection, like proj_sig1 *)
      val : sub_sort -> T;

      (* constructor *)
      Sub : forall x : T, P x -> sub_sort;

      (* elimination principle *)
      _ : forall K : sub_sort -> Type,
          (forall (x : T) (Px : P x), K (Sub x Px)) ->
          forall u : sub_sort, K u;

      (* projection is injective *)
      _ : forall (x : T) (Px : P x),
          val (Sub x Px) = x
    }.
*)

(** An example of a [subType] *)
Section PosSubtype.

Inductive pos := Positive m of 0 < m.

Coercion nat_of_pos p :=
  let: Positive n _ := p in n.

Variables p1 p2 : pos.

(** This is something not possible with
    {n | 0 < n} type *)
Check p1.-1 + p2.
Set Printing Coercions.
Check p1.-1 + p2.
Unset Printing Coercions.

(** Register [pos] as a [subType] *)
Canonical pos_subType :=
  [subType for nat_of_pos].

(** Given that propositions are expressed as
    booleans, we can use the fact that proofs of
    these properties are irrelevant. *)

(** Hence we can build subtypes and prove that
    the projection to the supertype is injective,
    which lets us inherit all of the theory of
    the supertype. *)

(** E.g. we can make [pos] inherit [eqType]
    from [nat] type with a bit of boilerplate *)

Definition pos_eqMixin :=
  Eval hnf in [eqMixin of pos by <:].

Canonical pos_eqType :=
  Eval hnf in EqType pos pos_eqMixin.

Check p1 == p2.

End PosSubtype.

(** * Some standard [subType]s *)

(** ** [ordinal]: type of finite ordinals *)

(**
[ordinal n] = {0, 1, ... , n-1}

Inductive ordinal : predArgType :=
  | Ordinal m of m < n.

Notation "''I_' n" := (ordinal n)

 *)

From mathcomp Require Import fintype.

Definition i1 : 'I_2 :=
  Ordinal (erefl : 0 < 2).

Definition i2 : 'I_2 :=
  Ordinal (erefl : 1 < 2).

Compute i1 == i2.

(** Note: [ordinal] is also a [finType] *)

(** ** [tuple] type *)

From mathcomp Require Import tuple.

Definition t : 3.-tuple nat :=
  [tuple 5; 6; 7].

(** It's not possible to take an out-of-bounds
    element of a tuple, so there is no need
    of a default element as for [nth] on [seq]s *)
About tnth.

Compute [tnth t 0].
Compute [tnth t 1].
Compute [tnth t 2].
Fail Compute [tnth t 3].

About thead.
(**
thead :
  forall (n : nat) (T : Type),
    (n.+1).-tuple T -> T
*)

Compute thead t.  (** = 5 *)
(** [thead] of empty tuple
    does not even typecheck *)
Fail Check thead [tuple].

(**
  Structure tuple_of (n : nat) (T : Type) : Type :=
    Tuple {
    (* [:>] means "is a coercion" *)
      tval :> seq T;
      _ : size tval == n;
    }.
*)

Section TupleExample.
Variables (m n : nat) (T : Type).
Variable t1 : m.-tuple T.
Variable t2 : n.-tuple T.

Check [tuple of t1 ++ t2] : (m + n).-tuple T.
Fail Check [tuple of t1 ++ t2] : (n + m).-tuple T.
End TupleExample.

Example seq_on_tuple (n : nat) (t : n .-tuple nat) :
  size (rev [seq 2 * x | x <- rev t]) = size t.
Proof.

Set Printing Coercions.
by rewrite map_rev revK size_map.
Unset Printing Coercions.

Restart.

rewrite size_tuple.  (** this should work *)
Check size_tuple.
(**
  size_tuple : forall (n : nat) (T : Type)
               (t : n.-tuple T), size t = n
*)

(** Why does this not fail? *)
(** rev [seq 2 * x | x <- rev t] is a list,
    not a tuple *)
rewrite size_tuple.
Abort.

Print Canonical Projections.
(**
  ...
  map <- tval ( map_tuple )
  ...
  rev <- tval ( rev_tuple )
  ...
*)

(**
This works because Coq is instrumented
to automatically promote sequences to tuples
using the mechanism of Canonical Structures.

Lemma rev_tupleP n A (t : n .-tuple A) :
  size (rev t) == n.
Proof. by rewrite size_rev size_tuple. Qed.

Canonical rev_tuple n A (t : n .-tuple A) :=
  Tuple (rev_tupleP t).

Lemma map_tupleP n A B (f:A -> B) (t: n.-tuple A) :
   size (map f t) == n.
Proof. by rewrite size_map size_tuple. Qed.

Canonical
  map_tuple n A B (f:A -> B) (t: n.-tuple A) :=
    Tuple (map_tupleP f t).
 *)

(** Exercise: show in detail how
    [rewrite size_tuple] from above works *)

(**
Since tuples are a subtype of lists, we
can reuse the theory of lists over equality types.
*)

Example test_eqtype (x y : 3.-tuple nat) :
  x == y -> True.
Proof.
move=> /eqP.
Abort.

(** * Finite types *)

From mathcomp Require Import choice fintype finfun.

(**
Fig. 3 of "Packaging Mathematical Structures"
by F. Garillot, G. Gonthier, A. Mahboubi,
L. Rideau(2009)
*)

(** A [finType] structure is composed of
    a list of elements of an [eqType] structure,
    each element of the type being uniquely
    represented in the list:

(* simplified definition of [finType] *)
  Structure finType : Type :=
    FinType {
        sort :> countType;
        enum : seq sort;
        enumP : forall x,
                  count (pred1 x) enum = 1;
    }.
*)

(**
Finite sets are then sets taken in a [finType]
domain. In the library, the basic operations
are provided.
For example, given [A] a finite set,
[card A] (or #|A|) represents the cardinality
of A. All these operations come with their
basic properties. For example, we have:

  Lemma cardUI : ∀ (d: finType) (A B: {pred T}),
    #|A ∪ B| + #|A ∩ B| = #|A| + #|B|.

  Lemma card_image :
    ∀ (T T': finType) (f : T -> T')
      injective f -> forall A : {pred T},
      #|image f A| = #|A|.
*)

(** ** How [finType] is actually organized *)

Print Finite.type.
(**
  Structure type : Type :=
    Pack {
      sort : Type;
      _ : Finite.class_of sort
    }.
*)

(** [finType] extends [choiceType] with a mixin *)
Print Finite.class_of.
(**
  Structure class_of (T : Type) : Type :=
    Class {
      base : Choice.class_of T;
      mixin : Finite.mixin_of (EqType T base)
    }
*)

Print Finite.mixin_of.
(** we mix in countable and two specific fields:
    an enumeration and an axiom

  Structure mixin_of (T : eqType) : Type :=
    Mixin {
      mixin_base : Countable.mixin_of T;
      mixin_enum : seq T;
      _ : Finite.axiom mixin_enum
    }.
*)

Print Finite.axiom.
(**
  Finite.axiom =
    fun (T : eqType) (e : seq T) =>
      forall x : T, count_mem x e = 1

where
  Notation count_mem x := (count (pred1 x)).
*)

Eval cbv in count_mem 5 [:: 1; 5; 2; 5; 3; 5; 4].

Section FinTypeExample.

Variable T : finType.

(** Cardinality of a finite type *)
Check #| T |.

(** "bounded" quantification *)
Check [forall x : T, x == x] && false.
Fail Check (forall x : T, x == x) && false.

(** We recover classical reasoning for
    the bounded quantifiers: *)
Check negb_forall:
  forall (T : finType) (P : pred T),
    ~~ [forall x, P x] = [exists x, ~~ P x].

Check negb_exists:
  forall (T : finType) (P : pred T),
    ~~ [exists x, P x] = [forall x, ~~ P x].

(** [negb_forall] does not hold
    in intuitionistic setting *)

End FinTypeExample.

(** * Examples of interfaces *)

From mathcomp Require Import finset.

Section Interfaces.

Variable chT : choiceType.

Check (@sigW chT).

Check [eqType of chT].

Variable coT : countType.

Check [countType of nat].
Check [choiceType of coT].
Check [choiceType of nat * nat].
Check [choiceType of seq coT].

Variable fT : finType.

Check [finType of bool].
Check [finType of 'I_10].
Check [finType of {ffun 'I_10 -> fT}].
Check [finType of bool * bool].
Check [finType of 3.-tuple bool].
Fail Check [finType of 3.-tuple nat].

Check {set 'I_4} : Type.
Check forall a : {set 'I_4},
        (a == set0) || (1 < #|a| < 4).
Print set_type.
Check {ffun 'I_4 -> bool} : Type.
Print finfun_eqType.
Check [eqType of #| 'I_4 |.-tuple bool].
Check [finType of #| 'I_4 |.-tuple bool].

Check {ffun 'I_4 * 'I_6 -> nat} : Type.
Check [eqType of {ffun 'I_4 * 'I_6 -> nat}] : Type.

End Interfaces.

(** * Bonus *)

(* The following requires
   the coq-mathcomp-algebra package
   from opam package manager *)
From mathcomp Require Import all_algebra.
Open Scope ring_scope.

Print matrix.

Section Rings.

Variable R : ringType.

Check forall x : R, x * 1 == x.

(** Matrices of size 4x4 over an arbitrary ring [R] *)
Check forall m : 'M[R]_(4,4), m == m * m.

End Rings.


Section ExProp.

Variable A B C D P Q R S:Prop.

Goal (P -> Q) -> (Q -> R) -> P -> R.
Proof.
intros pq qr p.
apply qr. apply pq. exact p.
Qed.

Goal ~False.
Proof.
intro H. exact H.
Qed.

Goal P -> ~~P.
Proof.
intro p. intro np. elim np. exact p.
Qed.

Goal (P -> Q) -> ~Q -> ~P.
Proof.
intros pq nq. intro p.
elim nq. apply pq. exact p.
Qed.

Goal P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
intro pqr. destruct pqr as [p [q r]].
split.
 split.
  exact p.
  exact q.
 exact r.
Qed.

Goal P /\ (Q \/ R) -> (P /\ Q) \/ (P /\ R).
Proof.
intro pqr.
destruct pqr as [p [q|r]].
 left. split.
  exact p.
  exact q.
 right. split.
  exact p.
  exact r.
Qed.

Goal P -> ~P -> Q.
Proof.
intros p np. elim np. exact p.
Qed.

Goal (A \/ B -> C) -> (A -> C)/\(B -> C).
Proof.
intro abc.
split.
 intro a. apply abc. left. exact a.
 intro b. apply abc. right. exact b.
Qed.

Goal (A \/ B -> C) -> (A -> C) \/ (B -> C).
Proof.
intro abc.
 left. intro a. apply abc. left. exact a.
Qed.

Goal (A -> (B -> C)) /\ (A -> B) -> (A -> C).
Proof.
intros H a. destruct H as [abc ab].
apply abc.
 exact a.
 apply ab. exact a.
Qed.

Goal (~A /\ ~B) -> ~(A \/ (~A /\ B)).
Proof.
intro nanb. intro anab.
destruct nanb as [na nb].
destruct anab as [a|[na' b]].
 elim na. exact a.
 elim nb. exact b.
Qed.

Goal (A -> ~A) -> ~A.
Proof.
intro ana. intro a. elim ana.
 exact a.
 exact a.
Qed.

Goal (~(A /\ A) -> (~A \/ ~A)).
Proof.
intro naa. left. intro a. elim naa.
split.
 exact a.
 exact a.
Qed.

Goal (A -> B) -> (A -> ~B) -> A -> C.
Proof.
intros ab anb a. elim anb.
 exact a.
 apply ab. exact a.
Qed.

End ExProp.


Require Import Bool Arith List Cpdt.CpdtTactics.
Set Implicit Arguments.
Set Asymmetric Patterns.

(* Chapter 2. Some Quick Examples *)
(* 2.1 Arithmetic Expressions Over Natural Numbers *)
Inductive binop : Set :=
| Plus  : binop
| Times : binop.

Inductive exp : Set :=
| Const : nat -> exp
| Binop : binop -> exp -> exp -> exp.

Definition binopDenote (b : binop) : nat -> nat -> nat :=
  match b with
  | Plus => plus
  | Times => mult
  end.

Fixpoint expDenote (e : exp) : nat :=
  match e with
  | Const n => n
  | Binop b e1 e2 => (binopDenote b) (expDenote e1) (expDenote e2)
  end.

Eval simpl in expDenote (Const 42).
Eval simpl in expDenote (Binop Plus (Const 2) (Const 2)).
Eval simpl in expDenote (Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7)).

Inductive instr : Set :=
| iConst : nat -> instr
| iBinop : binop -> instr.
Definition prog := list instr.
Definition stack := list nat.

Definition instrDenote (i : instr) (s : stack) : option stack :=
  match i with
  | iConst n => Some (n :: s)
  | iBinop b =>
      match s with
      | arg1 :: arg2 :: s' => Some ((binopDenote b) arg1 arg2 :: s')
      | _ => None
      end
  end.

Fixpoint progDenote (p : prog) (s : stack) : option stack :=
  match p with
  | nil => Some s
  | i :: p' =>
      match instrDenote i s with
      | None => None
      | Some s' => progDenote p' s'
      end
  end.

Fixpoint compile (e : exp) : prog :=
  match e with
  | Const n => iConst n :: nil
  | Binop b e1 e2 => compile e2 ++ compile e1 ++ iBinop b :: nil
  end.

Eval simpl in compile (Const 42).
Eval simpl in compile (Binop Plus (Const 2) (Const 2)).
Eval simpl in compile (Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7)).
Eval simpl in progDenote (compile (Const 42)) nil.
Eval simpl in progDenote (compile (Binop Plus (Const 2) (Const 2))) nil.
Eval simpl in progDenote (compile (Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7))).

Theorem compile_correct : forall e,
  progDenote (compile e) nil = Some (expDenote e :: nil).
Abort.

Lemma compile_correct' : forall e p s,
  progDenote (compile e ++ p) s = progDenote p (expDenote e :: s).
Proof.
  induction e.
  - intros. unfold compile. unfold expDenote. unfold progDenote at 1. simpl.
    fold progDenote. reflexivity.
  - intros.
    unfold compile. fold compile. unfold expDenote. fold expDenote.
    rewrite app_assoc_reverse. rewrite IHe2.
    rewrite app_assoc_reverse. rewrite IHe1.
    simpl. reflexivity.
Abort.

Lemma compile_correct' : forall e p s,
  progDenote (compile e ++ p) s = progDenote p (expDenote e :: s).
Proof.
  induction e; crush.
Qed.

Theorem compile_correct : forall e,
  progDenote (compile e) nil = Some (expDenote e :: nil).
Proof.
  intros. rewrite (app_nil_end (compile e)).
  rewrite compile_correct'. reflexivity.
Qed.

(* 2.2 Typed Expressions *)
Inductive type : Set :=
| Nat : type
| Bool : type.

Inductive tbinop : type -> type -> type -> Set :=
| TPlus : tbinop Nat Nat Nat
| TTimes : tbinop Nat Nat Nat
| TEq : forall t, tbinop t t Bool
| TLt : tbinop Nat Nat Bool.
Check tbinop_ind.

Inductive texp : type -> Set :=
| TNConst : nat -> texp Nat
| TBConst : bool -> texp Bool
| TBinop : forall t1 t2 t, tbinop t1 t2 t -> texp t1 -> texp t2 -> texp t.

Definition typeDenote (t : type) : Set :=
  match t with
  | Nat => nat
  | Bool => bool
  end.

Definition tbinopDenote arg1 arg2 res (b : tbinop arg1 arg2 res)
  : typeDenote arg1 -> typeDenote arg2 -> typeDenote res :=
  match b with
  | TPlus => plus
  | TTimes => mult
  | TEq Nat => beq_nat
  | TEq Bool => eqb
  | TLt => leb
  end.

Fixpoint texpDenote t (e : texp t) : typeDenote t :=
  match e with
  | TNConst n => n
  | TBConst b => b
  | TBinop _ _ _ b e1 e2 => (tbinopDenote b) (texpDenote e1) (texpDenote e2)
  end.

Check (TBinop).

Eval simpl in texpDenote (TNConst 42).
Eval simpl in texpDenote (TBConst true).
Eval simpl in texpDenote
  (TBinop TTimes (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)).
Eval simpl in texpDenote
  (TBinop (TEq Nat) (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)).
Eval simpl in texpDenote
  (TBinop TLt (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7)).

Definition tstack := list type.

(* what initial stack type it expects and what final stack type it will produce *)
Inductive tinstr : tstack -> tstack -> Set :=
| TiNConst : forall s, nat -> tinstr s (Nat :: s)
| TiBConst : forall s, bool -> tinstr s (Bool :: s)
| TiBinop : forall arg1 arg2 res s,
    tbinop arg1 arg2 res -> tinstr (arg1 :: arg2 :: s) (res :: s).

Inductive tprog : tstack -> tstack -> Set :=
| TNil : forall s, tprog s s
| TCons : forall s1 s2 s3,
    tinstr s1 s2 -> tprog s2 s3 -> tprog s1 s3.

(* representation for stacks at runtime *)
Fixpoint vstack (ts : tstack) : Set :=
  match ts with
  | nil => unit
  | t :: ts' => typeDenote t * vstack ts'
  end%type.

Definition tinstrDenote ts ts' (i : tinstr ts ts') : vstack ts -> vstack ts' :=
  match i with
  | TiNConst _ n => fun s => (n, s)
  | TiBConst _ b => fun s => (b, s)
  | TiBinop _ _ _ _ b => fun s =>
      let '(arg1, (arg2, s')) := s in
      ((tbinopDenote b) arg1 arg2, s')
  end.

Fixpoint tprogDenote ts ts' (p : tprog ts ts') : vstack ts -> vstack ts' :=
  match p with
  | TNil _ => fun s => s
  | TCons _ _ _ i p' => fun s => tprogDenote p' (tinstrDenote i s)
  end.

Fixpoint tconcat ts ts' ts'' (p : tprog ts ts') : tprog ts' ts'' -> tprog ts ts'' :=
  match p with
  | TNil _ => fun p' => p'
  | TCons _ _ _ i p1 => fun p' => TCons i (tconcat p1 p')
  end.

Fixpoint tcompile t (e : texp t) (ts : tstack) : tprog ts (t :: ts) :=
  match e with
  | TNConst n => TCons (TiNConst _ n) (TNil _)
  | TBConst b => TCons (TiBConst _ b) (TNil _)
  | TBinop _ _ _ b e1 e2 =>
      tconcat (tcompile e2 _)
      (tconcat (tcompile e1 _) (TCons (TiBinop _ b) (TNil _)))
  end.

Eval simpl in tprogDenote (tcompile (TNConst 42) nil) tt.
Eval simpl in tprogDenote (tcompile (TBConst true) nil) tt.
Eval simpl in tprogDenote
  (tcompile
  (TBinop TTimes (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7))
  nil)
  tt.
Eval simpl in tprogDenote
  (tcompile
  (TBinop (TEq Nat) (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7))
  nil)
  tt.
Eval simpl in tprogDenote
  (tcompile
  (TBinop TLt (TBinop TPlus (TNConst 2) (TNConst 2)) (TNConst 7))
  nil)
  tt.

Theorem tcompile_correct : forall t (e : texp t),
  tprogDenote (tcompile e nil) tt = (texpDenote e, tt).
Abort.

Lemma tconcat_correct :
  forall ts ts' ts''
  (p : tprog ts ts') (p' : tprog ts' ts'') (s : vstack ts),
  tprogDenote (tconcat p p') s = tprogDenote p' (tprogDenote p s).
Proof.
  induction p; crush.
Qed.

Hint Rewrite tconcat_correct.

Lemma tcompile_correct' : forall t (e : texp t) ts (s : vstack ts),
  tprogDenote (tcompile e ts) s = (texpDenote e, s).
Proof.
  induction e; crush.
Qed.

Theorem tcompile_correct : forall t (e : texp t),
  tprogDenote (tcompile e nil) tt = (texpDenote e, tt).
Proof.
  intros. apply tcompile_correct'.
Qed.


(* My first Coq theorem. *)

Definition pierce := forall (p q : Prop), ((p -> q) -> p) -> p.

Definition lem := forall (p : Prop), p \/ ~ p.

Theorem pierce_equiv_lem : pierce <-> lem.
  unfold pierce, lem.
  firstorder.
  apply H with (q := ~(p \/ ~p)).
  tauto.
  destruct (H p).
  assumption.
  tauto.
Qed.


Require Import Arith.
Import Nat.

Definition EM := forall A : Prop, A \/ ~ A.

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

Definition LLPO := forall (f : nat -> bool),
  (forall n m : nat, n <> m -> f n = false \/ f m = false) ->
    (forall n : nat, even n = true  -> f n = false) \/
    (forall n : nat, even n = false -> f n = false).

Theorem EM_impl_LPO : EM -> LPO.
Proof. unfold EM. unfold LPO.
  intros. destruct H with (exists n : nat, f n = true).
  right. auto.
  left. intros. destruct H with (f n = false).
  auto. destruct H0. exists n. destruct (f n). auto.
  exfalso. apply H1. auto.
Qed.

Theorem LPO_impl_LLPO : LPO -> LLPO.
Proof.
  unfold LPO. unfold LLPO.
  intros. specialize (H f).
  destruct H. left. auto.
  destruct H.
  assert (Hev: even x = false \/ even x = true). { destruct (even x); eauto. }
  destruct Hev. left. intros. destruct (Nat.eq_dec x n) eqn:Heq.
  - subst. rewrite H2 in H1. inversion H1.
  - clear Heq. apply H0 in n0. destruct n0. rewrite H3 in H. inversion H. auto.
  - right. intros. destruct (Nat.eq_dec x n) eqn:Heq.
    + subst. rewrite H2 in H1. inversion H1.
    + clear Heq. apply H0 in n0. destruct n0. rewrite H3 in H. inversion H. auto.
Qed.


(*
 * Some basic functions and definitions
 *)

(* Booleans *)

(* True if all arguments are true *)
Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  match b1, b2, b3 with
    | true, true, true => true
    | _, _, _ => false
  end.

(* Natural Numbers *)

(* True if n is equal to m *)
Fixpoint beq_nat (n m : nat) : bool :=
  match n with
    | O => match m with
             | O => true
             | S m' => false
           end
    | S n' => match m with
                | O => false
                | S m' => beq_nat n' m'
              end
  end.

(* True if n is less than or equal to m *)
Fixpoint ble_nat (n m : nat) : bool :=
  match n with
    | O => true
    | S n' =>
        match m with
          | O => false
          | S m' => ble_nat n' m'
        end
  end.

(* True if n is less than m *)
Definition blt_nat (n m : nat) : bool :=
  match ble_nat n m with
    | false => false
    | true => negb (ble_nat m n)
  end.

(*
 * Lists, their notations and some useful functions on them
 *)

Require Import List.
Notation "x :: l" := (cons x l) (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).

(* Determines if all elements of the list satisfy the predicate *)
Fixpoint all {A:Type} (f:A -> bool) (l:list A) : bool :=
  match l with
    | [] => true
    | x :: xs => if f x then all f xs else false
  end.

(* Determines if any element of the list satisfies the predicate *)
Fixpoint any {A:Type} (f:A -> bool) (l:list A) : bool :=
  match l with
    | [] => false
    | x :: xs => if f x then true else any f xs
  end.

(* Splits a list before the first element that fulfills the test  *)
Fixpoint break {A:Type} (f: A -> bool) (l:list A) : (list A * list A) :=
  match l with
    | nil => (nil, nil)
    | x::xs => if f x then (nil, l)
               else let (a, b) := (break f xs) in (x::a, b)
  end.

(* Combines two lists by prepending the elements of one list
   to each sublist of the other list *)
Fixpoint combine_prepend {A:Type} (l:list A) (l':list (list A)) : list (list A) :=
  match l, l' with
    | x::xs, y::ys => (x :: y) :: (combine_prepend xs ys)
    | _, _ => nil
  end.

(* As per http://coq.inria.fr/V8.1/stdlib/Coq.Lists.List.html *)
Fixpoint filter {A:Type} (f:A -> bool) (l:list A) : list A :=
  match l with
    | nil => nil
    | x :: l => if f x then x::(filter f l) else filter f l
  end.

(* Groups a list into chunks of size n *)
Fixpoint group_by {A:Type} (n:nat) (l:list A) : list (list A) :=
  match l with
    | [] => []
    | x :: xs => match group_by n xs with
      | [] => [[x]]
      | y :: ys =>
        if beq_nat (length y) n then [x] :: (y :: ys)
        else (x :: y) :: ys
    end
  end.

(* Returns the length of the list *)
Fixpoint list_size {A:Type} (l:list A) : nat :=
  match l with
    | nil => 0
    | x::xs => S (list_size xs)
  end.

(* Returns the minimum of the list and 0 for the empty list *)
Fixpoint minimum (l:list nat) : nat :=
  match l with
    | [] => 0
    | [x] => x
    | x::xs => let m := minimum xs in if blt_nat m x then m else x
  end.

(* Test whether a list is empty *)
Definition null {A:Type} (l:list A) : bool :=
  match l with
    | [] => true
    | _ => false
  end.

(* True if the list only contains one element *)
Definition single {A:Type} (l:list A) : bool :=
  match l with
    | [x] => true
    | _ => false
  end.

(* Merges a list of lists into a single list *)
Fixpoint ungroup {A:Type} (l:list (list A)) : list A :=
  match l with
    | [] => []
    | xs :: xss => xs ++ ungroup xss
  end.

(* Cartesian product of a list of lists *)
Fixpoint cp {A:Type} (l:list (list A)) : list (list A) :=
  match l with
    | [] => [[]]
    | xs :: xss => ungroup (map (fun x => map (fun ys => x :: ys) (cp xss)) xs)
  end.

(* Matrix cartesian product *)
Definition mcp {A:Type} (l: list (list (list A))) : list (list (list A)) :=
  cp (map cp l).


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


Require Export Iron.Data.List.Base.
Require Export Iron.Tactics.

Fixpoint max_list (xs : list nat) :=
 match xs with
 |  nil     => 0
 |  x :: xs => max x (max_list xs)
 end.

Lemma max_ge_left1
 : forall a b
 , max a b >= a.
Proof.
 intros. gen b.
 induction a; intros.
  omega.
  simpl. break b.
   omega.
   cut (max a X >= a).
    intros. omega.
   eauto.
Qed.
Hint Resolve max_ge_left1.

Lemma max_ge_right1
 : forall a b
 , max a b >= b.
Proof.
 intros. gen b.
 induction a; intros.
  simpl. auto.
  simpl. destruct b.
   omega.
   spec IHa b. omega.
Qed.
Hint Resolve max_ge_right1.

Lemma max_ge_left
 : forall a b c
 , c >= max a b -> c >= a.
Proof.
 intros. gen b c.
 induction a; intros.
  simpl in *. omega.
   simpl in *. break b.
   subst. auto.
   destruct c.
    nope.
    have (c >= max a X) by omega.
    lets D: IHa H0. omega.
Qed.
Hint Resolve max_ge_left.

Lemma max_ge_right
 : forall a b c
 , c >= max a b -> c >= b.
Proof.
 intros. gen b c.
 induction a; intros.
  simpl in *. subst. auto.
  simpl in *. destruct b.
   omega.
   destruct c.
    nope.
    have (c >= max a b) by omega.
    lets D: IHa H0. omega.
Qed.
Hint Resolve max_ge_right.

Lemma max_ge_above_left
 :  forall a b c
 ,  a >= b
 -> max a c >= b.
Proof.
 intros. gen c b.
 induction a; intros.
  simpl. omega.
  simpl. destruct c.
   omega.
   destruct b.
    omega.
    cut (max a c >= b).
     intros. omega.
     eapply IHa. omega.
Qed.
Hint Resolve max_ge_above_left.

Lemma max_ge_above_right
 :  forall a b c
 ,  a >= b
 -> max c a >= b.
Proof.
 intros. gen a b.
 induction c; intros.
  simpl. auto.
  simpl. break a.
   omega.
   subst.
   destruct b.
    omega.
    have (X >= b) by omega.
    spec IHc H0. omega.
Qed.
Hint Resolve max_ge_above_right.

Lemma max_weaken_left
 :  forall a b c
 ,        a >= b
 -> max c a >= b.
Proof.
 intros. gen a b.
 induction c; intros.
  simpl. auto.
  simpl. destruct a.
   omega.
   destruct b.
    omega.
    cut (max c a >= b). intros. omega.
     eapply IHc. omega.
Qed.
Hint Resolve max_weaken_left.

(********************************************************************)
(* Lemmas: max_list *)

Lemma max_list_above
 :  forall xs
 ,  Forall (fun x => max_list xs >= x) xs.
Proof.
 intros.
 induction xs; unfold not; intros.
  - simpl. auto.
  - eapply Forall_cons.
    + simpl. eauto.

    + eapply Forall_impl
       with (P := (fun x => max_list xs >= x)); eauto.
      intros.
      simpl.
      remember (max_list xs) as mx.
      eapply max_weaken_left. auto.
Qed.
Hint Resolve max_list_above.

Lemma max_list_succ_not_in
 :  forall xs
 ,  not (In (S (max_list xs)) xs).
Proof.
 intros.
 unfold not. intros.
 lets D1: max_list_above xs.
  rewrite Forall_forall in D1.
 spec D1 H. omega.
Qed.
Hint Resolve max_list_succ_not_in.


Require Import Bool.
Definition bool_not (b:bool) : bool := if b then false else true.

Definition bool_xor (b b':bool) : bool := if b then bool_not b' else b'.

Definition bool_and (b b':bool) : bool := if b then b' else false.

Definition bool_or (b b':bool) := if b then true else b'.

Definition bool_eq (b b':bool) := if b then b' else bool_not b'.

Theorem bool_xor_not_eq :
 forall b1 b2:bool, bool_xor b1 b2 = bool_not (bool_eq b1 b2).
Proof.
  destruct b1, b2; reflexivity.
Qed.

Theorem bool_not_and :
 forall b1 b2:bool,
   bool_not (bool_and b1 b2) = bool_or (bool_not b1) (bool_not b2).
Proof.
 destruct b1, b2; reflexivity.
Qed.

Theorem bool_not_not : forall b:bool, bool_not (bool_not b) = b.
Proof.
 now destruct b.
Qed.

Theorem bool_ex_middle : forall b:bool, bool_or b (bool_not b) = true.
Proof.
 now destruct b.
Qed.

Theorem bool_eq_reflect : forall b1 b2:bool, bool_eq b1 b2 = true -> b1 = b2.
Proof.
  destruct  b1, b2; (reflexivity || discriminate).
Qed.

Theorem bool_eq_reflect2 : forall b1 b2:bool, b1 = b2 -> bool_eq b1 b2 = true.
Proof.
 destruct b1, b2; trivial; discriminate.
Qed.

Theorem bool_not_or :
 forall b1 b2:bool,
   bool_not (bool_or b1 b2) = bool_and (bool_not b1) (bool_not b2).
Proof.
   now destruct b1, b2.
Qed.

Theorem bool_or_and_distr :
 forall b1 b2 b3:bool,
   bool_or (bool_and b1 b3) (bool_and b2 b3) = bool_and (bool_or b1 b2) b3.
Proof.
 now destruct b1, b2, b3.
Qed.


Require Export Elementary_Logic.

(* THE CLASSIFICATION AXIOM SCHEME *)

Module Classification.

(* Class: the universe of discourse consists of classes. *)

Parameter Class : Type.

(* ∈: is read 'is a member of' or 'belongs to.' *)

Parameter In : Class -> Class -> Prop.

Notation "x ∈ y" := (In x y) (at level 10).

(* I Axiom of extent  For each x and each y it is true that x=y if and only if
   for each z, z∈x when and only when z∈y. *)

Axiom Axiom_Extent : forall (x y: Class),
  x = y <-> (forall z: Class, z∈x <-> z∈y).

Hint Resolve Axiom_Extent : set.

(* 1 Definition  x is a set iff for some y, x∈y. *)

Definition Ensemble (x: Class) : Prop := exists y: Class, x∈y.

Ltac Ens := unfold Ensemble; eauto.

Ltac AssE x := assert (Ensemble x); Ens.

Hint Unfold Ensemble : set.

(* {...:...} : the classifier. *)

Parameter Classifier : forall P: Class -> Prop, Class.

Notation "\{ P \}" := (Classifier P) (at level 0).

(* II Classification axiom-scheme  An axiom results if in the following 'a' and
   'b' are replaced by variables, 'A' by a formula P and 'B' by the formula
   obtained from P by replacing each occurrence of the variable which replaced
   a by the variable which replaced b:
   For each b, b ∈ { a : A } if and only if b is a set and B. *)

Axiom Axiom_Scheme : forall (b: Class) (P: Class -> Prop),
  b ∈ \{ P \} <-> Ensemble b /\ (P b).

Hint Resolve Axiom_Scheme : set.

End Classification.

Export Classification.


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

Require Import Arith ZArith Lia List.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list gcd prime php utils_nat.

From Undecidability.H10.ArithLibs
  Require Import Zp.

Set Implicit Arguments.

Section utils.

  Fact prime_2_or_odd p : prime p -> p = 2 \/ exists n, 0 < n /\ p = 2*n+1.
  Proof.
    intros Hp.
    assert (H1 : p <> 0).
    { generalize (prime_ge_2 Hp); lia. }
    assert (H3 : 2 <> 0) by discriminate.
    destruct (eq_nat_dec p 2) as [ | H2 ]; auto; right.
    assert (rem p 2 = 1) as Hp1.
    { generalize (div_rem_spec2 p H3).
      case_eq (rem p 2).
      + intros H _.
        apply divides_rem_eq in H.
        apply proj2 in Hp.
        destruct (Hp _ H); subst; lia.
      + intros; lia. }
    exists (div p 2); split.
    + generalize (div_rem_spec1 p 2) (prime_ge_2 Hp).
      destruct (div p 2); intros; lia.
    + rewrite Nat.mul_comm.
      rewrite (div_rem_spec1 p 2) at 1.
      f_equal; auto.
  Qed.

  Fact remarkable_id1_nat x y : (x+y)*(x+y) = x*x+2*(x*y)+y*y.
  Proof. ring. Qed.

  Fact remarkable_id1_Z (a b : Z) : ((a+b)*(a+b) = a*a + 2*a*b + b*b)%Z.
  Proof. ring. Qed.

  Fact Zsquare_bound x y : (-y <= x <= y -> x*x <= y*y)%Z.
  Proof.
    intros (H1 & H2).
    destruct (Z_pos_or_neg x).
    + apply Z.square_le_mono_nonneg; auto.
    + replace (y*y)%Z with ((-y)*(-y))%Z by ring.
      apply Z.square_le_mono_nonpos; lia.
  Qed.

  Local Fact bounded_upper_limit_4 a b c d m :
           (a <= m
         -> b <= m
         -> c <= m
         -> d <= m
         -> a+b+c+d = 4*m
         -> a = m
         /\ b = m
         /\ c = m
         /\ d = m)%Z.
  Proof. lia. Qed.

  Local Fact bounded_lower_limit_4 a b c d :
           (0 <= a
         -> 0 <= b
         -> 0 <= c
         -> 0 <= d
         -> a+b+c+d = 0
         -> a = 0
         /\ b = 0
         /\ c = 0
         /\ d = 0)%Z.
  Proof. lia. Qed.

  Local Fact four_squares_zero a b c d :
           (a*a+b*b+c*c+d*d = 0
         -> a = 0
         /\ b = 0
         /\ c = 0
         /\ d = 0)%Z.
  Proof.
    intros H.
    apply bounded_lower_limit_4 in H; try apply Z.square_nonneg.
    destruct H as (H1 & H2 & H3 & H4).
    apply Zmult_integral in H1.
    apply Zmult_integral in H2.
    apply Zmult_integral in H3.
    apply Zmult_integral in H4.
    destruct H1; destruct H2; destruct H3; destruct H4; auto.
  Qed.

  Fact Zsquare_inj x y : (x*x = y*y -> { x = y } + { - x = y } )%Z.
  Proof.
    intros H.
    assert ( (x+y)*(x-y) = 0 )%Z as E.
    { rewrite Z.mul_sub_distr_l, !Z.mul_add_distr_r, H; ring. }
    apply Zmult_integral in E.
    destruct (Z.eq_dec x y); auto.
    right; lia.
  Qed.

  Fact square_4_simpl x m :
        (4*(x*x) = Z.of_nat m*Z.of_nat m)%Z
     -> { n | m = 2*n
           /\   (x = Z.of_nat n
             \/ (x = - Z.of_nat n)%Z) }.
  Proof.
    intros H.
    replace (4*(x*x))%Z with ((2*x)*(2*x))%Z in H by ring.
    apply Zsquare_inj in H.
    destruct H as [ H | H ].
    + destruct Z_of_nat_complete_inf with x as (k & ->).
      * generalize (Zle_0_nat m); lia.
      * exists k; split; auto.
        apply Nat2Z.inj.
        rewrite Nat2Z.inj_mul, <- H; auto.
    + destruct (Z_of_nat_complete_inf (Z.opp x)) as (k & Hk).
      * generalize (Zle_0_nat m); lia.
      * exists k; split.
        - apply Nat2Z.inj.
          rewrite Nat2Z.inj_mul, <- H, <- Hk; ring.
        - right; rewrite <- Hk; ring.
  Qed.

  Fact square_4_simpl' x m :
         (4*(x*x) = Z.of_nat (2*m)*Z.of_nat (2*m)
       -> x = Z.of_nat m \/ x = - Z.of_nat m)%Z.
  Proof.
    intros H.
    replace (4*(x*x))%Z with ((2*x)*(2*x))%Z in H by ring.
    apply Zsquare_inj in H.
    destruct H as [ H | H  ]; rewrite Nat2Z.inj_mul in H;
      change (Z.of_nat 2) with 2%Z in H; lia.
  Qed.

  (* We can find a small representative in absolute value *)

  Lemma Zp_small_repr m (Hm : m <> 0) x :
         exists y, Z2Zp Hm x = Z2Zp Hm y
               /\ (4*(y*y) <= Z.of_nat m * Z.of_nat m)%Z.
  Proof.
    destruct (euclid_2 m) as (p & [ H | H ]).
    + destruct (Zp_repr_interval Hm (- Z.of_nat p)%Z (Z.of_nat p) x) as (y & H1 & H2).
      * rewrite H, Nat2Z.inj_mul; simpl Z_of_nat; lia.
      * exists y; split; auto.
        rewrite H, Nat2Z.inj_mul.
        simpl Z.of_nat.
        replace (2*Z.of_nat p*(2*Z.of_nat p))%Z
        with    (4*(Z.of_nat p*Z.of_nat p))%Z by ring.
        nia.
    + destruct (Zp_repr_interval Hm (- Z.of_nat p)%Z (1+Z.of_nat p) x) as (y & H1 & H2).
      * rewrite H, Nat2Z.inj_add, Nat2Z.inj_mul; simpl Z_of_nat; lia.
      * exists y; split; auto.
        apply Z.le_trans with (Z.of_nat (2*p) * Z.of_nat (2*p))%Z.
        - rewrite Nat2Z.inj_mul.
          simpl Z.of_nat.
          replace (2*Z.of_nat p*(2*Z.of_nat p))%Z
          with    (4*(Z.of_nat p*Z.of_nat p))%Z by ring.
          nia.
        - apply Zsquare_bound; subst.
          rewrite !Nat2Z.inj_add, !Nat2Z.inj_mul; simpl Z.of_nat; lia.
  Qed.

  Lemma Zp_square_zero m (Hm : m <> 0) (Hm2 : m*m <> 0) x :
            Z2Zp Hm x      = Zp_zero Hm
         -> Z2Zp Hm2 (x*x) = Zp_zero Hm2.
  Proof.
    intros H.
    apply Z2Zp_zero_inv in H.
    destruct H as (v & ->).
    replace (Z.of_nat m*v*(Z.of_nat m*v))%Z
    with    (Z.of_nat m*Z.of_nat m*(v*v))%Z by ring.
    now rewrite <- Nat2Z.inj_mul, Z2Zp_mult, Z2Zp_of_nat, nat2Zp_p, Zp_mult_zero.
  Qed.

End utils.

Section half_modulus_lemma.

  (* If x = +- m [ 2m ] then x² = m² [4m²] *)

  Variable (m : nat) (H2m : 2*m <> 0) (Hm2 : 4*m*m <> 0).

  Let lemma1 x :
          Z2Zp H2m x = nat2Zp H2m m
       -> Z2Zp Hm2 (x*x) = nat2Zp Hm2 (m*m).
  Proof.
    intros H.
    rewrite <- Z2Zp_of_nat in H.
    apply Z2Zp_inj in H.
    destruct H as (k & H).
    assert (x = Z.of_nat m+2*k*Z.of_nat m)%Z as Hx.
    { rewrite Nat2Z.inj_mul, Z.mul_assoc, (Z.mul_comm k) in H.
      change 2%Z with (Z.of_nat 2); lia. }
    rewrite Hx, remarkable_id1_Z, !Z2Zp_plus.
    replace (2*Z.of_nat m * (2*k*Z.of_nat m))%Z
    with    (Z.of_nat (4*m*m)*k)%Z.
    2:{ rewrite !Nat2Z.inj_mul; ring. }
    replace (2*k*Z.of_nat m * (2*k*Z.of_nat m))%Z
    with    (Z.of_nat (4*m*m)*(k*k))%Z.
    2:{ rewrite !Nat2Z.inj_mul; ring. }
    rewrite (Z2Zp_mult _ _ k), Z2Zp_of_nat, nat2Zp_p, Zp_mult_zero.
    rewrite (Z2Zp_mult _ _ (k*k)), Z2Zp_of_nat, nat2Zp_p, Zp_mult_zero.
    rewrite !Zp_plus_zero_r, <- Nat2Z.inj_mul, Z2Zp_of_nat; auto.
  Qed.

  Let lemma2 x :
        (Z2Zp H2m x = Zp_opp H2m (nat2Zp H2m m))%Z
      -> Z2Zp Hm2 (x*x) = nat2Zp Hm2 (m*m).
  Proof.
    intros H.
    replace (x*x)%Z with ((-x)*(-x))%Z by ring.
    apply lemma1.
    rewrite Z2Zp_opp, H, Zp_opp_inv; auto.
  Qed.

  Fact half_modulus_lemma' x :
           Z2Zp H2m x = nat2Zp H2m m
       \/ (Z2Zp H2m x = Zp_opp H2m (nat2Zp H2m m))%Z
       -> Z2Zp Hm2 (x*x) = nat2Zp Hm2 (m*m).
  Proof. intros []; auto. Qed.

  Fact half_modulus_lemma x y :
           Z2Zp H2m x = Z2Zp H2m y
        -> y = Z.of_nat m
        \/ y = (- Z.of_nat m)%Z
        -> Z2Zp Hm2 (x*x) = nat2Zp Hm2 (m*m).
  Proof.
    intros H1 H2.
    apply half_modulus_lemma'.
    rewrite H1.
    destruct H2; subst y; [ left | right ].
    + rewrite Z2Zp_of_nat; auto.
    + rewrite Z2Zp_opp, Z2Zp_of_nat; auto.
  Qed.

End half_modulus_lemma.

Section lagrange_prelim_odd.

  Variable (p n : nat) (Hp1 : prime p) (Hp2 : p = 2*n+1).

  Let Hn : 0 < n.
  Proof.
    destruct n; try lia.
    simpl in Hp2; subst.
    exfalso; apply Hp1; trivial.
  Qed.

  Let Hp : p <> 0.
  Proof. lia. Qed.

  Let l := list_an 0 (1+n).

  Let Hl : forall x, In x l <-> x <= n.
  Proof.
    unfold l; intros x; rewrite list_an_spec; lia.
  Qed.

  (* Let us defined two injective functions from [0,n] to Z/Z(2n+1)

     f := x => x²
     g := x => -(1+x²)

   *)

  Let f x := nat2Zp Hp (x*x).
  Let g y := Zp_opp Hp (Zp_plus Hp (Zp_one Hp) (f y)).

  Let Hf x y : In x l -> In y l -> f x = f y -> x = y.
  Proof.
    unfold f; intros G1 G2 H.
    do 2 rewrite nat2Zp_mult in H.
    apply Zp_prime_square_eq_square in H; auto.
    destruct H as [ H | H ].
    + rewrite nat2Zp_inj in H.
      rewrite <- (@rem_idem x p), H, rem_idem; auto.
      * apply Hl in G2; lia.
      * apply Hl in G1; lia.
    + apply f_equal with (f := @proj1_sig _ _) in H; simpl in H.
      rewrite rem_idem in H.
      2: apply Hl in G1; lia.
      case_eq (rem y p).
      * intros Hy.
        rewrite Hy, Nat.sub_0_r, rem_diag in H; auto.
        rewrite rem_idem in Hy; try lia.
        apply Hl in G2; lia.
      * intros w Hw.
        rewrite rem_idem in H; try lia.
        rewrite H.
        apply Hl in G2.
        apply Hl in G1.
        rewrite rem_idem in H; lia.
  Qed.

  Let Hg x y : In x l -> In y l -> g x = g y -> x = y.
  Proof.
      unfold g; intros G1 G2 G3.
      apply Zp_opp_inj, Zp_plus_inj_l in G3.
      revert G3; apply Hf; auto.
  Qed.

  (* Since |map f l| = n+1 and |map g l| = n+1
     and the domain has cardinal 2*n+1, they must intersect *)

  Let intersection : exists y, In y (map f l) /\ In y (map g l).
  Proof.
    destruct partition_intersection with (l := map f l) (m := map g l) (k := Zp_list Hp)
        as [ G | [ G | ] ]; auto.
    * rewrite Zp_list_length, app_length, map_length, map_length.
      unfold l; rewrite list_an_length; lia.
    * intros ? _; apply Zp_list_spec.
    * apply list_has_dup_map_inv in G; auto.
      apply not_list_has_dup_an in G; tauto.
    * apply list_has_dup_map_inv in G; auto.
      apply not_list_has_dup_an in G; tauto.
  Qed.

  Local Lemma lagrange_prelim_odd :
              exists a b, divides p (1+a*a+b*b)
                       /\ 2*a <= p-1
                       /\ 2*b <= p-1.
  Proof using Hf.
    destruct intersection as (u & G1 & G2).
    rewrite in_map_iff in G1.
    rewrite in_map_iff in G2.
    destruct G1 as (a & G3 & G4).
    destruct G2 as (b & G5 & G6).
    exists a, b; msplit 2.
    + rewrite divides_nat2Zp with (Hp := Hp),
              (Nat.add_comm 1), <- Nat.add_assoc,
              !nat2Zp_plus, nat2Zp_one.
      fold (f a).
      apply Zp_opp_plus_eq.
      fold (f b); fold (g b).
      now rewrite G3, G5, Zp_plus_zero.
    + apply Hl in G4; lia.
    + apply Hl in G6; lia.
  Qed.

End lagrange_prelim_odd.

(* Preliminary lemma : any prime p has a (small) multiple n*p of the form 1+a²+b² with 0 < n < p *)

Lemma lagrange_prelim p : prime p -> exists n a b, n*p = 1+a*a+b*b /\ 0 < n < p.
Proof.
  intros Hp.
  destruct (prime_2_or_odd Hp) as [ | (n & Hn1 & Hn2) ].
  + exists 1, 1, 0; subst; auto.
  + destruct (lagrange_prelim_odd _ Hp Hn2)
      as (a & b & (k & Hk) & Ha & Hb).
    exists k, a, b; split; auto.
    split.
    1: destruct k; simpl in Hk; try lia; discriminate.
    assert (a <= n) as Ha' by lia.
    assert (b <= n) as Hb' by lia.
    destruct (le_lt_dec p k) as [ H | H ]; auto.
    exfalso.
    assert (a*a+2*(1*1)+b*b <= k*p) as C; try lia.
    apply Nat.le_trans with ((n+n)*(n+n)).
    2: apply Nat.mul_le_mono; lia.
    rewrite remarkable_id1_nat.
    apply Nat.add_le_mono; [ | apply Nat.mul_le_mono; auto ].
    apply Nat.add_le_mono; [ apply Nat.mul_le_mono; auto | ].
    apply Nat.mul_le_mono_l.
    now apply Nat.mul_le_mono.
Qed.

Local Notation four_squares := (fun a b c d => a*a+b*b+c*c+d*d)%Z.

Fact Euler_squares x y a1 b1 c1 d1 a2 b2 c2 d2 :
         (x = four_squares a1 b1 c1 d1
       -> y = four_squares a2 b2 c2 d2
       -> x*y = four_squares (a1*a2+b1*b2+c1*c2+d1*d2)
                             (a1*b2-b1*a2+d1*c2-c1*d2)
                             (a1*c2-c1*a2+b1*d2-d1*b2)
                             (a1*d2-d1*a2+c1*b2-b1*c2))%Z.
Proof. intros -> ->; ring. Qed.

(* The primes are sums of four square, the hard part *)

Section lagrange_for_primes.

  Variable (p : nat) (Hp : prime p).

  (* P n is "n*p is sum of four squares" *)

  Let P n := exists a b c d, Z.of_nat (n*p) = four_squares a b c d.

  (* DLW: This one was a pain in the ... *)

  Section lagrange_prime_step.

    (* We show P m /\ 1 < m < p -> P r for some 1 <= r < m *)

    Variable (m : nat) (H1 : m < p) (H3 : 1 < m) (x1 x2 x3 x4 : Z)
             (H2 : Z.of_nat (m*p) = four_squares x1 x2 x3 x4).

    Let Hm : m <> 0.
    Proof. lia. Qed.

    Local Fact lagrange_prime_step' : exists r, 1 <= r < m /\ P r.
    Proof using H1 H2 H3 Hp.
      (* we get small representatives for x1 ... x4
         as y1 ... y4 *)
      generalize (Zp_small_repr Hm x1) (Zp_small_repr Hm x2)
                 (Zp_small_repr Hm x3) (Zp_small_repr Hm x4).
      intros (y1 & E1 & Q1) (y2 & E2 & Q2) (y3 & E3 & Q3) (y4 & E4 & Q4).
      (* they satisfy the same eq for another value r *)
      assert (Z2Zp Hm (y1*y1+y2*y2+y3*y3+y4*y4) = Zp_zero Hm) as H4.
      { rewrite !Z2Zp_plus, !Z2Zp_mult, <- E1, <- E2, <- E3, <- E4.
        rewrite <- !Z2Zp_mult, <- !Z2Zp_plus, <- H2.
        rewrite Nat2Z.inj_mul, Z2Zp_mult.
        rewrite Z2Zp_of_nat, nat2Zp_p, Zp_mult_zero; auto. }
      apply Z2Zp_zero_inv in H4.
      destruct H4 as (r' & Hr).
      rewrite (Z.mul_comm _ r') in Hr.
      (* r is smaller than m *)
      assert (4 * (r' * Z.of_nat m) <= 4 * (Z.of_nat m * Z_of_nat m))%Z as Hr'.
      { rewrite <- Hr, !Z.mul_add_distr_l; lia. }
      rewrite !(Z.mul_comm 4) in Hr'.
      apply Zmult_le_reg_r in Hr'; try lia.
      apply Zmult_le_reg_r in Hr'; try lia.
      (* r is positive *)
      assert (0 <= r' * Z_of_nat m)%Z as Hr''.
      { rewrite <- Hr; repeat apply Z.add_nonneg_nonneg; apply Z.square_nonneg. }
      apply Zmult_le_0_reg_r in Hr''.
      2:{ apply (inj_gt m 0); lia. }
      (* So r is a nat below m *)
      apply Z_of_nat_complete_inf in Hr''.
      destruct Hr'' as (r & ?); subst r'.
      apply Nat2Z.inj_le in Hr'.
      (* Let us show r is not m *)
      destruct (eq_nat_dec m r) as [ <- | Hr1 ].
      { (* Because r = m implies an absurdity *)
        (* first we show m = 2q and y1 ... y4 = +- q *)
        clear Hr'.
        apply f_equal with (f := fun i => (4*i)%Z) in Hr.
        rewrite !Z.mul_add_distr_l in Hr.
        apply bounded_upper_limit_4 in Hr; auto.
        destruct Hr as (F1 & F2 & F3 & F4).
        apply square_4_simpl in F1.
        destruct F1 as (q & Hq & F1).
        rewrite Hq in F2, F3, F4.
        apply square_4_simpl' in F2.
        apply square_4_simpl' in F3.
        apply square_4_simpl' in F4.
        (* then we show xi² = q² [4q²] *)
        subst m.
        assert (4*q*q <> 0) as Hq.
        { destruct q; simpl; try discriminate; lia. }
        apply half_modulus_lemma with (1 := E1) (Hm2 := Hq) in F1.
        apply half_modulus_lemma with (1 := E2) (Hm2 := Hq) in F2.
        apply half_modulus_lemma with (1 := E3) (Hm2 := Hq) in F3.
        apply half_modulus_lemma with (1 := E4) (Hm2 := Hq) in F4.
        (* thus 2q*p = m*p = x1²+...+x4² = 0 [4q²] *)
        assert (Z2Zp Hq (Z.of_nat (2 * q * p)) = Zp_zero Hq) as C.
        { rewrite H2, !Z2Zp_plus, F1, F2, F3, F4.
          rewrite <- !nat2Zp_plus.
          replace (q*q+q*q+q*q+q*q) with (4*q*q) by ring.
          rewrite nat2Zp_p; auto. }
        rewrite Z2Zp_of_nat in C.
        apply divides_nat2Zp in C.
        destruct C as (d & Hd).
        (* thus 2q divides p *)
        assert (divides (2*q) p) as C.
        { replace (d*(4*q*q)) with (2*q*(d*(2*q))) in Hd by ring.
          apply Nat.mul_cancel_l in Hd; try lia.
          exists d; auto. }
        (* Not possible because p is prime *)
        apply Hp in C; destruct C; try lia. }
      (* Let us show that r is not 0 *)
      destruct (eq_nat_dec r 0) as [ -> | Hr2 ].
      { (* all the yi are zero *)
        apply four_squares_zero in Hr.
        destruct Hr as (? & ? & ? & ?); subst y1 y2 y3 y4.
        (* xi² = 0 [ m² ] *)
        assert (Hm2 : m*m <> 0).
        { destruct m; simpl; try discriminate; lia. }
        rewrite Z2Zp_zero in E1; apply Zp_square_zero with (Hm2 := Hm2) in E1.
        rewrite Z2Zp_zero in E2; apply Zp_square_zero with (Hm2 := Hm2) in E2.
        rewrite Z2Zp_zero in E3; apply Zp_square_zero with (Hm2 := Hm2) in E3.
        rewrite Z2Zp_zero in E4; apply Zp_square_zero with (Hm2 := Hm2) in E4.
        (* mp = 0 [ m² ] *)
        assert (Z2Zp Hm2 (Z.of_nat (m*p)) = Zp_zero Hm2) as C.
        { rewrite H2, !Z2Zp_plus, E1, E2, E3, E4, !Zp_plus_zero; auto. }
        (* m divides p *)
        rewrite Z2Zp_of_nat in C.
        apply divides_nat2Zp in C.
        destruct C as (d & Hd).
        assert (divides m p) as C.
        { replace (d*(m*m)) with (m*(d*m)) in Hd by ring.
          apply Nat.mul_cancel_l in Hd; try lia.
          exists d; auto. }
        (* impossible because p is prime *)
        apply Hp in C.
        destruct C as [ C | C ]; lia. }
      (* Hence we have y1²+...+y4² = mr with 0 < r < m *)
      assert (0 < r < m) as Hk by lia.
      clear Hr' Hr1 Hr2 Q1 Q2 Q3 Q4.
      symmetry in Hr.
      rewrite <- Nat2Z.inj_mul in Hr.
      (* rpm² = a²+...+d² with m dividing a, b, c, d *)
      assert (exists a b c d, Z.of_nat (r*p*m*m) = four_squares a b c d%Z
                           /\ Z2Zp Hm a = Zp_zero Hm
                           /\ Z2Zp Hm b = Zp_zero Hm
                           /\ Z2Zp Hm c = Zp_zero Hm
                           /\ Z2Zp Hm d = Zp_zero Hm) as Q.
      { exists (x1 * y1 + x2 * y2 + x3 * y3 + x4 * y4)%Z,
               (x1 * y2 - x2 * y1 + x4 * y3 - x3 * y4)%Z,
               (x1 * y3 - x3 * y1 + x2 * y4 - x4 * y2)%Z,
               (x1 * y4 - x4 * y1 + x3 * y2 - x2 * y3)%Z; msplit 4.
        + rewrite <- (Euler_squares _ _ _ _ _ _ _ _ H2 Hr).
          rewrite <- Nat2Z.inj_mul; f_equal; ring.
        + rewrite !Z2Zp_plus, !Z2Zp_mult.
          rewrite <- E1, <- E2, <- E3, <- E4.
          rewrite <- !Z2Zp_mult, <- !Z2Zp_plus.
          rewrite <- H2, Nat2Z.inj_mul, Z2Zp_mult,
                  Z2Zp_of_nat, nat2Zp_p, Zp_mult_zero; auto.
        + repeat (rewrite !Z2Zp_minus || rewrite !Z2Zp_plus).
          rewrite !Z2Zp_mult.
          rewrite <- E1, <- E2, <- E3, <- E4.
          rewrite <- !Z2Zp_mult.
          repeat (rewrite <- !Z2Zp_minus || rewrite <- !Z2Zp_plus).
          rewrite <- Z2Zp_zero; f_equal; ring.
        + repeat (rewrite !Z2Zp_minus || rewrite !Z2Zp_plus).
          rewrite !Z2Zp_mult.
          rewrite <- E1, <- E2, <- E3, <- E4.
          rewrite <- !Z2Zp_mult.
          repeat (rewrite <- !Z2Zp_minus || rewrite <- !Z2Zp_plus).
          rewrite <- Z2Zp_zero; f_equal; ring.
        + repeat (rewrite !Z2Zp_minus || rewrite !Z2Zp_plus).
          rewrite !Z2Zp_mult.
          rewrite <- E1, <- E2, <- E3, <- E4.
          rewrite <- !Z2Zp_mult.
          repeat (rewrite <- !Z2Zp_minus || rewrite <- !Z2Zp_plus).
          rewrite <- Z2Zp_zero; f_equal; ring. }
      clear x1 x2 x3 x4 H2 H3 y1 E1 y2 E2 y3 E3 y4 E4 Hr.
      (* then we built a smaller solution *)
      destruct Q as (a & b & c & d & H & Ha & Hb & Hc & Hd).
      apply Z2Zp_zero_inv in Ha; destruct Ha as (x & ->).
      apply Z2Zp_zero_inv in Hb; destruct Hb as (y & ->).
      apply Z2Zp_zero_inv in Hc; destruct Hc as (z & ->).
      apply Z2Zp_zero_inv in Hd; destruct Hd as (w & ->).
      exists r; split; try lia.
      exists x, y, z, w.
      apply Z.mul_cancel_r with (p := Z.of_nat (m*m)).
      { intros E.
        apply Nat2Z.inj with (m := 0) in E.
        destruct m; try discriminate; lia. }
      rewrite <- Nat2Z.inj_mul, Nat.mul_assoc, H.
      rewrite Nat2Z.inj_mul; ring.
    Qed.

  End lagrange_prime_step.

  Let lagrange_prime_step m : 1 < m < p -> P m -> exists r, 1 <= r < m /\ P r.
  Proof.
    intros H1 (x1 & x2 & x3 & x4 & H2); apply lagrange_prime_step' with (3 := H2); lia.
  Qed.

  (* Now that P 1 holfs ie p is sum of 4 squares *)

  Lemma lagrange_prime : exists a b c d, Z.of_nat p = (a*a+b*b+c*c+d*d)%Z.
  Proof using Hp.
    replace p with (1*p) by lia; change (P 1).
    destruct (lagrange_prelim Hp) as (n & a & b & H1 & H2 & H3).
    cut (P n).
    + revert H2 H3; clear H1.
      induction on n as IH with measure n.
      intros H2 H3 H.
      destruct (le_lt_dec n 1) as [ | Hn ].
      * now replace 1 with n by lia.
      * destruct lagrange_prime_step with (2 := H) as (m & H4 & H5); auto.
        generalize H5; destruct H5; apply IH; auto; lia.
    + exists 0%Z, 1%Z, (Z.of_nat a), (Z.of_nat b).
      rewrite H1, !Nat2Z.inj_add, !Nat2Z.inj_mul.
      simpl Z.of_nat at 1; lia.
  Qed.

End lagrange_for_primes.

Section lagrange.

  Open Scope Z_scope.

  Theorem lagrange_theorem_nat : forall n, exists a b c d, Z.of_nat n = a*a+b*b+c*c+d*d.
  Proof.
    induction n as [ | | p Hp | x y Hx Hy ] using prime_rect.
    + exists 0, 0, 0, 0; auto.
    + exists 1, 0, 0, 0; auto.
    + apply lagrange_prime; auto.
    + destruct Hx as (a1 & b1 & c1 & d1 & H1).
      destruct Hy as (a2 & b2 & c2 & d2 & H2).
      subst.
      exists (a1*a2+b1*b2+c1*c2+d1*d2),
             (a1*b2-b1*a2+d1*c2-c1*d2),
             (a1*c2-c1*a2+b1*d2-d1*b2),
             (a1*d2-d1*a2+c1*b2-b1*c2).
      rewrite Nat2Z.inj_mul; apply Euler_squares; auto.
  Qed.

  (* An relative integer is positive iff it is the sum of four squares *)

  Corollary lagrange_theorem_Z n : 0 <= n <-> exists a b c d, n = a*a+b*b+c*c+d*d.
  Proof.
    split.
    + intros H.
      destruct Z_of_nat_complete with (1 := H) as (m & ->).
      apply lagrange_theorem_nat.
    + intros (a & b & c & d & ->).
      generalize (a*a) (b*b) (c*c) (d*d)
                 (Z.square_nonneg a) (Z.square_nonneg b)
                 (Z.square_nonneg c) (Z.square_nonneg d).
      intros; lia.
  Qed.

End lagrange.

(* Check lagrange_theorem_Z. *)


Lemma ex1: forall A B C:Prop, A/\(B/\C)->(A/\B)/\C.
Proof.
    intros A B C H.
    destruct H as [H1 Ht].
    destruct Ht as [H2 H3].
    split.
    split.
    assumption.
    assumption.
    assumption.
Qed.

Lemma ex2: forall A B C D: Prop,(A->B)/\(C->D)/\A/\C -> B/\D.
Proof.
    intros A B C D H.
    destruct H as [ab [cd [a c]]].
    split.
    apply ab.
    assumption.
    apply cd.
    assumption.
Qed.

Lemma ex3: forall A: Prop, ~(A/\~A).
Proof.
    intros a P.
    destruct P as [A NA].
    elim NA.
    assumption.
Qed.

Lemma ex4: forall A B C: Prop, A\/(B\/C)->(A\/B)\/C.
Proof.
    intros A B C H.
    destruct H as [H1 | [H2 | H3]].
    left; left.
    assumption.
    left; right.
    assumption.
    right.
    assumption.
Qed.

Lemma ex5: forall A B: Prop, (A\/B)/\~A -> B.
Proof.
    intros A B H.
    destruct H as [[H1 | H2] H3].
    elim H3.
    assumption.
    assumption.
Qed.

Lemma ex6: forall A:Type, forall P Q: A->Prop,
(forall x, P x)\/(forall y, Q y)->forall x, P x\/Q x.
Proof.
    intros A P Q H.
    destruct H as [H1 | H2].
    intros X.
    left.
    apply H1 with (x:=X).
    intros X.
    right.
    apply H2 with (y:=X).
Qed.


(* Correct Definition of φ *)

Require Import Utf8 Arith.
Import List List.ListNotations.
Require Import Misc Primes.
Require Import PTotient Primisc.

Definition coprimes n := filter (λ d, Nat.gcd n d =? 1) (seq 1 n).
Definition φ n := length (coprimes n).

Lemma coprimes_coprimes' :
    ∀ n, 2 ≤ n → coprimes n = coprimes' n.
Proof.
    intros. unfold coprimes, coprimes'.
    replace n with ((n - 1) + 1) at 1 by flia H.
    rewrite seq_app.
    replace (1 + (n - 1)) with n at 1 by flia H.
    rewrite filter_app. simpl.
    destruct (Nat.eqb_spec (Nat.gcd n n) 1).
    - rewrite Nat.gcd_diag in *. flia H e.
    - rewrite app_nil_r. reflexivity.
Qed.

Lemma φ_φ' :
    ∀ n, 2 ≤ n → φ n = φ' n.
Proof.
    intros. unfold φ, φ'.
    rewrite coprimes_coprimes' by flia H.
    reflexivity.
Qed.

Theorem prime_φ :
    ∀ p, prime p → φ p = p - 1.
Proof.
    intros.
    rewrite <- prime_φ' by assumption.
    apply φ_φ'. apply prime_ge_2. assumption.
Qed.

Theorem φ_multiplicative :
    ∀ m n,
        Nat.gcd m n = 1 →
        φ (m * n) = φ m * φ n.
Proof.
    intros.
    destruct (Nat.leb_spec 2 m).
    destruct (Nat.leb_spec 2 n).
    -   assert (2 ≤ m * n) by flia H0 H1.
        repeat rewrite φ_φ' by assumption.
        rewrite φ'_multiplicative by assumption.
        reflexivity.
    -   destruct n. rewrite Nat.gcd_0_r in H.
        flia H H0. replace n with 0 by flia H1.
        cbn. rewrite mult_1_r. rewrite mult_1_r.
        reflexivity.
    -   destruct m. rewrite Nat.gcd_0_l in H.
        rewrite mult_0_l. cbn. reflexivity.
        replace m with 0 by flia H0.
        rewrite mult_1_l. cbn. rewrite plus_0_r.
        reflexivity.
Qed.

Theorem prime_pow_φ :
    ∀ p, prime p →
        ∀ k, k ≠ 0 → φ (p ^ k) = p ^ (k - 1) * φ p.
Proof.
    intros.
    assert (2 ≤ p ^ k).
    {
        apply le_trans with p.
        apply prime_ge_2.
        assumption.
        rewrite <- Nat.pow_1_r at 1.
        apply Nat.pow_le_mono_r.
        apply prime_ge_2 in H. flia H.
        flia H0.
    }
    rewrite φ_φ' by assumption.
    rewrite prime_pow_φ' by assumption.
    rewrite φ_φ'. reflexivity.
    apply prime_ge_2. assumption.
Qed.


Print negb.

Theorem negb_involutive : forall b : bool,
    negb (negb b) = b.
Proof.
  intros. destruct b as [|] eqn:E.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Print andb.
Theorem andb_commutative : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b eqn:E.
  - destruct c eqn:E1.
    + reflexivity.
    + reflexivity.
  - destruct c eqn:E1.
    + reflexivity.
    + reflexivity.
Qed.

Theorem andb3_exchange :
  forall b c d, andb (andb b c) d = andb (andb b d) c.
Proof.
  intros b c d. destruct b eqn: Eb.
  - destruct c eqn: Ec.
    { destruct d eqn: Ed.
      - reflexivity.
      - reflexivity. }
    { destruct d eqn: Ed.
      - reflexivity.
      - reflexivity. }
  - destruct c eqn: Ec.
    { destruct d eqn: Ed.
      - reflexivity.
      - reflexivity. }
    { destruct d eqn: Ed.
      - reflexivity.
      - reflexivity. }
Qed.


(* http://qnighy.github.io/coqex2014/ex2.html *)
Require Import Arith.

Goal forall x y, x < y -> x + 10 < y + 10.
Proof.
  intros.
  apply plus_lt_compat_r.
  apply H.
Qed.

Goal forall P Q : nat -> Prop, P 0 -> (forall x, P x -> Q x) -> Q 0.
Proof.
  intros.
  apply H0.
  apply H.
Qed.

Goal forall P : nat -> Prop, P 2 -> (exists y, P (1 + y)).
Proof.
  intros.
  exists 1.
  apply H.
Qed.

Goal forall P : nat -> Prop, (forall n m, P n -> P m) -> (exists p, P p) -> forall q, P q.
Proof.
  intros.
  destruct H0.
  apply (H x q).
  apply H0.
Qed.

Require Import Arith.
Goal forall m n : nat, (n * 10) + m = (10 * n) + m.
Proof.
  intros.
  assert (n * 10 = 10 * n).
  apply Nat.mul_comm.
  rewrite H.
  reflexivity.
Qed.

Goal forall n m p q : nat, (n + m) + (p + q) = (n + p) + (m + q).
Proof.
  intros.
  apply Nat.add_shuffle1.
Qed.

Goal forall n m : nat, (n + m) * (n + m) = n * n + m * m + 2 * n * m.
Proof.
  intros.
  assert ((n + m) * (n + m) = n * (n + m) + m * (n + m)).
  apply (Nat.mul_add_distr_r n m (n + m)).
  rewrite H.
  assert (n * (n + m) = n * n + n * m).
  apply (Nat.mul_add_distr_l n n m).
  assert (m * (n + m) = m * n + m * m).
  apply (Nat.mul_add_distr_l m n m).
  rewrite H0.
  rewrite H1.
  assert (m * n + m * m = m * m + m * n).
  apply Nat.add_comm.
  rewrite H2.
  assert (n * n + n * m + (m * m + m * n) = n * n + m * m + (n * m + m * n)).
  apply Unnamed_thm4.
  rewrite H3.
  assert (n * m + m * n = n * m + n * m).
  assert (m * n = n * m).
  apply Nat.mul_comm.
  rewrite H4.
  reflexivity.
  rewrite H4.
  assert ((n + n) * m = n * m + n * m).
  apply Nat.mul_add_distr_r.
  rewrite <- H5.
  simpl.
  assert (n + n + 0 = n + (n + 0)).
  apply (plus_assoc_reverse n n 0).
  rewrite <- H6.
  assert (n + n + 0 = n + n).
  apply (Nat.add_0_r (n + n)).
  rewrite H7.
  reflexivity.
Qed.

Parameter G : Set.
Parameter mult : G -> G -> G.
Notation "x * y" := (mult x y).
Parameter one : G.
Notation "1" := one.
Parameter inv : G -> G.
Notation "/ x" := (inv x).
(* Notation "x / y" := (mult x (inv y)). *) (* 使ってもよい *)

Axiom mult_assoc : forall x y z, x * (y * z) = (x * y) * z.
Axiom one_unit_l : forall x, 1 * x = x.
Axiom inv_l : forall x, /x * x = 1.

Lemma inv_r : forall x, x * / x = 1.
Proof.
  intros.
  assert (//x * /x = 1).
  apply (inv_l (/ x)).
  assert (//x * /x * x = //x * (/x * x)).
  rewrite <- (mult_assoc (//x) (/x) x).
  reflexivity.
  rewrite H in H0.
  rewrite inv_l in H0.
  rewrite one_unit_l in H0.
  assert (//x * (1 * /x) = 1).
  rewrite one_unit_l.
  apply H.
  rewrite mult_assoc in H1.
  rewrite <- H0 in H1.
  apply H1.
Qed.

Lemma one_unit_r : forall x, x * 1 = x.
Proof.
  intros.
  rewrite <- (inv_l x).
  rewrite mult_assoc.
  rewrite inv_r.
  rewrite one_unit_l.
  reflexivity.
Qed.