Require Export ZArith.
Require Export List.
Require Export Arith.

Section bad_proof_example_for_Induction1.

 Theorem le_plus_minus' : forall n m:nat, m <= n -> n = m+(n-m).
 Proof.
  intros n m H;  induction n.
  -   rewrite <- le_n_O_eq with (1 := H); simpl; trivial.
  - (* dead end *)
    Abort.

End bad_proof_example_for_Induction1.

Theorem lazy_example : forall n:nat, (S n) + 0 = S n.
Proof.
 intros n; lazy beta iota zeta delta.
 fold plus.
 rewrite plus_0_r; reflexivity.
Qed.

Hint Extern 4 (_ <> _) => discriminate : core.

Hint Resolve le_S_n : le_base.

Theorem auto_le_example :
 forall n m:nat, S (S (S n)) <= S (S (S m)) ->  n <= m.
Proof.
  intros n m H.
  auto with le_base.
Qed.

Lemma unprovable_le : forall n m:nat, n <= m.
Proof.
 Time auto with arith.
 Time auto with le_base arith.
Abort.

Section bad_proof_for_auto.

 Section Trying_auto.
  Variable l1 : forall n m:nat, S n <= S m -> n <= m.

  Theorem unprovable_le2 : forall n m:nat, n <= m.
  Proof.
   Time auto with arith.
   Time try (clear l1; auto with arith; fail).
  Abort.

 End Trying_auto.

End bad_proof_for_auto.

Section combinatory_logic.

Variables (CL:Set)(App:CL->CL->CL)(S:CL)(K:CL).
Hypotheses
  (S_rule :
   forall A B C:CL, App (App (App S A) B) C = App (App A C)(App B C))
  (K_rule :
   forall A B:CL, App (App K A) B = A).

Hint Rewrite  S_rule K_rule : CL_rules.

Theorem obtain_I : forall A:CL, App (App (App S K) K) A = A.
Proof.
 intros; autorewrite with CL_rules.
 reflexivity.
Qed.

End combinatory_logic.

Theorem example_for_subst :
  forall (a b c d:nat), a = b+c -> c = 1 -> a+b = d -> 2*a = d+c.
Proof.
 intros a b c d H H1 H2.
 subst a.
 subst.
 lazy delta [mult] iota zeta beta;
  rewrite  plus_0_r;
  repeat rewrite plus_assoc_reverse;
   trivial.
Qed.

Open Scope Z_scope.

Theorem ring_example1 : forall x y:Z, (x+y) * (x+y)=x*x + 2*x*y + y*y.
Proof.
 intros x y; ring.
Qed.

Definition square (z:Z) := z*z.

Theorem ring_example2 :
  forall x y:Z, square (x+y) = square x + 2*x*y + square y.
Proof.
 intros x y; unfold square; ring.
Qed.

Theorem ring_example3 :
  (forall x y:nat, (x+y)*(x+y) = x*x + 2*x*y + y*y)%nat.
Proof.
 intros x y; ring.
Qed.

Theorem ring_example4 :
 (forall x:nat, (S x)*(x+1) = x*x + (x+x+1))%nat.
Proof.
 intro x; ring_simplify.
 trivial.
Qed.

Require Omega.

Theorem omega_example1 :
 forall x y z t:Z, x <= y <= z /\  z <= t <= x -> x = t.
Proof.
 intros x y z t H; omega.
Qed.

Theorem omega_example2 :
 forall x y:Z,
    0 <= square x -> 3*(square x) <= 2*y -> square x <= y.
Proof.
 intros x y H H0; omega.
Qed.

Theorem omega_example3 :
 forall x y:Z,
   0 <= x*x -> 3*(x*x) <= 2*y -> x*x <= y.
Proof.
 intros x y H H0; omega.
Qed.

Check (fun (X y:Z) => 0 <= X -> 3*X <= 2*y  ->  X < y).

Require Export Reals.

Open Scope R_scope.

Theorem example_for_field : forall x y:R, y <> 0 ->(x+y) / y = 1  +(x/y).
Proof.
  intros x y H; field.
  assumption.
Qed.

Require Import Fourier.

Theorem example_for_Fourier : forall x y:R, x-y >1 -> x - 2*y < 0 -> x > 1.
Proof.
  intros x y H H0.
  fourier.
Qed.

Theorem ex_tauto1 : forall A B:Prop, A/\B->A.
Proof.
 tauto.
Qed.

Theorem ex_tauto2 : forall A B:Prop, A/\~A -> B.
Proof.
 tauto.
Qed.

Open Scope Z_scope.
Theorem ex_tauto3 : forall x y:Z, x<=y -> ~(x<=y) -> x=3.
Proof.
 tauto.
Qed.

Theorem ex_tauto4 : forall A B:Prop, A\/B -> B\/A.
Proof.
 tauto.
Qed.

Theorem ex_tauto5 :
 forall A B C D:Prop, (A->B)\/(A->C)->A->(B->D)->(C->D)->D.
Proof.
 tauto.
Qed.

Open Scope nat_scope.

Theorem example_intuition :
  (forall n p q:nat,  n <= p \/ n <= q -> n <= p \/ n <= S q).
Proof.
 intros n p q; intuition auto with arith.
Qed.

Ltac autoClear h := try (clear h; auto with arith; fail).

Ltac autoAfter tac := try (tac; auto with arith; fail).

Open Scope nat_scope.

Theorem example_for_autoAfter : forall  n p:nat,
   n < p -> n <= p -> 0 < p -> S n < S p.
Proof.
 intros n p H H0 H1.
 autoAfter ltac:(clear H0 H1).
Qed.

Open Scope nat_scope.

Ltac le_S_star := apply le_n || (apply le_S; le_S_star).

Theorem le_5_25 : 5 <= 25.
Proof.
 le_S_star.
Qed.

Ltac contrapose H :=
  match goal with
  | id:(~_) |- (~_) => intro H; apply id
  end.

Theorem example_contrapose :
  forall x y:nat, x <> y -> x <= y -> ~y <= x.
Proof.
 intros x y H H0.
 contrapose H'.
 auto with arith.
Qed.

Section primes.

 Definition divides (n m:nat) := exists p:nat, p*n = m.

 Lemma divides_O : forall n:nat, divides n 0.
 Admitted. (** Left as an exercise, as well as the next 6 lemmas  *)

 Lemma divides_plus : forall n m:nat, divides n m -> divides n (n+m).
 Admitted.

 Lemma not_divides_plus : forall n m:nat, ~divides n m -> ~divides n (n+m).
 Admitted.

 Lemma not_divides_lt : forall n m:nat, 0<m -> m<n -> ~divides n m.
 Admitted.

 Lemma not_lt_2_divides : forall n m:nat, n<>1 -> n<2 -> 0 < m -> ~divides n m.
 Admitted.

 Lemma le_plus_minus : forall n m:nat, le n m -> m = n+(m-n).
 Admitted.

 Lemma lt_lt_or_eq : forall n m:nat, n < S m ->  n<m \/ n=m.
 Admitted.

 Ltac check_not_divides :=
   match goal with
   | |- (~divides ?X1 ?X2) =>
       cut (X1<=X2);[ idtac | le_S_star ]; intros Hle;
        rewrite (le_plus_minus _ _ Hle); apply not_divides_plus;
        simpl; clear Hle; check_not_divides
   | |- _ => apply not_divides_lt; unfold lt; le_S_star

  end.
Open Scope nat_scope.

Hint Resolve lt_O_Sn.

Ltac check_lt_not_divides :=
  match goal with
  | Hlt:(lt ?X1 2%nat) |- (~divides ?X1 ?X2) =>
      apply not_lt_2_divides; auto
  | Hlt:(lt ?X1 ?X2) |- (~divides ?X1 ?X3) =>
      elim (lt_lt_or_eq _ _ Hlt);
       [clear Hlt; intros Hlt; check_lt_not_divides
        | intros Heq; rewrite Heq; check_not_divides]
  end.

Definition is_prime (p:nat) : Prop :=
   forall n:nat, n <> 1 -> lt n p -> ~divides n p.

Theorem prime37 : is_prime 37.
Proof.
 unfold is_prime; intros.
 check_lt_not_divides.
Time Qed.

End primes.

Ltac clear_all :=
  match goal with
  | id:_ |- _ => clear id; clear_all
  | |- _ => idtac
  end.

Theorem clear_example_thm :
  forall (x y z:nat), x<z->z=2*x->0<x->x=2*y->y<z->x>y.
Proof.
 intros x y z H H1 H2 H3.
 generalize H1 H2 H3; clear_all; intros; omega.
Qed.

Theorem S_to_plus_one : forall n:nat, S n = n+1.
Proof.
  intros; rewrite plus_comm; reflexivity.
Qed.

Ltac S_to_plus_simpl :=
  match goal with
  | |-  context [(S ?X1)] =>
      match X1 with
      | 0%nat => fail 1
      | ?X2 => rewrite (S_to_plus_one X2); S_to_plus_simpl
      end
  | |- _ => idtac
  end.

Ltac a_function X1 :=
        match X1 with
      | 0%nat => fail 1
      | ?X2 => rewrite (S_to_plus_one X2); S_to_plus_simpl
      end.

Ltac simpl_on e :=
  let v := eval simpl in e in
  match goal with
  | |- context [e] => replace e with v; [idtac | auto]
  end.

Theorem simpl_on_example :
  forall n:nat, exists m : nat, (1+n) + 4*(1+n) = 5*(S m).
Proof.
  intros n; simpl_on (1+n).
  exists n; auto with arith.
Qed.


Theorem plus_O_n : forall n : nat, 0 + n = n.
Proof.
  intros n. simpl. reflexivity.  Qed.

Theorem plus_O_n' : forall n : nat, 0 + n = n.
Proof.
  intros n. reflexivity. Qed.

Theorem plus_1_l : forall n:nat, 1 + n = S n.
Proof.
  intros n. reflexivity.  Qed.

Theorem mult_0_l : forall n:nat, 0 * n = 0.
Proof.
  intros n. reflexivity.  Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Sebastien Hinderer, 2004-05-20
- Frederic Blanqui, 2005-02-25

Ring equipped with a decidable strict ordering.
*)

Require Import Ring RingType1 RelUtil LogicUtil VecUtil Setoid BoolUtil
  Wellfounded Morphisms RelExtras1.

(***********************************************************************)
(** Module type for building the theory module of an ordered ring *)

Class OrdRing := {
  (*o_ring :> Ring;*)
  o_ring :> Ring;
  o_gt : s_typ -> s_typ -> Prop;
  o_gt_trans : transitive o_gt;
  o_gt_irrefl : irreflexive o_gt;
  o_bgt : s_typ -> s_typ -> bool;
  o_bgt_ok : forall x y, o_bgt x y = true <-> o_gt x y;
  o_one_gt_zero : o_gt ring_A1 ring_A0;
  o_add_gt_mono_r : forall x y z, o_gt x y -> o_gt (ring_Aplus x z) (ring_Aplus y z);
  o_mul_gt_mono_r : forall x y z, o_gt z ring_A0 -> o_gt x y -> o_gt (ring_Amult x z) (ring_Amult y z)
}.

(***********************************************************************)
(* Integers as an order ring *)

Require Import ZArith.

Definition gtA_dec := Z_gt_dec.

Definition bgtA x y :=
  match gtA_dec x y with
    |left _ => true
    |right _ => false
  end.

Instance Z_as_OrdRing : OrdRing.

Proof.
  apply Build_OrdRing with
  (o_ring := Int_as_Ring)
  (o_gt := Zgt)(o_bgt:= bgtA).
  exact Zcompare_Gt_trans.
  intros n H. apply (Zgt_asym n n H H).
  intros. unfold bgtA. case (gtA_dec x y); intuition.
  simpl. omega. simpl. intros. omega.
  simpl.  intros x y z H H0. destruct z. contradiction (Zgt_irrefl 0).
  rewrite (Zmult_comm x); rewrite (Zmult_comm y).
  unfold Zgt in |- *; rewrite Zcompare_mult_compat; hyp.
  discr.
Defined.

(***********************************************************************)
(**Rational numbers as an order ring *)

Require Import QArith.

Definition Qgt x y := Qlt y x.

Definition Q_gt_dec x y : {x > y} + {~ x > y}.
Proof.
  unfold Qlt in |- *. intros.
  exact (Z_lt_dec (Qnum y * QDen x) (Qnum x * QDen y)).
Defined.

Definition Qgt_dec := Q_gt_dec.

Definition Qbgt x y :=
  match Qgt_dec x y with
    |left _ => true
    |right _ => false
  end.

Instance Q_as_OrdRing : OrdRing.

Proof.
  apply Build_OrdRing with
  (o_ring := Q_as_Ring)(o_gt:=Qgt)
  (o_bgt:= Qbgt). (* FIXME *)


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2019   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.

Section Exponentiation.

(* Why3 goal *)
Variable t : Type.
Hypothesis t_WhyType : WhyType t.
Existing Instance t_WhyType.

(* Why3 goal *)
Variable one: t.

(* Why3 goal *)
Variable infix_as: t -> t -> t.

(* Why3 goal *)
Hypothesis Assoc :
  forall (x:t) (y:t) (z:t),
  ((infix_as (infix_as x y) z) = (infix_as x (infix_as y z))).

(* Why3 goal *)
Hypothesis Unit_def_l : forall (x:t), ((infix_as one x) = x).

(* Why3 goal *)
Hypothesis Unit_def_r : forall (x:t), ((infix_as x one) = x).

(* Why3 goal *)
Definition power : t -> Numbers.BinNums.Z -> t.
intros x n.
exact (iter_nat (Zabs_nat n) t (fun acc => infix_as x acc) one).
Defined.

(* Why3 goal *)
Lemma Power_0 : forall (x:t), ((power x 0%Z) = one).
Proof.
easy.
Qed.

(* Why3 goal *)
Lemma Power_s :
  forall (x:t) (n:Numbers.BinNums.Z), (0%Z <= n)%Z ->
  ((power x (n + 1%Z)%Z) = (infix_as x (power x n))).
Proof.
intros x n h1.
unfold power.
fold (Zsucc n).
now rewrite Zabs_nat_Zsucc.
Qed.

(* Why3 goal *)
Lemma Power_s_alt :
  forall (x:t) (n:Numbers.BinNums.Z), (0%Z < n)%Z ->
  ((power x n) = (infix_as x (power x (n - 1%Z)%Z))).
Proof.
intros x n h1.
rewrite <- Power_s; auto with zarith.
f_equal; omega.
Qed.

(* Why3 goal *)
Lemma Power_1 : forall (x:t), ((power x 1%Z) = x).
Proof.
exact Unit_def_r.
Qed.

(* Why3 goal *)
Lemma Power_sum :
  forall (x:t) (n:Numbers.BinNums.Z) (m:Numbers.BinNums.Z), (0%Z <= n)%Z ->
  (0%Z <= m)%Z -> ((power x (n + m)%Z) = (infix_as (power x n) (power x m))).
Proof.
intros x n m Hn Hm.
revert n Hn.
apply natlike_ind.
apply sym_eq, Unit_def_l.
intros n Hn IHn.
replace (Zsucc n + m)%Z with ((n + m) + 1)%Z by ring.
rewrite Power_s by auto with zarith.
rewrite IHn.
now rewrite <- Assoc, <- Power_s.
Qed.

(* Why3 goal *)
Lemma Power_mult :
  forall (x:t) (n:Numbers.BinNums.Z) (m:Numbers.BinNums.Z), (0%Z <= n)%Z ->
  (0%Z <= m)%Z -> ((power x (n * m)%Z) = (power (power x n) m)).
Proof.
intros x n m Hn Hm.
revert m Hm.
apply natlike_ind.
now rewrite Zmult_0_r, 2!Power_0.
intros m Hm IHm.
replace (n * Zsucc m)%Z with (n + n * m)%Z by ring.
rewrite Power_sum by auto with zarith.
rewrite IHm.
now rewrite <- Power_s.
Qed.

(* Why3 goal *)
Lemma Power_comm1 :
  forall (x:t) (y:t), ((infix_as x y) = (infix_as y x)) ->
  forall (n:Numbers.BinNums.Z), (0%Z <= n)%Z ->
  ((infix_as (power x n) y) = (infix_as y (power x n))).
Proof.
intros x y comm.
apply natlike_ind.
now rewrite Power_0, Unit_def_r, Unit_def_l.
intros n Hn IHn.
unfold Zsucc.
rewrite (Power_s _ _ Hn).
rewrite Assoc.
rewrite IHn.
rewrite <- Assoc.
rewrite <- Assoc.
now rewrite comm.
Qed.

(* Why3 goal *)
Lemma Power_comm2 :
  forall (x:t) (y:t), ((infix_as x y) = (infix_as y x)) ->
  forall (n:Numbers.BinNums.Z), (0%Z <= n)%Z ->
  ((power (infix_as x y) n) = (infix_as (power x n) (power y n))).
Proof.
intros x y comm.
apply natlike_ind.
rewrite 3!Power_0.
now rewrite Unit_def_r.
intros n Hn IHn.
unfold Zsucc.
rewrite 3!(Power_s _ _ Hn).
rewrite IHn.
rewrite <- Assoc.
rewrite (Assoc x).
rewrite <- (Power_comm1 _ _ comm _ Hn).
now rewrite <- 2!Assoc.
Qed.

End Exponentiation.


From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

(* Here we define a more verbose notation for projections of pairs... *)
Section Pair.

  Context {A B: Type}.
  Variable p: A * B.
  Definition pair_1st := fst p.
  Definition pair_2nd := snd p.

End Pair.

(* ...and triples. *)
Section Triple.

  Context {A B C: Type}.
  Variable p: A * B * C.
  Definition triple_1st (p: A * B * C) := fst (fst p).
  Definition triple_2nd := snd (fst p).
  Definition triple_3rd := snd p.

End Triple.

(* Define a wrapper from an element to a singleton list. *)
Definition make_sequence {T: Type} (opt: option T) :=
  match opt with
    | Some j => [:: j]
    | None => [::]
  end.

(* Next we define a notation for the big concatenation operator.*)

Reserved Notation "\cat_ ( m <= i < n ) F"
  (at level 41, F at level 41, i, m, n at level 50,
   format "'[' \cat_ ( m <= i < n ) '/ ' F ']'").

Notation "\cat_ ( m <= i < n ) F" :=
  (\big[cat/[::]]_(m <= i < n) F%N) : nat_scope.

Reserved Notation "\cat_ ( m <= i < n | P ) F"
  (at level 41, F at level 41, P at level 41, i, m, n at level 50,
   format "'[' \cat_ ( m <= i < n | P ) '/ ' F ']'").

Notation "\cat_ ( m <= i < n | P ) F" :=
  (\big[cat/[::]]_(m <= i < n | P) F%N) : nat_scope.

Reserved Notation "\cat_ ( i < n ) F"
  (at level 41, F at level 41, i, n at level 50,
   format "'[' \cat_ ( i < n ) '/ ' F ']'").

Notation "\cat_ ( i < n ) F" :=
  (\big[cat/[::]]_(i < n) F%N) : nat_scope.

Reserved Notation "\cat_ ( i < n | P ) F"
  (at level 41, F at level 41, i, n at level 50,
   format "'[' \cat_ ( i < n | P ) '/ ' F ']'").

Notation "\cat_ ( i < n | P ) F" :=
  (\big[cat/[::]]_(i < n | P) F%N) : nat_scope.

(* Let's define big operators for lists of pairs. *)

Reserved Notation "\sum_ ( ( m , n ) <- r ) F"
  (at level 41, F at level 41, m, n at level 50,
   format "'[' \sum_ ( ( m , n ) <- r ) '/ ' F ']'").

Notation "\sum_ ( ( m , n ) <- r ) F" :=
  (\sum_(i <- r) (let '(m,n) := i in F)) : nat_scope.

Reserved Notation "\sum_ ( ( m , n ) <- r | P ) F"
  (at level 41, F at level 30, P at level 41, m, n at level 50,
   format "'[' \sum_ ( ( m , n ) <- r | P ) '/ ' F ']'").

Notation "\sum_ ( ( m , n ) <- r | P ) F" :=
  (\sum_(i <- r | (let '(m,n) := i in P))
    (let '(m,n) := i in F)) : nat_scope.

Reserved Notation "\max_ ( ( m , n ) <- r ) F"
  (at level 41, F at level 41, m, n at level 50,
   format "'[' \max_ ( ( m , n ) <- r ) '/ ' F ']'").

Notation "\max_ ( ( m , n ) <- r ) F" :=
  (\max_(i <- r) (let '(m,n) := i in F)) : nat_scope.

Reserved Notation "\max_ ( ( m , n ) <- r | P ) F"
  (at level 41, F at level 30, P at level 41, m, n at level 50,
   format "'[' \max_ ( ( m , n ) <- r | P ) '/ ' F ']'").

Notation "\max_ ( ( m , n ) <- r | P ) F" :=
  (\max_(i <- r | (let '(m,n) := i in P))
    (let '(m,n) := i in F)) : nat_scope.

Notation "[ 'pairs' ( x , y ) <- s | C ]" :=
  (filter (fun i => let '(x,y) := i in C%B) s)
 (at level 0, x at level 99,
  format "[ '[hv' 'pairs' ( x , y ) <- s '/ ' | C ] ']'") : seq_scope.

Notation "[ 'pairs' ( E , F ) | x <- s ]" :=
    (map (fun y => ((fun x1 => let x := x1 in E) y, (fun x2 => let x := x2 in F) y)) s)
  (at level 0, E at level 1, F at level 1,
   format "[ '[hv' 'pairs' ( E , F )  |  x  <-  s ] ']'") : seq_scope.

(* In case we use an (option list T), we can define membership
   without having to match the option type. *)
Reserved Notation "x \In A"
  (at level 70, format "'[hv' x '/ ' \In A ']'", no associativity).
Notation "x \In A" :=
  (if A is Some B then in_mem x (mem B) else false) : bool_scope.


(** ** auto

まず、forall (P : Prop), P -> P という命題を例として考えます。
この命題は auto 一発で証明できます。
*)

Goal forall (P : Prop), P -> P.
Proof.
  auto.

(** ここで No more subgoals. と表示されて、証明できたことがわかります。
構築された証明項は Show Proof というコマンドで表示できます。*)
  Show Proof.
(**
<<
(fun (P : Prop) (H : P) => H)
>>
*)
(** Show Proof とすると私の環境 (CoqIDE) では以下のように表示されます。
<<
(fun (P : Prop) (H : P) => H)
>>

(fun (P : Prop) (H : P) => H) は Gallina の式です。
Gallina というのは Coq に組み込まれている ML のような言語で、
ここで使っているように証明項にも用いますし、
Gallina で直接プログラムを書くこともあります。

(fun (P : Prop) (H : P) => ...) というのは
Gallina の関数抽象で、カリー化されているのでじつは
(fun (P : Prop) => (fun (H : P) => ...)) と同じものです。
関数型言語を知っていればだいたいわかるとは思いますが、
(fun (P : Prop) => ...) は Prop 型の値 P を受け取って ... の部分を返す関数抽象です。

Prop というのは命題の型です。
ですから、Prop 型の値である P は命題です。
というわけでカリーハワード対応により P は型でもあります。
ですが、このように型を普通の引数として受け取るのはちょっと見慣れない形かもしれません。
Gallina では型も普通に引数として
受けとることができ、受け取った型はそれ以降の引数の型などに使うことができます。

(fun (P : Prop) (H : P) => H) は、
プログラムの世界の言葉で表現するなら、
Prop 型の値Pを受け取り、P型の値Hを受け取り、Hを返す関数です。
証明の世界の言葉で表現するなら、
命題Pを受け取り、Pの証明Hを受け取り、Hを返す関数です。
そのような関数が存在することが、forall (P : Prop), P -> P の証明である、ということです。

*)
Qed.

(* xxx: ここで説明する必然性はない
証明を終えるとき、Qed は証明項があらためて正しいかどうか
（ちゃんと正しい型がつく項になっているかどうか）
あらためて検査します。
そのため、怪しげなユーザ拡張の tactic が変な証明項を生成しても、
そのような証明はQedの段階で拒否されます。
*)

(** ところで、Qed としたときに Unnamed_thm is defined と表示されます。
つまり、Unnamed_thm という定理が定義された、ということですが、
もちろん、後で使いたい定理にこういう内容に関係ない名前をつけるのはよくありません。
自分で定理に名前をつけるときには Goal ではなく Lemma や Theorem で証明を始めます。
Lemmaというのは補題で、Theoremというのは定理ですが、
機能的な違いはとくにありません。ここでは常に Lemma をつかうことにします。
*)

Lemma LemmaPP: forall (P : Prop), P -> P.
(** 証明しようとしているのは上と同じく forall (P : Prop), P -> P という命題であり、
これはその証明に LemmaPP という名前をつけよう、という指定です。
*)
Proof. auto. Qed.

Print LemmaPP.
(** 証明が終った後、Print LemmaPP とすると以下のように表示されます。
<<
LemmaPP = fun (P : Prop) (H : P) => H
     : forall P : Prop, P -> P
>>
これは、LemmaPP の値は fun (P : Prop) (H : P) => H という値であり、
その型は forall P : Prop, P -> P である、という意味です。
プログラムの世界で解釈すれば、まさに LemmaPP という定数は
構築した証明項を値として定義されている、
というわけです。
*)


Require Import List.
Require Import Omega.
Require Import LibUtils.

Require Import ListAdd.

Section Vector.

  Definition Vector (T:Type) (n : nat) := {n':nat | n' < n}%nat -> T.
  Definition Matrix (T:Type) (n m : nat) :=
    {n':nat | n' < n}%nat -> {m':nat | m' < m}%nat -> T.

  Definition ConstVector {T} (n:nat) (c:T) : (Vector T n) :=
    fun (n': {n':nat | n' < n}%nat) => c.
  Definition ConstMatrix {T} (n m : nat) (c:T) : (Matrix T n m) :=
    fun (n': {n':nat | n' < n}%nat) (m':{m':nat | m' < m}%nat) => c.

(*  Definition vector_fold_right1_bounded_dep {A:nat->Type} {B}
             (f:forall n,B->A n->A (S n)) (init:A 0%nat) (singleton:B->A 1%nat) {m:nat}
             (v:Vector B m) (n:nat) (pf:(n<=m)%nat) {struct n}
    : A n.
  Proof.
    destruct n.
    - exact init.
    - specialize (vector_fold_right1_bounded_dep A B f init singleton m v n (le_Sn_le _ _ pf)).
      destruct n; intros.
      + exact (singleton (v (exist _ 0 pf)%nat)).
      + apply f.
        * exact (v (exist _ n (le_Sn_le _ _ pf))).
        * exact vector_fold_right1_bounded_dep.
  Defined.c
*)

  Fixpoint vector_fold_right1_bounded_dep {A:nat->Type} {B}
           (f:forall n,B->A n->A (S n)) (init:A 0%nat) (singleton:B->A 1%nat) {m:nat}
           (v:Vector B m) (bound:nat) {struct bound}
    : (bound <= m)%nat -> A bound :=
    match bound as bound' return (bound' <= m -> A bound') with
    | 0 => fun _ =>
             init
    | S bound1 =>
      fun pf0 : S bound1 <= m =>
        let an := vector_fold_right1_bounded_dep f init singleton v bound1 (le_Sn_le bound1 m pf0) in

        match bound1 as bound1' return (A bound1' -> S bound1' <= m -> A (S bound1')) with
        | 0 => fun (_ : A 0) (pf1 : 1 <= m) =>
                 singleton (v (exist _ 0 pf1))
        | S bound2 => fun (an' : A (S bound2)) (pf1 : S (S bound2) <= m) =>
                        f (S bound2) (v (exist _ bound1 pf0)) an'
        end an pf0
    end.

  Definition vector_fold_right_bounded_dep {A:nat->Type} {B}
               (f:forall n,B->A n->A (S n)) (init:A 0%nat) {m:nat} (v:Vector B m) (n:nat)
               (pf:(n<=m)%nat)
      : A n.
    Proof.
      induction n.
      - exact init.
      - apply f.
        + exact (v (exist _ n pf)).
        + apply IHn.
          exact (le_Sn_le _ _ pf).
    Defined.

  Definition vnil {T} : Vector T 0.
  Proof.
    intros [i pf].
    omega.
  Defined.

  Definition vcons {T} {n} (x:T) (v:Vector T n) : (Vector T (S n)).
  Proof.
    intros [i pf].
    destruct (Nat.eq_dec i n).
    + exact x.
    + apply v.
      exists i.
      apply NPeano.Nat.le_neq.
      split; trivial.
      now apply le_S_n in pf.
  Defined.

  Definition vhd {T} {n} (v:Vector T (S n)) : T := v (exist _ (0%nat) (Nat.lt_0_succ n)).
  Definition vlast {T} {n} (v:Vector T (S n)) : T := v (exist _ (n%nat) (Nat.lt_succ_diag_r n)).

  Definition vdrop_last {T} {n} (v:Vector T (S n)) : Vector T n.
  Proof.
    intros [i pf]; apply v.
    exists i.
    apply NPeano.Nat.lt_lt_succ_r; trivial.
  Defined.

  Lemma vector_fold_right1_bounded_dep_as_vector_fold_right_bounded_dep {A:nat->Type} {B}
           (f:forall n,B->A n->A (S n)) (init:A 0%nat) (singleton:B->A 1%nat) {m:nat}
           (v:Vector B m) (bound:nat) pf
    :
      (forall x, singleton x = f _ x init) ->
        vector_fold_right1_bounded_dep f init singleton v bound pf =
        vector_fold_right_bounded_dep f init v bound pf.
  Proof.
    intros feq.
    unfold vector_fold_right_bounded_dep.
    induction bound; simpl; trivial.
    rewrite IHbound.
    destruct bound; simpl; auto.
  Qed.

  Lemma vector_fold_right_bounded_dep_as_vector_fold_right1_bounded_dep {A:nat->Type} {B}
        (f:forall n,B->A n->A (S n)) (init:A 0%nat) {m:nat}
        (v:Vector B m) (bound:nat) pf
    :
      vector_fold_right_bounded_dep f init v bound pf =
      vector_fold_right1_bounded_dep f init (fun x => f 0 x init) v bound pf.
  Proof.
    unfold vector_fold_right_bounded_dep.
    induction bound; simpl; trivial.
    rewrite IHbound.
    destruct bound; simpl; auto.
  Qed.

  Definition vector_fold_right1_dep {A:nat->Type} {B} (f:forall n, B->A n->A (S n))
             (init:A 0%nat) (singleton:B->A 1%nat) {m:nat} (v:Vector B m) : A m
    := vector_fold_right1_bounded_dep f init singleton v m (le_refl _).

  Definition vector_fold_right_dep {A:nat->Type} {B} (f:forall n, B->A n->A (S n))
             (init:A 0%nat) {m:nat} (v:Vector B m) : A m
    := vector_fold_right_bounded_dep f init v m (le_refl _).

  Definition vector_fold_right1 {A B:Type} (f:B->A->A) (init:A) (singleton:B->A) {m:nat} (v:Vector B m)
    := vector_fold_right1_dep (A:=fun _ => A) (fun _ => f) init singleton v.

  Definition vector_fold_right {A B:Type} (f:B->A->A) (init:A) {m:nat} (v:Vector B m)
    := vector_fold_right_dep (fun _ => f) init v.

  Lemma vector_fold_right1_dep_as_vector_fold_right_dep {A:nat->Type} {B}
        (f:forall n,B->A n->A (S n)) (init:A 0%nat) (singleton:B->A 1%nat) {m:nat}
        (v:Vector B m)
    :
      (forall x, singleton x = f _ x init) ->
        vector_fold_right1_dep f init singleton v  =
        vector_fold_right_dep f init v.
  Proof.
    apply vector_fold_right1_bounded_dep_as_vector_fold_right_bounded_dep.
  Qed.

  Lemma vector_fold_right_dep_as_vector_fold_right1_dep {A:nat->Type} {B}
        (f:forall n,B->A n->A (S n)) (init:A 0%nat) {m:nat}
        (v:Vector B m)
    :
      vector_fold_right_dep f init v =
      vector_fold_right1_dep f init (fun x => f 0 x init) v.
  Proof.
    apply vector_fold_right_bounded_dep_as_vector_fold_right1_bounded_dep.
  Qed.

  Lemma vector_fold_right1_as_vector_fold_right {A:Type} {B}
        (f:B->A->A) (init:A) (singleton:B->A) {m:nat}
        (v:Vector B m)
    :
      (forall x, singleton x = f x init) ->
        vector_fold_right1 f init singleton v  =
        vector_fold_right f init v.
  Proof.
    apply (vector_fold_right1_dep_as_vector_fold_right_dep (fun _ => f)).
  Qed.

  Lemma vector_fold_right_as_vector_fold_right1 {A:Type} {B}
        (f:B->A->A) (init:A) {m:nat}
        (v:Vector B m)
    :
      vector_fold_right f init v =
      vector_fold_right1 f init (fun x => f x init) v.
  Proof.
    apply (vector_fold_right_dep_as_vector_fold_right1_dep (fun _ => f)).
  Qed.

  Definition vectoro_to_ovector {T} {n} (v:Vector (option T) n) : option (Vector T n)
    := vector_fold_right_dep (fun n => lift2 (@vcons _ n)) (Some vnil) v.

  Definition matrixo_to_omatrix {T} {m n} (v:Matrix (option T) m n) : option (Matrix T m n)
    := vectoro_to_ovector (fun i => vectoro_to_ovector (v i)).

  Definition vmap {A B} {n} (f:A->B) (v:Vector A n) : Vector B n
    := vector_fold_right_dep (fun n x y => vcons (n:=n) (f x) y) vnil v.

  Definition mmap {A B} {m n} (f:A->B) (mat:Matrix A m n) : Matrix B m n
    := vmap (fun mrow => vmap f mrow) mat.

  Definition list_fold_right1_bounded_dep {A:nat->Type} {B} (f:forall n,B->A n->A (S n))
             (init:A 0%nat) (singleton:B->A 1%nat) (l:list B) (n:nat) (pf:(n<=length l)%nat)
    : A n.
  Proof.
    revert l pf.
    induction n; intros l pf.
    - exact init.
    - destruct n.
      + assert (pf2:(0 < length l)%nat) by omega.
        destruct l.
        * simpl in pf; omega.
        * exact (singleton b).
      + destruct l; simpl in *; try omega.
        apply f.
        * apply b.
        * apply (IHn l).
          omega.
  Defined.

  Definition list_fold_right1_dep {A:nat->Type} {B} (f:forall n, B->A n->A (S n))
             (init:A 0%nat) (singleton:B->A 1%nat) (l:list B) : A (length l)
    := list_fold_right1_bounded_dep f init singleton l (length l) (le_refl _).

  Definition list_fold_right_dep {A:nat->Type} {B} (f:forall n, B->A n->A (S n))
             (init:A 0%nat) (l:list B) : A (length l)
    := list_fold_right1_dep f init (fun a => f _ a init) l.

  Definition list_to_vector {A} (l:list A) : Vector A (length l)
    := list_fold_right_dep (@vcons _) vnil l.

  Definition vector_to_list {A} {n} (v:Vector A n) : list A
    := vector_fold_right cons nil v.

  Definition matrix_to_list_list {T} {m n} (v:Matrix T m n) : (list (list T))
    := vector_to_list (fun i => vector_to_list (v i)).

  Definition matrix_to_list {T} {m n} (v:Matrix T m n) : (list T)
    := concat (matrix_to_list_list v).

  Definition vseq start len : Vector nat len
    := eq_rect _ _ (list_to_vector (seq start len)) _ (seq_length _ _).

  Definition vector_zip {A B} {m:nat} (v1:Vector A m) (v2:Vector B m) : Vector (A*B) m
    := fun i => (v1 i, v2 i).

  Definition matrix_zip {A B} {m n:nat} (mat1:Matrix A m n) (mat2:Matrix B m n) : Matrix (A*B) m n
    := let mat12:Vector (Vector A n*Vector B n) m := vector_zip mat1 mat2 in
       vmap (fun '(a,b) => vector_zip a b) mat12.

  Definition vector_split {A B} {m:nat} (v:Vector (A*B) m) : Vector A m * Vector B m
    := (fun i => fst (v i), fun i => snd (v i)).

  Program Definition vtake {A} {m:nat} (v:Vector (A) m) (n:nat) (pf:(n<=m)%nat) : Vector A n
    := fun i => v i.
  Next Obligation.
    omega.
  Defined.

  Program Definition vskip {A} {m:nat} (v:Vector (A) m) (n:nat) (pf:(n<=m)%nat) : Vector A (m-n)
    := fun i => v (i+n).
  Next Obligation.
    omega.
  Defined.

  Definition transpose {A} {n m:nat} (mat:Matrix A n m) :=
    fun i j => mat j i.

  Definition vec_eq {A} {m:nat} (x y:Vector A m) := forall i, x i = y i.
  Notation "x =v= y" := (vec_eq x y) (at level 70).

  (* If we are willing to assume an axiom *)
  Lemma vec_eq_eq {A} {m:nat} (x y:Vector A m) : vec_eq x y -> x = y.
  Proof.
    intros.
    apply FunctionalExtensionality.functional_extensionality.
    apply H.
  Qed.

  Lemma index_pf_irrel n m pf1 pf2 :
    exist (fun n' : nat => (n' < n)%nat) m pf1 =
    exist (fun n' : nat => (n' < n)%nat) m pf2.
    f_equal.
    apply digit_pf_irrel.
  Qed.

  Ltac index_prover := erewrite index_pf_irrel; reflexivity.

  Lemma vector_Sn_split {T} {n} (v:Vector T (S n)) :
    v =v= vcons (vlast v) (vdrop_last v).
  Proof.
    intros [i pf].
    unfold vcons, vlast, vdrop_last.
    destruct (Nat.eq_dec i n)
    ; subst
    ; f_equal
    ; apply index_pf_irrel.
  Qed.

  Lemma vector_split_zip {A B} {m:nat} (v:Vector (A*B) m) :
    let '(va,vb):=vector_split v in vector_zip va vb =v= v.
  Proof.
    simpl.
    intros i.
    vm_compute.
    now destruct (v i).
  Qed.

  Lemma split_vector_zip {A B} {m:nat} (va:Vector A m) (vb:Vector B m) :
    vector_split (vector_zip va vb) = (va,vb).
  Proof.
    vm_compute.
    f_equal.
  Qed.

  Definition vlconcat {A n} (v:Vector (list A) n) : list A
    := concat (vector_to_list v).

  Definition vlconcat_map {A B n} (f:A->list B) (v:Vector A n) : list B
    := vlconcat (vmap f v).

  Definition vin {A n} (x:A) (v:Vector A n) : Prop
    := exists i, v i = x.

  (*
  Lemma nth_In :
    forall (n:nat) (l:list A) (d:A), n < length l -> In (nth n l d) l.

  Lemma In_nth l x d : In x l ->
    exists n, n < length l /\ nth n l d = x.
   *)

  Notation "x =v= y" := (vec_eq x y) (at level 70).

  Lemma vector_fold_right_dep_bounded_pf_ext {A:nat->Type} {B} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) {m:nat} (v:Vector B m) bound pf1 pf2 :
    vector_fold_right_bounded_dep f init v bound pf1 = vector_fold_right_bounded_dep f init v bound pf2.
  Proof.
    revert pf1 pf2.
    induction bound; trivial; intros.
    simpl.
    f_equal.
    f_equal.
    apply index_pf_irrel.
    trivial.
  Qed.

  Lemma vector_fold_right_dep_bounded_ext {A:nat->Type} {B} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) {m:nat} (x y:Vector B m) bound pf :
    x =v= y -> vector_fold_right_bounded_dep f init x bound pf = vector_fold_right_bounded_dep f init y bound pf.
  Proof.
    intros eqq.
    induction bound; simpl; congruence.
  Qed.

  Lemma vector_fold_right_dep_bounded_cut_down {A:nat->Type} {B} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) {m:nat} (x:Vector B (S m)) bound pf1 pf2 :
    vector_fold_right_bounded_dep f init x bound pf1 = vector_fold_right_bounded_dep f init (vdrop_last x) bound pf2.
  Proof.
    induction bound; simpl; trivial.
    f_equal.
    - f_equal.
      apply index_pf_irrel.
    - apply IHbound.
  Qed.

  Lemma vector_fold_right_dep_ext {A:nat->Type} {B} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) {m:nat} {x y:Vector B m} :
    x =v= y -> vector_fold_right_dep f init x = vector_fold_right_dep f init y.
  Proof.
    apply vector_fold_right_dep_bounded_ext.
  Qed.

  Lemma vector_fold_right_ext {A:Type} {B} (f:B->A->A) (init:A) {m:nat} {x y:Vector B m} :
    x =v= y -> vector_fold_right f init x = vector_fold_right f init y.
  Proof.
    apply (@vector_fold_right_dep_ext (fun _ => A)).
  Qed.

  Lemma veq_refl {T} {n} (x:Vector T n) : x =v= x.
  Proof.
    intros i; reflexivity.
  Qed.

  Lemma veq_sym {T} {n} {x y:Vector T n} : x =v= y -> y =v= x.
  Proof.
    intros eqq i; symmetry; trivial.
  Qed.

  Lemma veq_trans {T} {n} {x y z:Vector T n} : x =v= y -> y =v= z -> x =v= z.
  Proof.
    intros eqq1 eqq2 i; etransitivity; eauto.
  Qed.

  Lemma vcons_proper {T} {n} a b (x y:Vector T n) : a = b -> x =v= y -> vcons a x =v= vcons b y.
  Proof.
    intros; subst.
    intros [i pf].
    unfold vcons.
    destruct (Nat.eq_dec i n); simpl; trivial.
  Qed.

  Lemma vdrop_last_proper {T} {n} (x y:Vector T (S n)) : x =v= y -> vdrop_last x =v= vdrop_last y.
  Proof.
    intros eqq [i pf].
    apply eqq.
  Qed.

  Lemma vlast_vcons {T} {n} x (d:Vector T n) : vlast (vcons x d) = x.
  Proof.
    unfold vlast, vcons.
    match_destr; congruence.
  Qed.

  Lemma vdrop_last_vcons {T} {n} x (d:Vector T n) : vdrop_last (vcons x d) = d.
  Proof.
    unfold vdrop_last, vcons.
    apply vec_eq_eq; intros [i pf].
    match_destr; [omega | ].
    erewrite index_pf_irrel; eauto.
  Qed.

  Lemma vector_fold_right_dep_0 {A:nat->Type} {B} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) (v:Vector B 0) :
    vector_fold_right_dep f init v = init.
  Proof.
    reflexivity.
  Qed.

  Lemma vector_fold_right_dep_Sn {A:nat->Type} {B} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) {m:nat} (v:Vector B (S m)) :
    vector_fold_right_dep f init v = f m (vlast v) (vector_fold_right_dep f init (vdrop_last v)).
  Proof.
    rewrite (vector_fold_right_dep_ext _ _ (vector_Sn_split v)).
    unfold vector_fold_right_dep.
    simpl.
    destruct (Nat.eq_dec m m) ; [ | congruence].
    f_equal.
    erewrite vector_fold_right_dep_bounded_pf_ext.
    erewrite vector_fold_right_dep_bounded_cut_down.
    apply vector_fold_right_dep_bounded_ext.
    apply vdrop_last_proper.
    apply veq_sym.
    apply vector_Sn_split.
    Unshelve.
    omega.
  Qed.

  Lemma vector_fold_right_Sn {A:Type} {B} (f:B->A->A) (init:A%nat) {m:nat} (v:Vector B (S m)) :
    vector_fold_right f init v = f (vlast v) (vector_fold_right f init (vdrop_last v)).
  Proof.
    unfold vector_fold_right.
    apply (@vector_fold_right_dep_Sn (fun _ => A)).
  Qed.

  Lemma vector_fold_right_dep_vcons {A:nat->Type} {B}
        (f:forall n,B->A n->A (S n)) (init:A 0%nat) {m:nat}
        x (v:Vector B m) :
    vector_fold_right_dep f init (vcons x v) = f m x (vector_fold_right_dep f init v).
  Proof.
    now rewrite vector_fold_right_dep_Sn, vlast_vcons, vdrop_last_vcons.
  Qed.

  Lemma vector_fold_right_vcons {A:Type} {B}
        (f:B->A->A) (init:A) {m:nat}
        x (v:Vector B m)  :
    vector_fold_right f init (vcons x v) = f x (vector_fold_right f init v).
  Proof.
    apply (vector_fold_right_dep_vcons (fun _ => f)).
  Qed.

  Lemma vector_fold_right1_dep_bounded_ext {A:nat->Type} {B} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) sing {m:nat} (x y:Vector B m) bound pf :
    x =v= y -> vector_fold_right1_bounded_dep f init sing x bound pf = vector_fold_right1_bounded_dep f init sing y bound pf.
  Proof.
    intros eqq.
    induction bound; simpl; trivial.
    destruct bound; trivial.
    - congruence.
    - f_equal.
      + erewrite index_pf_irrel; eauto.
      + apply IHbound.
    Unshelve.
    omega.
  Qed.

  Lemma vector_fold_right1_dep_ext {A:nat->Type} {B} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) sing {m:nat} {x y:Vector B m} :
    x =v= y -> vector_fold_right1_dep f init sing x = vector_fold_right1_dep f init sing y.
  Proof.
    apply vector_fold_right1_dep_bounded_ext.
  Qed.

  Lemma vector_fold_right1_ext {A:Type} {B} (f:B->A->A) (init:A) sing {m:nat} {x y:Vector B m} :
    x =v= y -> vector_fold_right1 f init sing x = vector_fold_right1 f init sing y.
  Proof.
    apply (@vector_fold_right1_dep_ext (fun _ => A)).
  Qed.

  Lemma vector_fold_right1_dep_bounded_f_ext {A:nat->Type} {B} (f1 f2:forall n,B->A n->A (S n))
        (init:A 0%nat) sing {m:nat} (v:Vector B m) bound pf :
    (forall n pf a, f1 n (v (exist _ n pf)) a = f2 n (v (exist _ n pf)) a) -> vector_fold_right1_bounded_dep f1 init sing v bound pf = vector_fold_right1_bounded_dep f2 init sing v bound pf.
  Proof.
    intros eqq.
    induction bound; simpl; trivial.
    destruct bound; trivial.
    f_equal.
    eauto.
  Qed.

  Lemma vector_fold_right1_dep_f_ext {A:nat->Type} {B} (f1 f2:forall n,B->A n->A (S n))
        (init:A 0%nat) sing {m:nat} {v:Vector B m} :
    (forall n pf a, f1 n (v (exist _ n pf)) a = f2 n (v (exist _ n pf)) a) -> vector_fold_right1_dep f1 init sing v = vector_fold_right1_dep f2 init sing v.
  Proof.
    apply vector_fold_right1_dep_bounded_f_ext.
  Qed.

  Lemma vector_fold_right1_f_ext {A:Type} {B} (f1 f2:B->A->A) (init:A) sing {m:nat} {v:Vector B m} :
   (forall i a, f1 (v i) a = f2 (v i) a) -> vector_fold_right1 f1 init sing v = vector_fold_right1 f2 init sing v.
  Proof.
    intros.
    apply (@vector_fold_right1_dep_f_ext (fun _ => A)); eauto.
  Qed.

  Lemma vector_fold_right1_dep_0 {A:nat->Type} {B} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) sing (v:Vector B 0) :
    vector_fold_right1_dep f init sing v = init.
  Proof.
    reflexivity.
  Qed.

  Lemma vector_fold_right1_dep_1 {A:nat->Type} {B} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) sing (v:Vector B 1) :
    vector_fold_right1_dep f init sing v = sing (v (exist _ 0 Nat.lt_0_1)).
  Proof.
    unfold vector_fold_right1_dep.
    simpl.
    f_equal.
    erewrite index_pf_irrel; eauto.
  Qed.

    Lemma vector_fold_right1_bounded_dep_pf_ext {A:nat->Type} {B} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) sing {m:nat} (v:Vector B m) bound pf1 pf2 :
    vector_fold_right1_bounded_dep f init sing v bound pf1 = vector_fold_right1_bounded_dep f init sing v bound pf2.
  Proof.
    revert pf1 pf2.
    induction bound; trivial; intros.
    simpl.
    destruct bound; simpl.
    - f_equal; index_prover.
    - f_equal; try index_prover.
      apply IHbound.
  Qed.

  Lemma vector_fold_right1_bounded_dep_SSn {A:nat->Type} {B} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) sing {m:nat} (v:Vector B (S m)) bound pf1 pf2 pf4:
    vector_fold_right1_bounded_dep f init sing v (S (S bound)) pf1 = f _ (v (exist _ (S bound) pf4)) (vector_fold_right1_bounded_dep f init sing v (S bound) pf2).
  Proof.
    revert pf4.
    induction bound; simpl; trivial; intros.
    f_equal; try index_prover.
    simpl in *.
    f_equal; try index_prover.
    destruct bound.
    - f_equal; try index_prover.
    - destruct bound.
      apply IHbound.
      f_equal; try index_prover.
      f_equal; try index_prover.
      apply vector_fold_right1_bounded_dep_pf_ext.
  Qed.

  Lemma vector_fold_right1_bounded_dep_relevant {A:nat->Type} {B} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) sing {m1:nat} (v1:Vector B m1) {m2:nat} (v2:Vector B m2) bound pf1 pf2:
    (forall i, i <= bound -> forall pf1 pf2, v1 (exist _ i pf1) = v2 (exist _ i pf2)) ->
    vector_fold_right1_bounded_dep f init sing v1 bound pf1 =
    vector_fold_right1_bounded_dep f init sing v2 bound pf2.
  Proof.
    intros eqq.
    induction bound; simpl; trivial.
    destruct bound; simpl.
    - f_equal; try index_prover.
      apply eqq.
      omega.
    - f_equal.
      + apply eqq.
        omega.
      + apply IHbound; auto.
  Qed.

  Lemma vector_fold_right1_bounded_dep_droplast {A:nat->Type} {B} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) sing {m:nat} (v:Vector B (S m)) bound pf1 pf2:
    bound < S m ->
    vector_fold_right1_bounded_dep f init sing (vdrop_last v) bound pf1 =
    vector_fold_right1_bounded_dep f init sing v bound pf2.
  Proof.
    intros.
    apply vector_fold_right1_bounded_dep_relevant; intros.
    unfold vdrop_last.
    index_prover.
  Qed.

  Lemma vector_fold_right1_dep_SSn {A:nat->Type} {B} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) sing {m:nat} (v:Vector B (S (S m))) :
    vector_fold_right1_dep f init sing v = f (S m) (vlast v) (vector_fold_right1_dep f init sing (vdrop_last v)).
  Proof.
    unfold vector_fold_right1_dep.
    unfold vlast.
    erewrite vector_fold_right1_bounded_dep_SSn.
    f_equal.
    erewrite vector_fold_right1_bounded_dep_droplast; trivial.
    omega.
    Unshelve.
    omega.
  Qed.

  Lemma vector_fold_right_bounded_dep_ind {A:nat->Type} {B} {P:forall m, A m -> Prop} (f:forall n,B->A n->A (S n))
        (init:A 0%nat)
        (finit : P 0 init)
        (ff: forall n b v, P n v -> P (S n) (f n b v)) :
    forall {m:nat} (v:Vector B m) bound pf, P bound (vector_fold_right_bounded_dep f init v bound pf).
  Proof.
    intros m v bound pf.
    revert m pf v.
    induction bound; simpl; trivial; intros.
    apply ff.
    apply IHbound.
  Qed.

  Lemma vector_fold_right_dep_ind {A:nat->Type} {B} {P:forall m, A m -> Prop} (f:forall n,B->A n->A (S n))
        (init:A 0%nat)
        (finit : P 0 init)
      (ff: forall n b v, P n v -> P (S n) (f n b v)) :
    forall {m:nat} (v:Vector B m), P m (vector_fold_right_dep f init v).
  Proof.
    intros.
    apply vector_fold_right_bounded_dep_ind; trivial.
  Qed.

  Lemma vector_fold_right_ind {A:Type} {B} {P:A -> Prop} (f:B->A ->A)
        (init:A)
        (finit : P init)
      (ff: forall b v, P v -> P (f b v)) :
    forall {m:nat} (v:Vector B m), P (vector_fold_right f init v).
  Proof.
    intros.
    apply (vector_fold_right_dep_ind (P:=fun _ => P)); trivial.
  Qed.

  Lemma vector_fold_right1_bounded_dep_ind {A:nat->Type} {B} {P:forall m, A m -> Prop} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) sing
        (finit : P 0 init)
        (fsing: forall b, P 1 (sing b))
        (ff: forall n b v, P n v -> P (S n) (f n b v)) :
    forall {m:nat} (v:Vector B m) bound pf, P bound (vector_fold_right1_bounded_dep f init sing v bound pf).
  Proof.
    intros m v bound pf.
    revert m pf v.
    induction bound; simpl; trivial; intros.
    destruct bound; simpl; trivial.
    apply ff.
    apply IHbound.
  Qed.

  Lemma vector_fold_right1_dep_ind {A:nat->Type} {B} {P:forall m, A m -> Prop} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) sing
        (finit : P 0 init)
       (fsing: forall b, P 1 (sing b))
      (ff: forall n b v, P n v -> P (S n) (f n b v)) :
    forall {m:nat} (v:Vector B m), P m (vector_fold_right1_dep f init sing v).
  Proof.
    intros.
    apply vector_fold_right1_bounded_dep_ind; trivial.
  Qed.

  Lemma vector_fold_right1_ind {A:Type} {B} {P:A -> Prop} (f:B->A ->A)
        (init:A) sing
        (finit : P init)
       (fsing: forall b, P (sing b))
      (ff: forall b v, P v -> P (f b v)) :
    forall {m:nat} (v:Vector B m), P (vector_fold_right1 f init sing v).
  Proof.
    intros.
    apply (vector_fold_right1_dep_ind (P:=fun _ => P)); trivial.
  Qed.

  Lemma vector_to_list_In {A} (x:A) {n} (v:Vector A n) :
    vin x v -> In x (vector_to_list v).
  Proof.
    induction n.
    - intros [[i pf] eqqi].
      omega.
    - intros [[i pf] eqqi].
      unfold vector_to_list in *.
      rewrite vector_fold_right_Sn; simpl.
      destruct (Nat.eq_dec i n).
      + left.
        unfold vlast.
        subst.
        erewrite index_pf_irrel; eauto.
      + right.
        apply IHn.
        eexists (exist _ i _).
        simpl.
        erewrite index_pf_irrel; eauto.

        Unshelve.
        simpl; omega.
  Qed.

  Lemma vin_cons {A} x (a:A) {n} {v:Vector A n} : vin x (vcons a v) <-> (x = a \/ vin x v).
  Proof.
    unfold vcons.
    split.
    - intros [[i pf] eqq].
      destruct (Nat.eq_dec i n).
      + subst; eauto.
      + right.
        eexists (exist _ i _).
        erewrite index_pf_irrel; eauto.

        Unshelve.
        simpl; omega.
    - intros [eqq | inn].
      + red.
        eexists (exist _ n _).
        destruct (Nat.eq_dec n n); congruence.
      + destruct inn as [[i pf] eqq].
        eexists (exist _ i _).
        destruct (Nat.eq_dec i n); [omega | ].
        erewrite index_pf_irrel; eauto.
        Unshelve.
        simpl; omega.
        simpl; omega.
  Qed.

  Lemma vin_proper {A} (x:A) {n} {v1 v2:Vector A n} : v1 =v= v2 -> vin x v1 <-> vin x v2.
  Proof.
    revert v1 v2.
    cut (forall (v1 v2:Vector A n), v1 =v= v2 -> vin x v1 -> vin x v2).
    { intros; split; [eauto| ].
      apply veq_sym in H0; eauto.
    }
    intros v1 v2 eqq1 [i eqq2].
    exists i.
    rewrite <- eqq1; trivial.
  Qed.

  Lemma vector_to_list_vin {A} (x:A) {n} (v:Vector A n) :
    In x (vector_to_list v) -> vin x v.
  Proof.
    unfold vector_to_list.
    revert v.
    induction n; [simpl; tauto|].
    intros v inn.
    rewrite vector_fold_right_Sn in inn.
    destruct inn as [eqq | inn].
    - eexists.
      apply eqq.
    - apply (@vin_proper A _ (S n) _ _ (vector_Sn_split v)).
      apply vin_cons.
      eauto.
  Qed.

  Lemma vdrop_last_i {A} {n} (v:Vector A (S n)) i pf1 pf2 :
    vdrop_last v (exist (fun n' : nat => (n' < n)%nat) i pf1) =
    v (exist (fun n' : nat => (n' < S n)%nat) i pf2).
  Proof.
    unfold vdrop_last.
    erewrite index_pf_irrel; eauto.
  Qed.

  Lemma vin_vlast {A n} (v:Vector A (S n)) : vin (vlast v) v.
  Proof.
    unfold vin, vlast.
    eauto.
  Qed.

  Lemma vin_vdrop_last {A n} x (v:Vector A (S n)) : vin x (vdrop_last v) -> vin x v.
  Proof.
    unfold vin, vdrop_last.
    intros [[??]?].
    eauto.
  Qed.

  Lemma vmap_nth {A B : Type} (f : A -> B) {n} (v : Vector A n) i :
    vmap f v i = f (v i).
  Proof.
    revert v i.
    unfold vmap.
    induction n; intros v [i pf].
    - omega.
    - rewrite vector_fold_right_dep_Sn.
      simpl.
      destruct (Nat.eq_dec i n).
      + subst.
        unfold vlast.
        erewrite index_pf_irrel; eauto.
      + specialize (IHn (vdrop_last v)).
        unfold vdrop_last.
        erewrite index_pf_irrel; rewrite IHn.
        erewrite vdrop_last_i; eauto.
        Unshelve.
        omega.
  Qed.

  Lemma mmap_nth {A B : Type} (f : A -> B) {m n} (mat : Matrix A m n) i j :
    mmap f mat i j = f (mat i j).
  Proof.
    unfold mmap.
    now repeat rewrite vmap_nth.
  Qed.

  Lemma vmap_ext {A B n} (f1 f2:A->B) (df:Vector A n) :
    (forall x, vin x df -> f1 x = f2 x) ->
    vmap f1 df = vmap f2 df.
  Proof.
    unfold vmap.
    induction n.
    - reflexivity.
    - intros.
      repeat rewrite vector_fold_right_dep_Sn.
      f_equal.
      + eapply H.
        eapply vin_vlast.
      + rewrite IHn; trivial.
        intros.
        eapply H.
        now apply vin_vdrop_last.
  Qed.

  Lemma vnil0 {A} (v:Vector A 0) : v = vnil.
  Proof.
    apply FunctionalExtensionality.functional_extensionality.
    intros [i pf].
    omega.
  Qed.

  Lemma vmap_id {A n} (df:Vector A n) :
    vmap (fun x => x) df = df.
  Proof.
    unfold vmap.
    induction n; simpl.
    - now rewrite vnil0, vector_fold_right_dep_0.
    - rewrite vector_fold_right_dep_Sn, IHn.
      apply vec_eq_eq.
      apply veq_sym.
      apply vector_Sn_split.
  Qed.

  Definition bounded_seq_bounded (start len : nat) : forall bound, bound<=len -> list {n':nat | n' < start+len}%nat.
  Proof.
    refine (fix F bound :=
             match bound as bound_ return bound_ <= len -> list {n':nat | n' < start+len}%nat with
             | 0 => fun _ => nil
             | S bound' => fun _ => exist _ (start + len-(S bound')) _ :: F bound' _
             end); omega.
  Defined.

  Lemma bounded_seq_bounded_ext (start len : nat) (bound:nat) (pf1 pf2:bound<=len) :
    bounded_seq_bounded start len bound pf1 = bounded_seq_bounded start len bound pf2.
  Proof.
    induction bound; simpl; trivial.
    f_equal.
    - eapply index_pf_irrel; eauto.
    - eapply IHbound.
  Qed.

  Definition bounded_seq (start len : nat) : list {n':nat | n' < start+len}%nat
    := bounded_seq_bounded start len len (le_refl _).

  Definition bounded_seq0 len : list {n':nat | n' < len}%nat := bounded_seq 0 len.

  Lemma bounded_seq_bounded_domain start len (bound:nat) (pf:bound<=len) : map (@proj1_sig _ _) (bounded_seq_bounded start len bound pf) = seq (start+(len-bound)) bound.
  Proof.
    revert start.
    induction bound; simpl; intros start; trivial.
    rewrite IHbound.
    f_equal.
    - omega.
    - f_equal.
      omega.
  Qed.

  Lemma bounded_seq_domain start len : map (@proj1_sig _ _) (bounded_seq start len) = seq start len.
  Proof.
    unfold bounded_seq.
    rewrite bounded_seq_bounded_domain.
    f_equal.
    omega.
  Qed.

  Lemma bounded_seq_strongly_sorted start len:
    StronglySorted (fun x y => proj1_sig x < proj1_sig y) (bounded_seq start len).
  Proof.
    apply StronglySorted_compose.
    rewrite bounded_seq_domain.
    apply StronglySorted_seq.
  Qed.

  Lemma bounded_seq_break_at start len x :
    proj1_sig x >= start ->
    exists b c, bounded_seq start len = b++x::c /\ Forall (fun y => (proj1_sig y) < (proj1_sig x)) b /\ Forall (fun y => (proj1_sig x) < (proj1_sig y)) c.
  Proof.
    intros xge.
    apply (StronglySorted_break (fun y x => (proj1_sig y) < (proj1_sig x)) (bounded_seq start len)).
    - apply bounded_seq_strongly_sorted.
    - destruct x as [x pf]; simpl in *.
      assert (inn:In x (map (@proj1_sig _ _) (bounded_seq start len))).
      + rewrite bounded_seq_domain.
        apply in_seq.
        omega.
      + apply in_map_iff in inn.
        destruct inn as [[??] [??]].
        subst.
        erewrite index_pf_irrel; eauto.
  Qed.

  Definition vforall {A n} (P:A->Prop) (v:Vector A n) :=
    vector_fold_right (fun x p => P x /\ p) True v.

  Lemma vforall_forall {A n} (P:A->Prop) (v:Vector A n) :
    vforall P v <-> forall i, P (v i).
  Proof.
    unfold vforall.
    split.
    - induction n.
      + intros ? [??].
        omega.
      + rewrite vector_fold_right_Sn.
        intros [Plast Pdrop].
        intros [i pf].
        destruct (Nat.eq_dec i n).
        * unfold vlast in Plast.
          subst.
          erewrite index_pf_irrel; eauto.
        * assert (pf2:(i < n)%nat) by omega.
          specialize (IHn _ Pdrop (exist _ i pf2)).
          erewrite index_pf_irrel; eauto.
    - induction n.
      + vm_compute; trivial.
      + rewrite vector_fold_right_Sn.
        intros.
        split.
        * eauto.
        * eapply IHn.
          intros [i pf].
          assert (pf2 : (i < S n)%nat) by omega.
          specialize (H (exist _ i pf2)).
          simpl in *.
          erewrite index_pf_irrel; eauto.
  Qed.

  Lemma vectoro_to_ovector_forall_some_f {A n} {vo:Vector (option A) n} {v:Vector A n} :
    vectoro_to_ovector vo = Some v ->
    (forall i, vo i = Some (v i)).
  Proof.
    unfold vectoro_to_ovector.
    induction n; simpl.
    - intros ? [??]; omega.
    - rewrite vector_fold_right_dep_Sn.
      intros eqq.
      apply some_lift2 in eqq.
      destruct eqq as [x [y eqq1 [eqq2 eqq3]]].
      subst.
      intros [i pf].
      rewrite vector_Sn_split.
      specialize (IHn _ _ eqq2).
      rewrite eqq1.
      unfold vcons.
      destruct (Nat.eq_dec i n); trivial.
  Qed.

  Lemma vectoro_to_ovector_forall_some_b {A n} (vo:Vector (option A) n) (v:Vector A n) :
    (forall i, vo i = Some (v i)) ->
    exists v', vectoro_to_ovector vo = Some v' /\ v =v= v'.
  Proof.
    unfold vectoro_to_ovector.
    induction n; simpl.
    - intros eqq.
      unfold vector_fold_right_dep.
      simpl.
      exists vnil; split; trivial.
      intros [??]; omega.
    - rewrite vector_fold_right_dep_Sn.
      intros eqq.
      specialize (IHn (vdrop_last vo) (vdrop_last v)).
      destruct IHn as [v' [eqq2 eqq3]].
      + intros [i pf].
        simpl; eauto.
      + rewrite eqq2.
        unfold vlast.
        rewrite eqq.
        simpl.
        eexists; split; [reflexivity | ].
        eapply veq_trans; [eapply (vector_Sn_split v) | ].
        apply vcons_proper; simpl; trivial.
  Qed.

  Lemma vectoro_to_ovector_forall_some_b_strong {A n} (vo:Vector (option A) n) (v:Vector A n) :
    (forall i, vo i = Some (v i)) ->
    vectoro_to_ovector vo = Some v.
  Proof.
    intros.
    destruct (vectoro_to_ovector_forall_some_b _ _ H) as [? [??]].
    rewrite H0.
    f_equal.
    apply FunctionalExtensionality.functional_extensionality.
    intros.
    symmetry.
    apply H1.
  Qed.

  Lemma vectoro_to_ovector_not_none {A n} (vo : Vector (option A) n) :
    (forall i, vo i <> None) -> vectoro_to_ovector vo <> None.
  Proof.
    unfold vectoro_to_ovector.
    induction n; simpl.
    - intros eqq.
      unfold vector_fold_right_dep.
      simpl.
      congruence.
    - rewrite vector_fold_right_dep_Sn.
      intros eqq.
      specialize (IHn (vdrop_last vo)).
      unfold lift2 in *.
      repeat match_option.
      + elim IHn; trivial.
        unfold vdrop_last.
        now intros [i pf].
      + unfold vlast in eqq0.
        elim (eqq _ eqq0).
  Qed.

  Lemma vectoro_to_ovector_exists_None {A n} {vo:Vector (option A) n} :
    vectoro_to_ovector vo = None ->
    {i | vo i = None}.
  Proof.
    unfold vectoro_to_ovector.
    induction n; simpl.
    - unfold vector_fold_right_dep; simpl.
      discriminate.
    - rewrite vector_fold_right_dep_Sn.
      intros eqq.
      specialize (IHn (vdrop_last vo)).
      unfold lift2 in *.
      repeat match_option_in eqq.
      + destruct (IHn eqq1) as [[i pf] ?].
        eauto.
      + eauto.
  Qed.

  Lemma vectoro_to_ovector_None_None {A n} {vo:Vector (option A) n} i :
    vo i = None ->
    vectoro_to_ovector vo = None.
  Proof.
    destruct i as [i pf].
    unfold vectoro_to_ovector.
    induction n; simpl.
    - omega.
    - intros eqq.
      rewrite vector_fold_right_dep_Sn.
      unfold vlast.
      destruct (Nat.eq_dec i n).
      + subst.
        erewrite index_pf_irrel.
        rewrite eqq; simpl; trivial.
      + unfold lift2.
        erewrite IHn; simpl.
        * match_destr.
        * erewrite index_pf_irrel; eauto.
   Unshelve.
   omega.
  Qed.

  Definition vfirstn {T} {n} (v:Vector T n) m (pf:(m<=n)%nat): Vector T m.
  Proof.
    intros [i pf2].
    apply v.
    exists i.
    eapply NPeano.Nat.lt_le_trans; eassumption.
  Defined.

  Lemma vfirstn0 {T} {n} (v:Vector T n) pf : vfirstn v 0 pf = vnil.
  Proof.
    apply vec_eq_eq; intros [??]; simpl.
    omega.
  Qed.

  Definition vfirstn_eq {T} {n} (v:Vector T n) pf : vfirstn v n pf = v.
  Proof.
    unfold vfirstn.
    apply FunctionalExtensionality.functional_extensionality; intros [??].
    erewrite index_pf_irrel; eauto.
  Qed.

  Lemma vfirstn_vdrop_last {T} {n} (v:Vector T n) bound pf pf2 :
      vdrop_last (vfirstn v (S bound) pf) = vfirstn v bound pf2.
  Proof.
    apply FunctionalExtensionality.functional_extensionality; intros [??]; simpl.
    erewrite index_pf_irrel; eauto.
  Qed.

  Lemma vlast_vfirstn {T} {n} (d:Vector T n) bound pf pf2 :
    (vlast (vfirstn d (S bound) pf)) = d ((exist _ bound pf2)).
  Proof.
    unfold vfirstn, vlast.
    erewrite index_pf_irrel; eauto.
  Qed.

  Lemma vector_fold_right1_bounded_dep_gen_ind {A:nat->Type} {B} {P:forall m, Vector B m -> A m -> Prop} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) sing
        (finit : P 0%nat vnil init)
        (fsing: forall b, P 1%nat (vcons b vnil) (sing b))
        (ff: forall n b v r, P n v r -> P (S n) (vcons b v) (f n b r)) :
    forall {m:nat} (v:Vector B m) bound pf, P bound (vfirstn v _ pf) (vector_fold_right1_bounded_dep f init sing v bound pf).
  Proof.
    intros m v bound pf.
    revert m pf v.
    induction bound; simpl; trivial; intros.
    - generalize (vfirstn v 0 pf); intros.
      rewrite (vnil0 v0); trivial.
    - destruct m; [omega | ].
      destruct bound; simpl; trivial.
      + replace (vfirstn v 1 pf) with (vcons (v (exist (fun n' : nat => (n' < S m)%nat) 0%nat pf)) vnil)
        ; trivial.
        apply FunctionalExtensionality.functional_extensionality; intros [??]; simpl.
        destruct x; [ | omega].
        simpl.
        erewrite index_pf_irrel; eauto.
      + assert (pf2:(S bound <= S m)%nat) by omega.
        replace (vfirstn v (S (S bound)) pf)
          with (vcons (v (exist (fun n' : nat => (n' < S m)%nat) (S bound) pf)) (vfirstn v (S bound) pf2)).
        * apply ff.
          replace (match bound as bound1' return (A bound1' -> (S bound1' <= S m)%nat -> A (S bound1')) with
                   | 0%nat =>
                     fun (_ : A 0%nat) (pf1 : (1 <= S m)%nat) =>
                       sing (v (exist (fun n' : nat => (n' < S m)%nat) 0%nat pf1))
                   | S bound2 =>
                     fun (an' : A (S bound2)) (_ : (S (S bound2) <= S m)%nat) =>
                       f (S bound2) (v (exist (fun n' : nat => (n' < S m)%nat) bound (le_Sn_le (S bound) (S m) pf))) an'
                   end
                     (vector_fold_right1_bounded_dep f init sing v bound
                                                     (le_Sn_le bound (S m) (le_Sn_le (S bound) (S m) pf))) (le_Sn_le (S bound) (S m) pf)) with (vector_fold_right1_bounded_dep f init sing v (S bound) pf2); try eapply IHbound.
          clear.
          destruct bound; simpl.
          -- erewrite index_pf_irrel; eauto.
          -- f_equal.
             ++ erewrite index_pf_irrel; eauto.
             ++ destruct bound.
                ** erewrite index_pf_irrel; eauto.
                ** { f_equal.
                     -- erewrite index_pf_irrel; eauto.
                     -- apply vector_fold_right1_bounded_dep_pf_ext.
                   }
        * generalize (vector_Sn_split (vfirstn v (S (S bound)) pf)); intros eqq.
          apply vec_eq_eq in eqq.
          rewrite eqq.
          f_equal.
          -- unfold vlast; simpl.
             erewrite index_pf_irrel; eauto.
          -- erewrite vfirstn_vdrop_last; eauto.
  Qed.

  Lemma vector_fold_right1_dep_gen_ind {A:nat->Type} {B} {P:forall m, Vector B m -> A m -> Prop} (f:forall n,B->A n->A (S n))
        (init:A 0%nat) sing
        (finit : P 0%nat vnil init)
        (fsing: forall b, P 1%nat (vcons b vnil) (sing b))
        (ff: forall n b v r, P n v r -> P (S n) (vcons b v) (f n b r)) :
    forall {m:nat} (v:Vector B m), P m v (vector_fold_right1_dep f init sing v).
  Proof.
    intros.
    rewrite <- (vfirstn_eq v (le_refl m)) at 1.
    apply vector_fold_right1_bounded_dep_gen_ind; trivial.
  Qed.

  Program Definition vapp {A} {m n} (v1:Vector A m) (v2:Vector A n) : Vector A (m+n)
    := fun i => if lt_dec i m then v1 i else v2 (i-m).
  Next Obligation.
    omega.
  Defined.

  Lemma vtake_skip_app_eq_pf n m (pf:(n<=m)%nat) : n + (m - n) = m.
  Proof.
    rewrite Nat.add_sub_assoc by trivial.
    now rewrite minus_plus.
  Defined.

  Lemma vtake_skip_app_lt_pf {m n i} (pf:(n<=m)%nat) (p2f:i < m) : i < n + (m - n).
  Proof.
    now rewrite vtake_skip_app_eq_pf.
  Defined.

  Lemma vtake_skip_app {A} {m:nat} (v:Vector (A) m) (n:nat) (pf:(n<=m)%nat) :
    forall i, v i = vapp (vtake v n pf) (vskip v n pf) (exist _ (proj1_sig i) (vtake_skip_app_lt_pf pf (proj2_sig i))).
  Proof.
    intros.
    unfold vapp, vtake, vskip.
    destruct i; simpl.
    match_destr.
    - now erewrite index_pf_irrel.
    -
      match goal with
        [|- _ = v (exist _ _ ?pff)] => generalize pff
      end.
      assert (HH:x - n + n = x) by omega.
      rewrite HH.
      intros.
      now erewrite index_pf_irrel.
  Qed.

  Lemma vmap_vdrop_last {A B} {n} (f:A->B) (v:Vector A (S n))  : vmap f (vdrop_last v) = vdrop_last (vmap f v).
  Proof.
    unfold vdrop_last.
    apply vec_eq_eq; intros [??]; simpl.
    now repeat rewrite vmap_nth.
  Qed.

  Lemma map_vector_to_list_vmap {A B} {n}  (f:A->B) (v:Vector A n) :
    map f (vector_to_list v) = vector_to_list (vmap f v).
  Proof.
    unfold vector_to_list, vector_fold_right.
    induction n.
    - rewrite vector_fold_right_dep_0; trivial.
    - repeat rewrite vector_fold_right_dep_Sn.
      simpl.
      rewrite IHn, vmap_vdrop_last.
      unfold vlast.
      now rewrite vmap_nth.
  Qed.

  Lemma vector_to_list_ext {A} {n} (x y:Vector A n) :
    vec_eq x y -> vector_to_list x = vector_to_list y.
  Proof.
    apply vector_fold_right_ext.
  Qed.

  Lemma vector_to_list_length (n : nat) (A : Type) (v : Vector.Vector A n) :
    length (Vector.vector_to_list v) = n.
  Proof.
    unfold vector_to_list, vector_fold_right.
    revert v.
    induction n; intros.
    - simpl; trivial.
    - rewrite vector_fold_right_dep_Sn.
      simpl.
      now rewrite IHn.
  Qed.

End Vector.


Set Warnings "-notation-overridden,-parsing".
Add LoadPath "lf/".
Require Import numbers.
Require Import induction.
Require Import poly.
Require Import tactics.
Require Import Coq.Lists.List.
Open Scope list_scope.

(* Propositions are first class objects in Coq *)
Theorem plus_2_2_is_4:
  2 + 2 = 4.

Proof. reflexivity. Qed.

Definition plus_fact: Prop := 2 + 2 = 4.
Check plus_fact.

Theorem plus_fact_is_true:
  plus_fact.

Proof. reflexivity. Qed.

(* Props can be parametrized *)
Definition is_three (n : nat) : Prop :=
  n = 3.

Check is_three 3. (* is_three defines properties of their arguments *)

Definition injective {A B} (f: A -> B) :=
  forall x y : A,
  f x = f y ->
  x = y.

Lemma succ_inj : injective S.

Proof.
  intros n m H.
  inversion H.
  reflexivity.
  Qed.

Check @eq.

(* Logical connectives *)

(* Conjuction *)
Example and_example:
  3 + 4 = 7 /\ 2 * 2 = 4.

Proof.
  split.
  - reflexivity.
  - reflexivity.
  Qed.

Lemma and_intro:
  forall A B: Prop,
  A -> B ->
  A /\ B.

Proof.
  intros A B HA HB.
  split.
  - apply HA.
  - apply HB.
  Qed.

Example and_example':
  3 + 4 = 7 /\ 2 * 2 = 4.

Proof.
  apply and_intro.
  - reflexivity.
  - reflexivity.
  Qed.

(* Exercise *)
Example and_exercise:
  forall n m : nat,
  n + m = 0 ->
  n = 0 /\ m = 0.

Proof.
  intros n m.
  split.
  generalize dependent m.
  - intros m. induction m as [| m' ].
    + intro H.
      rewrite plus_comm in H.
      rewrite plus_0_n in H.
      apply H.
    + destruct n.
      * simpl. intro H. reflexivity.
      * simpl. intro H. inversion H.
  - induction m as [| m' ].
    + reflexivity.
    + destruct n.
      * simpl in H. inversion H.
      * simpl in H. inversion H.
  Qed.

(* Demonstrating `destruct` for using a conjunctive hypothesis to help prove stuff *)
Lemma and_example_2:
  forall n m : nat,
  n = 0 /\ m = 0 ->
  n + m = 0.

Proof.
  intros n m H.
  destruct H as [Hn Hm].
  rewrite Hn. rewrite Hm.
  reflexivity.
  Qed.

Lemma and_example_3:
  forall n m : nat,
  n + m = 0 ->
  n * m = 0.

Proof.
  intros n m H.
  assert (H' : n = 0 /\ m = 0).
  - apply and_exercise. apply H.
  - destruct H' as [Hn Hm].
    + rewrite Hn. reflexivity.
  Qed.

Lemma proj1:
  forall P Q : Prop,
  P /\ Q -> P.

Proof.
  intros P Q [HP HQ].
  apply HP.
  Qed.

(* Exercise *)
Lemma proj2:
  forall P Q : Prop,
  P /\ Q -> Q.

Proof.
  intros P Q [HP HQ].
  apply HQ.
  Qed.

Theorem and_commut:
  forall P Q : Prop,
  P /\ Q -> Q /\ P.

Proof.
  intros P Q [HP HQ].
  split.
  - apply HQ.
  - apply HP.
  Qed.

(* Exercise *)
Theorem and_assoc:
  forall P Q R : Prop,
  P /\ (Q /\ R) -> (P /\ Q) /\ R.

Proof.
  intros P Q R [HP [HQ HR]].
  split.
  - split.
    + apply HP.
    + apply HQ.
  - apply HR.
  Qed.

(* Disjunction *)
Lemma or_example:
  forall n m : nat,
  n = 0 \/ m = 0 ->
  n * m = 0.

Proof.
  intros n m [Hn | Hm].
  - rewrite Hn. reflexivity.
  - rewrite Hm.
    rewrite <- mult_n_O.
    reflexivity.
  Qed.

Lemma or_intro:
  forall A B : Prop,
  A -> A \/ B.

Proof.
  intros A B HA.
  left.
  apply HA.
  Qed.

Lemma zero_or_succ:
  forall n : nat,
  n = 0 \/ n = S (pred n).

Proof.
  intros [| n ].
  - left. reflexivity.
  - right. reflexivity.
  Qed.

(* Demonstrating negation, falsehood *)
Module MyNot.

Definition not (P : Prop) := P -> False.

Notation "~ x" := (not x) : type_scope.

Check not.

End MyNot.

Theorem ex_falso_quodlibet:
  forall (P : Prop),
  False -> P.

Proof.
  intros P contra.
  destruct contra.
  Qed.

(* Exercise *)
Fact not_implies_our_not:
  forall (P : Prop),
  ~ P -> (forall (Q : Prop), P -> Q).

Proof.
  intros.
  destruct H.
  apply H0.
  Qed.

Theorem zero_not_one: ~ (0 = 1).

Proof.
  intros contra.
  inversion contra.
  Qed.

(* Inequality notation *)
Check (0 <> 1).

Theorem zero_not_one': 0 <> 1.

Proof.
  intros H.
  inversion H.
  Qed.

Theorem not_False:
  ~ False.

Proof.
  unfold not.
  intros H.
  apply H.
  Qed.

Theorem contradiction_implies_anything:
  forall P Q : Prop,
  (P /\ ~ P) -> Q.

Proof.
  intros P Q [HP HNA].
  unfold not in HNA.
  apply HNA in HP.
  destruct HP.
  Qed.

Theorem double_neg:
  forall P : Prop,
  P -> ~~P.

Proof.
  intros P H.
  unfold not.
  intros G.
  apply G.
  apply H.
  Qed.

(* Exercise *)
Theorem contrapositive:
  forall (P Q : Prop),
  (P -> Q) -> (~Q -> ~P).

Proof.
  intros P Q HP HNQ HNP.
  unfold not in HNQ.
  apply HNQ in HP.
  - apply HP.
  - apply HNP.
  Qed.

(* Exercise *)
Theorem not_both_true_and_false:
  forall P : Prop,
  ~ (P /\ ~P).

Proof.
  intros P contra.
  destruct contra as [H HN].
  unfold not in HN.
  apply HN in H.
  apply H.
  Qed.

Theorem not_true_is_false:
  forall b : bool,
  b <> true -> b = false.

Proof.
  intros [] H.
  - (* b = true *)
    unfold not in H.
    apply ex_falso_quodlibet.
    apply H. reflexivity.
  - (* b = false *)
    reflexivity.
  Qed.

(* Coq has a built-in tactic `exfalso` for applying reasoning with `ex_falso_quodlibet` *)
Theorem not_true_is_false':
  forall b : bool,
  b <> true -> b = false.

Proof.
  intros [] H.
  - unfold not in H.
    exfalso.
    apply H. reflexivity.
  - reflexivity.
  Qed.

(* Truth *)
(* `I` is a predefined constant `I : True` *)
Lemma True_is_true : True.

Proof.
  apply I. Qed.

(* Logical equivalence *)
Module MyIff.

Definition iff (P Q : Prop) :=
  (P -> Q) /\ (Q -> P).

Notation "P <-> Q" := (iff P Q) (at level 95, no associativity) : type_scope.

End MyIff.

Theorem iff_sym:
  forall P Q : Prop,
  (P <-> Q) -> (Q <-> P).

Proof.
  intros P Q [HAB HBA].
  split.
  - apply HBA.
  - apply HAB.
  Qed.

Lemma not_true_iff_false:
  forall b, b <> true <-> b = false.

Proof.
  intros b.
  split.
  - unfold not. apply not_true_is_false.
  - intros H. rewrite H. intros H'. inversion H'.
  Qed.

(* Exercise *)
Theorem or_distributes_over_and:
  forall P Q R : Prop,
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).

Proof.
  Admitted.

(* Existential quantification *)
Lemma four_is_even:
  exists n : nat,
  4 = n + n.

Proof.
  exists 2. reflexivity.
  Qed.

Theorem exists_example_2:
  forall n,
  (exists m, n = 4 + m) ->
  (exists o, n = 2 + o).

Proof.
  intros n [m Hm].
  exists (2 + m).
  apply Hm.
  Qed.

(* Exercise *)
Theorem dist_not_exists:
  forall (X : Type) (P : X -> Prop),
  (forall x, P x) -> ~ (exists x, ~ P x).

Proof.
  intros.
  unfold not. intros H2. destruct H2 as [x E].
  apply E. apply H.
  Qed.

Fixpoint In
  {A : Type} (x : A) (l : list A) : Prop :=
  match l with
    | nil => False
    | x' :: l' => x' = x \/ In x l'
  end.

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

Example In_example_1:
  In 4 [ 1; 2; 3; 4; 5 ].

Proof.
  simpl. right. right. right. left. reflexivity.
  Qed.


(** Source: https://golem.ph.utexas.edu/category/2015/06/semigroup_puzzles.html *)

Require Import Setoid.
Require Import ssreflect.

Generalizable All Variables.

Section puzzles.
  Variable A : Type.
  Variable op : A -> A -> A.
  Local Infix "*" := op (at level 40, left associativity).

  Hypothesis assoc  : `(x * y * z = x * (y * z)).
  Hypothesis absorp : `(x * y * x = x).

  Section vanilla.
    Lemma puzzle1 : forall x y z, x * y * z = x * z.
    Proof.
      intros x y z.
      rewrite <- (absorp x (y*z)) at 2.
      rewrite (assoc _ x z).
      rewrite (assoc x (y*z) (x*z)).
      rewrite (assoc y _ _).
      rewrite <- (assoc z x z).
      now rewrite absorp.
    Qed.

    Lemma puzzle2 : forall x, x * x = x.
    Proof.
      intro x.
      rewrite <- (absorp x x) at 1.
      rewrite (assoc x _ x).
      now rewrite absorp.
    Qed.
  End vanilla.

  Section ssr.
    Lemma puzzle1_ssr : forall x y z, x * y * z = x * z.
    Proof.
      move=> x y z.
      rewrite -{2}(absorp x (y*z)) (assoc _ x z) (assoc x (y*z) (x*z)).
      by rewrite (assoc y _ _) -(assoc z x z) absorp.
    Qed.

    Lemma puzzle2_ssr : forall x, x * x = x.
    Proof.
      move=> x.
      by rewrite -{1}(absorp x x) (assoc x _ x) absorp.
    Qed.
  End ssr.
End puzzles.


Require Export B7_Triangle_Equilateral.

Section POINT_PROPERTIES.

Lemma ExistsHalfLineEquidistant : forall A B C D : Point,
	A <> B ->
	C <> D ->
	{E : Point |
		HalfLine A B E /\
		Distance A E = Distance C D}.
Proof.
	intros A B C D Hab Hcd.
	setLine A B Hab ipattern:(L) ipattern:(AB).
	setCircle A C D Hcd ipattern:(G) ipattern:(ACD).
	setLinterposC L G AB ACD ipattern:(E) ipattern:(H1) ipattern:(H2) ipattern:(H3) ipattern:(H4).
	 apply CollinearABA.
	 exists E; canonize.
Qed.

Lemma HalfLineEquidistantEqual : forall A B C : Point,
	A <> B ->
	HalfLine A B C ->
	Distance A B = Distance A C ->
	B = C.
Proof.
	intros.
	setLine A B H ipattern:(L) ipattern:(AB).
	setCircle A A B H ipattern:(G) ipattern:(Aab).
	setLinterposC L G AB Aab ipattern:(D) ipattern:(H2) ipattern:(H3) ipattern:(H4) ipattern:(H5).
	 apply CollinearABA.
	 rewrite <- (H5 B).
	  apply H5.
	    canonize.
	   elim (NotClockwiseBAA C A); auto.
	   generalizeChangeSense.
	     elim (NotClockwiseABA C A); auto.
	  canonize.
	   exact (NotClockwiseBAA B A H2).
	   exact (NotClockwiseABA B A H2).
Qed.

Lemma ExistsBetweenEquidistant : forall A B C D : Point,
	A <> B ->
	C <> D ->
	{E : Point |
		Between E A B /\
		Distance A E = Distance C D}.
Proof.
	intros A B C D Hab Hcd.
	setLine A B Hab ipattern:(L) ipattern:(AB).
	setCircle A C D Hcd ipattern:(G) ipattern:(ACD).
	setLinternegC L G AB ACD ipattern:(E) ipattern:(H1) ipattern:(H2) ipattern:(H3) ipattern:(H4).
	 apply CollinearABA.
	 exists E; canonize.
	  destruct (ClockwiseExists B A (sym_not_eq Hab)) as (F, H5).
	    subst; elim (NotClockwiseAAB A F); auto.
	  generalizeChangeSide.
Qed.

Lemma ExistsEquidistantBetween : forall A B C D : Point,
	A <> B ->
	C <> D ->
	{E : Point |
		Between A B E  /\
		Distance B E = Distance C D}.
Proof.
	intros A B C D Hab Hcd.
	setLine A B Hab ipattern:(L) ipattern:(AB).
	setCircle B C D Hcd ipattern:(G) ipattern:(BCD).
	setLinterposC L G AB BCD ipattern:(E) ipattern:(H1) ipattern:(H2) ipattern:(H3)
	 ipattern:(H4).
	 apply CollinearABB.
	 exists E; canonize.
Qed.

Lemma CentralSymetPoint : forall A B : Point,
	A <> B ->
	{C : Point | Distance A B = Distance B C /\ Between A B C}.
Proof.
	intros.
	destruct (ExistsBetweenEquidistant B A A B (sym_not_eq H) H) as (C, (H0, H1)).
	exists C; generalizeChangeSide.
Qed.

Lemma CoordinatePoint : forall A B : Point,
	A <> B ->
	{C : Point | HalfLine Oo Uu C /\ Distance Oo C = Distance A B}.
Proof.
	intros.
	exact (ExistsHalfLineEquidistant Oo Uu A B DistinctOoUu H).
Qed.

End POINT_PROPERTIES.


(** * Bound semantics for correctness of Poly1305.

Poly1305 is a high speed message authentication primitive
<https://en.wikipedia.org/wiki/Poly1305> which makes use of finite
field arithmetic over the finite field F = GF(2^130 - 5). In this
sample code, we demonstrate how one can use the bound semantics to
verify correctness of the portions that implement this arithmetic on a
64-bit machine.

Arithmetic over the field F the integer arithmetic done modulo the
prime 2^130 - 5. One can think of these elements as bit vectors of
size 130 bits. Implementations of poly1305 on 64-bit machines store
store these 130-bit words in 5x64-bit variables each containing
26-bits of the original word. The extra 36 bits in each of these
variables is meant to hold the overflow when performing arithmetic
operations.

*)

Require Import Verse.

(** ** The program variables.

Consider two elements [a] and [b] in the field represented via
5x64-bit words each of 26-bit each [a0,...,a4] and [b0,...,b4]
respectively. Computing [a * b] in [F] results in 5x64-bit elements.
[p0,...,p4]. In this file we only consider the correctness in the
evaluation of p0. Let us first define our program variables for this.

*)
Inductive var : VariableT :=
| p0 : var _ Word64
| a0 : var _ Word64
| a1 : var _ Word64
| a2 : var _ Word64
| a3 : var _ Word64
| a4 : var _ Word64
| b0 : var _ Word64
| b51 : var _ Word64
| b52 : var _ Word64
| b53 : var _ Word64
| b54 : var _ Word64
| tmp : var _ Word64
.

Definition var_eqb k (ty : type k) (x y : var _ ty) : bool :=
  match x, y with
  | p0, p0
  | a0, a0 | a1, a1 | a2, a2 | a3, a3 | a4, a4
  | b0, b0
  | b51, b51 | b52, b52 | b53, b53 | b54, b54
  | tmp, tmp => true
  | _, _ => false
  end.

Require Import Verse.Semantics.
Require Import Verse.DecFacts.
Require Import Verse.Semantics.BoundSemantics.
Require Import Verse.Types.
Require Import Verse.Types.Internal.
Require Import List.
Import VectorNotations.
Notation SIZE := 5.

(**

The formula for the [p0,...,p4] is given below

<<

p0 = a0*b0                                    + 5 * ( a1*b4 + a2*b3 + a3*b2 + a4*b1);
p1 = a0*b1 + a1*b0                            + 5 * ( a2*b4 + a3*b3 + a4*b2 );
p2 = a0*b2 + a1*b1 + a2*b0                    + 5 * ( a3*b4 + a4*b3 );
p3 = a0*b3 + a1*b2 + a2*b1 + a3*b0            + 5 * ( a4*b54 );
p4 = a0*b4 + a1*b3 + a2*b2 + a3*b1 + a4*b0 ;

>>

 *)

(**

Note that the first few terms (printed left aligned) are the usual
terms that arise in the multiplication of

<< a = a0 + 2^26 * a1 + ... + 2^(104) a4 >>

<< b = b0 + 2^26 * b1 + ... + 2^(104) b4 >>

The additional terms that are of the form (5 * (...) ) arise because
2^130 is 5 in the field F.  We refer to the blog post of
<http://loup-vaillant.fr/tutorials/poly1305-design> for details.

*)

Definition polymul : code var.
  verse
    [ p0 ::== Ox "0000000000000000";
      tmp ::= a0 [*] b0;
      p0 ::=+ tmp;
      tmp ::= a1 [*] b54;
      p0 ::=+ tmp;
      tmp ::= a2 [*] b53;
      p0 ::=+ tmp;
      tmp ::= a3 [*] b52;
      p0 ::=+ tmp;
      tmp ::= a4 [*] b51;
      p0 ::=+ tmp
    ]%list.
Defined.

Import BoundSemantics.

Definition init : State var :=
  fun k (ty : type k) (v : var _ ty) =>
    match v in var _ ty0 return T.typeDenote ty0 + {VariableError var} with
    | a0 | a1 | a2 | a3 | a4 => {- (0, 26) -}
    | b0 => {- (0, 26) -}
    | b54 | b53 | b52 | b51 => {- (0, 29) -}
    | p0 => {- (0, 0) -}
    | tmp => {- (0, 0) -}
    end.

Definition finalS := (recover(codeDenote var_eqb init polymul)).

Compute (finalS _ _ p0).

(**

This computation gives the following response

<<
     = {-(0, 59) -}
     : T.typeDenote Word64 + {VariableError var}
>>
 *)

(**

What this means is that p0 has an upper bound of 2^59 and that none of
the arithmetic operations have overflowed.

*)


From MyCoq.Lib Require Export Nat.

(* 多态 *)

Inductive boollist : Type :=
  | bool_nil
  | bool_cons (b : bool) (l : boollist).

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

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

Check nil.
Check cons.

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.

Example test_repeat1:
  repeat nat (N 4) (N 2) = cons nat (N 4) (cons nat (N 4) (nil nat)).
Proof. simpl. reflexivity. Qed.

Example test_repeat2:
  repeat bool false (N 1) = cons bool false (nil bool).
Proof. simpl. reflexivity. Qed.

Inductive mumble : Type :=
  | a
  | b (x : mumble) (y : nat)
  | c.
Inductive grumble (X:Type) : Type :=
  | d (m : mumble)
  | e (x : X).

(* Check d (b a (N 5)). *)
Check d mumble (b a (N 5)).
Check d bool (b a (N 5)).
Check e bool true.
Check e mumble (b c O).
(* Check e bool (b c O). *)
(* Check c. *)

(* 类型标注的推断 *)
Fixpoint repeat' X x count : list X :=
  match count with
  | O => nil X
  | S count' => cons X x (repeat' X x count')
  end.

Check repeat.
Check repeat'.

(* 类型参数的推断 *)
Fixpoint repeat'' X x count : list X :=
  match count with
  | O => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

(* 隐式参数 *)
Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

Definition list_nat := cons (N 1) nil.

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

Check repeat'''.

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 => O
  | cons _ l' => S (length l')
  end.

(* 显式提供类型参数 *)
Fail Definition mynil := nil nat.
Definition mynil := @nil nat.

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

Definition list_nat' := [true; false; false].

Theorem app_nil_r: forall (X : Type), forall l : list X,
  l ++ [] = l.
Proof.
  induction l as [| n l'].
  - reflexivity.
  - simpl.
    rewrite IHl'.
    reflexivity.
Qed.

Theorem app_assoc: forall A (l m n : list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  induction l as [| x l'].
  - reflexivity.
  - simpl.
    intros m n.
    rewrite IHl'.
    reflexivity.
Qed.

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

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  induction l1 as [| n1 l1'].
  - simpl.
    intros l2.
    rewrite app_nil_r.
    reflexivity.
  - simpl.
    intros l2.
    rewrite IHl1'.
    rewrite app_assoc.
    reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  induction l as [| n l'].
  - reflexivity.
  - simpl.
    rewrite rev_app_distr.
    simpl.
    rewrite IHl'.
    reflexivity.
Qed.

(* 多态序对 *)
Inductive prod (X Y : Type) : Type :=
  | pair (x : X) (y : Y).
Arguments pair {X} {Y} _ _.

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

(* 积类型 Product Types *)
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.

Check @combine.

Fixpoint split {X Y : Type} (l : list (X * Y)) : (list X) * (list Y) :=
  match l with
  | nil => (nil, nil)
  | x :: y => match x with
              | (m, n) => match split y with
                              | (l1, l2) => (m :: l1, n :: l2)
                              end
              end
  end.

Example test_split:
  split [(N 1,false);(N 2,false)] = ([N 1; N 2],[false;false]).
Proof. simpl. 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
  | x :: y => if n =? O
              then Some x
              else nth_error y (pred n)
  end.

Example test_nth_error1: nth_error [N 4; N 5; N 6; N 7] (N 0) = Some (N 4).
Proof. simpl. reflexivity. Qed.
Example test_nth_error2: nth_error [[N 1];[N 2]] (N 1) = Some [N 2].
Proof. simpl. reflexivity. Qed.
Example test_nth_error3: nth_error [true] (N 2) = None.
Proof. simpl. reflexivity. Qed.

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

Check @hd_error.
Example test_hd_error1: hd_error [N 1; N 2] = Some (N 1).
Proof. simpl. reflexivity. Qed.
Example test_hd_error2: hd_error [[N 1]; [N 2]] = Some [N 1].
Proof. simpl. reflexivity. Qed.

(* 函数作为数据 *)

(* 高阶函数 *)
Definition doit3times {X : Type} (f : X -> X) (n : X) : X :=
  f (f (f n)).

Check @doit3times.
Example test_doit3times': doit3times negb true = false.
Proof. simpl. reflexivity. Qed.

(* 过滤器 *)
Fixpoint filter {X : Type} (test: X -> bool) (l : list X) : (list X) :=
  match l with
  | [] => []
  | x :: y => if test x
              then x :: filter test y
              else filter test y
  end.

Example test_filter1: filter evenb [N 1; N 2; N 3; N 4] = [N 2; N 4].
Proof. simpl. reflexivity. Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  length l =? N 1.

(* 匿名函数 *)
Example test_anon_fun':
  doit3times (fun n => n * n) (N 2) = N 256.
Proof. simpl. reflexivity. Qed.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun n => evenb n && ((N 7) <=? n)) l.

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

Fixpoint partition {X : Type} (test : X -> bool) (l : list X) : list X * list X :=
  match l with
  | [] => ([], [])
  | x :: y => if test x
              then match partition test y with
                   | (l1, l2) => (x :: l1, l2)
                   end
              else match partition test y with
                   | (l1, l2) => (l1, x :: l2)
                   end
  end.

Example test_partition1: partition oddb [N 1; N 2; N 3; N 4; N 5] = ([N 1; N 3; N 5], [N 2; N 4]).
Proof. simpl. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [N 5; N 9; N 0] = ([], [N 5; N 9; N 0]).
Proof. simpl. 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_app: forall (X Y : Type) (f : X -> Y) (l1 l2 : list X),
  map f (l1 ++ l2) = (map f l1) ++ (map f l2).
Proof.
  induction l1 as [| n1 l1'].
  - reflexivity.
  - simpl.
    intros l2.
    rewrite -> IHl1'.
    reflexivity.
Qed.

Theorem map_rev: forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  induction l as [| n l'].
  - reflexivity.
  - simpl.
    rewrite map_app.
    simpl.
    rewrite <- IHl'.
    reflexivity.
Qed.

Fixpoint flat_map {X Y: Type} (f : X -> list Y) (l : list X) : (list Y) :=
  match l with
  | [] => []
  | x :: y => (f x) ++ flat_map f y
  end.

Example test_flat_map1: flat_map (fun n => [n; n; n]) [N 1; N 5; N 4] = [N 1; N 1; N 1; N 5; N 5; N 5; N 4; N 4; N 4].
Proof. simpl. 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 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.

Example test_fold: fold cons [true; true; false] [] = [true; true; false].
Proof. simpl. reflexivity. Qed.

(* 用函数构造函数 *)
Definition constfun {X : Type} (x : X) : nat -> X :=
  fun (k : nat) => x.
Definition ftrue := constfun true.
Example constfun_example1: ftrue O = true.
Proof. simpl. reflexivity. Qed.
Example constfun_example2: (constfun (N 5)) (N 99) = N 5.
Proof. simpl. reflexivity. Qed.

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l O.
Example test_fold_length1: fold_length [N 4; N 7; N 0] = N 3.
Proof. simpl. reflexivity. Qed.

Theorem fold_length_correct: forall X (l : list X),
  fold_length l = length l.
Proof.
  induction l as [| n l'].
  - reflexivity.
  - simpl.
    rewrite <- IHl'.
    reflexivity.
Qed.

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

Example test_fold_map: fold_map negb [true; true] = [false; false].
Proof. simpl. reflexivity. Qed.

Theorem fold_map_correct: forall (X Y : Type) (f : X -> Y) (l : list X),
  fold_map f l = map f l.
Proof.
  induction l as [| n l'].
  - reflexivity.
  - simpl.
    rewrite <- IHl'.
    (* reflexivity 化简力度比 simpl 更强 *)
    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 :=
  f (fst p) (snd p).

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.
  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.
  intros f.
  intros [x y].
  reflexivity.
Qed.

Set Universe Polymorphism.
Definition cnat := forall X : Type,
  (X -> X) -> X -> X.

Check cnat.

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 :=
  fun (X : Type) (f : X -> X) (x : X) => f (f (f x)).

Check @one.

(* match 行不通，cnat 本质上是一个函数，不是一个可归纳的数据类型 *)
Definition succ (n : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (n X f x).

Example succ1: succ zero = one.
Proof. simpl. reflexivity. Qed.
Example succ2: succ one = two.
Proof. simpl. reflexivity. Qed.
Example succ3: succ two = three.
Proof. simpl. reflexivity. Qed.

Definition succ_f (X : Type) (f f_0 : X -> X) (x : X) : X := f (f_0 x).

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

Example plus1: plus zero one = one.
Proof. simpl. reflexivity. Qed.
Example plus2: plus two three = plus three two.
Proof. simpl. reflexivity. Qed.
Example plus3:
  plus (plus two two) three = plus one (plus three three).
Proof. simpl. reflexivity. Qed.

(* 思考定义 *)
Definition mult (n m : cnat) : cnat :=
  (* fun (X : Type) (f : X -> X) (x : X) => n X (m X f) x. *)
  (* m X f 是对 X 类型的变量做 m 次 f 变换，其依然是 X -> X 的对 X 类型变量的变换，记作 f' *)
  (* 之后 n X f' 意味着做 n 次 f' 变换，最终效果即 n * m 次 f 变换 *)
  fun (X : Type) (f : X -> X) => n X (m X f).

Example mult1: mult one one = one.
Proof. simpl. reflexivity. Qed.
Example mult2: mult zero (plus three three) = zero.
Proof. simpl. reflexivity. Qed.
Example mult3: mult two three = plus three three.
Proof. simpl. reflexivity. Qed.

(* 如果直接令 m 接收 cnat 作为泛型参数会导致 universe inconsistency *)
(* https://stackoverflow.com/questions/32153710/what-does-error-universe-inconsistency-mean-in-coq *)
(* 1. 在 cnat 定义前添加 Set Universe Polymorphism. *)
Definition exp (n m : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => m cnat (mult n) one X f x.
(* 2. 注意和 mult 的区别 *)
Definition exp' (n m : cnat) : cnat :=
  (* n X 代表对原变换重复 n 次，可以认为其是对 X -> X 的变换，即变换的变换 *)
  (* 可以参看 plus 中使用 succ_f 的做法 *)
  fun (X : Type) => m (X -> X) (n X).

Example exp1: exp two two = plus two two.
Proof. simpl. reflexivity. Qed.
Example exp2: exp three zero = one.
Proof. simpl. reflexivity. Qed.
Example exp3: exp three two = plus (mult two (mult two two)) one.
Proof. simpl. reflexivity. Qed.
Example exp'1: exp' two two = plus two two.
Proof. simpl. reflexivity. Qed.
Example exp'2: exp' three zero = one.
Proof. simpl. reflexivity. Qed.
Example exp'3: exp' three two = plus (mult two (mult two two)) one.
Proof. simpl. reflexivity. Qed.


Require Export Induction.
(* ((Polymorphism)) *)

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

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

(* Exercise: 2 stars (mumble_grumble) *)

(*
Inductive mumble : Type :=
  | a : mumble
  | b : mumble → nat → mumble
  | c : mumble.
Inductive grumble (X:Type) : Type :=
  | d : mumble → grumble X
  | e : X → grumble X.

Which of the following are well-typed elements of grumble X for some type X?
- d (b a 5)      // the type cannot be inferred
+ d mumble (b a 5)
+ d bool (b a 5)
+ e bool true
+ e mumble (b c 0)
- e bool (b c 0) // (b c 0) is a mumble, not bool
- c              // is a mumble
*)

(* END mumble_grumble. *)

(* Exercise: 2 stars (baz_num_elts) *)

(* None. There are no sinks. *)

(* END baz_num_elts. *)

(* Exercise: 2 stars, optional (poly_exercises) *)

Fixpoint repeat {X : Type} (n : X) (count : nat) : list X :=
  match count with
    | O => nil
    | S c' => (n :: repeat n c')%list
  end.

Example test_repeat1 : repeat true 2 = (true :: true :: nil)%list.
Proof. reflexivity. Qed.

Theorem nil_app : forall X : Type, forall l : list X,
  app nil l = l.
Proof. reflexivity. Qed.

Theorem rev_snoc : forall X : Type, forall v : X, forall l : list X,
  rev (snoc l v) = (v :: rev l)%list.
Proof.
  intros X v l.
  induction l as [|n l'].
  Case "l = nil".
    reflexivity.
  Case "l = n :: l'".
    simpl.
    rewrite -> IHl'.
    reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros X l.
  induction l as [|n l'].
  Case "l = nil".
    reflexivity.
  Case "l = n :: l'".
    simpl.
    assert (forall Z : Type, forall z : list Z, forall m : Z,
            rev (snoc z m) = (m :: rev z)%list).
    SCase "proving rev (snoc l v) = v :: rev l".
      intros Z z m.
      induction z as [|m' z'].
      SSCase "z = nil".
        reflexivity.
      SSCase "z = m' :: z'".
        simpl.
        rewrite -> IHz'.
        reflexivity.
    rewrite -> H.
    rewrite -> IHl'.
    reflexivity.
Qed.

Theorem snoc_with_append :
  forall X : Type, forall l1 l2 : list X, forall v : X,
  snoc (l1 ++ l2)%list v = (l1 ++ snoc l2 v)%list.
Proof.
  intros X l1 l2 v.
  induction l1 as [|n l1'].
  Case "l1 = nil".
    reflexivity.
  Case "l1 = n :: l1'".
    simpl.
    rewrite -> IHl1'.
    reflexivity.
Qed.

(* END poly_exercises. *)

(* Exercise: 1 star, optional (combine_checks) *)

(* combine : forall X Y : Type, -> list X -> list Y -> list (X * Y) *)

(* Eval compute in (combine [1; 2] [false; false; true; true])
= [(1, false), (2, false)]
*)

(* END combine_checks. *)

(* Exercise: 2 stars (split) *)

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
                         (xt, yt) => ((x :: xt)%list, (y :: yt)%list)
                       end
  end.

Example test_split:
  split ((1, false) :: (2, false) :: nil)%list =
  ((1 :: 2 :: nil)%list, (false :: false :: nil)%list).
Proof. reflexivity. Qed.

(* END split. *)

(* Exercise: 1 star, optional (hd_opt_poly) *)

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

Example test_hd_opt1 : hd_opt (1 :: 2 :: nil)%list = Some 1.
Proof. reflexivity. Qed.

Example test_hd_opt2 :
  hd_opt ((1 :: nil)%list :: (2 :: nil)%list :: nil)%list =
  Some (1 :: nil)%list.
Proof. reflexivity. Qed.

(* END hd_opt_poly. *)

(* ((Functions as Data)) *)

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

(* Exercise: 2 stars, advanced (currying) *)

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

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.
  replace (prod_curry (prod_uncurry f) x y) with ((prod_uncurry f) (x, y)).
    reflexivity.
    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.
  destruct p.
  reflexivity.
Qed.

(* END currying. *)

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

(* Exercise: 2 stars (filter_even_gt7) *)

Definition filter_even_gt7_1 (l : list nat) : list nat :=
  filter (fun x => ((evenb x) && negb (ble_nat 7 x))%bool) l.

(* END filter_even_gt7. *)

(* Exercise: 3 stars (partition) *)

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

Example test_partition1 : partition oddb (1 :: 2 :: 3 :: 4 :: 5 :: nil)%list =
  ((1 :: 3 :: 5 :: nil)%list, (2 :: 4 :: nil)%list).
Proof. reflexivity. Qed.

Example test_partition2 :
  partition (fun x => false) (5 :: 9 :: 0 :: nil)%list =
  (nil, (5 :: 9 :: 0 :: nil)%list).
Proof. reflexivity. Qed.

(* END partition. *)

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

(* Exercise: 3 stars (map_rev) *)

Theorem map_app : forall (X Y : Type) (f : X -> Y) (l1 l2 : list X),
  map f (l1 ++ l2) = (map f l1 ++ map f l2)%list.
Proof.
  intros X Y f l1 l2.
  induction l1 as [|n l1'].
  Case "l = nil".
    reflexivity.
  Case "l = n :: l1'".
    simpl.
    rewrite <- IHl1'.
    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 [|n l'].
  Case "l = nil".
    reflexivity.
  Case "l = n :: l'".
    simpl.
    assert (forall (Z : Type) (j : list Z) (k : Z),
            snoc j k = (j ++ (k :: nil))%list).
      intros Z j k.
      induction j as [|m j'].
      SCase "j = nil".
        reflexivity.
      SCase "j = m :: j'".
        simpl.
        rewrite -> IHj'.
        reflexivity.
    rewrite -> H.
    rewrite -> H.
    rewrite <- IHl'.
    rewrite -> map_app.
    reflexivity.
Qed.

(* END map_rev. *)

(* Exercise: 2 stars (flat_map) *)

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)%list
  end.

Example test_flat_map1:
  flat_map (fun n => (n :: n :: n :: nil)%list) (1 :: 5 :: 4 :: nil)%list =
  (1 :: 1 :: 1 :: 5 :: 5 :: 5 :: 4 :: 4 :: 4 :: nil)%list.
Proof. reflexivity. Qed.

(* END flat_map. *)

(* Exercise: 1 star, advanced (fold_types_different) *)

(* rev = fold (fun x y => snoc y x) *)

(* END fold_types_different. *)

Definition constfun {X : Type} (x : X) : nat -> X := fun k => x.

Definition override {X : Type} (f : nat -> X) (k : nat) (x : X) : nat -> X :=
  fun (k' : nat) => if beq_nat k k' then x else f k'.

(* Exercise: 1 star (override_example) *)

Theorem override_example : forall (b : bool),
  override (constfun b) 3 true 2 = b.
Proof.
  intros b.
  destruct b.
    reflexivity.
    reflexivity.
Qed.

(* END override_example. *)

(* Exercise: 2 stars (override_neq) *)

Theorem override_neq : forall (X : Type) x1 x2 k1 k2 (f : nat -> X),
  f k1 = x1 ->
  beq_nat k2 k1 = false ->
  (override f k2 x2) k1 = x1.
Proof.
  intros X x1 x2 k1 k2 f.
  intros H1.
  intros H2.
  unfold override.
  rewrite -> H2.
  rewrite -> H1.
  trivial.
Qed.

(* END override_neq. *)

(* ((Additional Exercises)) *)

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

(* Exercise: 2 stars (fold_length) *)

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 :: nil)%list = 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 [|n l'].
  Case "l = nil".
    reflexivity.
  Case "l = n :: l'".
    simpl.
    rewrite <- IHl'.
    reflexivity.
Qed.

(* END fold_length. *)

(* Exercise: 3 stars (fold_map) *)

Definition fold_map {X Y : Type} (f : X -> Y) (l : list X) : list Y :=
  fold (fun x y => cons (f x) y) l nil.

Theorem fold_map_correct : forall (X Y : Type) (l : list X) (f : X -> Y),
  map f l = fold_map f l.
Proof.
  intros X Y l f.
  induction l as [|n l'].
  Case "l = nil".
    reflexivity.
  Case "l = n :: l'".
    simpl.
    rewrite -> IHl'.
    reflexivity.
Qed.

(* END fold_map. *)

Fixpoint index { X : Type } (n : nat) (l : list X) : option X :=
  match l with
    | nil => None
    | cons h t => if beq_nat n 0 then Some h else index (pred n) t
  end.

(* Exercise: 2 stars, advanced (index_informal) *)

(* Performing an induction over the given list, we have the following cases.
* If the list is empty, the case is trivial: no elements are present, and the
* function returns None.
* If the list is non-empty, then its length is not zero; thus the index in the
* remaining list can't be zero, and the inductive step applies. *)

(* END index_informal. *)

Module Church.

Definition nat := forall X : Type, (X -> X) -> X -> X.

Definition zero : nat := fun (X : Type) (f : X -> X) (x : X) => x.

Definition one : nat := fun (X : Type) (f : X -> X) (x : X) => f x.

Definition two : nat := fun (X : Type) (f : X -> X) (x : X) => f (f x).

Definition three : nat := fun (X : Type) (f : X -> X) (x : X) => f (f (f x)).

(* Exercise: 4 stars, advanced (church_numerals) *)

Definition succ (n : nat) : nat :=
  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 : nat) : nat :=
  fun (X : Type) (f : X -> X) (x : X) => m X f (n 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 : nat) : nat :=
  fun (X : Type) (f : X -> X) => m X (n X f).

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 exp (n m : nat) : nat :=
  fun (X : Type) (f : X -> X) => m (X -> X) (n X) (one X f).

Example exp_1 : exp two two = plus two two.
Proof. reflexivity. Qed.

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

Example exp_3 : exp three zero = one.
Proof. reflexivity. Qed.

(* END church_numerals. *)

End Church.