Require Import Utf8.
Require Import GroupDefinition.
Require Import Setoid.

(* The direct product of two groups is a group. *)

Definition GroupProduct_op
    {G : Set} {g_op : SemiGroupOp G} {g_i : GroupInv G} {g_e: G} `{@Group G g_op g_i g_e}
    {H : Set} {h_op : SemiGroupOp H} {h_i : GroupInv H} {h_e: H} `{@Group H h_op h_i h_e}
    : SemiGroupOp (prod G H) := fun (a: prod G H) (b: prod G H) =>
  match a, b with
  | (x, y), (s, t) => (g_op x s, h_op y t)
  end.

Definition GroupProduct_i
    {G : Set} {g_op : SemiGroupOp G} {g_i : GroupInv G} {g_e: G} `{@Group G g_op g_i g_e}
    {H : Set} {h_op : SemiGroupOp H} {h_i : GroupInv H} {h_e: H} `{@Group H h_op h_i h_e}
    : GroupInv (prod G H) := fun (a: prod G H) =>
  match a with
  | (x, y) => (g_i x, h_i y)
  end.

Instance GroupProduct
    {G : Set} {g_op : SemiGroupOp G} {g_i : GroupInv G} {g_e: G} (P : @Group G g_op g_i g_e)
    {H : Set} {h_op : SemiGroupOp H} {h_i : GroupInv H} {h_e: H} (Q : @Group H h_op h_i h_e)
    : (@Group
        (prod G H)
        (@GroupProduct_op G g_op g_i g_e P H h_op h_i h_e Q)
        (@GroupProduct_i G g_op g_i g_e P H h_op h_i h_e Q)
        (g_e, h_e)
    ).
Proof.
  repeat split.
  intros a b c.
  compute.
  destruct a.
  destruct b.
  destruct c.
  repeat rewrite (@sg_assoc G g_op _).
  repeat rewrite (@sg_assoc H h_op _).
  reflexivity.
  intros a.
  compute.
  destruct a.
  rewrite (@g_right_identity G g_op _).
  rewrite (@g_right_identity H h_op _).
  reflexivity.
  assumption.
  assumption.
  intros a.
  compute.
  destruct a.
  rewrite (@g_right_inverse G g_op g_i _ _).
  rewrite (@g_right_inverse H h_op h_i _ _).
  reflexivity.
Qed.

Declare Scope product_scope.
Delimit Scope product_scope with product.
Notation "A × B" := (GroupProduct A B) (at level 30, right associativity) : product_scope.
Bind Scope product_scope with Group.

(* The direct product of two abelian groups is an abelian group. *)

Instance AbelianGroupProduct
    {G : Set} {g_op : SemiGroupOp G} {g_i : GroupInv G} {g_e: G} (P : @AbelianGroup G g_op g_i g_e)
    {H : Set} {h_op : SemiGroupOp H} {h_i : GroupInv H} {h_e: H} (Q : @AbelianGroup H h_op h_i h_e)
    : (@AbelianGroup
        (prod G H)
        (@GroupProduct_op G g_op g_i g_e (AsGroup P) H h_op h_i h_e (AsGroup Q))
        (@GroupProduct_i G g_op g_i g_e (AsGroup P) H h_op h_i h_e (AsGroup Q))
        (g_e, h_e)
    ).
Proof.
  repeat split.
  intros a b c.
  compute.
  destruct a.
  destruct b.
  destruct c.
  repeat rewrite (@sg_assoc G g_op _).
  repeat rewrite (@sg_assoc H h_op _).
  reflexivity.
  intros a.
  compute.
  destruct a.
  rewrite (@g_right_identity G g_op _).
  rewrite (@g_right_identity H h_op _).
  reflexivity.
  exact abelian_groups_are_groups.
  exact abelian_groups_are_groups.
  intros a.
  compute.
  destruct a.
  rewrite (@g_right_inverse G g_op g_i _ _).
  rewrite (@g_right_inverse H h_op h_i _ _).
  reflexivity.
  intros a b.
  compute.
  destruct a.
  destruct b.
  rewrite (@ag_commutative G g_op g_i g_e).
  rewrite (@ag_commutative H h_op h_i h_e).
  reflexivity.
  assumption.
  assumption.
Qed.

Declare Scope abelian_product_scope.
Delimit Scope abelian_product_scope with abelian_product.
Notation "A × B" := (AbelianGroupProduct A B) (at level 30, right associativity) : abelian_product_scope.
Bind Scope abelian_product_scope with AbelianGroup.


Require Export section_03_nat.

(* Section 4. More inductive types *)

(** Analogous to the type of natural numbers, many types can be specified as
    inductive types. In this lecture we introduce some further examples of
    inductive types: the unit type, the empty type, the booleans, coproducts,
    dependent pair types, and cartesian products. We also introduce the type of
    integers. *)

(** Section 4.2. The unit type *)

(** The unit type is an inductive type generated by a single point called star.
    *)

Inductive unit : Type :=
| star : unit.

(** Section 4.3. The empty type *)

(** The empty type is an inductive type with no constructors at all. *)

Inductive empty : Type := .

(** The induction principle gives a section of every family of types over the
    empty type. In other words, anything follows from falso: ex falso
    quodlibet. *)

Definition ex_falso {B : empty -> Type} : forall x, B x.
Proof.
  intro x.
  induction x.
Defined.

Definition ex_falso_map {A} : empty -> A := ex_falso.

(** We use the empty type to define the negation of an arbitrary type. *)

Definition neg (A : Type) : Type := A -> empty.

(** Section 4.4. The booleans *)

(** The type of booleans is an inductive type generated by two constructors:
    true and false. *)

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

(** Using the induction principle of the booleans, we can define some of the
    boolean operations. We show here how to define negation, conjunction, and
    disjunction as boolean operators. Some other boolean operators are defined
    in the exercises. *)

Definition negb (b : bool) : bool.
Proof.
  induction b.
  - exact false.
  - exact true.
Defined.

Definition andb (b b' : bool) : bool.
Proof.
  induction b.
  - induction b'.
    * exact true.
    * exact false.
  - induction b'.
    * exact false.
    * exact false.
Defined.

Definition orb (b b' : bool) : bool.
Proof.
  induction b.
  - induction b'.
    * exact true.
    * exact true.
  - induction b'.
    * exact true.
    * exact false.
Defined.

(** Section 4.5. Coproducts and the type of integers *)

(** The coproduct of two types is defined as an inductive type with
    constructors

    inl : A -> coprod A B
    inr : B -> coprod A B. *)

Inductive coprod (A B : Type) : Type :=
| inl : A -> coprod A B
| inr : B -> coprod A B.

(** We make the arguments A and B of inl and inr implicit. *)

Arguments inl {A B}.
Arguments inr {A B}.

(** Using coproducts, the type of natural numbers, and the unit type we now
    construct the type of integers. *)

Definition Z : Type := coprod ℕ (coprod unit ℕ).

(** We define some integers close to zero. *)

Definition zero_Z : Z := inr (inl star).

Definition one_Z : Z := inr (inr zero_ℕ).

Definition two_Z : Z := inr (inr one_ℕ).

Definition neg_one_Z : Z := inl zero_ℕ.

Definition neg_two_Z : Z := inl one_ℕ.

(** Now we extend the successor function on the natural numbers to a successor
    function on the integers. *)

Definition succ_Z (k : Z) : Z.
Proof.
  destruct k as [n | x].
  - destruct n.
    * exact zero_Z.
    * exact (inl n).
  - destruct x as [x | n].
    * exact one_Z.
    * exact (inr (inr (succ_ℕ n))).
Defined.

(** Section 4.6. Dependent pair types *)

(** Given a family B of types over A, we can for the type of pairs (x,y),
    consisting of a term x:A and a term y:B(x). Note that the type of the term
    y depends on the term x, hence we call such pairs dependent pairs.

    More traditionally, the type of dependent pair types is called the
    Sigma-type. It is defined as an inductive type, of which the pairs are the
    constructors. *)

Inductive Sigma (A : Type) (B : A -> Type) : Type :=
| pair : forall x, B x -> Sigma A B.

(** We make the arguments A and B of pair implicit. *)

Arguments pair {A B}.

(** Using the induction principle, we define the two projection functions on
    a dependent pair type. *)

Definition pr1 {A : Type} {B : A -> Type} (x : Sigma A B) : A.
Proof.
  induction x.
  assumption.
Defined.

Definition pr2 {A : Type} {B : A -> Type} (x : Sigma A B) : B (pr1 x).
Proof.
  induction x.
  assumption.
Defined.

(** Section 4.8. Cartesian products *)

(** The cartesian product of two types is defined as a special case of the
    dependent pair type. *)

Definition prod (A B : Type) : Type := Sigma A (fun x => B).

(** Exercises for section 4 *)

(** Exercise 4.2 *)

(** Exercise 4.2.a *)

Lemma double_neg_elim_decidable (A : Type) :
  coprod A (neg A) -> (neg (neg A) -> A).
Proof.
  intro x.
  induction x.
  - now apply const.
  - intro y. now apply ex_falso_map.
Defined.

(** Exercise 4.2.b *)

Lemma triple_neg_elim (A : Type) :
  neg (neg (neg A)) -> neg A.
Proof.
  intros f a.
  apply ex_falso_map.
  now apply f.
Defined.

(** Exercise 4.3 *)

Definition xorb (b b' : bool) : bool.
Proof.
  induction b.
  - induction b'.
    * exact false.
    * exact true.
  - induction b'.
    * exact true.
    * exact false.
Defined.

Definition impliesb (b b' : bool) : bool.
Proof.
  induction b.
  - induction b'.
    * exact true.
    * exact false.
  - induction b'.
    * exact true.
    * exact true.
Defined.

Definition iffb (b b' : bool) : bool.
Proof.
  induction b.
  - induction b'.
    * exact true.
    * exact false.
  - induction b'.
    * exact false.
    * exact true.
Defined.

Definition peirce_arrow (b b' : bool) : bool.
Proof.
  induction b.
  - induction b'.
    * exact false.
    * exact false.
  - induction b'.
    * exact false.
    * exact true.
Defined.

Definition sheffer_stroke (b b' : bool) : bool.
Proof.
  induction b.
  - induction b'.
    * exact false.
    * exact true.
  - induction b'.
    * exact true.
    * exact true.
Defined.

(** Exercise 4.4 *)

Definition pred_Z (k : Z) : Z.
Proof.
  destruct k as [n | x].
  - exact (inl (succ_ℕ n)).
  - destruct x as [x | n].
    * exact neg_one_Z.
    * destruct n.
      ** exact zero_Z.
      ** exact (inr (inr n)).
Defined.

(** Exercise 4.5 *)

Definition add_Z (k l : Z) : Z.
Proof.
  destruct l as [n | x].
  - induction n as [|n s].
    * exact (pred_Z k).
    * exact (pred_Z s).
  - destruct x as [x | n].
    * exact k.
    * induction n as [|n s].
      ** exact (succ_Z k).
      ** exact (succ_Z s).
Defined.

Definition neg_Z (k : Z) : Z.
Proof.
  destruct k as [n | x].
  - exact (inr (inr n)).
  - destruct x as [x | n].
    * exact (inr (inl x)).
    * exact (inl n).
Defined.

Definition mul_Z (k l : Z) : Z.
Proof.
  destruct l as [n | x].
  - induction n as [|n m].
    * exact (neg_Z k).
    * exact (add_Z m (neg_Z k)).
  - destruct x as [x | n].
    * exact zero_Z.
    * induction n as [|n m].
      ** exact k.
      ** exact (add_Z m k).
Defined.

(** Exercise 4.6 *)

(** The following is ill-formed. I don't know yet how to fix it.

Fixpoint Fibonacci_Z (k : Z) : Z :=
  match k with
  | inl n =>
    match n with
    | zero_ℕ => one_Z
    | succ_ℕ m =>
      match m with
      | zero_ℕ => neg_one_Z
      | succ_ℕ m' =>
        add_Z (Fibonacci_Z (inl m)) (neg_Z (Fibonacci_Z (inl m')))
      end
    end
  | inr x =>
    match x with
    | inl x => zero_Z
    | inr n => inr (inr (Fibonacci (succ_ℕ n)))
    end
  end.
 *)

(*
Proof.
  destruct k as [n | x].
  - induction n as [|n f].
    * exact one_Z.
    * exact (neg_Z !!!
  - destruct x as [x | n].
    * exact zero_Z.
    * exact (inr (inr (Fibonacci (succ_ℕ n)))).
Defined.
 *)

(** Exercise 4.7 *)

Definition true' : coprod unit unit := inl star.

Definition false' : coprod unit unit := inr star.

Definition ind_coprod_unit_unit {P : coprod unit unit -> Type} (p1 : P true') (p0 : P false') : forall x, P x.
Proof.
  intro x.
  destruct x as [x | x].
  destruct x. assumption.
  destruct x. assumption.
Defined.

(** Exercise 4.8 *)

(** Exercise 4.8.a *)

Inductive list (A : Type) : Type :=
| nil : list A
| cons : A -> list A -> list A.

Arguments nil {A}.
Arguments cons {A}.

Definition in_list {A} (a : A) : list A := cons a nil.

(** Exercise 4.8.b *)

Definition fold_list {A B} (b : B) (m : A -> B -> B) : list A -> B.
Proof.
  intro l.
  induction l as [|a l' b'].
  - exact b.
  - exact (m a b').
Defined.

(** Exercise 4.8.c *)

Definition length_list {A} : list A -> ℕ.
Proof.
  apply fold_list.
  - exact zero_ℕ.
  - exact (const succ_ℕ).
Defined.

(** Exercise 4.8.d *)

Definition sum_list_ℕ : list ℕ -> ℕ.
Proof.
  apply fold_list.
  - exact zero_ℕ.
  - exact add_ℕ.
Defined.

(** Exercise 4.8.e *)

Definition concat_list {A} : list A -> (list A -> list A).
Proof.
  apply (@fold_list A (list A -> list A)).
  - exact (fun l => l).
  - intro a. exact (comp (cons a)).
Defined.

(** Exercise 4.8.f *)

Definition flatten_list {A} : list (list A) -> list A.
Proof.
  apply fold_list.
  - exact nil.
  - exact concat_list.
Defined.

(** Exercise 4.8.g *)

Definition reverse_list {A} : list A -> list A.
Proof.
  intro l.
  induction l as [|a l r].
  - exact nil.
  - exact (concat_list r (in_list a)).
Defined.


Require Import Utf8.

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

Section Cantor.

  Variable A : Type.
  Variable f : A -> (A -> bool).

  Definition diagb : A -> bool := λ x, negb (f x x).

  Theorem Cantor_Theorem : forall x, f x ≠ diagb.
  Proof.
    intros x Eq.
    assert (Eq': diagb x = f x x) by now rewrite Eq.
    unfold diagb in Eq'.
    now destruct (f x x).
  Qed.

  Corollary Cantor_Theorem_2 : ~Surjective f.
  Proof.
    firstorder using Cantor_Theorem.
  Qed.

End Cantor.


Require Export GeoCoq.Tarski_dev.Ch05_bet_le.
Require Import GeoCoq.Utils.all_equiv.

Section Equivalence_between_decidability_properties_of_basic_relations.

Context `{Tn:Tarski_neutral_dimensionless}.

Lemma cong_dec_eq_dec :
  (forall A B C D, Cong A B C D \/ ~ Cong A B C D) ->
  (forall A B:Tpoint, A=B \/ A<>B).
Proof.
    intros H A B.
    elim (H A B A A); intro HCong.
      left; apply cong_identity with A; assumption.
    right; intro; subst; apply HCong.
    apply cong_pseudo_reflexivity.
Qed.

Lemma eq_dec_cong_dec :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  (forall A B C D, Cong A B C D \/ ~ Cong A B C D).
Proof.
intro eq_dec.
apply (@cong_dec Tn (Build_Tarski_neutral_dimensionless_with_decidable_point_equality Tn eq_dec)).
Qed.

Lemma bet_dec_eq_dec :
  (forall A B C, Bet A B C \/ ~ Bet A B C) ->
  (forall A B:Tpoint, A=B \/ A<>B).
Proof.
intros.
induction (H A B A).
left; apply between_identity; assumption.
right; intro; subst; apply H0;  apply between_trivial.
Qed.

Lemma eq_dec_bet_dec :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  (forall A B C, Bet A B C \/ ~ Bet A B C).
Proof.
intro eq_dec.
apply (@bet_dec Tn (Build_Tarski_neutral_dimensionless_with_decidable_point_equality Tn eq_dec)).
Qed.

Definition decidability_of_equality_of_points := forall A B:Tpoint, A=B \/ A<>B.

Definition decidability_of_congruence_of_points := forall A B C D:Tpoint,
  Cong A B C D \/ ~ Cong A B C D.

Definition decidability_of_betweenness_of_points := forall A B C:Tpoint,
  Bet A B C \/ ~ Bet A B C.

Theorem equivalence_between_decidability_properties_of_basic_relations :
  all_equiv  (decidability_of_equality_of_points::
              decidability_of_congruence_of_points::
              decidability_of_betweenness_of_points::nil).
Proof.
apply all_equiv__equiv.
simpl.
unfold decidability_of_equality_of_points, decidability_of_congruence_of_points,
        decidability_of_betweenness_of_points.
assert (P:=cong_dec_eq_dec).
assert (Q:=eq_dec_cong_dec).
assert (R:=bet_dec_eq_dec).
assert (S:=eq_dec_bet_dec).
repeat split; auto.
Qed.

End Equivalence_between_decidability_properties_of_basic_relations.


Require Export Arith.
Require Export ZArithRing.
Require Export Omega.

Theorem Frobenius_3_8 :
  forall n:nat,
    8 <= n -> exists p:nat, (exists q:nat, n = 3 * p + 5 * q).
Proof.
 intros n Hle; induction Hle as [ | m Hm IHm].
 - exists 1,  1; ring.
 -  destruct IHm as [p' [q']].
    destruct q'.
   +
      assert (H3lep': 3 <= p') by omega.
      exists (p' - 3), 2.
      subst m.
      replace (3 * (p' - 3) + 5 * 2)
        with    (S (3 * 3 + 3 * (p' - 3)))
        by  omega.
      rewrite <- mult_plus_distr_l.
      rewrite le_plus_minus_r; auto.
   +   exists (p'+2), q'; rewrite H;  ring.
Qed.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

Require Import ZArith.

Lemma Zlt_le_Zs : forall z z1 : Z, (Z.succ z <= z1)%Z -> (z < z1)%Z.

Proof.
intros.
apply Z.lt_le_trans with (Z.succ z).
apply Zlt_succ.
auto.
Qed.

Hint Resolve Zlt_le_Zs: real.

Lemma Zle_add_compatibility :
 forall z z1 z2 : Z, (z + z1 <= z2)%Z -> (z <= z2 - z1)%Z.

Proof.
intros.
apply Zplus_le_reg_l with z1.
rewrite Zplus_minus.
rewrite Zplus_comm; auto.
Qed.

Hint Resolve Zle_add_compatibility: real.


Set Warnings "-notation-overridden,-parsing".
From LF Require Export Indprop.

Definition relation (X: Type) := X -> X -> Prop.

Print le.

Definition partial_function {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Print next_nat.
Check next_nat : relation nat.

Theorem next_nat_partial_function :
   partial_function next_nat.
Proof.
  unfold partial_function.
  intros x y1 y2 H1 H2.
  inversion H1. inversion H2.
  reflexivity. Qed.

Theorem le_not_a_partial_function :
  ~ (partial_function le).
Proof.
  unfold not. unfold partial_function. intros Hc.
  assert (0 = 1) as Nonsense. {
    apply Hc with (x := 0).
    - apply le_n.
    - apply le_S. apply le_n. }
  discriminate Nonsense. Qed.

Inductive total_relation : nat -> nat -> Prop :=
  | tr : forall n m, total_relation n m.

Inductive empty_relation : nat -> nat -> Prop := .

(*optional (total_relation_not_partial)*)
Theorem total_relation_not_a_partial_function :
  ~ (partial_function total_relation).
Proof.
  unfold not. unfold partial_function. intros Hc.
  assert (0 = 1) as Nonsense. {
    apply (Hc 0).
    - apply tr.
    - apply tr. }
  discriminate Nonsense. Qed.
(*/optional (total_relation_not_partial)*)

(*optional (empty_relation_partial)*)
Theorem empty_relation_not_a_partial_function :
  partial_function empty_relation.
Proof.
  unfold partial_function. intros x y1 y2 H1 H2.
  inversion H1. Qed.
(*/optional (empty_relation_partial)*)

Definition reflexive {X: Type} (R: relation X) :=
  forall a : X, R a a.

Theorem le_reflexive :
  reflexive le.
Proof.
  unfold reflexive. intros n. apply le_n. Qed.

Definition transitive {X: Type} (R: relation X) :=
  forall a b c : X, (R a b) -> (R b c) -> (R a c).

Theorem le_trans :
  transitive le.
Proof.
  intros n m o Hnm Hmo.
  induction Hmo.
  - apply Hnm.
  - apply le_S. apply IHHmo. Qed.

Theorem lt_trans:
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  apply le_S in Hnm.
  apply le_trans with (a := (S n)) (b := (S m)) (c := o).
  apply Hnm.
  apply Hmo. Qed.

(*optional (le_trans_hard_way)*)
Theorem lt_trans' :
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction Hmo as [| m' Hm'o].
  - apply le_S. apply Hnm.
  - apply le_S. apply IHHm'o.
Qed.
(*/optional (le_trans_hard_way)*)

(*standard, optional (lt_trans'')*)
Theorem lt_trans'' :
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction o as [| o'].
  - inversion Hmo.
  - apply le_S. inversion Hmo.
    + rewrite <- H0. apply Hnm.
    + apply IHo'. apply H0.
Qed.
(*/standard, optional (lt_trans'')*)

Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
Proof.
  intros n m H. apply le_trans with (S n).
  - apply le_S. apply le_n.
  - apply H.
Qed.

(*standard, optional (le_S_n)*)
Theorem le_S_n : forall n m,
  (S n <= S m) -> (n <= m).
Proof.
  intros n m H. inversion H.
  - apply le_n.
  - apply le_Sn_le. apply H1.
Qed.
(*/standard, optional (le_S_n)*)

(*standard, optional (le_Sn_n)*)
Theorem le_Sn_n : forall n,
  ~ (S n <= n).
Proof.
  unfold not. induction n as [|n' IHn'].
  - intro H. inversion H.
  - intro H. apply IHn'. apply le_S_n. apply H.
Qed.
(*/standard, optional (le_Sn_n)*)

Definition symmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a).

(*standard, optional (le_not_symmetric)*)
Theorem le_not_symmetric :
  ~ (symmetric le).
Proof.
  unfold not. unfold symmetric. intros H.
  assert (N: 1 <= 0 -> False).
  { apply (le_Sn_n 0). }
  apply N. apply H. apply le_S. apply le_n.
Qed.
(*/standard, optional (le_not_symmetric)*)

Definition antisymmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a) -> a = b.

(*standard, optional (le_antisymmetric)*)
Theorem le_antisymmetric :
  antisymmetric le.
Proof.
  unfold antisymmetric.
  induction a as [|a'].
  - (* a = 0 *)
    intros b ab ba.
    inversion ba as [E|].
    reflexivity.
  - (* a = S a' *)
    intros b ab ba.
    inversion ab as [E | b' H H'].
    + (* a = b *)
      reflexivity.
    + (* a < b *)
      cut (a' = b').
      * intros E. rewrite E. reflexivity.
      * apply IHa'.
        { apply le_Sn_le. apply H. }
        { apply le_S_n. rewrite H'. apply ba. }
Qed.
(*/standard, optional (le_antisymmetric)*)

Definition equivalence {X:Type} (R: relation X) :=
  (reflexive R) /\ (symmetric R) /\ (transitive R).

Definition order {X:Type} (R: relation X) :=
  (reflexive R) /\ (antisymmetric R) /\ (transitive R).

Definition preorder {X:Type} (R: relation X) :=
  (reflexive R) /\ (transitive R).

Theorem le_order :
  order le.
Proof.
  unfold order. split.
    - apply le_reflexive.
    - split.
      + apply le_antisymmetric.
      + apply le_trans. Qed.

Inductive clos_refl_trans {A: Type} (R: relation A) : relation A :=
    | rt_step x y (H : R x y) : clos_refl_trans R x y
    | rt_refl x : clos_refl_trans R x x
    | rt_trans x y z
          (Hxy : clos_refl_trans R x y)
          (Hyz : clos_refl_trans R y z) :
          clos_refl_trans R x z.

Theorem next_nat_closure_is_le : forall n m,
  (n <= m) <-> ((clos_refl_trans next_nat) n m).
Proof.
  intros n m. split.
  -
    intro H. induction H.
    + apply rt_refl.
    +
      apply rt_trans with m. apply IHle. apply rt_step.
      apply nn.
  -
    intro H. induction H.
    + inversion H. apply le_S. apply le_n.
    + apply le_n.
    +
      apply le_trans with y.
      apply IHclos_refl_trans1.
      apply IHclos_refl_trans2. Qed.

Inductive clos_refl_trans_1n {A : Type}
                             (R : relation A) (x : A)
                             : A -> Prop :=
  | rt1n_refl : clos_refl_trans_1n R x x
  | rt1n_trans (y z : A)
      (Hxy : R x y) (Hrest : clos_refl_trans_1n R y z) :
      clos_refl_trans_1n R x z.

Lemma rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> clos_refl_trans_1n R x y.
Proof.
  intros X R x y H.
  apply rt1n_trans with y. apply H. apply rt1n_refl. Qed.


Fixpoint leb (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => leb n' m'
      end
  end.

Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.

Lemma add_0_r : forall n : nat,
    n + 0 = n.
Proof.
    Admitted.

Lemma add_0_l : forall n : nat,
    0 + n = n.
Proof.
    Admitted.

Theorem n_leb_n_plus_m : forall n m : nat,
    n <=? (n + m) = true.
Proof.
    intros n m.
    induction n as [| n' IHn'].
    - simpl. reflexivity.
    - simpl. rewrite -> IHn'. reflexivity.
    Qed.

Theorem plus_leb_compat_1 : forall n m p : nat,
    n <=? m = true -> (p + n) <=? (p + m) = true.
Proof.
    intros n m p.
    intros H.
    destruct n.
    - rewrite <- H. destruct p.
     + simpl. reflexivity.
     + simpl. rewrite <- H. simpl. rewrite -> add_0_r. rewrite -> n_leb_n_plus_m. reflexivity.
    - induction p as [| p' IHp'].
     + rewrite -> add_0_l. rewrite -> add_0_l. rewrite -> H. reflexivity.
     + simpl. rewrite -> IHp'. reflexivity.
    Qed.


(** DISCLAIMER: the current presentation of monoids uses typeclasses,
    but in fact it's not obvious that typeclasses are needed/useful here.
    Indeed, there is no overloading involved.
    Thus, the interface might change in the near future. *)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Mathematical structures                                                 *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibOperation.
Generalizable Variables A B.

(* ********************************************************************** *)
(** * Monoids *)

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

(** Monoid structure: binary operator and neutral element *)

Record monoid_op (A:Type) : Type := monoid_make {
   monoid_oper : A -> A -> A;
   monoid_neutral : A }.

(** Monoid properties
    Note that field names are suffixed by [_prop] because the corresponding
    properties are also available through typeclass instances. *)
(* -- LATER: factorize [let (o,n) := m] for the record definition *)

Class Monoid A (m:monoid_op A) : Prop := Monoid_make {
   monoid_assoc_prop : let (o,n) := m in assoc o;
   monoid_neutral_l_prop : let (o,n) := m in neutral_l o n;
   monoid_neutral_r_prop : let (o,n) := m in neutral_r o n }.

(** Commutative monoid *)

Class Comm_monoid A (m:monoid_op A) : Prop := Comm_monoid_make {
   comm_monoid_monoid : Monoid m;
   comm_monoid_comm : let (o,n) := m in comm o }.

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

(** Example:

  Instance monoid_plus_zero:
    Monoid (monoid_make plus 0).
  Proof using.
    constructor; repeat intro; lia.
  Qed.

*)

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

Section MonoidProp.
Context {A:Type}.

Class Monoid_assoc {m:monoid_op A} := {
  monoid_assoc : assoc (monoid_oper m) }.

Class Monoid_neutral_l {m:monoid_op A} := {
  monoid_neutral_l : neutral_l (monoid_oper m) (monoid_neutral m) }.

Class Monoid_neutral_r {m:monoid_op A} := {
  monoid_neutral_r : neutral_r (monoid_oper m) (monoid_neutral m) }.

Class Monoid_comm {m:monoid_op A} := {
  monoid_comm : comm (monoid_oper m) }.

End MonoidProp.

(* --------------------------------------------------------------------- *)
(** * Derived Properties *)

Section MonoidInst.
Variables (A:Type).
Implicit Types m : monoid_op A.

Global Instance Monoid_assoc_of_Monoid : forall m (M:Monoid m),
  Monoid_assoc (m:=m).
Proof using.
  introv M. constructor. destruct M as [U ? ?]. destruct m. simpl. apply U.
Qed.

Global Instance Monoid_neutral_l_of_Monoid : forall m (M:Monoid m),
  Monoid_neutral_l (m:=m).
Proof using.
  introv M. constructor. destruct M as [? U ?]. destruct m. simpl. apply U.
Qed.

Global Instance Monoid_neutral_r_of_Monoid : forall m (M:Monoid m),
  Monoid_neutral_r (m:=m).
Proof using.
  introv M. constructor. destruct M as [? ? U]. destruct m. simpl. apply U.
Qed.

Global Instance Monoid_of_Comm_monoid : forall m (M:Comm_monoid m),
  Monoid m.
Proof using.
  introv M. destruct M as [U ?]. destruct m. simpl. apply U.
Qed.

Global Instance Monoid_comm_of_Comm_Monoid : forall m (M:Comm_monoid m),
  Monoid_comm (m:=m).
Proof using.
  introv M. constructor. destruct M as [? U]. destruct m. simpl. apply U.
Qed.

End MonoidInst.


Require Import Nat Arith.

Inductive Lst : Type := cons : nat -> Lst -> Lst |  nil : Lst.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Fixpoint len (len_arg0 : Lst) : nat
           := match len_arg0 with
              | nil => 0
              | cons x y => plus 1 (len y)
              end.

Theorem theorem0 : forall (x : Lst) (y : Lst), eq (len (append x y)) (plus (len x) (len y)).
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - simpl. reflexivity.
Qed.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                                                                          *)
(*                           Group Theory in Coq                            *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*									    *)
(*                                  INRIA                                   *)
(*                             Sophia-Antipolis                             *)
(*									    *)
(*				 January 1996				    *)
(*                                                                          *)
(****************************************************************************)

Require Import Ensembles.
Require Import Laws.
Require Import Group_definitions.
Section group_trivialities.
Variable U : Type.
Variable Gr : Group U.

Let G : Ensemble U := G_ U Gr.

Let star : U -> U -> U := star_ U Gr.

Let inv : U -> U := inv_ U Gr.

Let e : U := e_ U Gr.

Definition G0 : forall a b : U, In U G a -> In U G b -> In U G (star a b) :=
  G0_ U Gr.

Definition G1 : forall a b c : U, star a (star b c) = star (star a b) c :=
  G1_ U Gr.

Definition G2a : In U G e := G2a_ U Gr.

Definition G2b : forall a : U, star e a = a := G2b_ U Gr.

Definition G2c : forall a : U, star a e = a := G2c_ U Gr.

Definition G3a : forall a : U, In U G a -> In U G (inv a) := G3a_ U Gr.

Definition G3b : forall a : U, star a (inv a) = e := G3b_ U Gr.

Definition G3c : forall a : U, star (inv a) a = e := G3c_ U Gr.
Hint Resolve G1.
Hint Resolve G2a G2b G2c.
Hint Resolve G3a G3b G3c.
Hint Resolve G0.

Theorem triv1 : forall a b : U, star (inv a) (star a b) = b.
intros a b; try assumption.
rewrite (G1 (inv a) a b); auto.
rewrite G3c; auto.
Qed.

Theorem triv2 : forall a b : U, star (star b a) (inv a) = b.
intros a b; try assumption.
rewrite <- (G1 b a (inv a)); auto.
rewrite (G3b a); auto.
Qed.

Theorem resolve : forall a b : U, star b a = e -> b = inv a.
intros a b H'1.
cut (star (star b a) (inv a) = inv a).
rewrite <- (G1 b a (inv a)); auto.
rewrite (G3b a); auto.
rewrite (G2c b); auto.
rewrite H'1.
rewrite (G2b (inv a)); auto.
Qed.

Theorem self_inv : e = inv e.
apply resolve; auto.
Qed.

Theorem inv_star : forall a b : U, star (inv b) (inv a) = inv (star a b).
intros a b.
apply resolve.
rewrite <- (G1 (inv b) (inv a) (star a b)).
rewrite (G1 (inv a) a b).
rewrite (G3c a).
rewrite (G2b b); auto.
Qed.

Theorem cancellation : forall a b : U, star a b = a -> b = e.
intros a b H'.
cut (star (inv a) (star a b) = b).
rewrite H'.
rewrite (G3c a); auto.
rewrite (G1 (inv a) a b).
rewrite (G3c a); auto.
Qed.

Theorem inv_involution : forall a : U, a = inv (inv a).
intro a; apply resolve; auto.
Qed.
End group_trivialities.
Hint Resolve G1.
Hint Resolve G2a G2b G2c.
Hint Resolve G3a G3b G3c.
Hint Resolve G0.
Hint Resolve triv1 triv2 resolve self_inv inv_star inv_involution.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


Require Import Coq.Init.Prelude.

Inductive prop :=
| Nil
| And (_:Prop) (_ : prop)
| Exis {T : Type} (_ : T -> prop).

Fixpoint interp_prop (p : prop) :=
  match p with
  | Nil => True
  | And A p => A /\ interp_prop p
  | Exis f => exists x, interp_prop (f x)
  end.

Fixpoint uncurry_prop (p : prop) (Q : Prop) :=
  match p with
  | Nil => Q
  | And A p => A -> uncurry_prop p Q
  | Exis f => forall x, uncurry_prop (f x) Q
  end.

Lemma uncurry_prop_and_r xs (P Q : Prop) : P -> uncurry_prop xs Q -> uncurry_prop xs (P /\ Q).
Proof. revert Q; revert P; induction xs; intros; cbn in *; eauto. Qed.
Lemma uncurry_prop_exists_r xs {T : Type} (P : T -> Prop) (x : T) : uncurry_prop xs (P x) -> uncurry_prop xs (exists x, P x).
Proof. revert dependent P; induction xs; intros; cbn in *; eauto. Qed.
Lemma uncurry_interp_prop p : uncurry_prop p (interp_prop p).
Proof. induction p; cbn in *; intros; eauto using uncurry_prop_and_r, uncurry_prop_exists_r. Qed.

Fixpoint Fex (t_prev : unit) (n : nat) : prop :=
  match n with
  | O => Nil
  | S n => Exis (fun t:unit => And (t = t_prev) (Fex t n))
  end.

Fixpoint fex (t_prev : unit) (n : nat) : Prop :=
  match n with
  | O => True
  | S n => exists t:unit, t = t_prev /\ fex t n
  end.

Goal fex tt 10000.
  Time (
    let n := match goal with [ |- fex tt ?n ] => n end in
    let p := constr:(Fex tt n) in
    let p := (eval cbv in p) in
    let pf := constr:(uncurry_interp_prop p) in
    let t := type of pf in
    let t := (eval cbv [uncurry_prop interp_prop] in t) in
    refine (let H : t := pf in _ )).
  Time clearbody H.
  Time eapply H.
  Time all: exact eq_refl.
Time Qed.
(*
Finished transaction in 5.965 secs (5.375u,0.57s) (successful)
Finished transaction in 0.001 secs (0.u,0.s) (successful)
Finished transaction in 87.529 secs (87.247u,0.006s) (successful)
Finished transaction in 89.998 secs (89.667u,0.073s) (successful)
Finished transaction in 42.641 secs (42.496u,0.006s) (successful)
*)


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Annexes.suma.
Require Import GeoCoq.Tarski_dev.Ch12_parallel.

Section consecutive_interior_angles_alternate_interior_angles.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma consecutive_interior__alternate_interior :
   consecutive_interior_angles_postulate -> alternate_interior_angles_postulate.
Proof.
  intros cia A B C D Hts HPar.
  destruct (segment_construction D C C D) as [D' []].
  apply suppa2__conga123 with A C D'.
  - apply cia; [|assert_diffs; apply par_left_comm, par_col_par with D; Col].
    exists D; split; trivial.
    destruct Hts as [_ [HNCol _]].
    repeat split.
      intro; apply HNCol; ColR.
      Col.
    exists C; split; [Col|Between].
  - assert_diffs; split; auto.
    exists D'; split; CongA.
Qed.

End consecutive_interior_angles_alternate_interior_angles.


Require Export ZArith.
Require Export Zwf.
Require Export Zcompare.
Check Zwf.
Check Zwf_well_founded.
Open Scope Z_scope.

Definition factZ_F: forall (x : Z), (forall y, Zwf 0 y x ->  Z) ->  Z.
refine (fun x fact =>
           match Z_lt_le_dec x 0 with
             left _ => 0
            | right Hle =>
                match Z.eq_dec x 0 with
                  left _ => 1
                 | right Hne => x * fact (x - 1) _
                end
           end).
unfold Zwf; omega.
Qed.


(* To build an impredicative definition that simulates an inductive type
   following this technique:

  * construct a function that takes the same type of arguments as the
    inductive type and returns a type, obtained in the following manner.

  + quantify over a predicate P that have the same type as the predicate
    one wants to simulate (excepted the parameters of the inductive type).

  + construct implications where premises state that the predicate P
    simulates the constructors of the inductive predicate.  In other words,
    each premise is a constructor of the inductive predicate where
    instances of the inductive predicate name are replaced with P.

  + the ultimate conclusion must express that P holds for the arguments
    (but the parameters do not appear).

  This definition actually expresses that the least property that satisfies
  the constructors holds. *)

(* For instance, for sorted lists: *)

Require Export List Relations.

Section R_declared.

  Variables (A: Type)
            (R: relation A).

  (* Here is the inductive definition: *)

  Inductive sorted : list A -> Prop :=
    sorted0 : sorted  nil
  | sorted1 : forall x:A, sorted  (x::nil)
  | sorted2 : forall (x1 x2:A)(l':list A),
      R x1 x2 -> sorted  (x2::l') -> sorted  (x1::x2::l').

  #[local] Hint Constructors sorted : core.

  Definition impredicative_sorted (l:list A) : Prop :=
    forall P :  list A -> Prop,
      P nil ->
      (forall x:A, P (x::nil))->
      (forall (x1 x2:A)(l':list A),
          R x1 x2 -> P (x2::l') -> P (x1::x2::l'))->
      P l.

  (* To prove that the two predicates are equivalent we first need to show
   that the impredicative definition satisfies the constructors. *)

  Theorem isorted0  :  impredicative_sorted nil.
  Proof.
    red; intros; assumption.
  Qed.

  Theorem isorted1 :  forall  x: A , impredicative_sorted (x::nil).
  Proof.
    unfold impredicative_sorted; auto.
  Qed.

  Theorem isorted2  :
    forall (x1 x2:A)(l':list A),
      R x1 x2 ->
      impredicative_sorted  (x2::l') ->
      impredicative_sorted  (x1::x2::l').
  Proof.
    intros x1 x2 l' Hr Hs P Hsn Hs1 Hs2.
    apply Hs2; auto.
    apply Hs; auto.
  Qed.

  #[local] Hint Resolve isorted0 isorted1 isorted2 : core.

  (* Proof of the equivalence between both definitions *)

  Theorem sorted_to_impredicative_sorted :
    forall l, sorted  l -> impredicative_sorted l.
  Proof.
    induction 1; auto.
  Qed.

  Theorem impredicative_sorted_to_sorted :
    forall l, impredicative_sorted  l -> sorted  l.
  Proof.
    intros  l H; apply H; auto.
  Qed.

End R_declared.

Arguments sorted {A} R _.
Arguments impredicative_sorted {A} R _.

(* If we want to simulate "less-or-equal" we can define the impredicative
   expression by again following the constructors. *)

Definition impredicative_le (n p:nat) : Prop :=
  forall P: nat -> Prop,
    P n ->
    (forall m:nat, P m -> P (S m)) ->
    P p.

(* We can prove it satisfies the constructors of  le. *)
Theorem impredicative_le_n : forall n: nat, impredicative_le n n.
Proof.
  unfold impredicative_le; auto.
Qed.

Theorem impredicative_le_S :
  forall n m:nat, impredicative_le n m -> impredicative_le n (S m).
Proof.
  intros n m Hle P Hn Hs; apply Hs; apply Hle; auto.
Qed.

#[export] Hint Resolve impredicative_le_n impredicative_le_S : core.

Theorem le_to_impredicative :
  forall n p, n <= p -> impredicative_le n p.
Proof.
  intros n p Hle; elim Hle; auto.
Qed.

Theorem impredicative_to_le :
  forall n p, impredicative_le n p -> n <= p.
Proof.
  intros n p H; apply H; auto.
Qed.

(* For disjunction, we do it in the same way, still giving the
   parameters a position outside the universal quantification. *)

Definition impredicative_or (A B:Prop) : Prop :=
  forall P:Prop,
    (* first constructor. *)
    (A -> P) ->
    (* second constructor. *)
    (B -> P) ->
    P.

Theorem impredicative_or_intro1 :
  forall A B:Prop, A -> impredicative_or A B.
Proof.
  unfold impredicative_or; auto.
Qed.

Theorem impredicative_or_intro2 :
  forall A B:Prop, B -> impredicative_or A B.
Proof.
  unfold impredicative_or; auto.
Qed.

#[export] Hint Resolve impredicative_or_intro1 impredicative_or_intro2 : core.

Theorem or_to_impredicative : forall A B, A \/ B -> impredicative_or A B.
Proof.
  intros A B H; elim H; auto.
Qed.

Theorem impredicative_to_or : forall A B, impredicative_or A B -> A \/ B.
Proof.
  intros A B H; apply H; auto.
Qed.


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

Inductive natlist: Type:=
    |nil: natlist
    |cons: nat -> natlist -> natlist.

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

Definition bag := natlist.

Fixpoint count (v: nat) (s: bag) : nat :=
    match s with
    |nil     => O
    |h :: t => if (Nat.eqb v h) then S(count v t) else count v t
    end.

Theorem count_member_nonzero: forall (s: bag),
  Nat.leb 1 (count 1 (1::s)) = true.
Proof.
    intros. induction s as[|s'].
    reflexivity.
    simpl. reflexivity.
Qed.

Fixpoint remove_one (v:nat) (s:bag) : bag :=
    match s with
    |nil => nil
    |h::t => if (Nat.eqb h v) then t else h::(remove_one v t)
    end.

Lemma ble_n_Sn: forall n: nat, Nat.leb n (S n) = true.
Proof.
    intros. induction n as [|n'].
    reflexivity.
simpl. rewrite IHn'. reflexivity.
Qed.

Theorem remove_decreases_count: forall (s: bag),
      Nat.leb (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
    intros. induction s as [|h t].
    reflexivity.
    destruct h as [|h'].
    simpl. rewrite ble_n_Sn. reflexivity.
    simpl. rewrite IHt. reflexivity.
Qed.


Require Import List.

Inductive par : Set := open | close.

Inductive wp : list par -> Prop :=
  | wp_nil          : wp nil
  | wp_open_close   : forall (l:list par), wp l -> wp ((open::l)++(close::nil))
  | wp_concat       : forall (l1 l2: list par), wp l1 -> wp l2 -> wp (l1++l2).

Lemma wp_oc: wp (open::close::nil).
Proof.
  apply wp_open_close with (l:=nil). apply wp_nil.
Qed.

Lemma wp_o_head_c: forall (l1 l2:list par),
  wp l1 -> wp l2 -> wp (open::(l1++(close::l2))).
Proof.
  intros l1 l2 H1 H2. cut (nil++l2 = l2). intro H. rewrite <- H.
  rewrite app_comm_cons with (x:=nil).
  rewrite app_comm_cons with (a:=open). rewrite app_assoc.
  apply wp_concat. apply wp_open_close. exact H1. exact H2. apply app_nil_l.
Qed.

Lemma wp_o_tail_c: forall (l1 l2:list par),
  wp l1 -> wp l2 -> wp (l1 ++ (open :: (l2 ++ (close :: nil)))).
Proof.
  intros l1 l2 H1 H2. apply wp_concat. exact H1. apply wp_open_close. exact H2.
Qed.

Inductive bin : Set :=
  | L : bin
  | N : bin -> bin -> bin.

Fixpoint bin2string (t:bin) : list par :=
  match t with
    | L     => nil
    | N u v => open :: ((bin2string u) ++ (close :: (bin2string v)))
  end.

Lemma wp_bin2string: forall t:bin, wp (bin2string t).
Proof.
  intro t. elim t. simpl. apply wp_nil. clear t.
  intros t1 H1 t2 H2. simpl. apply wp_o_head_c. exact H1. exact H2.
Qed.

Fixpoint bin2string' (t:bin) : list par :=
  match t with
    | L     => nil
    | N u v => (bin2string' u) ++ (open :: ((bin2string' v) ++ (close :: nil)))
  end.

Lemma wp_bin2string': forall t:bin, wp (bin2string' t).
Proof.
  intro t. elim t. simpl. apply wp_nil. clear t.
  intros t1 H1 t2 H2. simpl. apply wp_o_tail_c. exact H1. exact H2.
Qed.


From mathcomp
  Require Import ssreflect div.
Require Import Nat Arith.

Definition task := forall n m, n < m \/ n = m \/ n > m.

(* TopProver umemasu *)
(* TopProver #6 *)

Lemma zeroLtN: forall n, 0 < S n.
Proof.
intros.
induction n.
by [].
auto.
Qed.

Lemma nGtZero: forall n, S n > 0.
Proof.
intros.
induction n.
by [].
auto.
Qed.

Theorem solution: task.
Proof.

unfold task.
(*intros.*)

induction n.
- induction m.
-- auto.
-- left. apply zeroLtN.
- induction m.
-- right; right. apply nGtZero.
-- destruct (IHn m).
--- left. apply lt_n_S. exact H.
-- destruct H.
--- right; left. apply eq_S. exact H.
--- right; right. apply gt_n_S. exact H.

Qed.


Require Import Basics.
Require Import Spaces.Pos.
Require Import Spaces.Int.Core.

Local Open Scope int_scope.

(** ** Addition is commutative *)

Lemma int_add_comm n m : n + m = m + n.
Proof.
  destruct n, m; cbn; trivial; by rewrite pos_add_comm.
Qed.

(** ** Zero is the additive identity. *)

Lemma int_add_0_l n : 0 + n = n.
Proof.
  reflexivity.
Qed.

Lemma int_add_0_r n : n + 0 = n.
Proof.
  by destruct n.
Qed.

(** ** Multiplication by zero is zero *)

Lemma int_mul_0_l n : 0 * n = 0.
Proof.
  reflexivity.
Qed.

Lemma int_mul_0_r n : n * 0 = 0.
Proof.
  by destruct n.
Qed.

(** ** One is the multiplicative identity *)

Lemma int_mul_1_l n : 1 * n = n.
Proof.
  by destruct n.
Qed.

Lemma int_mul_1_r n : n * 1 = n.
Proof.
  destruct n; trivial; cbn; apply ap, pos_mul_1_r.
Qed.

(** ** Inverse laws *)

Lemma int_pos_sub_diag n : int_pos_sub n n = 0.
Proof.
  induction n; trivial; cbn; by rewrite IHn.
Qed.

Lemma int_add_negation_l n : (-n) + n = 0.
Proof.
  destruct n; trivial; cbn; apply int_pos_sub_diag.
Qed.

Lemma int_add_negation_r n : n + (-n) = 0.
Proof.
  destruct n; trivial; cbn; apply int_pos_sub_diag.
Qed.

(** ** Permutation of neg and pos_succ *)
Lemma int_neg_pos_succ p : neg (pos_succ p) = int_pred (neg p).
Proof.
  by destruct p.
Qed.

(** ** Negation of a doubled positive integer *)
Lemma int_negation_double a
  : - (int_double a) = int_double (- a).
Proof.
  by destruct a.
Qed.

(** Negation of the predecessor of a doubled positive integer. *)
Lemma int_negation_pred_double a
  : - (int_pred_double a) = int_succ_double (- a).
Proof.
  by destruct a.
Qed.

(** Negation of the doubling of the sucessor of an positive. *)
Lemma int_negation_succ_double a
  : - (int_succ_double a) = int_pred_double (- a).
Proof.
  by destruct a.
Qed.

(** Negation of subtraction of positive integers *)
Lemma int_pos_sub_negation a b
  : - (int_pos_sub a b) = int_pos_sub b a.
Proof.
  revert a b.
  induction a as [|a ah|a ah];
  destruct b;
  cbn; trivial.
  all: rewrite ?int_negation_double,
    ?int_negation_succ_double,
    ?int_negation_pred_double.
  all: apply ap, ah.
Qed.

(** ** int_succ is a retract of int_pred *)
Definition int_succ_pred : Sect int_pred int_succ.
Proof.
  intros [n | | n]; [|trivial|].
  all: destruct n; trivial.
  1,2: cbn; apply ap.
  1: apply pos_pred_double_succ.
  rewrite pos_add_1_r.
  apply pos_succ_pred_double.
Qed.

(** ** int_pred is a retract of int_succ *)
Definition int_pred_succ : Sect int_succ int_pred.
Proof.
  intros [n | | n]; [|trivial|].
  all: destruct n; trivial.
  1,2: cbn; apply ap.
  1: rewrite pos_add_1_r.
  1: apply pos_succ_pred_double.
  apply pos_pred_double_succ.
Qed.

(** ** Negation distributes over addition *)
Lemma int_negation_add_distr n m : - (n + m) = - n + - m.
Proof.
 destruct n, m; simpl; trivial using int_pos_sub_negation.
Qed.

(** ** Negation is injective *)
Lemma int_negation_inj n m : -n = -m -> n = m.
Proof.
  destruct n, m; simpl; intro H.
  1: apply pos_inj in H.
  2: apply pos_neq_zero in H.
  3: apply pos_neq_neg in H.
  4: apply  zero_neq_pos in H.
  6: apply  zero_neq_neg in H.
  7: apply  neg_neq_pos in H.
  8: apply  neg_neq_zero in H.
  9: apply  neg_inj in H.
  all: by destruct H.
Qed.

(** ** Subtracting 1 from a sucessor gives the positive integer. *)
Lemma int_pos_sub_succ_l a
  : int_pos_sub (pos_succ a) 1%pos = pos a.
Proof.
  destruct a; trivial.
  cbn; apply ap, pos_pred_double_succ.
Qed.

(** ** Subtracting a sucessor from 1 gives minus the integer. *)
Lemma int_pos_sub_succ_r a
  : int_pos_sub 1%pos (pos_succ a) = neg a.
Proof.
  destruct a; trivial.
  cbn; apply ap, pos_pred_double_succ.
Qed.

(** ** Interaction of doubling functions and subtraction *)

Lemma int_succ_double_int_pos_sub a b
  : int_succ_double (int_pos_sub a (pos_succ b))
    = int_pred_double (int_pos_sub a b).
Proof.
  revert a b.
  induction a; induction b; trivial.
  + cbn; apply ap.
    by rewrite pos_pred_double_succ.
  + destruct a; trivial.
  + cbn; destruct (int_pos_sub a b); trivial.
  + cbn.
    rewrite <- IHa.
    destruct (int_pos_sub a (pos_succ b)); trivial.
  + destruct a; trivial.
  + cbn; destruct (int_pos_sub a b); trivial.
  + cbn.
    rewrite IHa.
    cbn; destruct (int_pos_sub a b); trivial.
Qed.

Lemma int_pred_double_int_pos_sub a b
  : int_pred_double (int_pos_sub (pos_succ a) b)
    = int_succ_double (int_pos_sub a b).
Proof.
  revert a b.
  induction a; induction b; trivial.
  + by destruct b.
  + by destruct b.
  + cbn; by destruct (int_pos_sub a b).
  + cbn; by destruct (int_pos_sub a b).
  + cbn; apply ap.
    by rewrite pos_pred_double_succ.
  + cbn.
    rewrite <- IHa.
    by destruct (int_pos_sub (pos_succ a) b).
  + cbn.
    rewrite IHa.
    by destruct (int_pos_sub a b).
Qed.

(** ** Subtractions cancel sucessors. *)
Lemma int_pos_sub_succ_succ a b
  : int_pos_sub (pos_succ a) (pos_succ b) = int_pos_sub a b.
Proof.
  rewrite <- 2 pos_add_1_r.
  revert a b.
  induction a; induction b; trivial.
  1: destruct b; trivial.
  { destruct b; trivial.
    cbn; apply ap.
    by rewrite pos_pred_double_succ. }
  1: destruct a; trivial.
  1: apply int_succ_double_int_pos_sub.
  { destruct a; trivial.
    cbn; apply ap, ap, pos_pred_double_succ. }
  1: apply int_pred_double_int_pos_sub.
  cbn; apply ap.
  rewrite <- 2 pos_add_1_r.
  apply IHa.
Defined.

(** ** Predecessor of a subtraction is the subtraction of a sucessor. *)
Lemma int_pred_pos_sub_r a b
  : int_pred (int_pos_sub a b) = int_pos_sub a (pos_succ b).
Proof.
  revert a.
  induction b as [|b bH] using pos_peano_ind.
  1: destruct a; trivial; destruct a; trivial.
  intro a.
  revert b bH.
  induction a as [|a aH] using pos_peano_ind.
  { intros b bH.
    rewrite <- bH.
    destruct b; trivial.
    cbn; apply ap.
    rewrite 2 pos_add_1_r.
    rewrite pos_succ_pred_double.
    rewrite pos_pred_double_succ.
    trivial. }
  intros b bH.
  rewrite 2 int_pos_sub_succ_succ.
  apply bH.
Qed.

(** ** Negation of the predecessor is an involution. *)
Lemma int_negation_pred_negation_red x
  : - int_pred (- int_pred x) = x.
Proof.
  destruct x as [x| |x]; trivial;
  destruct x; trivial; cbn; apply ap.
  1: apply pos_pred_double_succ.
  rewrite pos_add_1_r.
  apply pos_succ_pred_double.
Qed.

(** ** Predecessor of a sum is the sum with a predecessor *)
Lemma int_pred_add_r a b
  : int_pred (a + b) = a + int_pred b.
Proof.
  revert a b.
  intros [a| |a] [b| |b]; trivial.
  + cbn; apply ap.
    by rewrite pos_add_assoc.
  + revert a.
    induction b as [|b bH] using pos_peano_ind.
    - intro a; exact (int_pred_succ (neg a)).
    - intro a.
      rewrite <- pos_add_1_r.
      rewrite (int_pred_succ (pos b)).
      rewrite int_add_comm.
      cbn.
      rewrite pos_add_1_r.
      rewrite <- int_pos_sub_negation.
      rewrite <- int_pred_pos_sub_r.
      apply int_negation_inj.
      rewrite int_pos_sub_negation.
      apply int_negation_pred_negation_red.
  + cbn.
    rewrite pos_add_1_r.
    apply int_pred_pos_sub_r.
  + revert a.
    induction b as [|b bH] using pos_peano_ind.
    - intro a; exact (int_pred_succ (pos a)).
    - intro a.
      rewrite <- pos_add_1_r.
      rewrite (int_pred_succ (pos b)).
      cbn; rewrite pos_add_assoc.
      change (int_pred (int_succ (pos (a + b)%pos)) = pos a + pos b).
      apply int_pred_succ.
Qed.

(** ** Subtraction from a sum is the sum of a subtraction *)
Lemma int_pos_sub_add (a b c : Pos)
  : int_pos_sub (a + b)%pos c = pos a + int_pos_sub b c.
Proof.
  revert c b a.
  induction c as [|c ch] using pos_peano_ind.
  { intros b a.
    change (int_pred (pos a + pos b) = pos a + (int_pred (pos b))).
    apply int_pred_add_r. }
  intros b a.
  rewrite <- int_pred_pos_sub_r.
  rewrite ch.
  rewrite <- int_pred_pos_sub_r.
  apply int_pred_add_r.
Qed.

(** An auxillary lemma used to prove associativity. *)
Lemma int_add_assoc_pos p n m : pos p + (n + m) = pos p + n + m.
Proof.
  destruct n as [n| |n], m as [m| |m]; trivial.
  - cbn; apply int_negation_inj.
    rewrite !int_negation_add_distr, !int_pos_sub_negation.
    rewrite int_add_comm, pos_add_comm.
    apply int_pos_sub_add.
  - symmetry.
    apply int_add_0_r.
  - by rewrite <- int_pos_sub_add, int_add_comm,
      <- int_pos_sub_add, pos_add_comm.
  - symmetry.
    apply int_pos_sub_add.
  - cbn; apply ap, pos_add_assoc.
Qed.

(** ** Associativity of addition *)
Lemma int_add_assoc n m p : n + (m + p) = n + m + p.
Proof.
  destruct n.
  - apply int_negation_inj.
    rewrite !int_negation_add_distr.
    apply int_add_assoc_pos.
  - trivial.
  - apply int_add_assoc_pos.
Qed.

(* ** The successor autoequivalence. *)
Global Instance isequiv_int_succ : IsEquiv int_succ | 0
  := isequiv_adjointify int_succ _ int_succ_pred int_pred_succ.

Definition equiv_int_succ : Int <~> Int
  := Build_Equiv _ _ _ isequiv_int_succ.


(* Copyright (c) 2008-2012, 2015, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* begin hide *)
Require Import Arith List.

Require Import Cpdt.CpdtTactics.

Set Implicit Arguments.
Set Asymmetric Patterns.
(* end hide *)

(** %\chapter{Dependent Data Structures}% *)

(** Our red-black tree example from the last chapter illustrated how dependent types enable static enforcement of data structure invariants.  To find interesting uses of dependent data structures, however, we need not look to the favorite examples of data structures and algorithms textbooks.  More basic examples like length-indexed and heterogeneous lists come up again and again as the building blocks of dependent programs.  There is a surprisingly large design space for this class of data structure, and we will spend this chapter exploring it. *)

(** * More Length-Indexed Lists *)

(** We begin with a deeper look at the length-indexed lists that began the last chapter.%\index{Gallina terms!ilist}% *)

Section ilist.
  Variable A : Set.

  Inductive ilist : nat -> Set :=
  | Nil : ilist O
  | Cons : forall n, A -> ilist n -> ilist (S n).

  (** We might like to have a certified function for selecting an element of an [ilist] by position.  We could do this using subset types and explicit manipulation of proofs, but dependent types let us do it more directly.  It is helpful to define a type family %\index{Gallina terms!fin}%[fin], where [fin n] is isomorphic to [{m : nat | m < n}].  The type family name stands for "finite." *)

  (* EX: Define a function [get] for extracting an [ilist] element by position. *)

(* begin thide *)
  Inductive fin : nat -> Set :=
  | First : forall n, fin (S n)
  | Next : forall n, fin n -> fin (S n).

  (** An instance of [fin] is essentially a more richly typed copy of a prefix of the natural numbers.  Every element is a [First] iterated through applying [Next] a number of times that indicates which number is being selected.  For instance, the three values of type [fin 3] are [First 2], [Next (First 1)], and [Next (Next (First 0))].

     Now it is easy to pick a [Prop]-free type for a selection function.  As usual, our first implementation attempt will not convince the type checker, and we will attack the deficiencies one at a time.
     [[
  Fixpoint get n (ls : ilist n) : fin n -> A :=
    match ls with
      | Nil => fun idx => ?
      | Cons _ x ls' => fun idx =>
        match idx with
          | First _ => x
          | Next _ idx' => get ls' idx'
        end
    end.
    ]]
    %\vspace{-.15in}%We apply the usual wisdom of delaying arguments in [Fixpoint]s so that they may be included in [return] clauses.  This still leaves us with a quandary in each of the [match] cases.  First, we need to figure out how to take advantage of the contradiction in the [Nil] case.  Every [fin] has a type of the form [S n], which cannot unify with the [O] value that we learn for [n] in the [Nil] case.  The solution we adopt is another case of [match]-within-[return], with the [return] clause chosen carefully so that it returns the proper type [A] in case the [fin] index is [O], which we know is true here; and so that it returns an easy-to-inhabit type [unit] in the remaining, impossible cases, which nonetheless appear explicitly in the body of the [match].
    [[
  Fixpoint get n (ls : ilist n) : fin n -> A :=
    match ls with
      | Nil => fun idx =>
        match idx in fin n' return (match n' with
                                        | O => A
                                        | S _ => unit
                                      end) with
          | First _ => tt
          | Next _ _ => tt
        end
      | Cons _ x ls' => fun idx =>
        match idx with
          | First _ => x
          | Next _ idx' => get ls' idx'
        end
    end.
    ]]
    %\vspace{-.15in}%Now the first [match] case type-checks, and we see that the problem with the [Cons] case is that the pattern-bound variable [idx'] does not have an apparent type compatible with [ls'].  In fact, the error message Coq gives for this exact code can be confusing, thanks to an overenthusiastic type inference heuristic.  We are told that the [Nil] case body has type [match X with | O => A | S _ => unit end] for a unification variable [X], while it is expected to have type [A].  We can see that setting [X] to [O] resolves the conflict, but Coq is not yet smart enough to do this unification automatically.  Repeating the function's type in a [return] annotation, used with an [in] annotation, leads us to a more informative error message, saying that [idx'] has type [fin n1] while it is expected to have type [fin n0], where [n0] is bound by the [Cons] pattern and [n1] by the [Next] pattern.  As the code is written above, nothing forces these two natural numbers to be equal, though we know intuitively that they must be.

    We need to use [match] annotations to make the relationship explicit.  Unfortunately, the usual trick of postponing argument binding will not help us here.  We need to match on both [ls] and [idx]; one or the other must be matched first.  To get around this, we apply the convoy pattern that we met last chapter.  This application is a little more clever than those we saw before; we use the natural number predecessor function [pred] to express the relationship between the types of these variables.
    [[
  Fixpoint get n (ls : ilist n) : fin n -> A :=
    match ls with
      | Nil => fun idx =>
        match idx in fin n' return (match n' with
                                        | O => A
                                        | S _ => unit
                                      end) with
          | First _ => tt
          | Next _ _ => tt
        end
      | Cons _ x ls' => fun idx =>
        match idx in fin n' return ilist (pred n') -> A with
          | First _ => fun _ => x
          | Next _ idx' => fun ls' => get ls' idx'
        end ls'
    end.
    ]]
    %\vspace{-.15in}%There is just one problem left with this implementation.  Though we know that the local [ls'] in the [Next] case is equal to the original [ls'], the type-checker is not satisfied that the recursive call to [get] does not introduce non-termination.  We solve the problem by convoy-binding the partial application of [get] to [ls'], rather than [ls'] by itself. *)

  Fixpoint get n (ls : ilist n) : fin n -> A :=
    match ls with
      | Nil => fun idx =>
        match idx in fin n' return (match n' with
                                        | O => A
                                        | S _ => unit
                                      end) with
          | First _ => tt
          | Next _ _ => tt
        end
      | Cons _ x ls' => fun idx =>
        match idx in fin n' return (fin (pred n') -> A) -> A with
          | First _ => fun _ => x
          | Next _ idx' => fun get_ls' => get_ls' idx'
        end (get ls')
    end.
(* end thide *)
End ilist.

Implicit Arguments Nil [A].
Implicit Arguments First [n].

(** A few examples show how to make use of these definitions. *)

Check Cons 0 (Cons 1 (Cons 2 Nil)).
(** %\vspace{-.15in}% [[
  Cons 0 (Cons 1 (Cons 2 Nil))
     : ilist nat 3
]]
*)

(* begin thide *)
Eval simpl in get (Cons 0 (Cons 1 (Cons 2 Nil))) First.
(** %\vspace{-.15in}% [[
     = 0
     : nat
]]
*)

Eval simpl in get (Cons 0 (Cons 1 (Cons 2 Nil))) (Next First).
(** %\vspace{-.15in}% [[
     = 1
     : nat
]]
*)

Eval simpl in get (Cons 0 (Cons 1 (Cons 2 Nil))) (Next (Next First)).
(** %\vspace{-.15in}% [[
     = 2
     : nat
]]
*)
(* end thide *)

(* begin hide *)
(* begin thide *)
Definition map' := map.
(* end thide *)
(* end hide *)

(** Our [get] function is also quite easy to reason about.  We show how with a short example about an analogue to the list [map] function. *)

Section ilist_map.
  Variables A B : Set.
  Variable f : A -> B.

  Fixpoint imap n (ls : ilist A n) : ilist B n :=
    match ls with
      | Nil => Nil
      | Cons _ x ls' => Cons (f x) (imap ls')
    end.

  (** It is easy to prove that [get] "distributes over" [imap] calls. *)

(* EX: Prove that [get] distributes over [imap]. *)

(* begin thide *)
  Theorem get_imap : forall n (idx : fin n) (ls : ilist A n),
    get (imap ls) idx = f (get ls idx).
    induction ls; dep_destruct idx; crush.
  Qed.
(* end thide *)
End ilist_map.

(** The only tricky bit is remembering to use our [dep_destruct] tactic in place of plain [destruct] when faced with a baffling tactic error message. *)

(** * Heterogeneous Lists *)

(** Programmers who move to statically typed functional languages from scripting languages often complain about the requirement that every element of a list have the same type.  With fancy type systems, we can partially lift this requirement.  We can index a list type with a "type-level" list that explains what type each element of the list should have.  This has been done in a variety of ways in Haskell using type classes, and we can do it much more cleanly and directly in Coq. *)

Section hlist.
  Variable A : Type.
  Variable B : A -> Type.

  (* EX: Define a type [hlist] indexed by a [list A], where the type of each element is determined by running [B] on the corresponding element of the index list. *)

  (** We parameterize our heterogeneous lists by a type [A] and an [A]-indexed type [B].%\index{Gallina terms!hlist}% *)

(* begin thide *)
  Inductive hlist : list A -> Type :=
  | HNil : hlist nil
  | HCons : forall (x : A) (ls : list A), B x -> hlist ls -> hlist (x :: ls).

  (** We can implement a variant of the last section's [get] function for [hlist]s.  To get the dependent typing to work out, we will need to index our element selectors (in type family [member]) by the types of data that they point to.%\index{Gallina terms!member}% *)

(* end thide *)
  (* EX: Define an analogue to [get] for [hlist]s. *)

(* begin thide *)
  Variable elm : A.

  Inductive member : list A -> Type :=
  | HFirst : forall ls, member (elm :: ls)
  | HNext : forall x ls, member ls -> member (x :: ls).

  (** Because the element [elm] that we are "searching for" in a list does not change across the constructors of [member], we simplify our definitions by making [elm] a local variable.  In the definition of [member], we say that [elm] is found in any list that begins with [elm], and, if removing the first element of a list leaves [elm] present, then [elm] is present in the original list, too.  The form looks much like a predicate for list membership, but we purposely define [member] in [Type] so that we may decompose its values to guide computations.

     We can use [member] to adapt our definition of [get] to [hlist]s.  The same basic [match] tricks apply.  In the [HCons] case, we form a two-element convoy, passing both the data element [x] and the recursor for the sublist [mls'] to the result of the inner [match].  We did not need to do that in [get]'s definition because the types of list elements were not dependent there. *)

  Fixpoint hget ls (mls : hlist ls) : member ls -> B elm :=
    match mls with
      | HNil => fun mem =>
        match mem in member ls' return (match ls' with
                                          | nil => B elm
                                          | _ :: _ => unit
                                        end) with
          | HFirst _ => tt
          | HNext _ _ _ => tt
        end
      | HCons _ _ x mls' => fun mem =>
        match mem in member ls' return (match ls' with
                                          | nil => Empty_set
                                          | x' :: ls'' =>
                                            B x' -> (member ls'' -> B elm)
                                            -> B elm
                                        end) with
          | HFirst _ => fun x _ => x
          | HNext _ _ mem' => fun _ get_mls' => get_mls' mem'
        end x (hget mls')
    end.
(* end thide *)
End hlist.

(* begin thide *)
Implicit Arguments HNil [A B].
Implicit Arguments HCons [A B x ls].

Implicit Arguments HFirst [A elm ls].
Implicit Arguments HNext [A elm x ls].
(* end thide *)

(** By putting the parameters [A] and [B] in [Type], we enable fancier kinds of polymorphism than in mainstream functional languages.  For instance, one use of [hlist] is for the simple heterogeneous lists that we referred to earlier. *)

Definition someTypes : list Set := nat :: bool :: nil.

(* begin thide *)

Example someValues : hlist (fun T : Set => T) someTypes :=
  HCons 5 (HCons true HNil).

Eval simpl in hget someValues HFirst.
(** %\vspace{-.15in}% [[
     = 5
     : (fun T : Set => T) nat
]]
*)

Eval simpl in hget someValues (HNext HFirst).
(** %\vspace{-.15in}% [[
     = true
     : (fun T : Set => T) bool
]]
*)

(** We can also build indexed lists of pairs in this way. *)

Example somePairs : hlist (fun T : Set => T * T)%type someTypes :=
  HCons (1, 2) (HCons (true, false) HNil).

(** There are many other useful applications of heterogeneous lists, based on different choices of the first argument to [hlist]. *)

(* end thide *)

(** ** A Lambda Calculus Interpreter *)

(** Heterogeneous lists are very useful in implementing %\index{interpreters}%interpreters for functional programming languages.  Using the types and operations we have already defined, it is trivial to write an interpreter for simply typed lambda calculus%\index{lambda calculus}%.  Our interpreter can alternatively be thought of as a denotational semantics (but worry not if you are not familiar with such terminology from semantics).

   We start with an algebraic datatype for types. *)

Inductive type : Set :=
| Unit : type
| Arrow : type -> type -> type.

(** Now we can define a type family for expressions.  An [exp ts t] will stand for an expression that has type [t] and whose free variables have types in the list [ts].  We effectively use the de Bruijn index variable representation%~\cite{DeBruijn}%.  Variables are represented as [member] values; that is, a variable is more or less a constructive proof that a particular type is found in the type environment. *)

Inductive exp : list type -> type -> Set :=
| Const : forall ts, exp ts Unit
(* begin thide *)
| Var : forall ts t, member t ts -> exp ts t
| App : forall ts dom ran, exp ts (Arrow dom ran) -> exp ts dom -> exp ts ran
| Abs : forall ts dom ran, exp (dom :: ts) ran -> exp ts (Arrow dom ran).
(* end thide *)

Implicit Arguments Const [ts].

(** We write a simple recursive function to translate [type]s into [Set]s. *)

Fixpoint typeDenote (t : type) : Set :=
  match t with
    | Unit => unit
    | Arrow t1 t2 => typeDenote t1 -> typeDenote t2
  end.

(** Now it is straightforward to write an expression interpreter.  The type of the function, [expDenote], tells us that we translate expressions into functions from properly typed environments to final values.  An environment for a free variable list [ts] is simply an [hlist typeDenote ts].  That is, for each free variable, the heterogeneous list that is the environment must have a value of the variable's associated type.  We use [hget] to implement the [Var] case, and we use [HCons] to extend the environment in the [Abs] case. *)

(* EX: Define an interpreter for [exp]s. *)

(* begin thide *)
Fixpoint expDenote ts t (e : exp ts t) : hlist typeDenote ts -> typeDenote t :=
  match e with
    | Const _ => fun _ => tt

    | Var _ _ mem => fun s => hget s mem
    | App _ _ _ e1 e2 => fun s => (expDenote e1 s) (expDenote e2 s)
    | Abs _ _ _ e' => fun s => fun x => expDenote e' (HCons x s)
  end.

(** Like for previous examples, our interpreter is easy to run with [simpl]. *)

Eval simpl in expDenote Const HNil.
(** %\vspace{-.15in}% [[
    = tt
     : typeDenote Unit
]]
*)

Eval simpl in expDenote (Abs (dom := Unit) (Var HFirst)) HNil.
(** %\vspace{-.15in}% [[
     = fun x : unit => x
     : typeDenote (Arrow Unit Unit)
]]
*)

Eval simpl in expDenote (Abs (dom := Unit)
  (Abs (dom := Unit) (Var (HNext HFirst)))) HNil.
(** %\vspace{-.15in}% [[
     = fun x _ : unit => x
     : typeDenote (Arrow Unit (Arrow Unit Unit))
]]
*)

Eval simpl in expDenote (Abs (dom := Unit) (Abs (dom := Unit) (Var HFirst))) HNil.
(** %\vspace{-.15in}% [[
     = fun _ x0 : unit => x0
     : typeDenote (Arrow Unit (Arrow Unit Unit))
]]
*)

Eval simpl in expDenote (App (Abs (Var HFirst)) Const) HNil.
(** %\vspace{-.15in}% [[
     = tt
     : typeDenote Unit
]]
*)

(* end thide *)

(** We are starting to develop the tools behind dependent typing's amazing advantage over alternative approaches in several important areas.  Here, we have implemented complete syntax, typing rules, and evaluation semantics for simply typed lambda calculus without even needing to define a syntactic substitution operation.  We did it all without a single line of proof, and our implementation is manifestly executable.  Other, more common approaches to language formalization often state and prove explicit theorems about type safety of languages.  In the above example, we got type safety, termination, and other meta-theorems for free, by reduction to CIC, which we know has those properties. *)

(** * Recursive Type Definitions *)

(** %\index{recursive type definition}%There is another style of datatype definition that leads to much simpler definitions of the [get] and [hget] definitions above.  Because Coq supports "type-level computation," we can redo our inductive definitions as _recursive_ definitions.  Here we will preface type names with the letter [f] to indicate that they are based on explicit recursive _function_ definitions. *)

(* EX: Come up with an alternate [ilist] definition that makes it easier to write [get]. *)

Section filist.
  Variable A : Set.

(* begin thide *)
  Fixpoint filist (n : nat) : Set :=
    match n with
      | O => unit
      | S n' => A * filist n'
    end%type.

  (** We say that a list of length 0 has no contents, and a list of length [S n'] is a pair of a data value and a list of length [n']. *)

  Fixpoint ffin (n : nat) : Set :=
    match n with
      | O => Empty_set
      | S n' => option (ffin n')
    end.

  (** We express that there are no index values when [n = O], by defining such indices as type [Empty_set]; and we express that, at [n = S n'], there is a choice between picking the first element of the list (represented as [None]) or choosing a later element (represented by [Some idx], where [idx] is an index into the list tail).  For instance, the three values of type [ffin 3] are [None], [Some None], and [Some (Some None)]. *)

  Fixpoint fget (n : nat) : filist n -> ffin n -> A :=
    match n with
      | O => fun _ idx => match idx with end
      | S n' => fun ls idx =>
        match idx with
          | None => fst ls
          | Some idx' => fget n' (snd ls) idx'
        end
    end.

  (** Our new [get] implementation needs only one dependent [match], and its annotation is inferred for us.  Our choices of data structure implementations lead to just the right typing behavior for this new definition to work out. *)
(* end thide *)

End filist.

(** Heterogeneous lists are a little trickier to define with recursion, but we then reap similar benefits in simplicity of use. *)

(* EX: Come up with an alternate [hlist] definition that makes it easier to write [hget]. *)

Section fhlist.
  Variable A : Type.
  Variable B : A -> Type.

(* begin thide *)
  Fixpoint fhlist (ls : list A) : Type :=
    match ls with
      | nil => unit
      | x :: ls' => B x * fhlist ls'
    end%type.

  (** The definition of [fhlist] follows the definition of [filist], with the added wrinkle of dependently typed data elements. *)

  Variable elm : A.

  Fixpoint fmember (ls : list A) : Type :=
    match ls with
      | nil => Empty_set
      | x :: ls' => (x = elm) + fmember ls'
    end%type.

  (** The definition of [fmember] follows the definition of [ffin].  Empty lists have no members, and member types for nonempty lists are built by adding one new option to the type of members of the list tail.  While for [ffin] we needed no new information associated with the option that we add, here we need to know that the head of the list equals the element we are searching for.  We express that idea with a sum type whose left branch is the appropriate equality proposition.  Since we define [fmember] to live in [Type], we can insert [Prop] types as needed, because [Prop] is a subtype of [Type].

     We know all of the tricks needed to write a first attempt at a [get] function for [fhlist]s.
     [[
  Fixpoint fhget (ls : list A) : fhlist ls -> fmember ls -> B elm :=
    match ls with
      | nil => fun _ idx => match idx with end
      | _ :: ls' => fun mls idx =>
        match idx with
          | inl _ => fst mls
          | inr idx' => fhget ls' (snd mls) idx'
        end
    end.
    ]]
    %\vspace{-.15in}%Only one problem remains.  The expression [fst mls] is not known to have the proper type.  To demonstrate that it does, we need to use the proof available in the [inl] case of the inner [match]. *)

  Fixpoint fhget (ls : list A) : fhlist ls -> fmember ls -> B elm :=
    match ls with
      | nil => fun _ idx => match idx with end
      | _ :: ls' => fun mls idx =>
        match idx with
          | inl pf => match pf with
                        | eq_refl => fst mls
                      end
          | inr idx' => fhget ls' (snd mls) idx'
        end
    end.

  (** By pattern-matching on the equality proof [pf], we make that equality known to the type-checker.  Exactly why this works can be seen by studying the definition of equality. *)

  (* begin hide *)
  (* begin thide *)
  Definition foo := @eq_refl.
  (* end thide *)
  (* end hide *)

  Print eq.
  (** %\vspace{-.15in}% [[
Inductive eq (A : Type) (x : A) : A -> Prop :=  eq_refl : x = x
]]

In a proposition [x = y], we see that [x] is a parameter and [y] is a regular argument.  The type of the constructor [eq_refl] shows that [y] can only ever be instantiated to [x].  Thus, within a pattern-match with [eq_refl], occurrences of [y] can be replaced with occurrences of [x] for typing purposes. *)
(* end thide *)

End fhlist.

Implicit Arguments fhget [A B elm ls].

(** How does one choose between the two data structure encoding strategies we have presented so far?  Before answering that question in this chapter's final section, we introduce one further approach. *)

(** * Data Structures as Index Functions *)

(** %\index{index function}%Indexed lists can be useful in defining other inductive types with constructors that take variable numbers of arguments.  In this section, we consider parameterized trees with arbitrary branching factor. *)

(* begin hide *)
Definition red_herring := O.
(* working around a bug in Coq 8.5! *)
(* end hide *)

Section tree.
  Variable A : Set.

  Inductive tree : Set :=
  | Leaf : A -> tree
  | Node : forall n, ilist tree n -> tree.
End tree.

(** Every [Node] of a [tree] has a natural number argument, which gives the number of child trees in the second argument, typed with [ilist].  We can define two operations on trees of naturals: summing their elements and incrementing their elements.  It is useful to define a generic fold function on [ilist]s first. *)

Section ifoldr.
  Variables A B : Set.
  Variable f : A -> B -> B.
  Variable i : B.

  Fixpoint ifoldr n (ls : ilist A n) : B :=
    match ls with
      | Nil => i
      | Cons _ x ls' => f x (ifoldr ls')
    end.
End ifoldr.

Fixpoint sum (t : tree nat) : nat :=
  match t with
    | Leaf n => n
    | Node _ ls => ifoldr (fun t' n => sum t' + n) O ls
  end.

Fixpoint inc (t : tree nat) : tree nat :=
  match t with
    | Leaf n => Leaf (S n)
    | Node _ ls => Node (imap inc ls)
  end.

(** Now we might like to prove that [inc] does not decrease a tree's [sum]. *)

Theorem sum_inc : forall t, sum (inc t) >= sum t.
(* begin thide *)
  induction t; crush.
  (** [[
  n : nat
  i : ilist (tree nat) n
  ============================
   ifoldr (fun (t' : tree nat) (n0 : nat) => sum t' + n0) 0 (imap inc i) >=
   ifoldr (fun (t' : tree nat) (n0 : nat) => sum t' + n0) 0 i

   ]]

   We are left with a single subgoal which does not seem provable directly.  This is the same problem that we met in Chapter 3 with other %\index{nested inductive type}%nested inductive types. *)

  Check tree_ind.
  (** %\vspace{-.15in}% [[
  tree_ind
     : forall (A : Set) (P : tree A -> Prop),
       (forall a : A, P (Leaf a)) ->
       (forall (n : nat) (i : ilist (tree A) n), P (Node i)) ->
       forall t : tree A, P t
]]

The automatically generated induction principle is too weak.  For the [Node] case, it gives us no inductive hypothesis.  We could write our own induction principle, as we did in Chapter 3, but there is an easier way, if we are willing to alter the definition of [tree]. *)

Abort.

Reset tree.
(* begin hide *)
Reset red_herring.
(* working around a bug in Coq 8.5! *)
(* end hide *)

(** First, let us try using our recursive definition of [ilist]s instead of the inductive version. *)

Section tree.
  Variable A : Set.

  (** %\vspace{-.15in}% [[
  Inductive tree : Set :=
  | Leaf : A -> tree
  | Node : forall n, filist tree n -> tree.
]]

<<
Error: Non strictly positive occurrence of "tree" in
 "forall n : nat, filist tree n -> tree"
>>

  The special-case rule for nested datatypes only works with nested uses of other inductive types, which could be replaced with uses of new mutually inductive types.  We defined [filist] recursively, so it may not be used in nested inductive definitions.

  Our final solution uses yet another of the inductive definition techniques introduced in Chapter 3, %\index{reflexive inductive type}%reflexive types.  Instead of merely using [fin] to get elements out of [ilist], we can _define_ [ilist] in terms of [fin].  For the reasons outlined above, it turns out to be easier to work with [ffin] in place of [fin]. *)

  Inductive tree : Set :=
  | Leaf : A -> tree
  | Node : forall n, (ffin n -> tree) -> tree.

  (** A [Node] is indexed by a natural number [n], and the node's [n] children are represented as a function from [ffin n] to trees, which is isomorphic to the [ilist]-based representation that we used above. *)

End tree.

Implicit Arguments Node [A n].

(** We can redefine [sum] and [inc] for our new [tree] type.  Again, it is useful to define a generic fold function first.  This time, it takes in a function whose domain is some [ffin] type, and it folds another function over the results of calling the first function at every possible [ffin] value. *)

Section rifoldr.
  Variables A B : Set.
  Variable f : A -> B -> B.
  Variable i : B.

  Fixpoint rifoldr (n : nat) : (ffin n -> A) -> B :=
    match n with
      | O => fun _ => i
      | S n' => fun get => f (get None) (rifoldr n' (fun idx => get (Some idx)))
    end.
End rifoldr.

Implicit Arguments rifoldr [A B n].

Fixpoint sum (t : tree nat) : nat :=
  match t with
    | Leaf n => n
    | Node _ f => rifoldr plus O (fun idx => sum (f idx))
  end.

Fixpoint inc (t : tree nat) : tree nat :=
  match t with
    | Leaf n => Leaf (S n)
    | Node _ f => Node (fun idx => inc (f idx))
  end.

(** Now we are ready to prove the theorem where we got stuck before.  We will not need to define any new induction principle, but it _will_ be helpful to prove some lemmas. *)

Lemma plus_ge : forall x1 y1 x2 y2,
  x1 >= x2
  -> y1 >= y2
  -> x1 + y1 >= x2 + y2.
  crush.
Qed.

Lemma sum_inc' : forall n (f1 f2 : ffin n -> nat),
  (forall idx, f1 idx >= f2 idx)
  -> rifoldr plus O f1 >= rifoldr plus O f2.
  Hint Resolve plus_ge.

  induction n; crush.
Qed.

Theorem sum_inc : forall t, sum (inc t) >= sum t.
  Hint Resolve sum_inc'.

  induction t; crush.
Qed.

(* end thide *)

(** Even if Coq would generate complete induction principles automatically for nested inductive definitions like the one we started with, there would still be advantages to using this style of reflexive encoding.  We see one of those advantages in the definition of [inc], where we did not need to use any kind of auxiliary function.  In general, reflexive encodings often admit direct implementations of operations that would require recursion if performed with more traditional inductive data structures. *)

(** ** Another Interpreter Example *)

(** We develop another example of variable-arity constructors, in the form of optimization of a small expression language with a construct like Scheme's <<cond>>.  Each of our conditional expressions takes a list of pairs of boolean tests and bodies.  The value of the conditional comes from the body of the first test in the list to evaluate to [true].  To simplify the %\index{interpreters}%interpreter we will write, we force each conditional to include a final, default case. *)

Inductive type' : Type := Nat | Bool.

Inductive exp' : type' -> Type :=
| NConst : nat -> exp' Nat
| Plus : exp' Nat -> exp' Nat -> exp' Nat
| Eq : exp' Nat -> exp' Nat -> exp' Bool

| BConst : bool -> exp' Bool
(* begin thide *)
| Cond : forall n t, (ffin n -> exp' Bool)
  -> (ffin n -> exp' t) -> exp' t -> exp' t.
(* end thide *)

(** A [Cond] is parameterized by a natural [n], which tells us how many cases this conditional has.  The test expressions are represented with a function of type [ffin n -> exp' Bool], and the bodies are represented with a function of type [ffin n -> exp' t], where [t] is the overall type.  The final [exp' t] argument is the default case.  For example, here is an expression that successively checks whether [2 + 2 = 5] (returning 0 if so) or if [1 + 1 = 2] (returning 1 if so), returning 2 otherwise. *)

Example ex1 := Cond 2
  (fun f => match f with
              | None => Eq (Plus (NConst 2) (NConst 2)) (NConst 5)
              | Some None => Eq (Plus (NConst 1) (NConst 1)) (NConst 2)
              | Some (Some v) => match v with end
            end)
  (fun f => match f with
              | None => NConst 0
              | Some None => NConst 1
              | Some (Some v) => match v with end
            end)
  (NConst 2).

(** We start implementing our interpreter with a standard type denotation function. *)

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

(** To implement the expression interpreter, it is useful to have the following function that implements the functionality of [Cond] without involving any syntax. *)

(* begin thide *)
Section cond.
  Variable A : Set.
  Variable default : A.

  Fixpoint cond (n : nat) : (ffin n -> bool) -> (ffin n -> A) -> A :=
    match n with
      | O => fun _ _ => default
      | S n' => fun tests bodies =>
        if tests None
          then bodies None
          else cond n'
            (fun idx => tests (Some idx))
            (fun idx => bodies (Some idx))
    end.
End cond.

Implicit Arguments cond [A n].
(* end thide *)

(** Now the expression interpreter is straightforward to write. *)

(* begin thide *)
Fixpoint exp'Denote t (e : exp' t) : type'Denote t :=
  match e with
    | NConst n => n
    | Plus e1 e2 => exp'Denote e1 + exp'Denote e2
    | Eq e1 e2 =>
      if eq_nat_dec (exp'Denote e1) (exp'Denote e2) then true else false

    | BConst b => b
    | Cond _ _ tests bodies default =>
      cond
      (exp'Denote default)
      (fun idx => exp'Denote (tests idx))
      (fun idx => exp'Denote (bodies idx))
  end.
(* begin hide *)
Reset exp'Denote.
(* end hide *)
(* end thide *)

(* begin hide *)
Fixpoint exp'Denote t (e : exp' t) : type'Denote t :=
  match e with
    | NConst n => n
    | Plus e1 e2 => exp'Denote e1 + exp'Denote e2
    | Eq e1 e2 =>
      if eq_nat_dec (exp'Denote e1) (exp'Denote e2) then true else false

    | BConst b => b
    | Cond _ _ tests bodies default =>
(* begin thide *)
      cond
      (exp'Denote default)
      (fun idx => exp'Denote (tests idx))
      (fun idx => exp'Denote (bodies idx))
(* end thide *)
  end.
(* end hide *)

(** We will implement a constant-folding function that optimizes conditionals, removing cases with known-[false] tests and cases that come after known-[true] tests.  A function [cfoldCond] implements the heart of this logic.  The convoy pattern is used again near the end of the implementation. *)

(* begin thide *)
Section cfoldCond.
  Variable t : type'.
  Variable default : exp' t.

  Fixpoint cfoldCond (n : nat)
    : (ffin n -> exp' Bool) -> (ffin n -> exp' t) -> exp' t :=
    match n with
      | O => fun _ _ => default
      | S n' => fun tests bodies =>
        match tests None return _ with
          | BConst true => bodies None
          | BConst false => cfoldCond n'
            (fun idx => tests (Some idx))
            (fun idx => bodies (Some idx))
          | _ =>
            let e := cfoldCond n'
              (fun idx => tests (Some idx))
              (fun idx => bodies (Some idx)) in
            match e in exp' t return exp' t -> exp' t with
              | Cond n _ tests' bodies' default' => fun body =>
                Cond
                (S n)
                (fun idx => match idx with
                              | None => tests None
                              | Some idx => tests' idx
                            end)
                (fun idx => match idx with
                              | None => body
                              | Some idx => bodies' idx
                            end)
                default'
              | e => fun body =>
                Cond
                1
                (fun _ => tests None)
                (fun _ => body)
                e
            end (bodies None)
        end
    end.
End cfoldCond.

Implicit Arguments cfoldCond [t n].
(* end thide *)

(** Like for the interpreters, most of the action was in this helper function, and [cfold] itself is easy to write. *)

(* begin thide *)
Fixpoint cfold t (e : exp' t) : exp' t :=
  match e with
    | NConst n => NConst n
    | Plus e1 e2 =>
      let e1' := cfold e1 in
      let e2' := cfold e2 in
      match e1', e2' return exp' Nat with
        | NConst n1, NConst n2 => NConst (n1 + n2)
        | _, _ => Plus e1' e2'
      end
    | Eq e1 e2 =>
      let e1' := cfold e1 in
      let e2' := cfold e2 in
      match e1', e2' return exp' Bool with
        | NConst n1, NConst n2 => BConst (if eq_nat_dec n1 n2 then true else false)
        | _, _ => Eq e1' e2'
      end

    | BConst b => BConst b
    | Cond _ _ tests bodies default =>
      cfoldCond
      (cfold default)
      (fun idx => cfold (tests idx))
      (fun idx => cfold (bodies idx))
  end.
(* end thide *)

(* begin thide *)
(** To prove our final correctness theorem, it is useful to know that [cfoldCond] preserves expression meanings.  The following lemma formalizes that property.  The proof is a standard mostly automated one, with the only wrinkle being a guided instantiation of the quantifiers in the induction hypothesis. *)

Lemma cfoldCond_correct : forall t (default : exp' t)
  n (tests : ffin n -> exp' Bool) (bodies : ffin n -> exp' t),
  exp'Denote (cfoldCond default tests bodies)
  = exp'Denote (Cond n tests bodies default).
  induction n; crush;
    match goal with
      | [ IHn : forall tests bodies, _, tests : _ -> _, bodies : _ -> _ |- _ ] =>
        specialize (IHn (fun idx => tests (Some idx)) (fun idx => bodies (Some idx)))
    end;
    repeat (match goal with
              | [ |- context[match ?E with NConst _ => _ | _ => _ end] ] =>
                dep_destruct E
              | [ |- context[if ?B then _ else _] ] => destruct B
            end; crush).
Qed.

(** It is also useful to know that the result of a call to [cond] is not changed by substituting new tests and bodies functions, so long as the new functions have the same input-output behavior as the old.  It turns out that, in Coq, it is not possible to prove in general that functions related in this way are equal.  We treat this issue with our discussion of axioms in a later chapter.  For now, it suffices to prove that the particular function [cond] is _extensional_; that is, it is unaffected by substitution of functions with input-output equivalents. *)

Lemma cond_ext : forall (A : Set) (default : A) n (tests tests' : ffin n -> bool)
  (bodies bodies' : ffin n -> A),
  (forall idx, tests idx = tests' idx)
  -> (forall idx, bodies idx = bodies' idx)
  -> cond default tests bodies
  = cond default tests' bodies'.
  induction n; crush;
    match goal with
      | [ |- context[if ?E then _ else _] ] => destruct E
    end; crush.
Qed.

(** Now the final theorem is easy to prove. *)
(* end thide *)

Theorem cfold_correct : forall t (e : exp' t),
  exp'Denote (cfold e) = exp'Denote e.
(* begin thide *)
  Hint Rewrite cfoldCond_correct.
  Hint Resolve cond_ext.

  induction e; crush;
    repeat (match goal with
              | [ |- context[cfold ?E] ] => dep_destruct (cfold E)
            end; crush).
Qed.
(* end thide *)

(** We add our two lemmas as hints and perform standard automation with pattern-matching of subterms to destruct. *)

(** * Choosing Between Representations *)

(** It is not always clear which of these representation techniques to apply in a particular situation, but I will try to summarize the pros and cons of each.

   Inductive types are often the most pleasant to work with, after someone has spent the time implementing some basic library functions for them, using fancy [match] annotations.  Many aspects of Coq's logic and tactic support are specialized to deal with inductive types, and you may miss out if you use alternate encodings.

   Recursive types usually involve much less initial effort, but they can be less convenient to use with proof automation.  For instance, the [simpl] tactic (which is among the ingredients in [crush]) will sometimes be overzealous in simplifying uses of functions over recursive types.  Consider a call [get l f], where variable [l] has type [filist A (S n)].  The type of [l] would be simplified to an explicit pair type.  In a proof involving many recursive types, this kind of unhelpful "simplification" can lead to rapid bloat in the sizes of subgoals.  Even worse, it can prevent syntactic pattern-matching, like in cases where [filist] is expected but a pair type is found in the "simplified" version.  The same problem applies to applications of recursive functions to values in recursive types: the recursive function call may "simplify" when the top-level structure of the type index but not the recursive value is known, because such functions are generally defined by recursion on the index, not the value.

   Another disadvantage of recursive types is that they only apply to type families whose indices determine their "skeletons."  This is not true for all data structures; a good counterexample comes from the richly typed programming language syntax types we have used several times so far.  The fact that a piece of syntax has type [Nat] tells us nothing about the tree structure of that syntax.

   Finally, Coq type inference can be more helpful in constructing values in inductive types.  Application of a particular constructor of that type tells Coq what to expect from the arguments, while, for instance, forming a generic pair does not make clear an intention to interpret the value as belonging to a particular recursive type.  This downside can be mitigated to an extent by writing "constructor" functions for a recursive type, mirroring the definition of the corresponding inductive type.

   Reflexive encodings of data types are seen relatively rarely.  As our examples demonstrated, manipulating index values manually can lead to hard-to-read code.  A normal inductive type is generally easier to work with, once someone has gone through the trouble of implementing an induction principle manually with the techniques we studied in Chapter 3.  For small developments, avoiding that kind of coding can justify the use of reflexive data structures.  There are also some useful instances of %\index{co-inductive types}%co-inductive definitions with nested data structures (e.g., lists of values in the co-inductive type) that can only be deconstructed effectively with reflexive encoding of the nested structures. *)


Require Import List.

Fixpoint split {A B: Type}(l: list (A * B)) : list A * list B :=
 match l with
   | nil => (nil, nil)
   | (a,b)::l' => let (l'1,l'2) := split  l'
                   in (a::l'1, b::l'2)
 end.

Fixpoint combine {A B: Type}(l1 : list A)(l2 :list B): list (A*B):=
  match l1,l2 with
    | nil,nil => nil
    | (a::l'1), (b::l'2) => (a,b)::(combine  l'1 l'2)
    | _,_  => nil
  end.

Theorem combine_of_split {A B : Type} :
  forall l:list (A*B),
    let (l1,l2) :=  split l
    in combine  l1 l2 = l.
Proof.
  induction l; simpl; auto.
  destruct a, (split l); simpl; congruence.
Qed.