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

(** Properties of the power function *)

Require Import Bool NAxioms NSub NParity NZPow.

(** Derived properties of power, specialized on natural numbers *)

Module Type NPowProp
 (Import A : NAxiomsSig')
 (Import B : NSubProp A)
 (Import C : NParityProp A B).

 Module Import NZPowP := Nop <+ NZPowProp A A B.

Ltac auto' := trivial; try rewrite <- neq_0_lt_0; auto using le_0_l.
Ltac wrap l := intros; apply l; auto'.

Lemma pow_succ_r' : forall a b, a^(S b) == a * a^b.
Proof. wrap pow_succ_r. Qed.

(** Power and basic constants *)

Lemma pow_0_l : forall a, a~=0 -> 0^a == 0.
Proof. wrap pow_0_l. Qed.

Definition pow_1_r : forall a, a^1 == a
 := pow_1_r.

Lemma pow_1_l : forall a, 1^a == 1.
Proof. wrap pow_1_l. Qed.

Definition pow_2_r : forall a, a^2 == a*a
 := pow_2_r.

(** Power and addition, multiplication *)

Lemma pow_add_r : forall a b c, a^(b+c) == a^b * a^c.
Proof. wrap pow_add_r. Qed.

Lemma pow_mul_l : forall a b c, (a*b)^c == a^c * b^c.
Proof. wrap pow_mul_l. Qed.

Lemma pow_mul_r : forall a b c, a^(b*c) == (a^b)^c.
Proof. wrap pow_mul_r. Qed.

(** Power and nullity *)

Lemma pow_eq_0 : forall a b, b~=0 -> a^b == 0 -> a == 0.
Proof. intros. apply (pow_eq_0 a b); trivial. auto'. Qed.

Lemma pow_nonzero : forall a b, a~=0 -> a^b ~= 0.
Proof. wrap pow_nonzero. Qed.

Lemma pow_eq_0_iff : forall a b, a^b == 0 <-> b~=0 /\ a==0.
Proof.
 intros a b. split.
 rewrite pow_eq_0_iff. intros [H |[H H']].
  generalize (le_0_l b); order. split; order.
 intros (Hb,Ha). rewrite Ha. now apply pow_0_l'.
Qed.

(** Monotonicity *)

Lemma pow_lt_mono_l : forall a b c, c~=0 -> a<b -> a^c < b^c.
Proof. wrap pow_lt_mono_l. Qed.

Lemma pow_le_mono_l : forall a b c, a<=b -> a^c <= b^c.
Proof. wrap pow_le_mono_l. Qed.

Lemma pow_gt_1 : forall a b, 1<a -> b~=0 -> 1<a^b.
Proof. wrap pow_gt_1. Qed.

Lemma pow_lt_mono_r : forall a b c, 1<a -> b<c -> a^b < a^c.
Proof. wrap pow_lt_mono_r. Qed.

(** NB: since 0^0 > 0^1, the following result isn't valid with a=0 *)

Lemma pow_le_mono_r : forall a b c, a~=0 -> b<=c -> a^b <= a^c.
Proof. wrap pow_le_mono_r. Qed.

Lemma pow_le_mono : forall a b c d, a~=0 -> a<=c -> b<=d ->
 a^b <= c^d.
Proof. wrap pow_le_mono. Qed.

Definition pow_lt_mono : forall a b c d, 0<a<c -> 0<b<d ->
 a^b < c^d
 := pow_lt_mono.

(** Injectivity *)

Lemma pow_inj_l : forall a b c, c~=0 -> a^c == b^c -> a == b.
Proof. intros; eapply pow_inj_l; eauto; auto'. Qed.

Lemma pow_inj_r : forall a b c, 1<a -> a^b == a^c -> b == c.
Proof. intros; eapply pow_inj_r; eauto; auto'. Qed.

(** Monotonicity results, both ways *)

Lemma pow_lt_mono_l_iff : forall a b c, c~=0 ->
  (a<b <-> a^c < b^c).
Proof. wrap pow_lt_mono_l_iff. Qed.

Lemma pow_le_mono_l_iff : forall a b c, c~=0 ->
  (a<=b <-> a^c <= b^c).
Proof. wrap pow_le_mono_l_iff. Qed.

Lemma pow_lt_mono_r_iff : forall a b c, 1<a ->
  (b<c <-> a^b < a^c).
Proof. wrap pow_lt_mono_r_iff. Qed.

Lemma pow_le_mono_r_iff : forall a b c, 1<a ->
  (b<=c <-> a^b <= a^c).
Proof. wrap pow_le_mono_r_iff. Qed.

(** For any a>1, the a^x function is above the identity function *)

Lemma pow_gt_lin_r : forall a b, 1<a -> b < a^b.
Proof. wrap pow_gt_lin_r. Qed.

(** Someday, we should say something about the full Newton formula.
    In the meantime, we can at least provide some inequalities about
    (a+b)^c.
*)

Lemma pow_add_lower : forall a b c, c~=0 ->
  a^c + b^c <= (a+b)^c.
Proof. wrap pow_add_lower. Qed.

(** This upper bound can also be seen as a convexity proof for x^c :
    image of (a+b)/2 is below the middle of the images of a and b
*)

Lemma pow_add_upper : forall a b c, c~=0 ->
  (a+b)^c <= 2^(pred c) * (a^c + b^c).
Proof. wrap pow_add_upper. Qed.

(** Power and parity *)

Lemma even_pow : forall a b, b~=0 -> even (a^b) = even a.
Proof.
 intros a b Hb. rewrite neq_0_lt_0 in Hb.
 apply lt_ind with (4:=Hb). solve_proper.
 now nzsimpl.
 clear b Hb. intros b Hb IH.
 rewrite pow_succ_r', even_mul, IH. now destruct (even a).
Qed.

Lemma odd_pow : forall a b, b~=0 -> odd (a^b) = odd a.
Proof.
 intros. now rewrite <- !negb_even, even_pow.
Qed.

End NPowProp.


Require Import List.
Export ListNotations.
Require Import PeanoNat.
Require Import Ensembles.

Delimit Scope My_scope with M.
Open Scope My_scope.
Set Implicit Arguments.

Global Parameter V : Set.

Parameter eq_dec_propvar : forall p q : V, {p = q}+{p <> q}.

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

(* Definitions Language *)

(* First, let us define the propositional formulas we use here. *)

Inductive MPropF : Type :=
 | Var : V -> MPropF
 | Bot : MPropF
 | Imp : MPropF -> MPropF -> MPropF
 | Box : MPropF -> MPropF
.

Notation "# p" := (Var p) (at level 1).
Notation "A --> B" := (Imp A B) (at level 16, right associativity).

Fixpoint subform (φ : MPropF) : Ensemble MPropF :=
match φ with
| Var p => Singleton _ (Var p)
| Bot => Singleton _ Bot
| Imp ψ χ => Union _ (Singleton _ (Imp ψ χ))
(Union _ (subform ψ) (subform χ))| Box ψ => Union _ (Singleton _ (Box ψ)) (subform ψ)
end.

Fixpoint subformlist (φ : MPropF) : list MPropF :=
match φ with
| Var p => (Var p) :: nil
| Bot => Bot :: nil
| Imp ψ χ => (Imp ψ χ) :: (subformlist ψ) ++ (subformlist χ)
| Box ψ => (Box ψ) :: (subformlist ψ)
end.

Definition Neg (A : MPropF) := Imp A (Bot).

Fixpoint Box_power (n : nat) (A : MPropF) : MPropF :=
match n with
 | 0 => A
 | S m => Box (Box_power m A)
end.

Fixpoint Imp_Box_power (n : nat) (A B : MPropF) : MPropF :=
match n with
 | 0 => A --> B
 | S m => A --> (Imp_Box_power m (Box A) B)
end.

Inductive Box_clos_set (Γ : @Ensemble MPropF): @Ensemble MPropF :=
  | InitClo : forall A, In _ Γ A -> Box_clos_set Γ A
  | IndClo : forall A,  Box_clos_set Γ A -> Box_clos_set Γ (Box A).

Lemma eq_dec_form : forall x y : MPropF, {x = y}+{x <> y}.
Proof.
induction x.
- intros. destruct y.
  * pose (eq_dec_propvar v v0). destruct s. left. subst. reflexivity.
    right. intro. inversion H. apply n. auto.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * auto.
  * right. intro. inversion H.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx1 y1). pose (IHx2 y2). destruct s. destruct s0. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption. right. intro. inversion H. apply n. auto.
  * right. intro. inversion H.
- intros. destruct y.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * right. intro. inversion H.
  * pose (IHx y). destruct s. subst. left. reflexivity.
    right. intro. inversion H. apply n. assumption.
Qed.

Fixpoint size (φ : MPropF) : nat :=
match φ with
| Var p => 1| Bot => 1
| Imp ψ χ => 1 + (size ψ) + (size χ) | Box ψ => 1 + (size ψ)
end.

Fixpoint subst (σ : V -> MPropF) (φ : MPropF) : MPropF :=
match φ with
| Var p => (σ p)
| Bot => Bot
| Imp ψ χ => Imp (subst σ ψ) (subst σ χ)| Box ψ => Box (subst σ ψ)
end.

Definition is_atomicT (A : MPropF) : Type :=
                  (exists (p : V), A = # p) + (A = Bot).

Definition is_Atomic (Γ : @Ensemble MPropF) : Type :=
    forall (A : MPropF), (Γ A) -> ((exists (p : V), A = # p) + (A = Bot)).

Fixpoint list_Imp (A : MPropF) (l : list MPropF) : MPropF :=
match l with
 | nil => A
 | h :: t => h --> (list_Imp A t)
end.

Fixpoint Box_list (l : list MPropF) : list MPropF :=
match l with
 | nil => nil
 | h :: t => (Box h) :: (Box_list t)
end.


(** Taken from https://gist.github.com/poizan42/c7017e66f921783c0e52
    with minor modifications. *)

Require Import Coq.ZArith.ZArith.
Require Import Coq.ZArith.Znumtheory.
Require Import Coq.Sets.Ensembles.
Require Import Coq.Sets.Finite_sets.
Require Import Coq.PArith.BinPos.
From Coq Require Import Lia.

Definition Z_ens := Ensemble Z.
(* Print Finite. *)
(* Print Empty_set. *)
Definition is_empty_set U A := forall x, ~(In U A x).
Inductive Finite' (U : Type) : Ensemble U -> Prop :=
    Empty_is_finite' : forall A : Ensemble U,
                      is_empty_set U A -> Finite' U A
  | Union_is_finite' : forall A : Ensemble U,
                      Finite' U A ->
                      forall x : U, ~ In U A x -> Finite' U (Add U A x).

Lemma finite_to_finite' : forall (U: Type) (A: Ensemble U),
  Finite U A -> Finite' U A.
Proof.
  intros.
  induction H.
  apply Empty_is_finite'.
  unfold is_empty_set.
  intros.
  firstorder.
  apply Union_is_finite'.
  firstorder.
  exact H0.
Qed.

Lemma finite'_empty_cases : forall (U: Type) (A: Ensemble U),
  Finite' U A -> is_empty_set U A \/ ~(is_empty_set U A).
Proof.
  intros.
  induction H.
  left.
  exact H.
  right.
  unfold not; intros.
  absurd (In U (Add U A x) x).
  firstorder.
  intuition.
Qed.

Lemma finite'_ne_inhabited : forall (U: Type) (A: Ensemble U),
  Finite' U A -> ~(is_empty_set U A) -> exists x, In U A x.
Proof.
  intros U A A_finite A_nonempty.
  induction A_finite.
  firstorder.
  exists x.
  intuition.
Qed.

Lemma Zdivide_Zabs_r a b : (a | b) -> (a | Z.abs b).
Proof.
  intros.
  elim Z.abs_eq_or_opp with (n := b).
  intros.
  rewrite H0.
  exact H.
  intros.
  rewrite H0.
  apply Zdivide_opp_r.
  exact H.
Qed.

Lemma Zdivide_Zabs_inv_r a b : (a | Z.abs b) -> (a | b).
Proof.
  intros.
  elim Z.abs_eq_or_opp with (n := b).
  intros.
  rewrite <- H0.
  exact H.
  intros.
  apply Zdivide_opp_r_rev.
  rewrite <- H0.
  exact H.
Qed.

Lemma mul_fin_set_divides : forall A:Z_ens,
  Finite' Z A -> (forall m:Z, In Z A m -> m <> 0) ->
    exists n:Z, n > 0 /\ forall m:Z, (In Z A m -> (m | n)).
Proof.
  intros A A_finite.
  apply Finite'_ind with (P := fun U =>
    (forall m:Z, In Z U m -> m <> 0) ->
    exists n:Z, n > 0 /\ forall m : Z, In Z U m -> (m | n)).
  (* Induction start *)
  intros A0 A0_empty _.
  exists 1.
  split.
  firstorder.
  intros m H.
  absurd (In Z A0 m).
  apply A0_empty.
  exact H.
  (* Induction step *)
  intros A0 A0_finite IH n_add n0_nin_A0 A0_nonzero.
  elim IH.
  intros n_mul IHdivides.
  clear IH.
  exists (n_mul * Z.abs n_add).
  split.
  apply Z.lt_gt.
  apply Z.mul_pos_pos.
  intuition.
  apply Z.abs_pos.
  { apply A0_nonzero; right; constructor. }
  intros.
  compare m n_add.
    (* m = n_add *)
    intros m_eq_n_mul.
    rewrite m_eq_n_mul.
    apply Z.divide_mul_r.
    apply Zdivide_Zabs_r.
    intuition.
    (* m <> n_add *)
    intros.
    apply Z.divide_mul_l.
    inversion H.
    apply IHdivides.
    exact H0.
    inversion H0.
    { apply IHdivides.
      inversion H; subst; auto.
      intuition. }
    apply Pos.eq_dec.
    apply Pos.eq_dec.
  intros m m_in_A0.
  apply A0_nonzero.
  intuition.
  exact A_finite.
Qed.

Lemma ex_rel_prime : forall P:Z_ens,
  (Finite' Z P /\ forall p:Z, In Z P p -> prime p) ->
  exists n:Z, n > 1 /\ (forall p:Z, In Z P p -> rel_prime p n).
Proof.
  intros P H.
  inversion H as [P_finite P_primes].
  clear H.
  elim finite'_empty_cases with (A := P).
  intros P_empty.
  exists 2.
  { split; try lia.
    intros p Hp.
    apply rel_prime_le_prime.
    { apply prime_2. }
    firstorder. }
  intros P_inhabited.
  apply finite'_ne_inhabited in P_inhabited.
  elim mul_fin_set_divides with (A := P).
  intros n all_divides'.
  inversion all_divides' as [n_pos all_divides]; clear all_divides'.
  exists (n+1).
  split.
  intuition.

  intros p p_in_P.
  pose proof p_in_P as prime_p.
  apply P_primes in prime_p.
  (* Show that p is positive *)
  pose proof prime_p as prime_p'.
  apply prime_alt in prime_p'.
  unfold prime' in prime_p'.
  inversion prime_p' as [p_geq_1 _].
  clear prime_p'.

  assert (n mod p = 0) as n_mod_p_eq_0.
    apply Zdivide_mod; apply all_divides; apply p_in_P.
  assert ((n+1) mod p = 1) as np1_mod_p_eq_1.
    assert (1 mod p = 1) as one_mod_p_eq_1.
    apply Zmod_1_l; exact p_geq_1.
    rewrite <- one_mod_p_eq_1 at 2; clear one_mod_p_eq_1.
    rewrite Zplus_mod.
    rewrite n_mod_p_eq_0.
    rewrite Z.add_0_l.
    rewrite Zmod_mod.
    apply eq_refl.
  apply rel_prime_sym.
  apply rel_prime_mod_rev.
  { lia. }
  rewrite np1_mod_p_eq_1.
  apply rel_prime_1.
  exact P_finite.
  intros p p_in_P.
  { intuition; subst.
    apply P_primes in p_in_P.
    apply not_prime_0; auto. }
  exact P_finite.
  exact P_finite.
Qed.

Lemma ex_maximal_element : forall (A : Ensemble Z), Finite' Z A ->
  (exists m, In Z A m) ->
  exists N, In Z A N /\ (forall n, In Z A n -> n <= N).

Proof.
  intros A A_is_finite.
  (* Check Finite'_ind. *)
  apply Finite'_ind with (P :=
    fun A => (exists m, In Z A m) ->
      exists N : Z, In Z A N /\ (forall n : Z, In Z A n -> n <= N)).
  (* Induction start, A0: empty set *)
  clear A A_is_finite; intros.
  firstorder.
  (* Induction step *)
  clear A A_is_finite;
    intros A0 A0_finite A0_ME_exists' n_add n_add_new add_non_empty.
  clear add_non_empty.

  (* - A0 is either empty or non-empty - *)
  inversion A0_finite as [A0_empty | A1 A1_finite n' n'_nin_A1 A1_A0_rel].
  (* A0 is empty, the new element must be the maximal element, as it's
   * the only element. *)
  exists n_add.
  split.
  apply Union_intror.
  firstorder.
  intros n0 n0_in_Znew.
  inversion n0_in_Znew.
  unfold is_empty_set in H.
  firstorder.
  inversion H1.
  intuition.
  (* A0 is non-empty, it contains n' *)
  assert (exists m : Z, In Z A0 m) as A0_non_empty.
  exists n'.
  inversion A1_A0_rel.
  apply Union_intror.
  apply In_singleton.
  (* Get rid of the knowledge of the extra element *)
  rewrite A1_A0_rel.
  clear A1 n' A1_finite n'_nin_A1 A1_A0_rel.

  (* Use our knowledge to get a useful induction hypothesis. *)
  apply A0_ME_exists' in A0_non_empty.
  rename A0_non_empty into A0_ME_exists.
  clear A0_ME_exists'.
  elim A0_ME_exists.
  clear A0_ME_exists.
  intros n0 n0_is_ME.

  inversion n0_is_ME as [n0_in_A0 n0_is_UB]; clear n0_is_ME.
  (* The actual element we claim is the maximal element is max(n_add, n0)*)
  exists (Z.max n_add n0).
  split.

  (** Show that the element is in A **)
  elim Z.lt_total with (n := n_add) (m := n0).
  (* n_add < n0 *)
  intros.
  rewrite Z.max_r.
  apply Union_introl.
  exact n0_in_A0.
  intuition.
  (* n_add = n0 \/ n0 < n_add *)
  intros.
  elim H; clear H.
  (* n_add = n0 *)
  intros.
  rewrite <- H in n0_in_A0.
  contradiction.
  (* n0 < n_add *)
  intros.
  rewrite Z.max_l.
  apply Union_intror.
  firstorder.
  intuition.

  (** Show that the element is an upper bound **)
  intros n n_in_Anew.
  elim Z.lt_total with (n := n_add) (m := n0).
  (* n_add < n0 *)
  intros.
  compare n n_add.
  (* n = n_add *)
  intros n_eq_n_add.
  rewrite Z.max_r.
  intuition.
  intuition.
  (* n <> n_add *)
  intros n_neq_n_add.
  rewrite Z.max_r.
  apply n0_is_UB.
  inversion n_in_Anew.
  trivial.
  inversion H0.
  exfalso.
  firstorder.
  intuition.
  apply Pos.eq_dec.
  apply Pos.eq_dec.
  (* n_add = n0 \/ n0 < n_add  *)
  intros.
  elim H.
  (* n_add = n0 *)
  clear H.
  intros.
  rewrite <- H in n0_in_A0.
  contradiction.
  (* n0 < n_add *)
  clear H.
  intros.
  rewrite Z.max_l.
  inversion n_in_Anew; clear x H1.
  { apply n0_is_UB in H0; lia. }
  inversion H0.
  intuition.
  intuition.
  (* Finally A is finite *)
  exact A_is_finite.
Qed.

Definition all_primes_leq (ub: Z) : Ensemble Z :=
  fun p: Z => p <= ub /\ prime p.

Lemma all_primes_leq_finite : forall ub, Finite' Z (all_primes_leq ub).

Proof.
  assert (forall p:Z, p <= 1 -> Finite' Z (all_primes_leq p)) as
    no_primes_finite.
  intros.
  apply Empty_is_finite'.
  unfold is_empty_set; intros n.
  unfold not; intros n_in_apleq_p.
  inversion n_in_apleq_p as [n_leq_p n_prime].
  inversion n_prime as [n_geq_1 _].
  intuition.

  intros.
  induction ub.
  (* n = 0 *)
  apply no_primes_finite.
  intuition.
  (* n > 0 *)
  apply Pos.peano_ind with (P :=
    fun n => Finite' Z (all_primes_leq (Z.pos n))).
  (* n = 1 *)
  apply no_primes_finite.
  intuition.
  (* n > 1, induction step *)
  intros n0 IH.
  set (n := Z.pos (Pos.succ n0)).
  assert (n = Z.succ (Z.pos n0)) as n_eq_succ_n0.
    rewrite <- Pos2Z.inj_succ.
    trivial.
  assert (n > Z.pos n0) as n_geq_n0.
    rewrite n_eq_succ_n0.
    apply Z.lt_gt.
    apply Z.lt_succ_diag_r.

  elim prime_dec with (p := n).
  (* n is prime *)
  intros n_prime.
  replace (all_primes_leq n) with (Add Z (all_primes_leq (Z.pos n0)) n).
  apply Union_is_finite'.
  assumption.
  unfold not, In; intros H.
  inversion H as [n_leq_n0 _].
  firstorder.
  apply Extensionality_Ensembles.
  split.
  split.
  (* inclusion new set -> all_primes_leq *)
  (* Proof that x <= n *)
    inversion H as [_1 x_in_apl _2 | _1 x_is_n _2].
    clear _1 _2 H.
    (* Case In Z (all_primes_leq (Z.pos n0)) x *)
    inversion x_in_apl as [x_leq_n0 _].
    apply Zgt_asym.
    apply Zgt_le_trans with (m := Z.pos n0).
    exact n_geq_n0.
    exact x_leq_n0.
    clear _1 _2 H.
    (* Case In Z (Singleton Z n) x *)
    inversion x_is_n as [n_eq_x].
    apply Z.le_refl.
  (* Proof that x is prime *)
    inversion H as [_1 x_in_apl _2 | _1 x_is_n _2].
    clear _1 _2 H.
    inversion x_in_apl as [_ x_is_prime].
    exact x_is_prime.
    clear _1 _2 H.
    inversion x_is_n.
    exact n_prime.
  (* inclusion all_primes_leq -> new set *)
  unfold Included.
  intros x x_in_apl.
  inversion x_in_apl as [x_leq_n x_prime].
  clear x_in_apl.
  compare x n.
    (* x = n *)
    intros x_eq_n.
    apply Union_intror.
    rewrite x_eq_n.
    apply In_singleton.
    (* x <> n *)
    intros x_neq_n.
    apply Union_introl.
    split.
    (* Show x <= Z.pos n0 *)
    apply Zgt_succ_le.
    rewrite <- n_eq_succ_n0.
    apply Z.lt_gt.
    elim not_Zeq with (n := x) (m := n).
    trivial.
    intros n_lt_x.
    apply Z.lt_gt in n_lt_x.
    contradiction.
    exact x_neq_n.
    (* show x is prime *)
    exact x_prime.
    apply Pos.eq_dec.
    apply Pos.eq_dec.

  (* n is not prime *)
  intros n_neq_prime.
  replace (all_primes_leq n) with (all_primes_leq (Z.pos n0)).
  exact IH.
  apply Extensionality_Ensembles.
  split.
  (* In Z (all_primes_leq (Z.pos n0)) x -> In Z (all_primes_leq n) *)
  split.
  inversion H as [x_leq_n0 _].
  apply Zgt_asym.
  apply Zgt_le_trans with (m := Z.pos n0).
  exact n_geq_n0.
  exact x_leq_n0.
  inversion H as [_ x_prime].
  exact x_prime.
  (* In Z (all_primes_leq n) -> In Z (all_primes_leq (Z.pos n0)) x *)
  split.
  inversion H as [x_leq_n x_prime].
  compare x (Z.pos n0).
  intros x_eq_n0.
  apply Z.eq_le_incl.
  exact x_eq_n0.
  intros x_neq_n0.
  apply Zgt_succ_le.
  rewrite <- n_eq_succ_n0.
  elim Zle_lt_or_eq with (n := x) (m := n).
  apply Z.lt_gt.
  intros x_eq_n.
  rewrite x_eq_n in x_prime.
  contradiction.
  exact x_leq_n.
  apply Pos.eq_dec.
  apply Pos.eq_dec.
  apply H.

  (* At last show that the set of negative primes is finite
    (because it's empty...)*)
  apply no_primes_finite.
  apply Z.lt_le_incl.
  apply Z.lt_trans with (m := 0).
  apply Zlt_neg_0.
  apply Z.lt_0_1.
Qed.

Lemma ex_prime_divisor : forall n, n > 1 -> exists p, prime p /\ (p | n).

Proof.
  intros n n_pos.
  induction n.
  absurd (0 > 1).
  intuition.
  assumption.
  (* Z.pos p > 0 *)
  (* A suffienctly strong IH (total induction) *)
  cut (forall n1, 1 < n1 <= Z.pos p -> exists p, prime p /\ (p | n1)).
  intros.
  apply H.
  split.
  apply Z.gt_lt.
  exact n_pos.
  apply Z.le_refl.
  apply Pos.peano_ind with (P := fun np =>
    forall n1, 1 < n1 <= Z.pos np -> exists p, prime p /\ (p | n1)).
  intros.
  exfalso.
  intuition.

  (* Induction "step" *)
  intros p0 IH n1 n1_n2_rel.
  set (n0 := Z.pos p0).
  set (n2 := Z.pos (Pos.succ p0)).
  fold n0 in IH.
  fold n2 in n1_n2_rel.
  elim prime_dec with (p := n1).
  (* n1 is prime *)
  intros n1_prime.
  exists n1.
  split.
  exact n1_prime.
  apply Z.divide_refl.
  (* n1 is not prime *)
  intros n1_nprime.
  cut (exists n, 1 < n < n1 /\ (n | n1)).
  intros.
  elim H; clear H.
  intros n n_div_of_n1.
  cut (exists p1, prime p1 /\ (p1 | n)).
  intros H.
  elim H; clear H.
  intros p2 p2_pf_of_n.
  exists p2.
  split.
  apply p2_pf_of_n.
  apply Z.divide_trans with (m := n).
  apply p2_pf_of_n.
  apply n_div_of_n1.
  apply IH.
  split.
  firstorder.
  assert (n2 = Z.succ n0) as n2_eq_n0p1.
  unfold n2, n0.
  rewrite Pos2Z.inj_succ.
  apply eq_refl.
  rewrite n2_eq_n0p1 in n1_n2_rel; clear n2_eq_n0p1 n2.
  elim Z.le_succ_r with (n := n1) (m := n0).
  intros H _.
  inversion n1_n2_rel as [_ H0].
  apply H in H0; clear H.
  elim H0; clear H0.
  (* case n1 <= n0 *)
  intros n1_leq_n0.
  apply Z.lt_le_incl.
  apply Z.lt_le_trans with (m := n1).
  apply n_div_of_n1.
  exact n1_leq_n0.
  (* case n1 = n0 + 1 *)
  intros n1_eq_n0p1.
  rewrite n1_eq_n0p1 in n_div_of_n1; clear n1_eq_n0p1.
  apply Z.lt_succ_r.
  apply n_div_of_n1.

  apply not_prime_divide.
  apply n1_n2_rel.
  exact n1_nprime.

  (* Negative numbers (contradiction) *)
  absurd (Z.neg p > 0).
  apply Pos2Z.neg_is_nonpos.
  firstorder.
Qed.

(*** There is an infinite number of primes ***)
(* Formulation 1: Given the set of all prime number <= an integer,
 *   then we can find a prime not in the set. *)
Theorem ex_prime_gt_ens : forall n, exists p,
  prime p /\ ~(In Z (all_primes_leq n) p).

Proof.
  intros n.
  elim ex_rel_prime with (P := all_primes_leq n).
  intros n2 H.
  inversion H as [n2_gt_1 n2_rel_prime]; clear H.
  elim ex_prime_divisor with (n := n2).
  intros p p_pf.
  exists p.
  split.
  apply p_pf.
  unfold not; intros p_in_apl.
  absurd (rel_prime p p).
  unfold rel_prime, not.
  intros p_rel_prime_self.
  elim Z.eq_dec with (x := p) (y := 1).
  intros p_eq_1.
  { subst. destruct p_pf as [HC ?].
    apply not_prime_1; auto. }
  intros p_neq_1.
  elim Zis_gcd_unique with (a := p) (b := p) (c := p) (d := 1).
  trivial.
  { intro; subst.
    destruct p_pf as [[] ?]; lia. }
  apply Zis_gcd_refl.
  exact p_rel_prime_self.
  cut (rel_prime p n2).
  intros p_n2_rp.
  apply rel_prime_sym in p_n2_rp.
  apply rel_prime_div with (p := n2).
  exact p_n2_rp.
  apply p_pf.
  apply n2_rel_prime.
  exact p_in_apl.
  apply n2_gt_1.

  split.
  apply all_primes_leq_finite.
  firstorder.
Qed.

(* Formulation 2: For every integer n there exists a prime larger than n.*)
Theorem ex_prime_gt : forall n,
  exists p, p > n /\ prime p.

Proof.
  intros n.
  (*cut (forall p, ~(In Z (all_primes_leq n) p) -> p > n).*)
  elim ex_prime_gt_ens with (n := n).
  intros.
  inversion H as [x_prime x_nin_apl]; clear H.
  exists x.
  split.
  unfold In, all_primes_leq in x_nin_apl.
  elim Z.lt_ge_cases with (n := n) (m := x).
  intros.
  apply Z.lt_gt.
  exact H.
  intros.
  absurd (x <= n /\ prime x).
  exact x_nin_apl.
  firstorder.
  exact x_prime.
Qed.

(* Formulation 3: For every set of prime numbers there exists a prime
     not in the set. *)
Theorem ex_other_prime : forall P:Z_ens,
  (Finite' Z P /\ forall p:Z, In Z P p -> prime p) ->
  exists q:Z, prime q /\ ~(In Z P q).

Proof.
  intros.
  inversion H as [P_finite P_primes]; clear H.
  (* - P is either empty or non-empty - *)
  inversion P_finite as [P_empty | P1 P1_finite p' p'_nin_P1 P1_P_rel].
  (* P is empty, 2 is prime.. *)
  exists 2.
  split.
  exact prime_2.
  firstorder.
  (* P is nonempty. *)
  assert (exists m : Z, In Z P m) as P_nonempty.
  exists p'.
  inversion P1_P_rel.
  intuition.
  (* Get a maximal element *)
  assert (exists N, In Z P N /\ (forall n, In Z P n -> n <= N))
    as ex_maximal_element'.
  apply ex_maximal_element.
  exact P_finite.
  exact P_nonempty.

  elim ex_maximal_element'.
  rewrite P1_P_rel.
  clear p' p'_nin_P1 P1_P_rel P1 P1_finite ex_maximal_element'.

  (* Introduce the maximal element *)
  intros p_max H.
  inversion H as [p_max_in_P p_max_ME]; clear H.
  elim ex_prime_gt with (n := p_max).
  intros q q_max_prime.
  exists q.
  split.
  apply q_max_prime.
  unfold not; intros q_in_P.
  absurd (q <= p_max).
  firstorder.
  firstorder.
Qed.


(*
Theorem ex_ip_ex : forall (A:Type)(a b:A), a=b -> b=a.
Proof.
  intros. rewrite H. auto.
Defined.
Print ex_ip_ex.
*)

Print eq_ind.

Theorem ex_ip_ex : forall (A:Type)(a b:A), a=b -> b=a.
Proof.
  refine
    (fun (A:Type) (a b:A) (H:a=b) =>
      eq_ind_r (fun a':A => b = a') (refl_equal b) H).
Defined.

Require Import ZArith.

Theorem plus_permute2 : forall (n m p:nat), n+m+p = n+p+m.
Proof.
  intros.
  pattern ((n+m)+p). rewrite <- plus_assoc.
  pattern (m+p). rewrite plus_comm.
  pattern (n+(p+m)). rewrite plus_assoc.
  reflexivity.
Defined.


Require Import Coq.Arith.EqNat.
Require Import Coq.Relations.Relations.
Require Import Coq.Sorting.Permutation.

Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.

Require Import VST.msl.Coqlib2.
Require Export VST.msl.eq_dec.

Lemma max_two_power_nat: forall n1 n2, Z.max (two_power_nat n1) (two_power_nat n2) = two_power_nat (Nat.max n1 n2).
Proof.
  intros.
  rewrite !two_power_nat_two_p.
  pose proof Zle_0_nat n1; pose proof Zle_0_nat n2.
  rewrite Nat2Z.inj_max.
  forget (Z.of_nat n1) as m1; forget (Z.of_nat n2) as m2.
  destruct (Z_le_dec m1 m2).
  + rewrite (Z.max_r m1 m2) by omega.
    apply Z.max_r.
    apply two_p_monotone; omega.
  + rewrite (Z.max_l m1 m2) by omega.
    apply Z.max_l.
    apply two_p_monotone; omega.
Qed.

Lemma Z_max_two_p: forall m1 m2, (exists n, m1 = two_power_nat n) -> (exists n, m2 = two_power_nat n) -> (exists n, Z.max m1 m2 = two_power_nat n).
Proof.
  intros ? ? [? ?] [? ?].
  subst.
  rewrite max_two_power_nat.
  eexists; reflexivity.
Qed.

Lemma power_nat_divide: forall n m, two_power_nat n <= two_power_nat m -> Z.divide (two_power_nat n) (two_power_nat m).
Proof.
  intros.
  repeat rewrite two_power_nat_two_p in *.
  unfold Zdivide.
  exists (two_p (Z.of_nat m - Z.of_nat n)).
  assert ((Z.of_nat m) = (Z.of_nat m - Z.of_nat n) + Z.of_nat n) by omega.
  rewrite H0 at 1.
  assert (Z.of_nat m >= 0) by omega.
  assert (Z.of_nat n >= 0) by omega.
  assert (Z.of_nat n <= Z.of_nat m).
    destruct (Z_le_gt_dec (Z.of_nat n) (Z.of_nat m)).
    exact l.
    assert (Z.of_nat m < Z.of_nat n) by omega.
    assert (two_p (Z.of_nat m) < two_p (Z.of_nat n)) by (apply two_p_monotone_strict; omega).
    omega.
  apply (two_p_is_exp (Z.of_nat m - Z.of_nat n) (Z.of_nat n)); omega.
Qed.

Lemma power_nat_divide_ge: forall n m: Z,
  (exists N, n = two_power_nat N) ->
  (exists M, m = two_power_nat M) ->
  (n >= m <-> (m | n)).
Proof.
  intros.
  destruct H, H0.
  split; intros.
  + subst.
    apply power_nat_divide.
    omega.
  + destruct H1 as [k ?].
    rewrite H1.
    pose proof two_power_nat_pos x0.
    pose proof two_power_nat_pos x.
    assert (k > 0).
    Focus 1. {
      eapply Zmult_gt_0_reg_l.
      + exact H2.
      + rewrite <- H0, Z.mul_comm; omega.
    } Unfocus.
    rewrite <- (Z.mul_1_l m) at 2.
    apply Zmult_ge_compat_r; omega.
Qed.

Lemma power_nat_divide_le: forall n m: Z,
  (exists N, n = two_power_nat N) ->
  (exists M, m = two_power_nat M) ->
  (m <= n <-> (m | n)).
Proof.
  intros.
  rewrite <- power_nat_divide_ge; auto.
  omega.
Qed.

Lemma two_p_max_divide: forall m1 m2 m, (exists n, m1 = two_power_nat n) -> (exists n, m2 = two_power_nat n) -> ((Z.max m1 m2 | m) <-> (m1 | m) /\ (m2 | m)).
Proof.
  intros.
  destruct (Z_le_dec m1 m2).
  + rewrite Z.max_r by omega.
    rewrite power_nat_divide_le in l by auto.
    pose proof Zdivides_trans m1 m2 m.
    tauto.
  + rewrite Z.max_l by omega.
    assert (m2 <= m1) by omega.
    rewrite power_nat_divide_le in H1 by auto.
    pose proof Zdivides_trans m2 m1 m.
    tauto.
Qed.

Lemma two_p_max_1: forall m1 m2, (exists n, m1 = two_power_nat n) -> (exists n, m2 = two_power_nat n) -> (Z.max m1 m2 = 1 <-> m1 = 1 /\ m2 = 1).
Proof.
  assert (forall x, (exists n : nat, x = two_power_nat n) -> (x = 1 <-> (x | 1))).
  + intros.
    split; intros.
    - subst.
      exists 1; auto.
    - rewrite <- power_nat_divide_le in H0 by (auto; exists 0%nat; auto).
      destruct H as [n ?]; subst x.
      pose proof two_power_nat_pos n.
      omega.
  + intros m1 m2 Hm1 Hm2.
    pose proof Z_max_two_p _ _ Hm1 Hm2 as Hmax.
    rewrite (H _ Hm1), (H _ Hm2), (H _ Hmax).
    apply two_p_max_divide; auto.
Qed.

Lemma two_power_nat_0: forall x, (exists n, x = two_power_nat n) -> x <> 0.
Proof.
  intros.
  destruct H.
  pose proof two_power_nat_pos x0.
  omega.
Qed.

Hint Rewrite andb_true_iff: align.
Hint Rewrite <- Zle_is_le_bool: align.
Hint Rewrite Z.eqb_eq: align.
Hint Rewrite power_nat_divide_le using (auto with align): align.
Hint Rewrite Z.mod_divide using (apply two_power_nat_0; auto with align): align.
Hint Rewrite two_p_max_divide using (auto with align): align.
Hint Rewrite two_p_max_1 using (auto with align): align.
Hint Resolve Z_max_two_p: align.

Lemma Z_of_nat_ge_O: forall n, Z.of_nat n >= 0.
Proof. intros.
change 0 with (Z.of_nat O).
apply inj_ge. clear; omega.
Qed.

Lemma nth_error_nth:
  forall A (al: list A) (z: A) i, (i < length al)%nat -> nth_error al i = Some (nth i al z).
Proof.
intros. revert al H; induction i; destruct al; simpl; intros; auto; try omega.
apply IHi. omega.
Qed.

Lemma nat_of_Z_eq: forall i, nat_of_Z (Z_of_nat i) = i.
Proof.
intros.
apply inj_eq_rev.
rewrite nat_of_Z_eq; auto.
omega.
Qed.

Lemma nth_error_length:
  forall {A} i (l: list A), nth_error l i = None <-> (i >= length l)%nat.
Proof.
induction i; destruct l; simpl; intuition.
inv H.
inv H.
rewrite IHi in H. omega.
rewrite IHi. omega.
Qed.

Lemma prop_unext: forall P Q: Prop, P=Q -> (P<->Q).
Proof. intros. subst; split; auto. Qed.

Lemma list_norepet_In_In: forall {K X} a x y (l:list (K*X)),
  list_norepet (map (@fst K X) l) -> In (a, x) l -> In (a, y) l -> x = y.
Proof.
  induction l; intros N Ix Iy.
   - inv Ix.
   - simpl in N; inv N.
     destruct Ix.
     + subst.
       simpl in Iy; destruct Iy as [|Iy]; [congruence|].
       exfalso; apply (in_map (@fst K X)) in Iy; tauto.
     + simpl in Iy; destruct Iy as [|Iy].
       subst. exfalso; apply (in_map (@fst K X)) in H; tauto.
       apply IHl; auto.
Qed.

Inductive sublist {A} : list A -> list A -> Prop :=
| sublist_nil : sublist nil nil
| sublist_cons a l1 l2 : sublist l1 l2 -> sublist (a :: l1) (a :: l2)
| sublist_drop a l1 l2 : sublist l1 l2 -> sublist l1 (a :: l2).

Lemma sublist_In {A} (a : A) l1 l2 : sublist l1 l2 -> In a l1 -> In a l2.
Proof.
  intros S; induction S; intros I.
  - inversion I.
  - simpl in I; destruct I.
    subst; left; auto.
    right; auto.
  - right; auto.
Qed.

Lemma sublist_norepet {A} (l1 l2 : list A) : sublist l1 l2 -> list_norepet l2 -> list_norepet l1.
Proof.
  intros S; induction S; intros N; auto.
  - inversion N; subst; constructor; auto.
    pose proof sublist_In a l1 l2; auto.
  - inversion N; auto.
Qed.

Require Import Coq.Sets.Ensembles.

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

Require Coq.Logic.ConstructiveEpsilon.

Lemma decidable_countable_ex_sig {A} (f : nat -> A)
      (Hf : forall a, exists n, a = f n)
      (P : A -> Prop)
      (Pdec : forall x, {P x} + {~ P x}) :
  (exists x : A, P x) -> {x : A | P x}.
Proof.
  intros E.
  cut ({n | P (f n)}). intros [n Hn]; eauto.
  apply ConstructiveEpsilon.constructive_indefinite_ground_description_nat.
  intro; apply Pdec.
  destruct E as [x Hx].
  destruct (Hf x) as [n ->].
  eauto.
Qed.

(** Additions to [if_tac]: when mature, move these upstream *)

Tactic Notation "if_tac" "eq:" simple_intropattern(E) :=
  match goal with
    |- context [if ?a then _ else _] =>
    destruct a as [?H | ?H] eqn:E
  end.

Tactic Notation "if_tac" simple_intropattern(H) "eq:" simple_intropattern(E):=
  match goal with
    |- context [if ?a then _ else _] =>
    destruct a as H eqn:E
  end.

Tactic Notation "if_tac" "in" hyp(H0) "eq:" simple_intropattern(E) :=
  match type of H0 with
    context [if ?a then _ else _] =>
    destruct a as [?H  | ?H] eqn:E
  end.

Tactic Notation "if_tac" simple_intropattern(H) "in" hyp(H1) "eq:" simple_intropattern(E) :=
  match type of H1 with
    context [if ?a then _ else _] =>
    destruct a as H eqn:E
  end.

(** Specializing a hypothesis with a newly created goal *)

Tactic Notation "assert_specialize" hyp(H) :=
  match type of H with
    forall x : ?P, _ =>
    let Htemp := fresh "Htemp" in
    assert P as Htemp; [ | specialize (H Htemp); try clear Htemp ]
  end.

Tactic Notation "assert_specialize" hyp(H) "by" tactic(tac) :=
  match type of H with
    forall x : ?P, _ =>
    let Htemp := fresh "Htemp" in
    assert P as Htemp by tac; specialize (H Htemp); try clear Htemp
  end.

Tactic Notation "assert_specialize" hyp(H) "as" simple_intropattern(Hnew) :=
  match type of H with
    forall x : ?P, _ =>
    assert P as Hnew; [ | specialize (H Hnew) ]
  end.

Tactic Notation "assert_specialize" hyp(H) "as" simple_intropattern(Hnew) "by" tactic(tac) :=
  match type of H with
    forall x : ?P, _ =>
    assert P as Hnew by tac;
    specialize (H Hnew)
  end.

(** Auto-specializing a hypothesis *)

Ltac autospec H := specialize (H ltac:(solve [eauto])).

(** When a hypothesis/term is provably equal, but not convertible, to
    your goal *)

Ltac exact_eq H :=
  revert H;
  match goal with
    |- ?p -> ?q => cut (p = q); [intros ->; auto | ]
  end.

(** Auto rewriting of a term *)

Tactic Notation "rewr" :=
  match goal with
  | H : ?f = _ |- context [?f] => rewrite H
  | H : ?f _ = ?f _ |- _ => try (injection H; repeat intros ->)
  end.

Tactic Notation "rewr" constr(e) :=
  match goal with
    E : e = _ |- _ => rewrite E
  | E : _ = e |- _ => rewrite <-E
  end.

Tactic Notation "rewr" constr(e) "in" "*" :=
  match goal with
    E : e = _ |- _ => rewrite E in *
  | E : _ = e |- _ => rewrite <-E in *
  end.

Tactic Notation "rewr" constr(e) "in" hyp(H) :=
  match goal with
    E : e = _ |- _ => rewrite E in H
  | E : _ = e |- _ => rewrite <-E in H
  end.

Lemma perm_search:
  forall {A} (a b: A) r s t,
     Permutation (a::t) s ->
     Permutation (b::t) r ->
     Permutation (a::r) (b::s).
Proof.
intros.
eapply perm_trans.
apply perm_skip.
apply Permutation_sym.
apply H0.
eapply perm_trans.
apply perm_swap.
apply perm_skip.
apply H.
Qed.

Lemma Permutation_concat: forall {A} (P Q: list (list A)),
  Permutation P Q ->
  Permutation (concat P) (concat Q).
Proof.
  intros.
  induction H.
  + apply Permutation_refl.
  + simpl.
    apply Permutation_app_head; auto.
  + simpl.
    rewrite !app_assoc.
    apply Permutation_app_tail.
    apply Permutation_app_comm.
  + eapply Permutation_trans; eauto.
Qed.

Lemma Permutation_app_comm_trans:
 forall (A: Type) (a b c : list A),
   Permutation (b++a) c ->
   Permutation (a++b) c.
Proof.
intros.
eapply Permutation_trans.
apply Permutation_app_comm.
auto.
Qed.

Ltac solve_perm :=
    (* solves goals of the form (R ++ ?i = S)
          where R and S are lists, and ?i is a unification variable *)
  try match goal with
       | |-  Permutation (?A ++ ?B) _ =>
            is_evar A; first [is_evar B; fail 1| idtac];
            apply Permutation_app_comm_trans
       end;
  repeat first [ apply Permutation_refl
       | apply perm_skip
       | eapply perm_search
       ].

Goal exists e, Permutation ((1::2::nil)++e) (3::2::1::5::nil).
eexists.
solve_perm.
Qed.

Lemma range_pred_dec: forall (P: nat -> Prop),
  (forall n, {P n} + {~ P n}) ->
  forall m,
    {forall n, (n < m)%nat -> P n} + {~ forall n, (n < m)%nat -> P n}.
Proof.
  intros.
  induction m.
  + left.
    intros; omega.
  + destruct (H m); [destruct IHm |].
    - left.
      intros.
      destruct (eq_dec n m).
      * subst; auto.
      * apply p0; omega.
    - right.
      intro.
      apply n; clear n.
      intros; apply H0; omega.
    - right.
      intro.
      apply n; clear n.
      apply H0.
      omega.
Qed.

Lemma Z2Nat_neg: forall i, i < 0 -> Z.to_nat i = 0%nat.
Proof.
  intros.
  destruct i; try reflexivity.
  pose proof Zgt_pos_0 p; omega.
Qed.

Lemma Zrange_pred_dec: forall (P: Z -> Prop),
  (forall z, {P z} + {~ P z}) ->
  forall l r,
    {forall z, l <= z < r -> P z} + {~ forall z, l <= z < r -> P z}.
Proof.
  intros.
  assert ((forall n: nat, (n < Z.to_nat (r - l))%nat -> P (l + Z.of_nat n)) <-> (forall z : Z, l <= z < r -> P z)).
  Focus 1. {
    split; intros.
    + specialize (H0 (Z.to_nat (z - l))).
      rewrite <- Z2Nat.inj_lt in H0 by omega.
      spec H0; [omega |].
      rewrite Z2Nat.id in H0 by omega.
      replace (l + (z - l)) with z in H0 by omega.
      auto.
    + apply H0.
      rewrite Nat2Z.inj_lt in H1.
      destruct (zlt (r - l) 0).
      - rewrite Z2Nat_neg in H1 by omega.
        simpl in H1.
        omega.
      - rewrite Z2Nat.id in H1 by omega.
        omega.
  } Unfocus.
  eapply sumbool_dec_iff; [clear H0 | eassumption].
  apply range_pred_dec.
  intros.
  apply H.
Qed.

Definition eqb_list {A: Type} (eqb_A: A -> A -> bool): list A -> list A -> bool :=
  fix eqb_list (l1 l2: list A): bool :=
    match l1, l2 with
    | nil, nil => true
    | a1 :: l1, a2 :: l2 => eqb_A a1 a2 && eqb_list l1 l2
    | _, _ => false
    end.

Lemma eqb_list_spec: forall {A: Type} (eqb_A: A -> A -> bool),
  (forall a1 a2, eqb_A a1 a2 = true <-> a1 = a2) ->
  (forall l1 l2, eqb_list eqb_A l1 l2 = true <-> l1 = l2).
Proof.
  intros.
  revert l2; induction l1 as [| a1 l1]; intros; destruct l2 as [| a2 l2].
  + simpl.
    tauto.
  + simpl.
    split; intros; congruence.
  + simpl.
    split; intros; congruence.
  + simpl.
    rewrite andb_true_iff.
    rewrite  H.
    rewrite IHl1.
    split; intros.
    - destruct H0; subst; auto.
    - inv H0; auto.
Qed.


Require Export Quantum.

Definition ketp : Vector 2 :=
  fun x y => match x, y with
          | 0, 0 => /√2
          | 1, 0 => /√2
          | _, _ => C0
          end.
Definition ketn : Vector 2 :=
  fun x y => match x, y with
          | 0, 0 => /√2
          | 1, 0 => -/√2
          | _, _ => C0
          end.

Notation "∣+⟩" := ketp.
Notation "∣-⟩" := ketn.
Notation "⟨+∣" := ketp†.
Notation "⟨-∣" := ketn†.

(* Deutsch *)

(* One-time *)

(* f(0) =  f(1) = 0 *)

Lemma deutsch0 : (hadamard ⊗ I 2) × (I 2 ⊗ I 2) × (hadamard ⊗ hadamard) × (∣0⟩ ⊗ ∣1⟩) = ∣0⟩ ⊗ ∣-⟩ .
Proof. solve_matrix. Qed.

Lemma Ddeutsch0 : super ((hadamard ⊗ I 2) × (I 2 ⊗ I 2) × (hadamard ⊗ hadamard)) ((∣0⟩ ⊗ ∣1⟩) × (∣0⟩ ⊗ ∣1⟩)†)= (∣0⟩ ⊗ ∣-⟩) × (∣0⟩ ⊗ ∣-⟩)†.
Proof.
unfold super.
Time solve_matrix.
Qed.

(* Lemma Ddeutsch0' : super (hadamard ⊗ I 2) (super (I 2 ⊗ I 2) (super (hadamard ⊗ hadamard) ((∣0⟩ ⊗ ∣1⟩) × (∣0⟩ ⊗ ∣1⟩)†))) = (∣0⟩ ⊗ ∣-⟩) × (∣0⟩ ⊗ ∣-⟩)†.
Proof.
unfold super.
solve_matrix.
Qed. *)

(* f(0) =  f(1) = 1 *)
Lemma deutsch1 : (hadamard ⊗ I 2) × (I 2 ⊗ σx) × (hadamard ⊗ hadamard) × (∣0⟩ ⊗ ∣1⟩) = -1 .* ∣0⟩ ⊗ ∣-⟩ .
Proof. solve_matrix. Qed.

Lemma Ddeutsch1 : super ((hadamard ⊗ I 2) × (I 2 ⊗ σx) × (hadamard ⊗ hadamard)) ((∣0⟩ ⊗ ∣1⟩) × (∣0⟩ ⊗ ∣1⟩)†)= (-1 .* ∣0⟩ ⊗ ∣-⟩) × (-1 .* ∣0⟩ ⊗ ∣-⟩ )†.
Proof.
unfold super.
Time solve_matrix.
Qed.

(* Lemma Ddeutsch1' : super (hadamard ⊗ I 2) (super (I 2 ⊗ σx) (super (hadamard ⊗ hadamard) ((∣0⟩ ⊗ ∣1⟩) × (∣0⟩ ⊗ ∣1⟩)†)))= (-1 .* ∣0⟩ ⊗ ∣-⟩) × (-1 .* ∣0⟩ ⊗ ∣-⟩ )†.
Proof.
unfold super.
solve_matrix.
Qed. *)

(* f(0) = 0, f(1) = 1 *)
Lemma deutsch2 : (hadamard ⊗ I 2) × cnot × (hadamard ⊗ hadamard) × (∣0⟩ ⊗ ∣1⟩) = ∣1⟩ ⊗ ∣-⟩ .
Proof. solve_matrix. Qed.

Lemma Ddeutsch2 : super ((hadamard ⊗ I 2) × cnot × (hadamard ⊗ hadamard)) ((∣0⟩ ⊗ ∣1⟩) × (∣0⟩ ⊗ ∣1⟩)†) = (∣1⟩ ⊗ ∣-⟩) × (∣1⟩ ⊗ ∣-⟩ )†.
Proof.
unfold super.
Time solve_matrix.
Qed.

(* Lemma Ddeutsch2' : super (hadamard ⊗ I 2) (super cnot (super (hadamard ⊗ hadamard) ((∣0⟩ ⊗ ∣1⟩) × (∣0⟩ ⊗ ∣1⟩)†))) = (∣1⟩ ⊗ ∣-⟩) × (∣1⟩ ⊗ ∣-⟩ )†.
Proof.
unfold super.
solve_matrix.
Qed. *)

(* f(0) = 1, f(1) = 0 *)
Definition notc : Matrix (2*2) (2*2) :=
  fun x y => match x, y with
          | 0, 1 => 1%C
          | 1, 0 => 1%C
          | 2, 2 => 1%C
          | 3, 3 => 1%C
          | _, _ => 0%C
          end.

Lemma deutsch3 : (hadamard ⊗ I 2) × notc × (hadamard ⊗ hadamard) × (∣0⟩ ⊗ ∣1⟩) = -1 .* ∣1⟩ ⊗ ∣-⟩ .
Proof. solve_matrix. Qed.

Lemma Ddeutsch3 : super ((hadamard ⊗ I 2) × notc × (hadamard ⊗ hadamard)) ((∣0⟩ ⊗ ∣1⟩) × (∣0⟩ ⊗ ∣1⟩)†) = (-1 .* ∣1⟩ ⊗ ∣-⟩) × (-1 .* ∣1⟩ ⊗ ∣-⟩)†.
Proof.
unfold super.
Time solve_matrix.
Qed.

(* Lemma Ddeutsch3' : super (hadamard ⊗ I 2) (super notc (super (hadamard ⊗ hadamard) ((∣0⟩ ⊗ ∣1⟩) × (∣0⟩ ⊗ ∣1⟩)†))) = (-1 .* ∣1⟩ ⊗ ∣-⟩) × (-1 .* ∣1⟩ ⊗ ∣-⟩)†.
Proof.
unfold super.
solve_matrix.
Qed. *)

(*
Finished transaction in 18.982 secs (17.437u,0.046s) (successful)
Finished transaction in 18.77 secs (17.078u,0.031s) (successful)
Finished transaction in 18.451 secs (17.187u,0.031s) (successful)
Finished transaction in 19.488 secs (17.578u,0.062s) (successful) *)


From CoqAlgs Require Import Base.

Set Implicit Arguments.

(* Formulas. [not f] will be represented as [fImpl f fFalse] and
   [f1 <-> f2] as [fAnd (fImpl f1 f2) (fImpl f2 f1)]. *)
Inductive formula : Type :=
    | fFalse : formula
    | fTrue : formula
    | fVar : nat -> formula
    | fAnd : formula -> formula -> formula
    | fOr : formula -> formula -> formula
    | fImpl : formula -> formula -> formula.

Fixpoint formulaDenote (env : Env Prop) (f : formula) : Prop :=
match f with
    | fFalse => False
    | fTrue => True
    | fVar i => holds i env
    | fAnd f1 f2 => formulaDenote env f1 /\ formulaDenote env f2
    | fOr f1 f2 => formulaDenote env f1 \/ formulaDenote env f2
    | fImpl f1 f2 => formulaDenote env f1 -> formulaDenote env f2
end.

Function simplifyFormula (f : formula) : formula :=
match f with
    | fFalse => fFalse
    | fTrue => fTrue
    | fVar P => fVar P
    | fAnd f1 f2 =>
        match simplifyFormula f1, simplifyFormula f2 with
            | fOr f11 f12, f2' => fOr (fAnd f11 f2') (fAnd f12 f2')
            | f1', fOr f21 f22 => fOr (fAnd f1' f21) (fAnd f1' f22)
            | fFalse, _ => fFalse
            | _, fFalse => fFalse
            | fTrue, f2' => f2'
            | f1', fTrue => f1'
            | f1', f2' => fAnd f1' f2'
        end
    | fOr f1 f2 =>
        match simplifyFormula f1, simplifyFormula f2 with
            | fAnd f11 f12, f2' => fAnd (fOr f11 f2') (fOr f12 f2')
            | f1', fAnd f21 f22 => fAnd (fOr f1' f21) (fOr f1' f22)
            | fFalse, f2' => f2'
            | f1', fFalse => f1'
            | fTrue, _ => fTrue
            | _, fTrue => fTrue
            | f1', f2' => fOr f1' f2'
        end
    | fImpl f1 f2 =>
        match simplifyFormula f1 with
            | fFalse => fTrue
            | fTrue => f2
            | fAnd f11 f12 => fImpl f11 (fImpl f12 f2)
            | fOr f11 f12 => fAnd (fImpl f11 f2) (fImpl f12 f2)
            | f1' => fImpl f1' f2
        end
end.

Theorem simplifyFormula_correct :
  forall (f : formula) (env : Env Prop),
    formulaDenote env (simplifyFormula f) <-> formulaDenote env f.
Proof.
  intros. functional induction simplifyFormula f; cbn.
  all:
  repeat match goal with
      | e : simplifyFormula ?f = _,
        IH : formulaDenote _ (simplifyFormula ?f) <-> _ |- _ =>
        rewrite <- IH, e; cbn
  end; try (tauto; fail).
Qed.

Definition solveHypothesis (env : Env Prop) :
  forall (proofs : Proofs) (H : allTrue env proofs) (hyp f : formula)
    (cont : Proofs -> bool), bool.
Proof.
  refine (
  fix solve
    (proofs : Proofs) (H : allTrue env proofs) (hyp f : formula)
      (cont : Proofs -> bool) : bool :=
  match hyp with
      | fFalse => false
      | fTrue => cont proofs
      | fVar i => cont (i :: proofs)
      | fAnd f1 f2 =>
          solve proofs H f1 (fImpl f2 f)
                        (fun proofs' => cont proofs')
      | fOr f1 f2 =>
          andb (solve proofs H f1 f cont)
               (solve proofs H f2 f cont)
      | _ => false
  end).
Defined.

Definition solveGoal (env : Env Prop)
  : forall (proofs : Proofs) (H : allTrue env proofs) (f : formula), bool.
Proof.
  refine (
  fix solve
    (proofs : Proofs) (H : allTrue env proofs) (f : formula) : bool :=
  match f with
      | fFalse => false
      | fTrue => true
      | fVar i =>
          match in_dec Nat.eq_dec i proofs with
              | left _ => true
              | right _ => false
          end
      | fAnd f1 f2 => andb (solve proofs H f1) (solve proofs H f2)
      | fOr f1 f2 => orb (solve proofs H f1) (solve proofs H f2)
 (*     | fImpl f1 f2 =>
          solveHypothesis env proofs H f1 f2
            (fun proofs' => solve proofs' _ f2)*)
      | _ => false
  end).
Defined.

Definition solveFormula (env : Env Prop) (f : formula) : bool.
Proof.
  refine (solveGoal env [] _ f). cbn. trivial.
Defined.

Theorem solveGoal_correct :
  forall (env : Env Prop) (proofs : Proofs) (H : allTrue env proofs)
  (f : formula),
    solveGoal env proofs H f = true -> formulaDenote env f.
Proof.
  induction f; cbn; intros; try congruence.
    trivial.
    destruct (in_dec Nat.eq_dec n proofs).
      apply find_spec with proofs; auto.
      congruence.
    rewrite andb_true_iff in H0. tauto.
    rewrite orb_true_iff in H0. tauto.
Qed.

Theorem solveFormula_correct :
  forall (env : Env Prop) (f : formula),
    solveFormula env f = true -> formulaDenote env f.
Proof.
  intros. destruct f; cbn in *; try congruence.
    trivial.
    rewrite andb_true_iff in H. destruct H.
      split; eapply solveGoal_correct; eauto.
    rewrite orb_true_iff in H. destruct H.
      left. eapply solveGoal_correct; eauto.
      right. eapply solveGoal_correct; eauto.
Qed.

Ltac allVarsFormula xs P :=
match P with
    | ~ ?P' => allVarsFormula xs P'
    | ?P1 /\ ?P2 =>
        let xs' := allVarsFormula xs P2 in allVarsFormula xs' P1
    | ?P1 \/ ?P2 =>
        let xs' := allVarsFormula xs P2 in allVarsFormula xs' P1
    | ?P1 -> ?P2 =>
        let xs' := allVarsFormula xs P2 in allVarsFormula xs' P1
    | ?P1 <-> ?P2 =>
        let xs' := allVarsFormula xs P2 in allVarsFormula xs' P1
    | _ => addToList P xs
end.

Ltac reifyFormula xs P :=
match P with
    | False => constr:(fFalse)
    | True => constr:(fTrue)
    | ~ ?P' =>
        let e := reifyFormula xs P' in constr:(fImpl e fFalse)
    | ?P1 /\ ?P2 =>
        let e1 := reifyFormula xs P1 in
        let e2 := reifyFormula xs P2 in constr:(fAnd e1 e2)
    | ?P1 \/ ?P2 =>
        let e1 := reifyFormula xs P1 in
        let e2 := reifyFormula xs P2 in constr:(fOr e1 e2)
    | ?P1 -> ?P2 =>
        let e1 := reifyFormula xs P1 in
        let e2 := reifyFormula xs P2 in constr:(fImpl e1 e2)
    | ?P1 <-> ?P2 =>
        let e1 := reifyFormula xs P1 in
        let e2 := reifyFormula xs P2 in
          constr:(fAnd (fImpl e1 e2) (fImpl e2 e1))
    | _ =>
        let i := lookup P xs in constr:(fVar i)
end.

Ltac reflectFormula :=
match goal with
    |- ?P =>
        let xs := allVarsFormula constr:(@nil Prop) P in
        let f := reifyFormula xs P in
          change (formulaDenote xs f);
          rewrite <- simplifyFormula_correct; cbn
end.

Ltac solveGoal :=
match goal with
    |- ?P =>
        let xs := allVarsFormula constr:(@nil Prop) P in
        let f := reifyFormula xs P in change (formulaDenote xs f);
          rewrite <- simplifyFormula_correct;
          apply solveFormula_correct; cbn; reflexivity
end.


Section PropositionLanguage.

Context { atom : Type }.

Inductive prop : Type :=
| atom_prop : atom -> prop
| bot_prop : prop
| top_prop : prop
| and_prop : prop -> prop -> prop
| or_prop : prop -> prop -> prop
| impl_prop : prop -> prop -> prop.

Definition not_prop (P : prop) :=
  impl_prop P bot_prop.

End PropositionLanguage.

Arguments prop atom : clear implicits.

Notation "⊥" := bot_prop.
Notation "⊤" := top_prop.
Notation "¬ P" := (not_prop P) (at level 51).
Infix "∧" := and_prop (left associativity, at level 52).
Infix "∨" := or_prop (left associativity, at level 53).
Infix "⊃" := impl_prop (right associativity, at level 54).


(** 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.

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


Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrbool eqtype ssrnat seq fintype ssrfun tuple finset.
From Bits
     Require Import bits.
Require Import spec.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Set complement  *)
Definition compl n (bs: BITS n): BITS n := invB bs.

Lemma compl_repr n (bs: BITS n) E :
  repr bs E -> repr (compl bs) (~: E).
Proof. by move->; apply/setP=> i; rewrite !inE getBit_liftUnOp. Qed.


(** Zhaoguo Wang **)

(** * Poly: Polymorphism and Higher-Order Functions *)

(** In this chapter we continue our development of basic
    concepts of functional programming.  The critical new ideas are
    _polymorphism_ (abstracting functions over the types of the data
    they manipulate) and _higher-order functions_ (treating functions
    as data).
*)

Require Export Lists.

(* ###################################################### *)
(** * Polymorphism *)
(* ###################################################### *)
(** ** Polymorphic Lists *)

(** For the last couple of chapters, we've been working just
    with lists of numbers.  Obviously, interesting programs also need
    to be able to manipulate lists with elements from other types --
    lists of strings, lists of booleans, lists of lists, etc.  We
    _could_ just define a new inductive datatype for each of these,
    for example... *)

Inductive boollist : Type :=
  | bool_nil : boollist
  | bool_cons : bool -> boollist -> boollist.

(** ... but this would quickly become tedious, partly because we
    have to make up different constructor names for each datatype, but
    mostly because we would also need to define new versions of all
    our list manipulating functions ([length], [rev], etc.)  for each
    new datatype definition. *)

(** To avoid all this repetition, Coq supports _polymorphic_
    inductive type definitions.  For example, here is a _polymorphic
    list_ datatype. *)

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

(** This is exactly like the definition of [natlist] from the
    previous chapter, except that the [nat] argument to the [cons]
    constructor has been replaced by an arbitrary type [X], a binding
    for [X] has been added to the header, and the occurrences of
    [natlist] in the types of the constructors have been replaced by
    [list X].  (We can re-use the constructor names [nil] and [cons]
    because the earlier definition of [natlist] was inside of a
    [Module] definition that is now out of scope.) *)

(** What sort of thing is [list] itself?  One good way to think
    about it is that [list] is a _function_ from [Type]s to
    [Inductive] definitions; or, to put it another way, [list] is a
    function from [Type]s to [Type]s.  For any particular type [X],
    the type [list X] is an [Inductive]ly defined set of lists whose
    elements are things of type [X]. *)

(** With this definition, when we use the constructors [nil] and
    [cons] to build lists, we need to tell Coq the type of the
    elements in the lists we are building -- that is, [nil] and [cons]
    are now _polymorphic constructors_.  Observe the types of these
    constructors: *)

Check nil.
(* ===> nil : forall X : Type, list X *)
Check cons.
(* ===> cons : forall X : Type, X -> list X -> list X *)

(** (Side note on notation: In .v files, the "forall" quantifier is
    spelled out in letters.  In the generated HTML files, [forall] is
    usually typeset as the usual mathematical "upside down A," but
    you'll see the spelled-out "forall" in a few places.  This is just
    a quirk of typesetting: there is no difference in meaning. *)

(** The "[forall X]" in these types can be read as an additional
    argument to the constructors that determines the expected types of
    the arguments that follow.  When [nil] and [cons] are used, these
    arguments are supplied in the same way as the others.  For
    example, the list containing [2] and [1] is written like this: *)

Check (cons nat 2 (cons nat 1 (nil nat))).

(** (We've gone back to writing [nil] and [cons] explicitly here
    because we haven't yet defined the [ [] ] and [::] notations for
    the new version of lists.  We'll do that in a bit.) *)

(** We can now go back and make polymorphic (or "generic")
    versions of all the list-processing functions that we wrote
    before.  Here is [length], for example: *)

Fixpoint length (X:Type) (l:list X) : nat :=
  match l with
  | nil      => 0
  | cons h t => S (length X t)
  end.

(** Note that the uses of [nil] and [cons] in [match] patterns
    do not require any type annotations: we already know that the list
    [l] contains elements of type [X], so there's no reason to include
    [X] in the pattern.  (More precisely, the type [X] is a parameter
    of the whole definition of [list], not of the individual
    constructors.  We'll come back to this point later.)

    As with [nil] and [cons], we can use [length] by applying it first
    to a type and then to its list argument: *)

Example test_length1 :
    length nat (cons nat 1 (cons nat 2 (nil nat))) = 2.
Proof. reflexivity.  Qed.

(** To use our length with other kinds of lists, we simply
    instantiate it with an appropriate type parameter: *)

Example test_length2 :
    length bool (cons bool true (nil bool)) = 1.
Proof. reflexivity.  Qed.

(** Let's close this subsection by re-implementing a few other
    standard list functions on our new polymorphic lists: *)

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

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

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

Example test_rev1 :
    rev nat (cons nat 1 (cons nat 2 (nil nat)))
  = (cons nat 2 (cons nat 1 (nil nat))).
Proof. reflexivity.  Qed.

Example test_rev2:
  rev bool (nil bool) = nil bool.
Proof. reflexivity.  Qed.

Module MumbleBaz.
(** **** Exercise: 2 stars (mumble_grumble) *)
(** Consider the following two inductively defined types. *)

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

(** Which of the following are well-typed elements of [grumble X] for
    some type [X]?
      - [d (b a 5)]
      - [d mumble (b a 5)]
      - [d bool (b a 5)]
      - [e bool true]
      - [e mumble (b c 0)]
      - [e bool (b c 0)]
      - [c]
(*
[d mumble (b a 5)]
[d bool (b a 5)]
[e bool true]
[e mumble (b c 0)]
[c]
*)
**)

(** **** Exercise: 2 stars (baz_num_elts) *)
(** Consider the following inductive definition: *)

Inductive baz : Type :=
   | x : baz -> baz
   | y : baz -> bool -> baz.

(** How _many_ elements does the type [baz] have? *)
(** 0. none of them is base type.**)

End MumbleBaz.

(* ###################################################### *)
(** *** Type Annotation Inference *)

(** Let's write the definition of [app] again, but this time we won't
    specify the types of any of the arguments. Will Coq still accept
    it? *)

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

(** Indeed it will.  Let's see what type Coq has assigned to [app']: *)

Check app'.
(* ===> forall X : Type, list X -> list X -> list X *)
Check app.
(* ===> forall X : Type, list X -> list X -> list X *)

(** It has exactly the same type type as [app].  Coq was able to
    use a process called _type inference_ to deduce what the types of
    [X], [l1], and [l2] must be, based on how they are used.  For
    example, since [X] is used as an argument to [cons], it must be a
    [Type], since [cons] expects a [Type] as its first argument;
    matching [l1] with [nil] and [cons] means it must be a [list]; and
    so on.

    This powerful facility means we don't always have to write
    explicit type annotations everywhere, although explicit type
    annotations are still quite useful as documentation and sanity
    checks.  You should try to find a balance in your own code between
    too many type annotations (so many that they clutter and distract)
    and too few (which forces readers to perform type inference in
    their heads in order to understand your code). *)

(* ###################################################### *)
(** *** Type Argument Synthesis *)

(** Whenever we use a polymorphic function, we need to pass it
    one or more types in addition to its other arguments.  For
    example, the recursive call in the body of the [length] function
    above must pass along the type [X].  But just like providing
    explicit type annotations everywhere, this is heavy and verbose.
    Since the second argument to [length] is a list of [X]s, it seems
    entirely obvious that the first argument can only be [X] -- why
    should we have to write it explicitly?

    Fortunately, Coq permits us to avoid this kind of redundancy.  In
    place of any type argument we can write the "implicit argument"
    [_], which can be read as "Please figure out for yourself what
    type belongs here."  More precisely, when Coq encounters a [_], it
    will attempt to _unify_ all locally available information -- the
    type of the function being applied, the types of the other
    arguments, and the type expected by the context in which the
    application appears -- to determine what concrete type should
    replace the [_].

    This may sound similar to type annotation inference -- and,
    indeed, the two procedures rely on the same underlying mechanisms.
    Instead of simply omitting the types of some arguments to a
    function, like
      app' X l1 l2 : list X :=
    we can also replace the types with [_], like
      app' (X : _) (l1 l2 : _) : list X :=
    which tells Coq to attempt to infer the missing information, just
    as with argument synthesis.

    Using implicit arguments, the [length] function can be written
    like this: *)

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

(** In this instance, we don't save much by writing [_] instead of
    [X].  But in many cases the difference can be significant.  For
    example, suppose we want to write down a list containing the
    numbers [1], [2], and [3].  Instead of writing this... *)

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

(** ...we can use argument synthesis to write this: *)

Definition list123' := cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

(* ###################################################### *)
(** *** Implicit Arguments *)

(** If fact, we can go further.  To avoid having to sprinkle [_]'s
    throughout our programs, we can tell Coq _always_ to infer the
    type argument(s) of a given function. *)

Implicit Arguments nil [[X]].
Implicit Arguments cons [[X]].
Implicit Arguments length [[X]].
Implicit Arguments app [[X]].
Implicit Arguments rev [[X]].
Implicit Arguments snoc [[X]].

(* note: no _ arguments required... *)
Definition list123'' := cons 1 (cons 2 (cons 3 nil)).
Check (length list123'').

(** Alternatively, we can declare an argument to be implicit while
    defining the function itself, by surrounding the argument in curly
    braces.  For example: *)

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

(** (Note that we didn't even have to provide a type argument to
    the recursive call to [length''].)  We will use this style
    whenever possible, although we will continue to use use explicit
    [Implicit Argument] declarations for [Inductive] constructors. *)

(** One small problem with declaring arguments [Implicit] is
    that, occasionally, Coq does not have enough local information to
    determine a type argument; in such cases, we need to tell Coq that
    we want to give the argument explicitly this time, even though
    we've globally declared it to be [Implicit].  For example, suppose we
    write this: *)

(* Definition mynil := nil. *)

(** If we uncomment this definition, Coq will give us an error,
    because it doesn't know what type argument to supply to [nil].  We
    can help it by providing an explicit type declaration (so that Coq
    has more information available when it gets to the "application"
    of [nil]): *)

Definition mynil : list nat := nil.

(** Alternatively, we can force the implicit arguments to be explicit by
   prefixing the function name with [@]. *)

Check @nil.

Definition mynil' := @nil nat.

(** Using argument synthesis and implicit arguments, we can
    define convenient notation for lists, as before.  Since we have
    made the constructor type arguments implicit, Coq will know to
    automatically infer these when we use the notations. *)

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

(** Now lists can be written just the way we'd hope: *)

Definition list123''' := [1, 2, 3].

(* ###################################################### *)
(** *** Exercises: Polymorphic Lists *)

(** **** Exercise: 2 stars, optional (poly_exercises) *)
(** Here are a few simple exercises, just like ones in the [Lists]
    chapter, for practice with polymorphism.  Fill in the definitions
    and complete the proofs below. *)

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

Example test_repeat1:
  repeat bool true 2 = cons true (cons true nil).
 Proof. reflexivity. Qed.

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

Theorem rev_snoc : forall X : Type,
                     forall v : X,
                     forall s : list X,
  rev (snoc s v) = v :: (rev s).
Proof.
  intros X v s.
  induction s.
  reflexivity.
  simpl.
  rewrite -> IHs.
  reflexivity.
  Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros X l.
  induction l.
  Case "l = nil".
  reflexivity.
  Case "l = cons".
  simpl.
  rewrite -> rev_snoc.
  rewrite -> IHl.
  reflexivity.
  Qed.

Theorem snoc_with_append : forall X : Type,
                         forall l1 l2 : list X,
                         forall v : X,
  snoc (l1 ++ l2) v = l1 ++ (snoc l2 v).
Proof.
  induction l1.
  reflexivity.
  intros.
  simpl.
  rewrite IHl1.
  reflexivity.
  Qed.

(* ###################################################### *)
(** ** Polymorphic Pairs *)

(** Following the same pattern, the type definition we gave in
    the last chapter for pairs of numbers can be generalized to
    _polymorphic pairs_ (or _products_): *)

Inductive prod (X Y : Type) : Type :=
  pair : X -> Y -> prod X Y.

Implicit Arguments pair [[X] [Y]].

(** As with lists, we make the type arguments implicit and define the
    familiar concrete notation. *)

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

(** We can also use the [Notation] mechanism to define the standard
    notation for pair _types_: *)

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

(** (The annotation [: type_scope] tells Coq that this abbreviation
    should be used when parsing types.  This avoids a clash with the
    multiplication symbol.) *)

(** A note of caution: it is easy at first to get [(x,y)] and
    [X*Y] confused.  Remember that [(x,y)] is a _value_ built from two
    other values; [X*Y] is a _type_ built from two other types.  If
    [x] has type [X] and [y] has type [Y], then [(x,y)] has type
    [X*Y]. *)

(** The first and second projection functions now look pretty
    much as they would in any functional programming language. *)

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

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

(** The following function takes two lists and combines them
    into a list of pairs.  In many functional programming languages,
    it is called [zip].  We call it [combine] for consistency with
    Coq's standard library. *)
(** Note that the pair notation can be used both in expressions and in
    patterns... *)

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

(** **** Exercise: 1 star, optional (combine_checks) *)
(** Try answering the following questions on paper and
    checking your answers in coq:
    - What is the type of [combine] (i.e., what does [Check
      @combine] print?)
    - What does
        Eval simpl in (combine [1,2] [false,false,true,true]).
      print?   []
*)

Check @combine.
(*Warning: query commands should not be inserted in scripts
combine
     : forall X Y : Type, list X -> list Y -> list (X * Y)*)

Eval simpl in (combine [1,2] [false,false,true,true]).
(*Warning: query commands should not be inserted in scripts
     = [(1, false), (2, false)]
     : list (nat * bool)*)

(** **** Exercise: 2 stars (split) *)
(** The function [split] is the right inverse of combine: it takes a
    list of pairs and returns a pair of lists.  In many functional
    programing languages, this function is called [unzip].

    Uncomment the material below and fill in the definition of
    [split].  Make sure it passes the given unit tests. *)

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

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

(** (If you're reading the HTML version of this file, note that
    there's an unresolved typesetting problem in the example: several
    square brackets are missing.  Refer to the .v file for the correct
    version. *)
(** [] *)

(* ###################################################### *)
(** ** Polymorphic Options *)

(** One last polymorphic type for now: _polymorphic options_.
    The type declaration generalizes the one for [natoption] in the
    previous chapter: *)

Inductive option (X:Type) : Type :=
  | Some : X -> option X
  | None : option X.

Implicit Arguments Some [[X]].
Implicit Arguments None [[X]].

(** We can now rewrite the [index] function so that it works
    with any type of lists. *)

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

Example test_index1 :    index 0 [4,5,6,7]  = Some 4.
Proof. reflexivity.  Qed.
Example test_index2 :    index  1 [[1],[2]]  = Some [2].
Proof. reflexivity.  Qed.
Example test_index3 :    index  2 [true]  = None.
Proof. reflexivity.  Qed.

(** **** Exercise: 1 star, optional (hd_opt_poly) *)
(** Complete the definition of a polymorphic version of the
    [hd_opt] function from the last chapter. Be sure that it
    passes the unit tests below. *)

Definition hd_opt {X : Type} (l : list X)  : option X :=
  (* FILL IN HERE *) admit.

(** Once again, to force the implicit arguments to be explicit,
    we can use [@] before the name of the function. *)

Check @hd_opt.

Example test_hd_opt1 :  hd_opt [1,2] = Some 1.
 (* FILL IN HERE *) Admitted.
Example test_hd_opt2 :   hd_opt  [[1],[2]]  = Some [1].
 (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################### *)
(** * Functions as Data *)
(* ###################################################### *)
(** ** Higher-Order Functions *)

(** Like many other modern programming languages -- including
    all _functional languages_ (ML, Haskell, Scheme, etc.) -- Coq
    treats functions as first-class citizens, allowing functions to be
    passed as arguments to other functions, returned as results,
    stored in data structures, etc.

    Functions that manipulate other functions are often called
    _higher-order_ functions.  Here's a simple one: *)

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

(** The argument [f] here is itself a function (from [X] to
    [X]); the body of [doit3times] applies [f] three times to some
    value [n]. *)

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

Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity.  Qed.

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

(* ###################################################### *)
(** ** Partial Application *)

(** In fact, the multiple-argument functions we have already
    seen are also examples of passing functions as data.  To see why,
    recall the type of [plus]. *)

Check plus.
(* ==> nat -> nat -> nat *)

(** Each [->] in this expression is actually a _binary_ operator
    on types.  (This is the same as saying that Coq primitively
    supports only one-argument functions -- do you see why?)  This
    operator is _right-associative_, so the type of [plus] is really a
    shorthand for [nat -> (nat -> nat)] -- i.e., it can be read as
    saying that "[plus] is a one-argument function that takes a [nat]
    and returns a one-argument function that takes another [nat] and
    returns a [nat]."  In the examples above, we have always applied
    [plus] to both of its arguments at once, but if we like we can
    supply just the first.  This is called _partial application_. *)

Definition plus3 := plus 3.
Check plus3.

Example test_plus3 :    plus3 4 = 7.
Proof. reflexivity.  Qed.
Example test_plus3' :   doit3times plus3 0 = 9.
Proof. reflexivity.  Qed.
Example test_plus3'' :  doit3times (plus 3) 0 = 9.
Proof. reflexivity.  Qed.

(* ###################################################### *)
(** ** Digression: Currying *)

(** **** Exercise: 2 stars, advanced (currying) *)
(** In Coq, a function [f : A -> B -> C] really has the type [A
    -> (B -> C)].  That is, if you give [f] a value of type [A], it
    will give you function [f' : B -> C].  If you then give [f'] a
    value of type [B], it will return a value of type [C].  This
    allows for partial application, as in [plus3].  Processing a list
    of arguments with functions that return functions is called
    _currying_, in honor of the logician Haskell Curry.

    Conversely, we can reinterpret the type [A -> B -> C] as [(A *
    B) -> C].  This is called _uncurrying_.  With an uncurried binary
    function, both arguments must be given at once as a pair; there is
    no partial application. *)

(** We can define currying as follows: *)

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

(** As an exercise, define its inverse, [prod_uncurry].  Then prove
    the theorems below to show that the two are inverses. *)

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z :=
  (* FILL IN HERE *) admit.

(** (Thought exercise: before running these commands, can you
    calculate the types of [prod_curry] and [prod_uncurry]?) *)

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type) (f : X -> Y -> Z) x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem curry_uncurry : forall (X Y Z : Type)
                               (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################### *)
(** ** Filter *)

(** Here is a useful higher-order function, which takes a list
    of [X]s and a _predicate_ on [X] (a function from [X] to [bool])
    and "filters" the list, returning a new list containing just those
    elements for which the predicate returns [true]. *)

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

(** For example, if we apply [filter] to the predicate [evenb]
    and a list of numbers [l], it returns a list containing just the
    even members of [l]. *)

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

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

Example test_filter2:
    filter length_is_1
           [ [1, 2], [3], [4], [5,6,7], [], [8] ]
  = [ [3], [4], [8] ].
Proof. reflexivity.  Qed.

(** We can use [filter] to give a concise version of the
    [countoddmembers] function from the [Lists] chapter. *)

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

Example test_countoddmembers'1:   countoddmembers' [1,0,3,1,4,5] = 4.
Proof. reflexivity.  Qed.
Example test_countoddmembers'2:   countoddmembers' [0,2,4] = 0.
Proof. reflexivity.  Qed.
Example test_countoddmembers'3:   countoddmembers' nil = 0.
Proof. reflexivity.  Qed.

(* ###################################################### *)
(** ** Anonymous Functions *)

(** It is a little annoying to be forced to define the function
    [length_is_1] and give it a name just to be able to pass it as an
    argument to [filter], since we will probably never use it again.
    Moreover, this is not an isolated example.  When using
    higher-order functions, we often want to pass as arguments
    "one-off" functions that we will never use again; having to give
    each of these functions a name would be tedious.

    Fortunately, there is a better way. It is also possible to
    construct a function "on the fly" without declaring it at the top
    level or giving it a name; this is analogous to the notation we've
    been using for writing down constant lists, natural numbers, and
    so on. *)

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

(** Here is the motivating example from before, rewritten to use
    an anonymous function. *)

Example test_filter2':
    filter (fun l => beq_nat (length l) 1)
           [ [1, 2], [3], [4], [5,6,7], [], [8] ]
  = [ [3], [4], [8] ].
Proof. reflexivity.  Qed.

(** **** Exercise: 2 stars (filter_even_gt7) *)

(** Use [filter] (instead of [Fixpoint]) to write a Coq function
    [filter_even_gt7] that takes a list of natural numbers as input
    and returns a list of just those that are even and greater than
    7. *)

Definition filter_even_gt7 (l : list nat) : list nat :=
  (* FILL IN HERE *) admit.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1,2,6,9,10,3,12,8] = [10,12,8].
 (* FILL IN HERE *) Admitted.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5,2,6,19,129] = [].
 (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (partition) *)
(** Use [filter] to write a Coq function [partition]:
  partition : forall X : Type,
              (X -> bool) -> list X -> list X * list X
   Given a set [X], a test function of type [X -> bool] and a [list
   X], [partition] should return a pair of lists.  The first member of
   the pair is the sublist of the original list containing the
   elements that satisfy the test, and the second is the sublist
   containing those that fail the test.  The order of elements in the
   two sublists should be the same as their order in the original
   list.
*)

Definition partition {X : Type} (test : X -> bool) (l : list X)
                     : list X * list X :=
(* FILL IN HERE *) admit.

Example test_partition1: partition oddb [1,2,3,4,5] = ([1,3,5], [2,4]).
(* FILL IN HERE *) Admitted.
Example test_partition2: partition (fun x => false) [5,9,0] = ([], [5,9,0]).
(* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################### *)
(** ** Map *)

(** Another handy higher-order function is called [map]. *)

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

(** It takes a function [f] and a list [ l = [n1, n2, n3, ...] ]
    and returns the list [ [f n1, f n2, f n3,...] ], where [f] has
    been applied to each element of [l] in turn.  For example: *)

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

(** The element types of the input and output lists need not be
    the same ([map] takes _two_ type arguments, [X] and [Y]).  This
    version of [map] can thus be applied to a list of numbers and a
    function from numbers to booleans to yield a list of booleans: *)

Example test_map2: map oddb [2,1,2,5] = [false,true,false,true].
Proof. reflexivity.  Qed.

(** It can even be applied to a list of numbers and
    a function from numbers to _lists_ of booleans to
    yield a list of lists of booleans: *)

Example test_map3:
    map (fun n => [evenb n,oddb n]) [2,1,2,5]
  = [[true,false],[false,true],[true,false],[false,true]].
Proof. reflexivity.  Qed.

(** **** Exercise: 3 stars (map_rev) *)
(** Show that [map] and [rev] commute.  You may need to define an
    auxiliary lemma. *)

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (flat_map) *)
(** The function [map] maps a [list X] to a [list Y] using a function
    of type [X -> Y].  We can define a similar function, [flat_map],
    which maps a [list X] to a [list Y] using a function [f] of type
    [X -> list Y].  Your definition should work by 'flattening' the
    results of [f], like so:
        flat_map (fun n => [n,n+1,n+2]) [1,5,10]
      = [1, 2, 3, 5, 6, 7, 10, 11, 12].
*)

Fixpoint flat_map {X Y:Type} (f:X -> list Y) (l:list X)
                   : (list Y) :=
  (* FILL IN HERE *) admit.

Example test_flat_map1:
  flat_map (fun n => [n,n,n]) [1,5,4]
  = [1, 1, 1, 5, 5, 5, 4, 4, 4].
 (* FILL IN HERE *) Admitted.
(** [] *)

(** Lists are not the only inductive type that we can write a
    [map] function for.  Here is the definition of [map] for the
    [option] type: *)

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

(** **** Exercise: 2 stars, optional (implicit_args) *)
(** The definitions and uses of [filter] and [map] use implicit
    arguments in many places.  Replace the curly braces around the
    implicit arguments with parentheses, and then fill in explicit
    type parameters where necessary and use Coq to check that you've
    done so correctly.  (This exercise is not to be turned in; it is
    probably easiest to do it on a _copy_ of this file that you can
    throw away afterwards.)  [] *)

(* ###################################################### *)
(** ** Fold *)

(** An even more powerful higher-order function is called
    [fold].  This function is the inspiration for the "[reduce]"
    operation that lies at the heart of Google's map/reduce
    distributed programming framework. *)

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

(* /TERSE *)

(** Intuitively, the behavior of the [fold] operation is to
    insert a given binary operator [f] between every pair of elements
    in a given list.  For example, [ fold plus [1,2,3,4] ] intuitively
    means [1+2+3+4].  To make this precise, we also need a "starting
    element" that serves as the initial second input to [f].  So, for
    example,
   fold plus [1,2,3,4] 0
    yields
   1 + (2 + (3 + (4 + 0))).
    Here are some more examples:
*)

Check (fold andb).
(* ===> fold andb : list bool -> bool -> bool *)

Example fold_example1 : fold mult [1,2,3,4] 1 = 24.
Proof. reflexivity. Qed.

Example fold_example2 : fold andb [true,true,false,true] true = false.
Proof. reflexivity. Qed.

Example fold_example3 : fold app  [[1],[],[2,3],[4]] [] = [1,2,3,4].
Proof. reflexivity. Qed.

(** **** Exercise: 1 star, advanced (fold_types_different) *)
(** Observe that the type of [fold] is parameterized by _two_ type
    variables, [X] and [Y], and the parameter [f] is a binary operator
    that takes an [X] and a [Y] and returns a [Y].  Can you think of a
    situation where it would be useful for [X] and [Y] to be
    different? *)

(* ###################################################### *)
(** ** Functions For Constructing Functions *)

(** Most of the higher-order functions we have talked about so
    far take functions as _arguments_.  Now let's look at some
    examples involving _returning_ functions as the results of other
    functions.

    To begin, here is a function that takes a value [x] (drawn from
    some type [X]) and returns a function from [nat] to [X] that
    yields [x] whenever it is called, ignoring its [nat] argument. *)

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

Definition ftrue := constfun true.

Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.

Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

(** Similarly, but a bit more interestingly, here is a function
    that takes a function [f] from numbers to some type [X], a number
    [k], and a value [x], and constructs a function that behaves
    exactly like [f] except that, when called with the argument [k],
    it returns [x]. *)

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

(** For example, we can apply [override] twice to obtain a
    function from numbers to booleans that returns [false] on [1] and
    [3] and returns [true] on all other arguments. *)

Definition fmostlytrue := override (override ftrue 1 false) 3 false.

Example override_example1 : fmostlytrue 0 = true.
Proof. reflexivity. Qed.

Example override_example2 : fmostlytrue 1 = false.
Proof. reflexivity. Qed.

Example override_example3 : fmostlytrue 2 = true.
Proof. reflexivity. Qed.

Example override_example4 : fmostlytrue 3 = false.
Proof. reflexivity. Qed.

(** **** Exercise: 1 star (override_example) *)
(** Before starting to work on the following proof, make sure you
    understand exactly what the theorem is saying and can paraphrase
    it in your own words.  The proof itself is straightforward. *)

Theorem override_example : forall (b:bool),
  (override (constfun b) 3 true) 2 = b.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** We'll use function overriding heavily in parts of the rest of the
    course, and we will end up needing to know quite a bit about its
    properties.  To prove these properties, though, we need to know
    about a few more of Coq's tactics; developing these is the main
    topic of the next chapter.  For now, though, let's introduce just
    one very useful tactic that will also help us with proving
    properties of some of the other functions we have introduced in
    this chapter. *)

(* ###################################################### *)
(** * The [unfold] Tactic *)

(** Sometimes, a proof will get stuck because Coq doesn't
    automatically expand a function call into its definition.  (This
    is a feature, not a bug: if Coq automatically expanded everything
    possible, our proof goals would quickly become enormous -- hard to
    read and slow for Coq to manipulate!) *)

Theorem unfold_example_bad : forall m n,
  3 + n = m ->
  plus3 n + 1 = m + 1.
Proof.
  intros m n H.
  (* At this point, we'd like to do [rewrite -> H], since
     [plus3 n] is definitionally equal to [3 + n].  However,
     Coq doesn't automatically expand [plus3 n] to its
     definition. *)
  Admitted.

(** The [unfold] tactic can be used to explicitly replace a
    defined name by the right-hand side of its definition.  *)

Theorem unfold_example : forall m n,
  3 + n = m ->
  plus3 n + 1 = m + 1.
Proof.
  intros m n H.
  unfold plus3.
  rewrite -> H.
  reflexivity.  Qed.

(** Now we can prove a first property of [override]: If we
    override a function at some argument [k] and then look up [k], we
    get back the overridden value. *)

Theorem override_eq : forall {X:Type} x k (f:nat->X),
  (override f k x) k = x.
Proof.
  intros X x k f.
  unfold override.
  rewrite <- beq_nat_refl.
  reflexivity.  Qed.

(** This proof was straightforward, but note that it requires
    [unfold] to expand the definition of [override]. *)

(** **** Exercise: 2 stars (override_neq) *)
Theorem override_neq : forall {X:Type} x1 x2 k1 k2 (f : nat->X),
  f k1 = x1 ->
  beq_nat k2 k1 = false ->
  (override f k2 x2) k1 = x1.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** As the inverse of [unfold], Coq also provides a tactic
    [fold], which can be used to "unexpand" a definition.  It is used
    much less often. *)

(* ##################################################### *)
(** * Additional Exercises *)

(** **** Exercise: 2 stars (fold_length) *)
(** Many common functions on lists can be implemented in terms of
   [fold].  For example, here is an alternate definition of [length]: *)

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

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

(** Prove the correctness of [fold_length]. *)

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (fold_map) *)
(** We can also define [map] in terms of [fold].  Finish [fold_map]
    below. *)

Definition fold_map {X Y:Type} (f : X -> Y) (l : list X) : list Y :=
(* FILL IN HERE *) admit.

(** Write down a theorem in Coq stating that [fold_map] is correct,
    and prove it. *)

(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 2 stars, advanced (index_informal) *)
(** Recall the definition of the [index] function:
   Fixpoint index {X : Type} (n : nat) (l : list X) : option X :=
     match l with
     | [] => None
     | a :: l' => if beq_nat n O then Some a else index (pred n) l'
     end.
   Write an informal proof of the following theorem:
   forall X n l, length l = n -> @index X (S n) l = None.
(* FILL IN HERE *)
*)
(** [] *)

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

Module Church.

(** In this exercise, we will explore an alternative way of defining
    natural numbers, using the so-called _Church numerals_, named
    after mathematician Alonzo Church. We can represent a natural
    number [n] as a function that takes a function [f] as a parameter
    and returns [f] iterated [n] times. More formally, *)

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

(** Let's see how to write some numbers with this notation. Any
    function [f] iterated once shouldn't change. Thus, *)

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

(** [two] should apply [f] twice to its argument: *)

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

(** [zero] is somewhat trickier: how can we apply a function zero
    times? The answer is simple: just leave the argument untouched. *)

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

(** More generally, a number [n] will be written as [fun X f x => f (f
    ... (f x) ...)], with [n] occurrences of [f]. Notice in particular
    how the [doit3times] function we've defined previously is actually
    just the representation of [3]. *)

Definition three : nat := @doit3times.

(** Complete the definitions of the following functions. Make sure
    that the corresponding unit tests pass by proving them with
    [reflexivity]. *)

(** Successor of a natural number *)

Definition succ (n : nat) : nat :=
  (* FILL IN HERE *) admit.

Example succ_1 : succ zero = one.
Proof. (* FILL IN HERE *) Admitted.

Example succ_2 : succ one = two.
Proof. (* FILL IN HERE *) Admitted.

Example succ_3 : succ two = three.
Proof. (* FILL IN HERE *) Admitted.

(** Addition of two natural numbers *)

Definition plus (n m : nat) : nat :=
  (* FILL IN HERE *) admit.

Example plus_1 : plus zero one = one.
Proof. (* FILL IN HERE *) Admitted.

Example plus_2 : plus two three = plus three two.
Proof. (* FILL IN HERE *) Admitted.

Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof. (* FILL IN HERE *) Admitted.

(** Multiplication *)

Definition mult (n m : nat) : nat :=
  (* FILL IN HERE *) admit.

Example mult_1 : mult one one = one.
Proof. (* FILL IN HERE *) Admitted.

Example mult_2 : mult zero (plus three three) = zero.
Proof. (* FILL IN HERE *) Admitted.

Example mult_3 : mult two three = plus three three.
Proof. (* FILL IN HERE *) Admitted.

(** Exponentiation *)

(** Hint: Polymorphism plays a crucial role here. However, choosing
    the right type to iterate over can be tricky. If you hit a
    "Universe inconsistency" error, try iterating over a different
    type: [nat] itself is usually problematic. *)

Definition exp (n m : nat) : nat :=
  (* FILL IN HERE *) admit.

Example exp_1 : exp two two = plus two two.
Proof. (* FILL IN HERE *) Admitted.

Example exp_2 : exp three two = plus (mult two (mult two two)) one.
Proof. (* FILL IN HERE *) Admitted.

Example exp_3 : exp three zero = one.
Proof. (* FILL IN HERE *) Admitted.

End Church.

(** [] *)

(* $Date: 2013-02-06 20:14:06 -0500 (Wed, 06 Feb 2013) $ *)


Require Import bool.
Require Import nat.
Require Import syntax.
Require Import eval.
Require Import state.
Require Import dictionary.
Require Import Imp_code.

Example test_aeval0 : forall (env:State), aeval env (ANum 17) = 17.
Proof. reflexivity. Qed.

Example test_aeval1 : forall (env:State), aeval env (APlus (ANum 2) (ANum 5)) = 7.
Proof. reflexivity. Qed.

Example test_aeval2 : forall (env:State), aeval env (AMinus (ANum 12) (ANum 5)) = 7.
Proof. reflexivity. Qed.

Example test_aeval3 : forall (env:State), aeval env (AMult (ANum 4) (ANum 5)) = 20.
Proof. reflexivity. Qed.

Example test_ceval1 : ceval (
    x ::= ANum 2;;
    IFB BLe (AKey x) (ANum 1)
        THEN y ::= ANum 3
        ELSE z ::= ANum 4
    FI)
    emptyState
    (t_update (t_update emptyState x 2) z 4).
Proof.
    apply E_Seq with (e' := t_update emptyState x 2).
    - apply E_Ass. reflexivity.
    - apply E_IfFalse.
        + reflexivity.
        + apply E_Ass. reflexivity.
Qed.

Theorem test_ceval2 : ceval pup_to_n
    (t_update emptyState x 3)
    (t_update
        (t_update
            (t_update
                (t_update
                    (t_update
                        (t_update
                            (t_update
                                (t_update
                                    emptyState
                                    x 3)  y 0) y 3) x 2) y 5) x 1) y 6) x 0).
Proof.
    remember (t_update emptyState x 3) as e0 eqn:E0.
    remember (t_update e0 y 0) as e1 eqn:E1.
    remember (t_update e1 y 3) as e2 eqn:E2.
    remember (t_update e2 x 2) as e3 eqn:E3.
    remember (t_update e3 y 5) as e4 eqn:E4.
    remember (t_update e4 x 1) as e5 eqn:E5.
    remember (t_update e5 y 6) as e6 eqn:E6.
    remember (t_update e6 x 0) as e7 eqn:E7.
    apply E_Seq with (e':=e1).
        - rewrite E1. apply E_Ass. reflexivity.
        - apply E_WhileLoop with (e':=e3).
            + rewrite E1, E0. reflexivity.
            + apply E_Seq with (e':=e2).
                { rewrite E2. apply E_Ass.
                    rewrite E1, E0. reflexivity. }
                { rewrite E3. apply E_Ass.
                    rewrite E2, E1, E0. reflexivity. }
            + apply E_WhileLoop with (e':=e5).
                { rewrite E3, E2, E1, E0. reflexivity. }
                { rewrite E5. apply E_Seq with (e':=e4).
                    { rewrite E4. apply E_Ass.
                        rewrite E3, E2, E1, E0. reflexivity. }
                    { apply E_Ass.
                        rewrite E4, E3, E2, E1, E0. reflexivity. } }
                { apply E_WhileLoop with (e':=e7).
                    { rewrite E5, E4, E3, E2, E1, E0. reflexivity. }
                    { apply E_Seq with (e':=e6).
                        { rewrite E6. apply E_Ass.
                            rewrite E5, E4, E3, E2, E1, E0. reflexivity. }
                        { rewrite E7. apply E_Ass.
                            rewrite E6, E5, E4, E3, E2, E1, E0. reflexivity. } }
                    { apply E_WhileEnd.
                        rewrite E7, E6, E5, E4, E3, E2, E1, E0. reflexivity. }}
Qed.

Theorem test_ceval3 : forall (e e':State) (n:nat),
    e x = n -> ceval Add2_x e e' -> e' x = n + 2.
Proof.
    intros e e' n H0 H1. unfold Add2_x in H1. inversion H1. subst. simpl.
    unfold t_update. reflexivity.
Qed.

Theorem test_ceval4 : forall (e e':State) (n m:nat),
    e x = n -> e y = m -> ceval Mult_x_y_z e e' -> e' z = n*m.
Proof.
    intros e e' n m Hx Hy H. unfold Mult_x_y_z in H. inversion H. subst.
    simpl. unfold t_update. reflexivity.
Qed.

(* infinite loop never stop *)
Theorem test_ceval5 : forall (e e':State), ~ceval loop e e'.
Proof.
    intros e e' H. unfold loop in H.
    remember (WHILE BTrue DO SKIP END) as c eqn:Hc. revert Hc.
    induction H as
        [e
        |e a n x H0
        |e e' e'' c1 c2 H1 IH1 H2 IH2
        |e e' b c1 c2 H0 H1 IH1
        |e e' b c1 c2 H0 H1 IH1
        |e b c H0
        |e e' e'' b c H0 H1 IH1 H2 IH2
        ].
    - intros H'. inversion H'.
    - intros H'. inversion H'.
    - intros H'. inversion H'.
    - intros H'. inversion H'.
    - intros H'. inversion H'.
    - intros H'. inversion H'. subst. assert (true = false) as E.
        { assumption. } inversion E.
    - intros H'. apply IH2. exact H'.
Qed.


(* efficiency problem related to termination checker in 8.2,
solved in 8.3 *)

Require Import Bool.

(*
La plus grande partie de ce qui suit revient a genere de gros calculs
tout d'abord sur le type Z, puis sur le type word
*)

(* BEGIN calculasse Z, pris essentiellement chez Xavier *)

Definition Nbit := 31%nat.
Definition Zbit := 30%nat.
Definition Cbit := 29%nat.
Definition Vbit := 28%nat.

Require Import ZArith.
Open Scope Z_scope.

Definition wordsize : nat := 32%nat.
Definition modulus : Z := two_power_nat wordsize.
Record int: Type := mkint { intval: Z; intrange: 0 <= intval < modulus }.

Lemma two_power_nat_O : two_power_nat O = 1.
Proof. reflexivity. Qed.

Lemma two_power_nat_pos : forall n : nat, two_power_nat n > 0.
Proof.
  induction n. rewrite two_power_nat_O. omega.
  rewrite two_power_nat_S. omega.
Qed.

Lemma mod_in_range:
  forall x, 0 <= Zmod x modulus < modulus.
Proof.
  intro.
  exact (Z_mod_lt x modulus (two_power_nat_pos wordsize)).
Qed.
Definition repr (x: Z) : int :=
  mkint (Zmod x modulus) (mod_in_range x).

Definition unsigned (n: int) : Z := intval n.
Definition Z_bin_decomp (x: Z) : bool * Z :=
  match x with
  | Z0 => (false, 0)
  | Zpos p =>
      match p with
      | xI q => (true, Zpos q)
      | xO q => (false, Zpos q)
      | xH => (true, 0)
      end
  | Zneg p =>
      match p with
      | xI q => (true, Zneg q - 1)
      | xO q => (false, Zneg q)
      | xH => (true, -1)
      end
  end.
Definition zeq: forall (x y: Z), {x = y} + {x <> y} := Z_eq_dec.

Fixpoint bits_of_Z (n: nat) (x: Z) {struct n}: Z -> bool :=
  match n with
  | O =>
      (fun i: Z => false)
  | S m =>
      let (b, y) := Z_bin_decomp x in
      let f := bits_of_Z m y in
      (fun i: Z => if zeq i 0 then b else f (i - 1))
  end.

Definition Z_shift_add (b: bool) (x: Z) :=
  if b then 2 * x + 1 else 2 * x.

Fixpoint Z_of_bits (n: nat) (f: Z -> bool) {struct n}: Z :=
  match n with
  | O => 0
  | S m => Z_shift_add (f 0) (Z_of_bits m (fun i => f (i + 1)))
  end.

Definition bitwise_binop (f: bool -> bool -> bool) (x y: int) :=
  let fx := bits_of_Z wordsize (unsigned x) in
  let fy := bits_of_Z wordsize (unsigned y) in
  repr (Z_of_bits wordsize (fun i => f (fx i) (fy i))).

Definition and (x y: int): int := bitwise_binop andb x y.

(* END calculasse Z *)

(* BEGIN calculasse word *)

Notation word := int.
Coercion intval : word >-> Z.

Fixpoint masks_aux (n k : nat) : Z :=
  match k with
    | O => two_power_nat n
    | S k' => two_power_nat n + masks_aux (S n) k'
  end.
Definition masks (n p : nat) : word := repr (masks_aux n (p-n)).

Definition bits (k l : nat) (w : word) : word := and (masks k l) w.
Definition bits_val (k l : nat) (w : word) : Z :=
  bits k l w / two_power_nat k.

Definition mask (n : nat) : word := repr (two_power_nat n).
Definition bit (k : nat) (w : word) : word := and (mask k) w.
Definition zne (x y : Z) : bool := if Z_eq_dec x y then false else true.
Definition is_set (k : nat) (w : word) : bool := zne (bit k w) 0.

(* *)

Definition FConditionPassed (w : word) : bool :=
  match bits_val 28 31 w with
    | (*0000*) 0 => (* Z set *) is_set Zbit w
    | (*0001*) 1 => (* Z clear *) negb (is_set Zbit w)
    | (*0010*) 2 => (* C set *) is_set Cbit w
    | (*0011*) 3 => (* C clear *) negb (is_set Cbit w)
    | (*0100*) 4 => (* N set *) is_set Cbit w
    | (*0101*) 5 => (* N clear *) negb (is_set Cbit w)
    | (*0110*) 6 => (* V set *) is_set Vbit w
    | (*0111*) 7 => (* V clear *) negb (is_set Vbit w)
    | (*1000*) 8 => (* C set and Z clear *)
      andb (is_set Cbit w) (negb (is_set Zbit w))
    | (*1001*) 9 => (* C clear or Z set *)
      orb (negb (is_set Cbit w)) (is_set Zbit w)
    | (*1010*) 10 => (* N set and V set, or N clear and V clear (N==V) *)
      eqb (is_set Nbit w) (is_set Vbit w)
    | (*1011*) 11 => (* N set and V clear, or N clear and V set (N!=V) *)
      negb (eqb (is_set Nbit w) (is_set Vbit w))
    | (*1100*) 12 => (* Z clear, and either N set and V set,
         or N clear and V clear (Z==0,N==V) *)
      andb (negb (is_set Zbit w)) (eqb (is_set Nbit w) (is_set Vbit w))
    | (*1101*) 13 => (* Z set, or N set and V clear, or N clear and V set
         (Z==1 or N!=V) *)
      orb (is_set Zbit w) (negb (eqb (is_set Nbit w) (is_set Vbit w)))
    | _ => true
  end.

(* END calculasse word *)

(*
Point fixe dont le type checking pedale dans le yaourt.
Si on enleve des cas dans [FConditionPassed] ci-dessus,
ca pedale d'autant moins.
On ne voit pas pourquoi [FConditionPassed w] est examine
dans la def de pt fixe.
*)
Inductive inst : Type :=
| Unpredictable
| IfThen (i : inst)
.

Fixpoint interp (w : word) (i : inst) : option bool :=
  match i with
    | Unpredictable => None
    | IfThen i =>
      if FConditionPassed w then interp w i else None
  end.