(* two_by_two_matrices.v *)
(* dIFP 2014-2015, Q1 *)
(* Teacher: Olivier Danvy <danvy@cs.au.dk> *)

(* Student name: ... *)
(* Student number: ... *)

(* ********** *)

(* The goal of this project is to study 2x2 matrices,
   along the lines of Section 5 of
     http://users-cs.au.dk/danvy/dProgSprog12/Supplementary-material/more-about-induction-proofs.pdf
*)

Require Import Arith.
Require Import unfold_tactic.

Lemma unfold_plus_bc :
  forall j : nat,
    plus 0 j = j.
Proof.
  unfold_tactic plus.
Qed.

Lemma unfold_plus_ic :
  forall i' j : nat,
    plus (S i') j = S (plus i' j).
Proof.
  unfold_tactic plus.
Qed.

Proposition plus_1_S :
  forall n : nat,
    S n = plus 1 n.
Proof.
  intro n.
  induction n as [ | n' IHn'].
    rewrite -> (plus_0_r 1).
    reflexivity.

    rewrite -> (unfold_plus_ic).
    rewrite -> (plus_0_l (S n')).
    reflexivity.
Qed.

Inductive m22 : Type :=
| M22 : nat -> nat -> nat -> nat -> m22.

Definition matr1 := (M22 1 2 3 4).
Definition matr2 := (M22 2 3 4 5).

Definition nine (m1 m2 : m22) : m22 :=
  match m1 with
    | (M22 x1 x2 x3 x4) => match m2 with
        | (M22 y1 y2 y3 y4) => (M22 (x1*y1 + x2*y3) (x1*y2 + x2*y4) (x3*y1 + x4*y3) (x3*y2 + x4*y4))
     end
  end.

Definition ninetwo (m1 m2 : m22) : m22 :=
  match m1,m2 with
      | (M22 x1 x2 x3 x4), (M22 y1 y2 y3 y4) => M22 (x1*y1 + x2*y3) (x1*y2 + x2*y4) (x3*y1 + x4*y3) (x3*y2 + x4*y4)
  end.

Lemma matrix_helper :
  forall (x1 x2 x3 x4 y1 y2 y3 y4 : nat),
    nine (M22 x1 x2 x3 x4) (M22 y1 y2 y3 y4) = M22 (x1*y1 + x2*y3) (x1*y2 + x2*y4) (x3*y1 + x4*y3) (x3*y2 + x4*y4).
Proof.
  intros x1 x2 x3 x4 y1 y2 y3 y4.
  unfold nine.
  reflexivity.
Qed.

Compute ninetwo matr1 matr2.

Compute nine matr1 matr2.

Definition identity : m22 := (M22 1 0 0 1).

Compute ninetwo identity identity.

Fixpoint exp (m : m22) (n : nat) : m22 :=
  match n with
    | 0 => identity
    | S n' => nine (exp m n') m
end.

Lemma unfold_exp_base_case :
  forall m : m22,
    exp m 0 = identity.
Proof.
  unfold_tactic exp.
Qed.

Lemma unfold_exp_induction_case :
  forall (m : m22) (n : nat),
    exp m (S n) = nine (exp m n) m.
Proof.
  unfold_tactic exp.
Qed.

Compute exp identity 4.

Lemma matrix_comm_help :
  forall n1 n2 n3 n4 n5 n6 n7 n8 : nat,
    n1 * (n2 * n3 + n4 * n5) + n6 * (n7 * n3 + n8 * n5) = (n1 * n2 + n6 * n7) * n3 + (n1 * n4 + n6 * n8) * n5.
Proof.
  intros n1 n2 n3 n4 n5 n6 n7 n8.
  ring.
Qed.

Lemma matrices_are_communative :
  forall (m1 m2 m3 : m22),
    nine m1 (nine m2 m3) = nine (nine m1 m2) m3.
Proof.
  intros m1 m2 m3.
  induction m1,m2,m3 as [ ].
  rewrite ->4 matrix_helper.
  rewrite -> (matrix_comm_help n n3 n7 n4 n9 n0 n5 n6).
  rewrite -> (matrix_comm_help n n3 n8 n4 n10 n0 n5 n6).
  rewrite -> (matrix_comm_help n1 n3 n7 n4 n9 n2 n5 n6).
  rewrite -> (matrix_comm_help n1 n3 n8 n4 n10 n2 n5 n6).
  reflexivity.
Qed.

Lemma identity_matrix_is_netrual_l :
  forall m : m22,
    nine identity m = m.
Proof.
  intros [x1 x2 x3 x4].
  unfold identity.
  unfold nine.
  rewrite ->4 (mult_1_l).
  rewrite ->4 (mult_0_l).
  rewrite ->2 (plus_0_r).
  rewrite ->2 (plus_0_l).
  reflexivity.
Qed.

Lemma identity_matrix_is_netrual_r :
  forall m : m22,
    nine m identity = m.
Proof.
  intro m.
  induction m as [ ].
  unfold identity.
  unfold nine.
  rewrite ->4 (mult_1_r).
  rewrite ->4 (mult_0_r).
  rewrite ->2 (plus_0_l).
  rewrite ->2 (plus_0_r).
  reflexivity.
Qed.

Lemma proposition_14 :
  forall (n : nat),
    exp (M22 1 1 0 1) n = (M22 1 n 0 1).
Proof.
  intro n.
  induction n as [ | n' IHn'].
  rewrite -> (unfold_exp_base_case).
  unfold identity.
  reflexivity.

  rewrite -> (unfold_exp_induction_case).
  rewrite -> (IHn').
  rewrite -> (matrix_helper).
  rewrite ->3 (mult_1_r).
  rewrite ->2 (mult_0_r).
  rewrite ->2 (plus_0_l).
  rewrite -> (plus_0_r).
  rewrite -> (plus_1_S n').
  reflexivity.
Qed.

Fixpoint exp_alt (m : m22) (n : nat) : m22 :=
  match n with
    | 0 => identity
    | S n' => nine m (exp_alt m n')
end.

Lemma unfold_exp_alt_base_case :
  forall m : m22,
    exp_alt m 0 = identity.
Proof.
  unfold_tactic exp_alt.
Qed.

Lemma unfold_exp_alt_induction_case :
  forall (m : m22) (n : nat),
    exp_alt m (S n) = nine m (exp_alt m n).
Proof.
  unfold_tactic exp_alt.
Qed.

Lemma proposition_14_alt :
  forall (n : nat),
    exp_alt (M22 1 1 0 1) n = (M22 1 n 0 1).
Proof.
  intro n.
  induction n as [ | n' IHn'].
  rewrite -> (unfold_exp_alt_base_case).
  unfold identity.
  reflexivity.

  rewrite -> (unfold_exp_alt_induction_case).
  rewrite -> (IHn').
  rewrite -> (matrix_helper).
  rewrite ->3 (mult_1_l).
  rewrite ->2 (mult_0_l).
  rewrite ->2 (plus_0_l).
  rewrite -> (plus_0_r).
  rewrite -> (plus_1_S n').
  rewrite -> (plus_comm n' 1).
  reflexivity.
Qed.

Lemma proposition_29 :
  forall (m : m22) (n : nat),
    nine m (exp m n) = nine (exp m n) m.
Proof.
  intros m n.
  induction n as [ | n' IHn'].

  rewrite -> (unfold_exp_base_case).
  rewrite -> (identity_matrix_is_netrual_r).
  rewrite -> (identity_matrix_is_netrual_l).
  reflexivity.

  (* We want both sides *)
  rewrite -> (unfold_exp_induction_case).
  rewrite -> (matrices_are_communative).
  rewrite -> (IHn').
  reflexivity.
Qed.

Lemma proposition_31 :
  forall (m : m22) (n : nat),
    nine m (exp_alt m n) = nine (exp_alt m n) m.
Proof.
  intros m n.
  induction n as [ | n' IHn'].
  rewrite -> (unfold_exp_alt_base_case).
  rewrite -> (identity_matrix_is_netrual_l).
  rewrite -> (identity_matrix_is_netrual_r).
  reflexivity.

  (* Again, both sides *)
  rewrite -> (unfold_exp_alt_induction_case).

  (* Sjov egenskab - her er det baglæns *)
  rewrite <- (matrices_are_communative).
  rewrite <- (IHn').
  reflexivity.
Qed.

Lemma coro32 :
  forall (m : m22) (n : nat),
    exp m n = exp_alt m n.
Proof.
  intros m n.

  induction n as [ | n' IHn'].
  rewrite -> (unfold_exp_alt_base_case).
  rewrite -> (unfold_exp_base_case).
  reflexivity.

  rewrite -> (unfold_exp_alt_induction_case).
  rewrite -> (unfold_exp_induction_case).
  rewrite -> (IHn').
  symmetry.
  apply proposition_31.
Qed.

Lemma proposition_33_34 :
  forall n : nat,
    exp (M22 1 0 1 1) n = (M22 1 0 n 1).
Proof.
  intro n.

  induction n as [ | n' IHn'].
  rewrite -> (unfold_exp_base_case).
  unfold identity.
  reflexivity.

  rewrite -> (unfold_exp_induction_case).
  rewrite -> (IHn').
  rewrite -> (matrix_helper).
  rewrite -> (mult_0_l).
  rewrite ->2 (mult_0_r).
  rewrite ->2 (mult_1_r).
  rewrite ->2 (plus_0_r).
  rewrite -> (plus_0_l).
  rewrite -> (plus_comm n' 1).
  rewrite -> (plus_1_S n').
  reflexivity.
Qed.

Definition transpose(m : m22) : m22 :=
  match m with
    | (M22 x1 x2 x3 x4) => (M22 x1 x3 x2 x4)
  end.

Lemma transpose_is_involutive :
  forall m : m22,
    transpose(transpose(m)) = m.
Proof.
  intro m.
  induction m as [ ].
  unfold transpose.
  reflexivity.
Qed.

Lemma transpose_is_something :
  forall (m n : m22),
    transpose(nine m n) = nine (transpose n) (transpose m).
Proof.

  intros m n.
  induction m,n as [ ].
  unfold nine.
  unfold transpose.
  rewrite -> (mult_comm n1 n5).
  rewrite -> (mult_comm).
  rewrite -> (mult_comm n2 n).
  rewrite -> (mult_comm n3 n5).
  rewrite -> (mult_comm n0 n4).
  rewrite -> (mult_comm n1 n6).
  rewrite -> (mult_comm n2 n4).
  rewrite -> (mult_comm n3 n6).
  reflexivity.
Qed.

Lemma proposition_38_transpose_and_exp_commute :
  forall (m : m22) (n : nat),
    transpose(exp m n) = exp (transpose m) n.
Proof.
  intros m n.
  induction m as [].
  induction n as [ | n' IHn'].
  rewrite -> (unfold_exp_base_case).
  rewrite -> (unfold_exp_base_case).
  unfold identity.
  unfold transpose.
  reflexivity.

  rewrite ->2 (unfold_exp_induction_case).
  rewrite <- (IHn').
  rewrite <- (transpose_is_something).
  rewrite -> (proposition_29).
  reflexivity.
Qed.

Lemma proposition_40 :
  forall (n : nat),
    exp (transpose (M22 1 1 0 1)) n = transpose (M22 1 n 0 1).
Proof.
  intro n.
  rewrite <- (proposition_38_transpose_and_exp_commute).
  rewrite -> (proposition_14).
  reflexivity.
Qed.

(* You are asked to:

   * implement Definitions 9, 11, and 13, x

   * prove Properties 10 and 12, x

   * prove Proposition 14, x

   * implement Definition 27, x

   * solve Exercise 28, x

   * prove Proposition 29, x

   * solve Exercise 31, x

   * implement Corollary 32,

   * solve Exercise 34, x

   * implement Definition 35, x

   * prove Property 36, x

   * prove Lemma 37, x

   * prove Proposition 38, and to x

   * solve Exercise 40. x
*)

(*********** *)

Definition matf := (M22 1 1 1 0).

Compute exp matf 0. (* 1 0 0 1 *)
Compute exp matf 1. (* 1 1 1 0 *)
Compute exp matf 2. (* 2 1 1 1 *)
Compute exp matf 3. (* 3 2 2 1 *)
Compute exp matf 4. (* 5 3 3 2 *)
Compute exp matf 5. (* 8 5 5 3 *)
Compute exp matf 6. (* 13 8 8 5 *)
Compute exp matf 7. (* 21 13 13 8 *)
Compute exp matf 8. (* 34 21 21 13 *)

(* For the over-achievers:

   * solve Exercise 25.
*)

(* ********** *)

(* end of two_by_two_matrices.v *)


(* Exercise 5.2 *)
(* Using tactics, redo the proofs of Exercise 4.5 *)
Theorem all_perm' : forall (A : Type) (P : A -> A -> Prop),
    (forall x y : A, P x y)
    -> forall x y : A, P y x.
Proof.
  intros A P H x y.
  apply H.
Qed.

Theorem resolution : forall (A : Type) (P Q R S : A -> Prop),
    (forall a : A, Q a -> R a -> S a)
    -> (forall b : A, P b -> Q b)
    -> (forall c : A, P c -> R c -> S c).
Proof.
  intros A P Q R S H H0 c pc rc.
  apply H.
  apply H0.
  assumption.
  assumption.
Qed.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)
(* A generic one-time pad that can be reused in other proofs. Also included are specializations for bit vectors and finite cyclic groups. *)

Set Implicit Arguments.

Require Import FCF.FCF.

Definition D := evalDist.
Definition dist_iso := evalDist_iso.

Ltac r_ident_r :=
  symmetry;
  rewrite <- evalDist_right_ident;
  symmetry.

Ltac xorTac_once :=
  match goal with
    | [|- context[?x xor (?x xor ?x0)] ]=> rewrite <- BVxor_assoc; rewrite BVxor_same_id; rewrite BVxor_id_l
    | [|- context[(?x xor ?x0) xor ?x] ]=> rewrite <- BVxor_comm
  end.

Ltac xorTac := repeat xorTac_once;
              simpl; try reflexivity; try eapply in_getAllBvectors.

(*
(* Simple example used for illustration *)
Section OTP.
  Variable c : nat.
  Definition OTP (x : Bvector c) : Comp (Bvector c)
    := p <-$ {0, 1}^c; ret (BVxor c p x).

  Theorem OTP_eq_Rnd:
    forall (x y : Bvector c),
      D (OTP x) y == D ({0, 1}^c) y.

    intuition.
    unfold OTP.
    r_ident_r.
    eapply (dist_iso (BVxor c x) (BVxor c x));
      intuition; xorTac.
  Qed.

End OTP.
*)

(* The actual argument is more general (and more complex) *)
Section OTP.

  Variable T : Set.
  Hypothesis T_EqDec : EqDec T.
  Variable RndT : Comp T.
  Variable T_op : T -> T -> T.
  Hypothesis op_assoc : forall x y z, T_op (T_op x y) z = T_op x (T_op y z).
  Variable T_inverse : T -> T.
  Variable T_ident : T.
  Hypothesis inverse_l_ident : forall x, T_op (T_inverse x) x = T_ident.
  Hypothesis inverse_r_ident : forall x, T_op x (T_inverse x) = T_ident.
  Hypothesis ident_l : forall x, T_op T_ident x = x.
  Hypothesis ident_r : forall x, T_op x T_ident = x.
  Hypothesis RndT_uniform : forall x y, comp_spec (fun a b => a = x <-> b = y) RndT RndT.

  Theorem all_in_support :
    forall y, In y (getSupport RndT) ->
    forall x, In x (getSupport RndT).

    intuition.
    eapply getSupport_In_evalDist.
    intuition.
    eapply getSupport_In_evalDist.
    eapply H.
    rewrite <- H0.
    eapply comp_spec_impl_eq.
    trivial.

  Qed.

  Theorem OTP_inf_th_sec_l :
    forall (x : T),
      comp_spec eq RndT (r <-$ RndT; ret (T_op x r)).

    intros.

    eapply (@comp_spec_eq_trans_l _ _ _ _ RndT (x <-$ RndT; ret x)).
    eapply comp_spec_eq_symm.
    eapply comp_spec_right_ident.

    eapply comp_spec_seq.
    trivial.
    trivial.

    eapply comp_spec_symm.
    eapply (comp_spec_iso (T_op x) (T_op (T_inverse x))); intuition.
    rewrite <- op_assoc.
    rewrite inverse_r_ident.
    eauto.
    rewrite <- op_assoc.
    rewrite inverse_l_ident.
    eauto.

    eapply all_in_support; eauto.

    intuition.
    subst.
    eapply comp_spec_eq_refl.

  Qed.

  Theorem OTP_inf_th_sec_r :
    forall (x : T),
      comp_spec eq RndT (r <-$ RndT; ret (T_op r x)).

    intros.

    eapply (@comp_spec_eq_trans_l _ _ _ _ RndT (x <-$ RndT; ret x)).
    eapply comp_spec_eq_symm.
    eapply comp_spec_right_ident.

    eapply comp_spec_seq.
    trivial.
    trivial.

    eapply comp_spec_symm.
    eapply (comp_spec_iso (fun b => T_op b x) (fun b => T_op b (T_inverse x))); intuition.
    rewrite op_assoc.
    rewrite inverse_l_ident.
    eauto.
    rewrite op_assoc.
    rewrite inverse_r_ident.
    eauto.

    eapply all_in_support; eauto.

    intuition.
    subst.
    eapply comp_spec_eq_refl.

  Qed.

End OTP.

(* OTP for bitstrings with xor *)
Section xor_OTP.

  Variable n : nat.

  Theorem xor_OTP:
    forall (x : Bvector n),
      comp_spec eq (Rnd n) (r <-$ Rnd n; ret (BVxor n x r)).

    eapply OTP_inf_th_sec_l; intuition.
    eapply BVxor_assoc.
    eapply BVxor_same_id.
    eapply BVxor_same_id.
    eapply BVxor_id_l.

    eapply comp_spec_rnd.

  Qed.

  Theorem xor_OTP_eq:
    forall (x y : Bvector n),
       evalDist (r <-$ Rnd n; ret (BVxor n x r)) y ==
       evalDist (Rnd n) y.

    intuition.
    symmetry.
    eapply comp_spec_eq_impl_eq.
    eapply xor_OTP.

  Qed.

End xor_OTP.

(* OTP for cyclic groups *)
Require Import FCF.RndNat.
Require Import FCF.RndGrpElem.

Local Open Scope group_scope.

Section Group_OTP.

  Context`{FCG : FiniteCyclicGroup}.

  Hypothesis GroupElement_EqDec : EqDec GroupElement.

  Theorem group_OTP_l :
    forall (x : GroupElement),
      comp_spec eq (RndG) (r <-$ RndG; ret (groupOp x r)).

    eapply OTP_inf_th_sec_l; intuition.

    apply associativity.
    eapply left_inverse.
    eapply right_inverse.
    eapply left_identity.

    eapply RndGrpElem_spec.
  Qed.

  Theorem group_OTP_r :
    forall (x : GroupElement),
      comp_spec eq (RndG) (r <-$ RndG; ret (groupOp r x)).

    eapply OTP_inf_th_sec_r; intuition.

    apply associativity.
    eapply left_inverse.
    eapply right_inverse.
    eapply right_identity.
    eapply RndGrpElem_spec.
  Qed.

End Group_OTP.

#[export] Hint Resolve RndGrpElem_wf : wftac.


Require Import Omega Arith.
Import Nat.

Definition sq n := n * n.

(* Some useful lemmas from the standard library. *)
Check mul_sub_distr_l: forall n m p, p * (n - m) = p * n - p * m.
Check mul_add_distr_r: forall n m p, (n + m) * p = n * p + m * p.
Check mul_comm: forall n m, n * m = m * n.

Lemma difference_of_squares:
  forall a b, sq a - sq b = (a + b) * (a - b).
Proof.

Qed.


(*** Constant list ***)

Require Import Arith.
Require Import List.
Require Import Omega.
Require Import Ott.ott_list_support.
Require Import Ott.ott_list_base.
Require Import Ott.ott_list_nth.
Import List_lib_Arith.

Section Lists.

Variables A B C : Type.
Implicit Types x : A.
Implicit Types y : B.
Implicit Types z : C.
Implicit Types xs l : list A.
Implicit Types ys : list B.
Implicit Types zs : list C.
Implicit Types f : A -> B.
Implicit Types g : B -> C.
Implicit Types m n : nat.
Set Implicit Arguments.

Fixpoint repeat n x {struct n} : list A :=
  match n with
    | 0 => nil
    | S m => x :: repeat m x
  end.

Lemma repeat_length : forall n x, length (repeat n x) = n.
Proof.
  induction n; intros. reflexivity. simpl. rewrite IHn. reflexivity.
Qed.

Lemma repeat_app :
  forall n m x, repeat (n + m) x = repeat n x ++ repeat m x.
Proof.
  induction n; simpl; intros. reflexivity. rewrite IHn. reflexivity.
Qed.

Lemma repeat_S : forall n x, repeat (S n) x = repeat n x ++ x::nil.
Proof.
  intros. replace (S n) with (n+1). 2: omega.
  rewrite repeat_app. reflexivity.
Qed.

Lemma nth_error_repeat :
  forall m n x,
    nth_error (repeat n x) m = if le_lt_dec n m then error else value x.
Proof.
  induction m; destruct n; intros; try reflexivity.
  simpl repeat. simpl nth_error. rewrite IHm.
  symmetry. apply le_lt_dec_S.
Qed.

Lemma nth_repeat :
  forall m n x,
    nth m (repeat n x) x = x.
Proof.
  induction m; destruct n; intros; try reflexivity.
  simpl. rewrite IHm. reflexivity.
Qed.

Lemma nth_safe_repeat :
  forall m n x H,
    nth_safe (repeat n x) m H = x.
Proof.
  intros. assert (value (nth_safe (repeat n x) m H) = value x).
  rewrite nth_safe_eq_nth_error. rewrite nth_error_repeat.
  rewrite repeat_length in H.
  destruct (le_lt_dec n m). elimtype False; omega. reflexivity.
  injection H0. tauto.
Qed.

End Lists.

Hint Rewrite repeat_length repeat_app repeat_S : lists.
Hint Rewrite nth_error_repeat nth_repeat nth_safe_repeat : lists.


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.lemma_congruencesymmetric.
Require Import ProofCheckingEuclid.lemma_congruencetransitive.
Require Import ProofCheckingEuclid.lemma_localextension.
Require Import ProofCheckingEuclid.proposition_02.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_extension_eq_B_P :
	forall A B P Q,
	neq A B ->
	neq P Q ->
	eq B P ->
	exists X, BetS A B X /\ Cong B X P Q.
Proof.
	intros A B P Q.
	intros neq_A_B.
	intros neq_P_Q.
	intros eq_B_P.

	assert (neq B Q) as neq_B_Q by (rewrite eq_B_P; exact neq_P_Q).

	pose proof (lemma_localextension _ _ _ neq_A_B neq_B_Q) as (X & BetS_A_B_X & Cong_BX_BQ).

	assert (Cong B X P Q) as Cong_BX_PQ by (rewrite <- eq_B_P; exact Cong_BX_BQ).

	exists X.
	split.
	exact BetS_A_B_X.
	exact Cong_BX_PQ.
Qed.

Lemma lemma_extension_neq_B_P :
	forall A B P Q,
	neq A B ->
	neq P Q ->
	neq B P ->
	exists X, BetS A B X /\ Cong B X P Q.
Proof.
	intros A B P Q.
	intros neq_A_B.
	intros neq_P_Q.
	intros neq_B_P.

	pose proof (proposition_02 _ _ _ neq_B_P neq_P_Q) as (D & Cong_BD_PQ).
	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_BD_PQ) as Cong_PQ_BD.
	pose proof (axiom_nocollapse _ _ _ _ neq_P_Q Cong_PQ_BD) as neq_B_D.

	pose proof (lemma_localextension _ _ _ neq_A_B neq_B_D) as (X & BetS_A_B_X & Cong_BX_BD).
	pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_BX_BD Cong_BD_PQ) as Cong_BX_PQ.

	exists X.
	split.
	exact BetS_A_B_X.
	exact Cong_BX_PQ.
Qed.

Lemma lemma_extension :
	forall A B P Q,
	neq A B ->
	neq P Q ->
	exists X, BetS A B X /\ Cong B X P Q.
Proof.
	intros A B P Q.
	intros neq_A_B.
	intros neq_P_Q.

	assert (eq B P \/ neq B P) as eq_B_P_or_neq_B_P by (apply Classical_Prop.classic).
	destruct eq_B_P_or_neq_B_P as [eq_B_P | neq_B_P].
	{
		pose proof (
			lemma_extension_eq_B_P _ _ _ _ neq_A_B neq_P_Q eq_B_P
		) as (X & BetS_A_B_X & Cong_BX_PQ).

		exists X.
		split.
		exact BetS_A_B_X.
		exact Cong_BX_PQ.
	}
	{
		pose proof (
			lemma_extension_neq_B_P _ _ _ _ neq_A_B neq_P_Q neq_B_P
		) as (X & BetS_A_B_X & Cong_BX_PQ).

		exists X.
		split.
		exact BetS_A_B_X.
		exact Cong_BX_PQ.
	}
Qed.

End Euclid.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
    Permutation.v

    Defintion and properties of permutations
   **********************************************************************)
Require Export List.
Require Export ListAux.

Section permutation.
Variable A : Type.

(**************************************
   Definition of permutations as sequences of adjacent transpositions
 **************************************)

Inductive permutation : list A -> list A -> Prop :=
  | permutation_nil : permutation nil nil
  | permutation_skip :
      forall (a : A) (l1 l2 : list A),
      permutation l2 l1 -> permutation (a :: l2) (a :: l1)
  | permutation_swap :
      forall (a b : A) (l : list A), permutation (a :: b :: l) (b :: a :: l)
  | permutation_trans :
      forall l1 l2 l3 : list A,
      permutation l1 l2 -> permutation l2 l3 -> permutation l1 l3.
Hint Constructors permutation.

(**************************************
   Reflexivity
 **************************************)

Theorem permutation_refl : forall l : list A, permutation l l.
simple induction l.
apply permutation_nil.
intros a l1 H.
apply permutation_skip with (1 := H).
Qed.
Hint Resolve permutation_refl.

(**************************************
   Symmetry
   **************************************)

Theorem permutation_sym :
 forall l m : list A, permutation l m -> permutation m l.
intros l1 l2 H'; elim H'.
apply permutation_nil.
intros a l1' l2' H1 H2.
apply permutation_skip with (1 := H2).
intros a b l1'.
apply permutation_swap.
intros l1' l2' l3' H1 H2 H3 H4.
apply permutation_trans with (1 := H4) (2 := H2).
Qed.

(**************************************
   Compatibility with list length
   **************************************)

Theorem permutation_length :
 forall l m : list A, permutation l m -> length l = length m.
intros l m H'; elim H'; simpl in |- *; auto.
intros l1 l2 l3 H'0 H'1 H'2 H'3.
rewrite <- H'3; auto.
Qed.

(**************************************
   A permutation of the nil list is the nil list
   **************************************)

Theorem permutation_nil_inv : forall l : list A, permutation l nil -> l = nil.
intros l H; generalize (permutation_length _ _ H); case l; simpl in |- *;
 auto.
intros; discriminate.
Qed.

(**************************************
   A permutation of the singleton list is the singleton list
   **************************************)

Let permutation_one_inv_aux :
  forall l1 l2 : list A,
  permutation l1 l2 -> forall a : A, l1 = a :: nil -> l2 = a :: nil.
intros l1 l2 H; elim H; clear H l1 l2; auto.
intros a l3 l4 H0 H1 b H2.
eq_tac.
injection H2; auto.
apply permutation_nil_inv; auto.
injection H2; intros H3 H4; rewrite <- H3; auto.
apply permutation_sym; auto.
intros; discriminate.
Qed.

Theorem permutation_one_inv :
 forall (a : A) (l : list A), permutation (a :: nil) l -> l = a :: nil.
intros a l H; apply permutation_one_inv_aux with (l1 := a :: nil); auto.
Qed.

(**************************************
   Compatibility with the belonging
   **************************************)

Theorem permutation_in :
 forall (a : A) (l m : list A), permutation l m -> In a l -> In a m.
intros a l m H; elim H; simpl in |- *; auto; intuition.
Qed.

(**************************************
   Compatibility with the append function
   **************************************)

Theorem permutation_app_comp :
 forall l1 l2 l3 l4,
 permutation l1 l2 -> permutation l3 l4 -> permutation (l1 ++ l3) (l2 ++ l4).
intros l1 l2 l3 l4 H1; generalize l3 l4; elim H1; clear H1 l1 l2 l3 l4;
 simpl in |- *; auto.
intros a b l l3 l4 H.
cut (permutation (l ++ l3) (l ++ l4)); auto.
intros; apply permutation_trans with (a :: b :: l ++ l4); auto.
elim l; simpl in |- *; auto.
intros l1 l2 l3 H H0 H1 H2 l4 l5 H3.
apply permutation_trans with (l2 ++ l4); auto.
Qed.
Hint Resolve permutation_app_comp.

(**************************************
   Swap two sublists
   **************************************)

Theorem permutation_app_swap :
 forall l1 l2, permutation (l1 ++ l2) (l2 ++ l1).
intros l1; elim l1; auto.
intros; rewrite <- app_nil_end; auto.
intros a l H l2.
replace (l2 ++ a :: l) with ((l2 ++ a :: nil) ++ l).
apply permutation_trans with (l ++ l2 ++ a :: nil); auto.
apply permutation_trans with (((a :: nil) ++ l2) ++ l); auto.
simpl in |- *; auto.
apply permutation_trans with (l ++ (a :: nil) ++ l2); auto.
apply permutation_sym; auto.
replace (l2 ++ a :: l) with ((l2 ++ a :: nil) ++ l).
apply permutation_app_comp; auto.
elim l2; simpl in |- *; auto.
intros a0 l0 H0.
apply permutation_trans with (a0 :: a :: l0); auto.
apply (app_ass l2 (a :: nil) l).
apply (app_ass l2 (a :: nil) l).
Qed.

(**************************************
   A transposition is a permutation
   **************************************)

Theorem permutation_transposition :
 forall a b l1 l2 l3,
 permutation (l1 ++ a :: l2 ++ b :: l3) (l1 ++ b :: l2 ++ a :: l3).
intros a b l1 l2 l3.
apply permutation_app_comp; auto.
change
  (permutation ((a :: nil) ++ l2 ++ (b :: nil) ++ l3)
     ((b :: nil) ++ l2 ++ (a :: nil) ++ l3)) in |- *.
repeat rewrite <- app_ass.
apply permutation_app_comp; auto.
apply permutation_trans with ((b :: nil) ++ (a :: nil) ++ l2); auto.
apply permutation_app_swap; auto.
repeat rewrite app_ass.
apply permutation_app_comp; auto.
apply permutation_app_swap; auto.
Qed.

(**************************************
   An element of a list can be put on top of the list to get a permutation
   **************************************)

Theorem in_permutation_ex :
 forall a l, In a l -> exists l1 : list A, permutation (a :: l1) l.
intros a l; elim l; simpl in |- *; auto.
intros H; case H; auto.
intros a0 l0 H [H0| H0].
exists l0; rewrite H0; auto.
case H; auto; intros l1 Hl1; exists (a0 :: l1).
apply permutation_trans with (a0 :: a :: l1); auto.
Qed.

(**************************************
   A permutation of a cons can be inverted
   **************************************)

Let permutation_cons_ex_aux :
  forall (a : A) (l1 l2 : list A),
  permutation l1 l2 ->
  forall l11 l12 : list A,
  l1 = l11 ++ a :: l12 ->
  exists l3 : list A,
    (exists l4 : list A,
       l2 = l3 ++ a :: l4 /\ permutation (l11 ++ l12) (l3 ++ l4)).
intros a l1 l2 H; elim H; clear H l1 l2.
intros l11 l12; case l11; simpl in |- *; intros; discriminate.
intros a0 l1 l2 H H0 l11 l12; case l11; simpl in |- *.
exists (nil (A:=A)); exists l1; simpl in |- *; split; auto.
eq_tac; injection H1; auto.
injection H1; intros H2 H3; rewrite <- H2; auto.
intros a1 l111 H1.
case (H0 l111 l12); auto.
injection H1; auto.
intros l3 (l4, (Hl1, Hl2)).
exists (a0 :: l3); exists l4; split; simpl in |- *; auto.
eq_tac; injection H1; auto.
injection H1; intros H2 H3; rewrite H3; auto.
intros a0 b l l11 l12; case l11; simpl in |- *.
case l12; try (intros; discriminate).
intros a1 l0 H; exists (b :: nil); exists l0; simpl in |- *; split; auto.
repeat eq_tac; injection H; auto.
injection H; intros H1 H2 H3; rewrite H2; auto.
intros a1 l111; case l111; simpl in |- *.
intros H; exists (nil (A:=A)); exists (a0 :: l12); simpl in |- *; split; auto.
repeat eq_tac; injection H; auto.
injection H; intros H1 H2 H3; rewrite H3; auto.
intros a2 H1111 H; exists (a2 :: a1 :: H1111); exists l12; simpl in |- *;
 split; auto.
repeat eq_tac; injection H; auto.
intros l1 l2 l3 H H0 H1 H2 l11 l12 H3.
case H0 with (1 := H3).
intros l4 (l5, (Hl1, Hl2)).
case H2 with (1 := Hl1).
intros l6 (l7, (Hl3, Hl4)).
exists l6; exists l7; split; auto.
apply permutation_trans with (1 := Hl2); auto.
Qed.

Theorem permutation_cons_ex :
 forall (a : A) (l1 l2 : list A),
 permutation (a :: l1) l2 ->
 exists l3 : list A,
   (exists l4 : list A, l2 = l3 ++ a :: l4 /\ permutation l1 (l3 ++ l4)).
intros a l1 l2 H.
apply (permutation_cons_ex_aux a (a :: l1) l2 H nil l1); simpl in |- *; auto.
Qed.

(**************************************
   A permutation can be simply inverted if the two list starts with a cons
   **************************************)

Theorem permutation_inv :
 forall (a : A) (l1 l2 : list A),
 permutation (a :: l1) (a :: l2) -> permutation l1 l2.
intros a l1 l2 H; case permutation_cons_ex with (1 := H).
intros l3 (l4, (Hl1, Hl2)).
apply permutation_trans with (1 := Hl2).
generalize Hl1; case l3; simpl in |- *; auto.
intros H1; injection H1; intros H2; rewrite H2; auto.
intros a0 l5 H1; injection H1; intros H2 H3; rewrite H2; rewrite H3; auto.
apply permutation_trans with (a0 :: l4 ++ l5); auto.
apply permutation_skip; apply permutation_app_swap.
apply (permutation_app_swap (a0 :: l4) l5).
Qed.

(**************************************
   Take a list and return tle list of all pairs of an element of the
   list and the remaining list
   **************************************)

Fixpoint split_one (l : list A) : list (A * list A) :=
  match l with
  | nil => nil (A:=A * list A)
  | a :: l1 =>
      (a, l1)
      :: map (fun p : A * list A => (fst p, a :: snd p)) (split_one l1)
  end.

(**************************************
   The pairs of the list are a permutation
   **************************************)

Theorem split_one_permutation :
 forall (a : A) (l1 l2 : list A),
 In (a, l1) (split_one l2) -> permutation (a :: l1) l2.
intros a l1 l2; generalize a l1; elim l2; clear a l1 l2; simpl in |- *; auto.
intros a l1 H1; case H1.
intros a l H a0 l1 [H0| H0].
injection H0; intros H1 H2; rewrite H2; rewrite H1; auto.
generalize H H0; elim (split_one l); simpl in |- *; auto.
intros H1 H2; case H2.
intros a1 l0 H1 H2 [H3| H3]; auto.
injection H3; intros H4 H5; (rewrite <- H4; rewrite <- H5).
apply permutation_trans with (a :: fst a1 :: snd a1); auto.
apply permutation_skip.
apply H2; auto.
case a1; simpl in |- *; auto.
Qed.

(**************************************
   All elements of the list are there
   **************************************)

Theorem split_one_in_ex :
 forall (a : A) (l1 : list A),
 In a l1 -> exists l2 : list A, In (a, l2) (split_one l1).
intros a l1; elim l1; simpl in |- *; auto.
intros H; case H.
intros a0 l H [H0| H0]; auto.
exists l; left; eq_tac; auto.
case H; auto.
intros x H1; exists (a0 :: x); right; auto.
apply
 (in_map (fun p : A * list A => (fst p, a0 :: snd p)) (split_one l) (a, x));
 auto.
Qed.

(**************************************
   An auxillary function to generate all permutations
   **************************************)

Fixpoint all_permutations_aux (l : list A) (n : nat) {struct n} :
 list (list A) :=
  match n with
  | O => nil :: nil
  | S n1 =>
      flat_map
        (fun p : A * list A =>
         map (cons (fst p)) (all_permutations_aux (snd p) n1)) (
        split_one l)
  end.
(**************************************
   Generate all the permutations
   **************************************)

Definition all_permutations (l : list A) := all_permutations_aux l (length l).

(**************************************
   All the elements of the list are permutations
   **************************************)

Let all_permutations_aux_permutation :
  forall (n : nat) (l1 l2 : list A),
  n = length l2 -> In l1 (all_permutations_aux l2 n) -> permutation l1 l2.
intros n; elim n; simpl in |- *; auto.
intros l1 l2; case l2.
simpl in |- *; intros H0 [H1| H1].
rewrite <- H1; auto.
case H1.
simpl in |- *; intros; discriminate.
intros n0 H l1 l2 H0 H1.
case in_flat_map_ex with (1 := H1).
clear H1; intros x; case x; clear x; intros a1 l3 (H1, H2).
case in_map_inv with (1 := H2).
simpl in |- *; intros y (H3, H4).
rewrite H4; auto.
apply permutation_trans with (a1 :: l3); auto.
apply permutation_skip; auto.
apply H with (2 := H3).
apply eq_add_S.
apply trans_equal with (1 := H0).
change (length l2 = length (a1 :: l3)) in |- *.
apply permutation_length; auto.
apply permutation_sym; apply split_one_permutation; auto.
apply split_one_permutation; auto.
Qed.

Theorem all_permutations_permutation :
 forall l1 l2 : list A, In l1 (all_permutations l2) -> permutation l1 l2.
intros l1 l2 H; apply all_permutations_aux_permutation with (n := length l2);
 auto.
Qed.

(**************************************
   A permutation is in the list
   **************************************)

Let permutation_all_permutations_aux :
  forall (n : nat) (l1 l2 : list A),
  n = length l2 -> permutation l1 l2 -> In l1 (all_permutations_aux l2 n).
intros n; elim n; simpl in |- *; auto.
intros l1 l2; case l2.
intros H H0; rewrite permutation_nil_inv with (1 := H0); auto with datatypes.
simpl in |- *; intros; discriminate.
intros n0 H l1; case l1.
intros l2 H0 H1;
 rewrite permutation_nil_inv with (1 := permutation_sym _ _ H1) in H0;
 discriminate.
clear l1; intros a1 l1 l2 H1 H2.
case (split_one_in_ex a1 l2); auto.
apply permutation_in with (1 := H2); auto with datatypes.
intros x H0.
apply in_flat_map with (b := (a1, x)); auto.
apply in_map; simpl in |- *.
apply H; auto.
apply eq_add_S.
apply trans_equal with (1 := H1).
change (length l2 = length (a1 :: x)) in |- *.
apply permutation_length; auto.
apply permutation_sym; apply split_one_permutation; auto.
apply permutation_inv with (a := a1).
apply permutation_trans with (1 := H2).
apply permutation_sym; apply split_one_permutation; auto.
Qed.

Theorem permutation_all_permutations :
 forall l1 l2 : list A, permutation l1 l2 -> In l1 (all_permutations l2).
intros l1 l2 H; unfold all_permutations in |- *;
 apply permutation_all_permutations_aux; auto.
Qed.

(**************************************
   Permutation is decidable
   **************************************)

Definition permutation_dec :
  (forall a b : A, {a = b} + {a <> b}) ->
  forall l1 l2 : list A, {permutation l1 l2} + {~ permutation l1 l2}.
intros H l1 l2.
case (In_dec (list_eq_dec H) l1 (all_permutations l2)).
intros i; left; apply all_permutations_permutation; auto.
intros i; right; contradict i; apply permutation_all_permutations; auto.
Defined.

End permutation.

(**************************************
   Hints
   **************************************)

Hint Constructors permutation.
Hint Resolve permutation_refl.
Hint Resolve permutation_app_comp.
Hint Resolve permutation_app_swap.

(**************************************
   Implicits
   **************************************)

Implicit Arguments permutation [A].
Implicit Arguments split_one [A].
Implicit Arguments all_permutations [A].
Implicit Arguments permutation_dec [A].

(**************************************
   Permutation is compatible with map
   **************************************)

Theorem permutation_map :
 forall (A B : Type) (f : A -> B) l1 l2,
 permutation l1 l2 -> permutation (map f l1) (map f l2).
intros A B f l1 l2 H; elim H; simpl in |- *; auto.
intros l0 l3 l4 H0 H1 H2 H3; apply permutation_trans with (2 := H3); auto.
Qed.
Hint Resolve permutation_map.

(**************************************
  Permutation  of a map can be inverted
  *************************************)

Let permutation_map_ex_aux :
  forall (A B : Type) (f : A -> B) l1 l2 l3,
  permutation l1 l2 ->
  l1 = map f l3 -> exists l4, permutation l4 l3 /\ l2 = map f l4.
intros A1 B1 f l1 l2 l3 H; generalize l3; elim H; clear H l1 l2 l3.
intros l3; case l3; simpl in |- *; auto.
intros H; exists (nil (A:=A1)); auto.
intros; discriminate.
intros a0 l1 l2 H H0 l3; case l3; simpl in |- *; auto.
intros; discriminate.
intros a1 l H1; case (H0 l); auto.
injection H1; auto.
intros l5 (H2, H3); exists (a1 :: l5); split; simpl in |- *; auto.
eq_tac; auto; injection H1; auto.
intros a0 b l l3; case l3.
intros; discriminate.
intros a1 l0; case l0; simpl in |- *.
intros; discriminate.
intros a2 l1 H; exists (a2 :: a1 :: l1); split; simpl in |- *; auto.
repeat eq_tac; injection H; auto.
intros l1 l2 l3 H H0 H1 H2 l0 H3.
case H0 with (1 := H3); auto.
intros l4 (HH1, HH2).
case H2 with (1 := HH2); auto.
intros l5 (HH3, HH4); exists l5; split; auto.
apply permutation_trans with (1 := HH3); auto.
Qed.

Theorem permutation_map_ex :
 forall (A B : Type) (f : A -> B) l1 l2,
 permutation (map f l1) l2 ->
 exists l3, permutation l3 l1 /\ l2 = map f l3.
intros A0 B f l1 l2 H; apply permutation_map_ex_aux with (l1 := map f l1);
 auto.
Qed.

(**************************************
   Permutation is compatible with flat_map
 **************************************)

Theorem permutation_flat_map :
 forall (A B : Type) (f : A -> list B) l1 l2,
 permutation l1 l2 -> permutation (flat_map f l1) (flat_map f l2).
intros A B f l1 l2 H; elim H; simpl in |- *; auto.
intros a b l; auto.
repeat rewrite <- app_ass.
apply permutation_app_comp; auto.
intros k3 l4 l5 H0 H1 H2 H3; apply permutation_trans with (1 := H1); auto.
Qed.


(* My first theorem *)

Definition pierce := forall (p q : Prop),
  ((p -> q) -> p) -> p.
Definition lem := forall p, p \/ ~p.

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


Require Export Poly.

Theorem silly1 : forall (n m o p : nat),
     n = m ->
     [n;o] = [n;p] ->
     [n;o] = [m;p].
Proof.
  intros.
  rewrite <- H.
  apply H0.
Qed.

Theorem silly2 : forall (n m o p : nat),
     n = m ->
     (forall (q r : nat), q = r -> [q;o] = [r;p]) ->
     [n;o] = [m;p].
Proof.
  intros.
  apply H0. apply H.
Qed.

Theorem silly2a : forall(n m : nat),
     (n,n) = (m,m) ->
     (forall (q r : nat), (q,q) = (r,r) -> [q] = [r]) ->
     [n] = [m].
Proof.
  intros.
  apply H0. apply H.
Qed.

Theorem silly_ex :
     (forall n, evenb n = true -> oddb (S n) = true) ->
     evenb 3 = true ->
     oddb 4 = true.
Proof.
  intros.
  apply H.
  apply H0.
Qed.

Theorem silly3_firsttry : forall (n : nat),
     true = beq_nat n 5 ->
     beq_nat (S (S n)) 7 = true.
Proof.
  intros.
  simpl.
  symmetry.
  apply H.
Qed.

Theorem rev_exercise1 : forall (l l' : list nat),
     l = rev l' ->
     l' = rev l.
Proof.
  intros.
  rewrite -> H.
  symmetry.
  apply rev_involutive.
Qed.

Example trans_eq_example : forall (a b c d e f : nat),
     [a;b] = [c;d] ->
     [c;d] = [e;f] ->
     [a;b] = [e;f].
Proof.
  intros.
  rewrite -> H.
  rewrite -> H0.
  reflexivity.
Qed.

Theorem trans_eq : forall (X: Type) (n m o: X),
  n = m -> m = o -> n = o.
Proof.
  intros.
  rewrite -> H.
  rewrite -> H0.
  reflexivity.
Qed.

Example trans_eq_example' : forall (a b c d e f : nat),
     [a;b] = [c;d] ->
     [c;d] = [e;f] ->
     [a;b] = [e;f].
Proof.
  intros.
  apply trans_eq with (m:=[c;d]).
  apply H. apply H0.
Qed.

Example trans_eq_exercise : forall (n m o p : nat),
     m = (minusTwo o) ->
     (n + p) = m ->
     (n + p) = (minusTwo o).
Proof.
  intros.
  apply trans_eq with (m).
  apply H0. apply H.
Qed.

Theorem S_injective : forall (n m : nat),
  S n = S m ->
  n = m.
Proof.
  intros.
  inversion H.
  reflexivity.
Qed.

Lemma S_injective_backwards : forall (n m : nat),
  n = m ->
  S n = S m.
Proof.
  intros. inversion H. reflexivity.
Qed.

Theorem inversion_ex1 : forall (n m o : nat),
  [n; m] = [o; o] ->
  [n] = [m].
Proof.
  intros.
  inversion H.
  reflexivity.
Qed.

Theorem inversion_ex2 : forall (n m : nat),
  [n] = [m] ->
  n = m.
Proof.
  intros.
  inversion H.
  reflexivity.
Qed.

Example inversion_ex3 : forall (X : Type) (x y z : X) (l j : list X),
  x :: y :: l = z :: j ->
  y :: l = x :: j ->
  x = y.
Proof.
  intros.
  inversion H0.
  reflexivity.
Qed.

Theorem beq_nat_0_l : forall n,
   beq_nat 0 n = true -> n = 0.
Proof.
  intros.
  destruct n as [| n'].
  - reflexivity.
  - inversion H.
Qed.

Theorem inversion_ex4 : forall (n : nat),
  S n = O ->
  2 + 2 = 5.
Proof.
  intros.
  inversion H.
Qed.

Theorem inversion_ex5 : forall (n m : nat),
  false = true ->
  [n] = [m].
Proof.
  intros.
  inversion H.
Qed.

Example inversion_ex6 : forall (X : Type)
                          (x y z : X) (l j : list X),
  x :: y :: l = [] ->
  y :: l = z :: j ->
  x = z.
Proof.
  intros.
  inversion H.
Qed.

Theorem f_equal : forall (A B : Type) (f: A -> B) (x y: A),
  x = y -> f x = f y.
Proof.
  intros.
  rewrite -> H.
  reflexivity.
Qed.

Theorem S_inj : forall (n m : nat) (b : bool),
     beq_nat (S n) (S m) = b ->
     beq_nat n m = b.
Proof.
  intros.
  simpl in H. apply H.
Qed.

Theorem silly3' : forall (n : nat),
  (beq_nat n 5 = true -> beq_nat (S (S n)) 7 = true) ->
  true = beq_nat n 5 ->
  true = beq_nat (S (S n)) 7.
Proof.
  intros.
  symmetry in H0. apply H in H0. symmetry in H0. apply H0.
Qed.

(* didn't work when I used 'intros.' at the outset... *)

Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros n.
  induction n as [| n' IHn].
  - intros. destruct m as [| m'].
    + reflexivity.
    + inversion H.
  - intros. destruct m as [| m'].
    + intros. inversion H.
    + intros. inversion H.
      rewrite <- plus_n_Sm in H1.
      rewrite <- plus_n_Sm in H1.
      inversion H1.
      apply IHn in H2.
      rewrite -> H2.
      reflexivity.
Qed.

Theorem double_injective : forall n m : nat,
     double n = double m ->
     n = m.
Proof.
  intros n.
  induction n as [| n' IHn].
  - intros.
    destruct m as [| m'].
    + reflexivity.
    + inversion H.
  - intros.
    destruct m as [| m'].
    + inversion H.
    + apply f_equal.
      apply IHn.
      inversion H.
      reflexivity.
Qed.

Theorem beq_nat_true : forall n m,
    beq_nat n m = true -> n = m.
Proof.
  intros n.
  induction n as [| n' IHn].
  - intros.
    destruct m as [| m'].
    + reflexivity.
    + inversion H.
  - intros.
    destruct m as [| m'].
    + inversion H.
    + apply f_equal.
      apply IHn.
      inversion H.
      reflexivity.
Qed.

Theorem double_injective_take2 : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros.
  generalize dependent n.
  induction m as [| m' IHm].
  - intros.
    destruct n as [| n'].
    + reflexivity.
    + inversion H.
  - intros.
    destruct n as [| n'].
    + inversion H.
    + apply f_equal.
      apply IHm.
      inversion H.
      reflexivity.
Qed.

Theorem beq_id_true : forall x y,
  beq_id x y = true -> x = y.
Proof.
  intros [m] [n].
  simpl.
  intros.
  assert (H' : m = n).
  - apply beq_nat_true. apply H.
  - rewrite -> H'. reflexivity.
Qed.

Theorem nth_error_after_last: forall (n : nat) (X : Type) (l : list X),
     length l = n ->
     nth_error l n = None.
Proof.
  intros.
  generalize dependent n.
  induction l as [| h t IH].
  - intros.
    rewrite <- H.
    reflexivity.
  - intros.
    rewrite <- H.
    simpl.
    apply IH.
    reflexivity.
Qed.

Definition square n := n * n.

Lemma square_mult : forall n m, square (n * m) = square n * square m.
Proof.
  intros.
  unfold square.
  rewrite -> mult_assoc.
  assert (H : n * m * n = n * n * m).
  - rewrite -> mult_comm. apply mult_assoc.
  - rewrite -> H. rewrite -> mult_assoc.
    reflexivity.
Qed.

Definition foo (x: nat) := 5.

Fact silly_fact_1 : forall m, foo m + 1 = foo (m + 1) + 1.
Proof.
  intros m.
  reflexivity.
Qed.

Definition bar x :=
  match x with
  | O => 5
  | S _ => 5
  end.

Fact silly_fact_2_FAILED : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  unfold bar.
  destruct m.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Definition sillyfun (n : nat) : bool :=
  if beq_nat n 3 then false
  else if beq_nat n 5 then false
  else false.

Theorem sillyfun_false : forall (n : nat),
  sillyfun n = false.
Proof.
  intros.
  unfold sillyfun.
  destruct (beq_nat n 3).
  - reflexivity.
  - destruct (beq_nat n 5).
    + reflexivity.
    + reflexivity.
Qed.

Theorem tail_eq: forall (X: Type) (h: X) (l1 l2: list X),
    l1 = l2 -> h :: l1 = h :: l2.
Proof.
  intros. apply f_equal. apply H.
Qed.

Theorem combine_split : forall X Y (l : list (X * Y)) l1 l2,
  split l = (l1, l2) ->
  combine l1 l2 = l.
Proof.
  intros X Y l.
  induction l as [| h t IH].
  - intros.
    inversion H.
    reflexivity.
  - intros.
    inversion H.
    destruct h.
    destruct (split t).
    simpl in H1.
    inversion H1.
    simpl.
    apply tail_eq.
    apply IH.
    reflexivity.
Qed.

Definition sillyfun1 (n : nat) : bool :=
  if beq_nat n 3 then true
  else if beq_nat n 5 then true
  else false.

Theorem sillyfun1_odd : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros.
  unfold sillyfun1 in H.
  destruct (beq_nat n 3) eqn:neq3.
  - apply beq_nat_true in neq3.
    rewrite -> neq3.
    reflexivity.
  - destruct (beq_nat n 5) eqn:neq5.
    + apply beq_nat_true in neq5.
      rewrite -> neq5.
      reflexivity.
    + inversion H.
Qed.

Theorem bool_fn_applied_thrice :
  forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  intros.
  destruct b.
  - destruct (f true) eqn:fTrue.
    + rewrite -> fTrue.
      apply fTrue.
    + destruct (f false) eqn:fFalse.
      * apply fTrue.
      * apply fFalse.
 - destruct (f false) eqn: fFalse.
   + destruct (f true) eqn:fTrue.
     * apply fTrue.
     * apply fFalse.
   + rewrite -> fFalse.
     apply fFalse.
Qed.

Theorem beq_nat_sym : forall (n m : nat),
  beq_nat n m = beq_nat m n.
Proof.
  intros.
  generalize dependent m.
  induction n as [| n' IHn].
  - intros. destruct m as [| m'].
    + reflexivity.
    + reflexivity.
  - intros. destruct m as [| m'].
    + reflexivity.
    + apply IHn.
Qed.

Theorem beq_nat_trans : forall n m p,
  beq_nat n m = true ->
  beq_nat m p = true ->
  beq_nat n p = true.
Proof.
  intros.
  destruct n as [| n'].
  - apply beq_nat_true in H.
    rewrite <- H in H0.
    apply beq_nat_true in H0.
    rewrite <- H0.
    reflexivity.
  - apply beq_nat_true in H.
    rewrite <- H in H0.
    apply H0.
Qed.

Definition split_combine_statement : Prop :=
  forall (X: Type) (l1 l2: list X),
  length l1 = length l2 ->
  split (combine l1 l2) = (l1, l2).

Theorem split_combine : split_combine_statement.
Proof.
  intros X l1.
  induction l1 as [| h1 t1 IH1].
  - intros.
    simpl.
    destruct l2 as [| h2 t2 IH2].
    + reflexivity.
    + inversion H.
  - intros.
    inversion H.
    destruct l2 as [| h2 t2].
    + inversion H1.
    + inversion H1.
      apply IH1 in H2.
      simpl.
      rewrite -> H2.
      reflexivity.
Qed.

Theorem filter_exercise : forall (X : Type) (test : X -> bool) (x : X) (l lf : list X),
     filter test l = x :: lf ->
     test x = true.
Proof.
  intros.
  generalize dependent lf.
  induction l as [| h t IH].
  - intros.
    simpl in H.
    inversion H.
  - intros.
    generalize dependent H.
    destruct lf as [| hf tf].
    + simpl.
      intros.
      destruct (test h) eqn:testH.
      * inversion H.
        rewrite -> H1 in testH.
        apply testH.
      * apply IH in H.
        apply H.
    + simpl.
      intros.
      destruct (test h) eqn:testH.
      * inversion H.
        rewrite -> H1 in testH.
        apply testH.
      * apply IH in H.
        apply H.
Qed.

Fixpoint forallb {X: Type} (test: X -> bool) (l: list X) : bool :=
  match l with
  | [] => true
  | h :: t => (test h) && (forallb test t)
  end.

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

Example forallb_1: forallb oddb [1;3;5;7;9] = true.
Proof. reflexivity. Qed.

Example forallb_2: forallb negb [false;false] = true.
Proof. reflexivity. Qed.

Example forallb_3: forallb evenb [0;2;4;5] = false.
Proof. reflexivity. Qed.

Example forallb_4: forallb (beq_nat 5) [] = true.
Proof. reflexivity. Qed.

Example existsb_1: existsb (beq_nat 5) [0;2;3;6] = false.
Proof. reflexivity. Qed.

Example existsb_2: existsb (andb true) [true;true;false] = true.
Proof. reflexivity. Qed.

Example existsb_3: existsb oddb [1;0;0;0;0;3] = true.
Proof. reflexivity. Qed.

Example existsb_4: existsb evenb [] = false.
Proof. reflexivity. Qed.

Definition existsb' {X: Type} (test: X -> bool) (l: list X) :=
  negb (forallb (fun a => negb (test a)) l).

Example existsb'_1: existsb' (beq_nat 5) [0;2;3;6] = false.
Proof. reflexivity. Qed.

Example existsb'_2: existsb' (andb true) [true;true;false] = true.
Proof. reflexivity. Qed.

Example existsb'_3: existsb' oddb [1;0;0;0;0;3] = true.
Proof. reflexivity. Qed.

Example existsb'_4: existsb' evenb [] = false.
Proof. reflexivity. Qed.

Theorem existsb_existsb': forall (X: Type) (test: X -> bool) (l: list X),
  existsb test l = existsb' test l.
Proof.
  intros.
  unfold existsb.
  unfold existsb'.
  induction l as [| h t IH].
  - simpl. reflexivity.
  - simpl.
    destruct (test h) eqn:testH.
    + simpl. reflexivity.
    + simpl. apply IH.
Qed.

Definition forallb' {X: Type} (test: X -> bool) (l: list X) : bool :=
  fold (fun item acc => acc && (test item)) l true.

Example forallb'_1: forallb' oddb [1;3;5;7;9] = true.
Proof. reflexivity. Qed.

Example forallb'_2: forallb' negb [false;false] = true.
Proof. reflexivity. Qed.

Example forallb'_3: forallb' evenb [0;2;4;5] = false.
Proof. reflexivity. Qed.

Example forallb'_4: forallb' (beq_nat 5) [] = true.
Proof. reflexivity. Qed.

Theorem andb_true_r: forall (a: bool),
    a && true = a.
Proof.
  intros.
  destruct a.
  - reflexivity.
  - reflexivity.
Qed.

Theorem forallb_forallb': forall (X: Type) (test: X -> bool) (l: list X),
  forallb test l = forallb' test l.
Proof.
  intros.
  unfold forallb.
  unfold forallb'.
  induction l as [| h t IH].
  - simpl. reflexivity.
  - simpl.
    destruct (test h) eqn:testH.
    + simpl.
      rewrite -> IH.
      rewrite -> andb_true_r.
      reflexivity.
    + simpl.
      rewrite -> andb_false_r.
      reflexivity.
Qed.

Theorem map_length_unchanged: forall (A B: Type) (f: A -> B) (l: list A),
    length l = length (map f l).
Proof.
  intros.
  induction l as [| h t IH].
  - reflexivity.
  - simpl.
    rewrite -> IH.
    reflexivity.
Qed.

Definition flat_map_fold {X Y: Type} (f: X -> list Y) (l: list X) : list Y :=
  fold (fun item acc => (f item) ++ acc) l [].

Theorem flat_map_fold_correct: forall (X Y: Type) (f: X -> list Y) (l: list X),
  flat_map f l = flat_map_fold f l.
Proof.
  intros.
  unfold flat_map_fold.
  unfold flat_map.
  induction l as [| h t IH].
  - reflexivity.
  - simpl.
    rewrite -> IH.
    reflexivity.
Qed.


(*****************************************************************)
(******    M2 LMFI Preuves Assistées par Ordinateur        *******)
(****** Projet : compilation d'expressions avec sommations *******)
(******               Pierre Letouzey                      *******)
(*****************************************************************)

Require Import String Datatypes Arith List Lia.
Import ListNotations.
Open Scope string_scope.
Open Scope list_scope.

(** I) Bibliotheque *)

(** Comparaisons d'entiers

    En Coq, la comparaison a <= b est une affirmation logique
    (dans Prop). On ne peut pas s'en servir pour un test dans
    un programme. Pour cela il faut utiliser la comparaison
    booléenne a <=? b (correspondant à la constante Nat.leb).
    Voici le lien entre ces deux notions,  *)

Lemma leb_le x y : (x <=? y)%nat = true <-> x <= y.
Proof.
 apply Nat.leb_le.
Qed.

Lemma leb_gt x y : (x <=? y)%nat = false <-> y < x.
Proof.
 apply Nat.leb_gt.
Qed.

(** Une soustraction sans arrondi.

    Sur les entiers naturels, la soustraction usuelle de Coq
    est tronquée : lorsque a < b, alors a - b = 0.
    Ici on utilise None pour signaler ce cas, et Some pour
    indiquer une soustraction "réussie". *)

Fixpoint safe_minus a b : option nat :=
 match b, a with
   | 0, _ => Some a
   | S b, 0 => None
   | S b, S a => safe_minus a b
 end.

Lemma safe_minus_spec a b :
 match safe_minus a b with
 | Some c => a = b + c
 | None => a < b
 end.
Proof.
 revert b; induction a; destruct b; simpl; auto with arith.
 specialize (IHa b). destruct (safe_minus a b); auto with arith.
Qed.

(** Accès au n-ieme élement d'une liste

   NB: list_get existe aussi dans la bibliothèque standard,
   c'est List.nth_error. *)

Fixpoint list_get {A} (l:list A) i : option A :=
  match i,l with
    | 0,   x::_ => Some x
    | S j, _::l => list_get l j
    | _, _ => None
  end.

Definition option_map {A B} (f:A->B) (o:option A) :=
  match o with
    | Some a => Some (f a)
    | None => None
  end.

Fixpoint list_set {A} (l:list A) i x : option (list A) :=
  match i,l with
    | 0, _::l => Some (x::l)
    | S j, a::l => option_map (cons a) (list_set l j x)
    | _, _ => None
  end.

Lemma get_app_l {A} (l l':list A)(n:nat) : n < length l ->
  list_get (l++l') n = list_get l n.
Proof.
 revert l.
 induction n; destruct l; simpl; auto with arith; inversion 1.
Qed.

Lemma get_app_r {A} (l l':list A)(n:nat) :
  list_get (l++l') (length l + n) = list_get l' n.
Proof.
 induction l; auto.
Qed.

Lemma get_app_r0 {A} (l l':list A)(n:nat) : n = length l ->
  list_get (l++l') n = list_get l' 0.
Proof.
  intros. rewrite <- (get_app_r l l'). f_equal. lia.
Qed.

Lemma get_app_r' {A} (l l':list A)(n:nat) : length l <= n ->
  list_get (l++l') n = list_get l' (n-length l).
Proof.
 intros. rewrite <- (get_app_r l l'). f_equal. lia.
Qed.

Lemma get_None {A} (l:list A) n :
 list_get l n = None <-> length l <= n.
Proof.
 revert n. induction l; destruct n; simpl; rewrite ?IHl; split;
  auto with arith; inversion 1.
Qed.

Lemma get_Some {A} (l:list A) n x :
 list_get l n = Some x -> n < length l.
Proof.
 revert n. induction l; destruct n; simpl; try discriminate.
  - auto with arith.
  - intros. apply IHl in H. auto with arith.
Qed.

Global Hint Resolve get_Some : core.

(** Equivalent de List.assoc, spécialisé aux string. Ici =? est String.eqb *)

Fixpoint lookup {A}(s:string)(l:list (string*A))(default:A) :=
  match l with
    | nil => default
    | (x,d)::l => if s =? x then d else lookup s l default
  end.

(** Index d'un element dans une liste, spécialisé aux string *)

Fixpoint index (s:string)(l:list string) :=
  match l with
    | nil => 0
    | x::l => if s =? x then 0 else S (index s l)
  end.

(** Opérateur de sommation : sum f x n = f x + ... + f (x+n).
    Attention, il y a (n+1) termes dans cette somme.
    En particulier sum f 0 n = f 0 + ... + f n. *)

Fixpoint sum f x k :=
  match k with
    | 0 => f x
    | S n' => f x + sum f (S x) n'
  end.

Compute sum (fun _ => 1) 0 10. (* 11 *)
Compute sum (fun x => x) 0 10. (* 0 + 1 + ... + 10 = 55 *)

(** II) Expressions arithmétiques avec sommations *)

(** Les expressions *)

Definition var := string.

Inductive op := Plus | Minus | Mult.

Inductive expr :=
  | EInt : nat -> expr
  | EVar : var -> expr
  | EOp  : op -> expr -> expr -> expr
  | ESum : var -> expr -> expr -> expr.

(** (ESum var max body) est la somme des valeurs de body
    lorsque var prend successivement les valeurs de 0 jusqu'à max
    (inclus). Par exemple, voici la somme des carrés de 0 à 10,
    ce qu'on écrit sum(x^2,x=0..10) en Maple ou encore
    $\sum_{x=0}^{10}{x^2}$ en LaTeX. *)

Definition test1 :=
  ESum "x" (EInt 10) (EOp Mult (EVar "x") (EVar "x")).

(** Un peu plus complexe, une double sommation:
    sum(sum(x*y,y=0..x),x=0..10) *)

Definition test2 :=
  ESum "x" (EInt 10)
   (ESum "y" (EVar "x")
     (EOp Mult (EVar "x") (EVar "y"))).

(** Evaluation d'expression *)

Definition eval_op o :=
  match o with
    | Plus => plus
    | Minus => minus
    | Mult => mult
  end.

Fixpoint eval (env:list (string*nat)) e :=
  match e with
    | EInt n => n
    | EVar v => lookup v env 0
    | EOp o e1 e2 => (eval_op o) (eval env e1) (eval env e2)
    | ESum v efin ecorps => sum (fun i => eval ( (v,i)::env ) ecorps) 0 (eval env efin)
  end.

Compute (eval nil (EOp Plus (EInt 37) (EInt 5) )). (* 37+5=42 *)
Compute (eval nil test1). (* 385 attendu: n(n+1)(2n+1)/6 pour n=10 *)
Compute (eval nil test2). (* 1705 attendu *)

(** III) Machine à pile *)

(** Notre machine est composée de deux piles : une pile principale
    (pour les calculs) et une pile de variables. Les instructions
    sont stockées à part. *)

Record machine :=
  Mach {
      (** Pointeur de code *)
      pc : nat;
      (** Pile principale *)
      stack : list nat;
      (** Pile de variables *)
      vars : list nat
    }.

Definition initial_machine := Mach 0 nil nil.

Inductive instr :=
  (** Pousse une valeur entière sur la pile. *)
  | Push : nat -> instr
  (** Enlève la valeur au sommet de la pile. *)
  | Pop : instr
  (** Dépile deux valeurs et empile le resultat de l'operation binaire. *)
  | Op : op -> instr
  (** Crée une nouvelle variable en haut de la pile des variables,
      contenant initialement 0. *)
  | NewVar : instr
  (** Enlève la variable en haut de la pile des variables.
      Sa valeur actuelle est perdue. *)
  | DelVar : instr
  (** Pousse la valeur de la i-eme variable sur la pile. *)
  | GetVar : nat -> instr
  (** Enlève la valeur au sommet de la pile et met-la dans la i-eme variable. *)
  | SetVar : nat -> instr
  (** Jump offset: retire offset au pointeur de code si la première
      variable est inférieure ou égale au sommet de pile.
      Pile et variables sont gardées à l'identique. *)
  | Jump : nat -> instr.

(* NB: il n'y a pas d'instruction Halt, on s'arrête quand
   pc arrive au delà du code. *)

(* Sémantique de référence des instructions,
   définie via une relation inductive *)

Inductive Stepi : instr -> machine -> machine -> Prop :=
| SPush pc stk vs n :
    Stepi (Push n) (Mach pc stk vs) (Mach (S pc) (n::stk) vs)
| SPop pc stk vs x :
    Stepi Pop (Mach pc (x::stk) vs) (Mach (S pc) stk vs)
| SOp pc stk vs o y x :
    Stepi (Op o) (Mach pc (y::x::stk) vs)
                 (Mach (S pc) (eval_op o x y :: stk) vs)
| SNewVar pc stk vs :
    Stepi NewVar (Mach pc stk vs) (Mach (S pc) stk (0::vs))
| SDelVar pc stk vs x :
    Stepi DelVar (Mach pc stk (x::vs)) (Mach (S pc) stk vs)
| SGetVar pc stk vs i x :
    list_get vs i = Some x ->
    Stepi (GetVar i) (Mach pc stk vs) (Mach (S pc) (x::stk) vs)
| SSetVar pc stk vs vs' i x :
    list_set vs i x = Some vs' ->
    Stepi (SetVar i) (Mach pc (x::stk) vs)
                     (Mach (S pc) stk vs')
| SJumpYes pc stk vs v x off : off <= pc -> v <= x ->
    Stepi (Jump off) (Mach pc (x::stk) (v::vs))
                     (Mach (pc-off) (x::stk) (v::vs))
| SJumpNo pc stk vs v x off : x < v ->
    Stepi (Jump off) (Mach pc (x::stk) (v::vs))
                     (Mach (S pc) (x::stk) (v::vs)).

Definition Step (code:list instr) (m m' : machine) : Prop :=
 match list_get code m.(pc) with
  | Some instr => Stepi instr m m'
  | None => False
 end.

Inductive Steps (code:list instr) : machine -> machine -> Prop :=
 | NoStep m : Steps code m m
 | SomeSteps m1 m2 m3 :
     Step code m1 m2 -> Steps code m2 m3 -> Steps code m1 m3.

(** state : état d'une machine, c'est à dire sa pile de calcul
    et sa pile de variables, mais pas son pc. *)

Definition state := (list nat * list nat)%type.

(** Une execution complète va de pc=0 à pc=(length code) *)

Definition Exec code '(stk, vs) '(stk', vs') :=
  Steps code (Mach 0 stk vs) (Mach (length code) stk' vs').

(** Run : relation entre un code et le résultat de son exécution. *)

Definition Run code res := Exec code (nil,nil) (res::nil,nil).

(** Petit exemple d'usage de cette sémantique *)

Lemma Run_example :
  Run (Push 7 :: Push 3 :: Op Minus :: nil) 4.
Proof.
 repeat econstructor.
Qed.

(** Propriétés basiques de Steps : transitivité, ... *)

Global Hint Constructors Stepi Steps : core.

Lemma Steps_trans code m1 m2 m3 :
 Steps code m1 m2 -> Steps code m2 m3 -> Steps code m1 m3.
Proof.
  intros.
  induction H.
  - apply H0.
  - apply IHSteps in H0. apply SomeSteps with m2; [apply H | apply H0].
Qed.

Lemma OneStep code st st' : Step code st st' -> Steps code st st'.
Proof.
  intro.
  apply SomeSteps with st'.
  - apply H.
  - apply NoStep.
Qed.

(** Décalage de pc dans une machine *)

Definition shift_pc k (p:machine) :=
 let '(Mach pc stk vars) := p in
 (Mach (k+pc) stk vars).

Lemma pc_shift n m : (shift_pc n m).(pc) = n + m.(pc).
Proof.
 now destruct m.
Qed.

(* Lemma pc_shift' n m stk vars : shift_pc n {|pc := 0+m; stack := stk; vars := vars|} =  {|pc := n+m; stack := stk; vars := vars|}.
Proof.
  unfold shift_pc.
  rewrite Nat.add_0_l.
  reflexivity.
Qed. *)

(** Ajout de code devant / derriere la zone intéressante *)

Lemma Step_extend code code' m m' :
 Step code m m' -> Step (code++code') m m'.
Proof.
  unfold Step.
  elim (le_or_lt (List.length code) (pc m));intros.
  - rewrite <- get_None in H.
    rewrite H in H0.
    contradiction.
  - rewrite get_app_l; assumption.
Qed.

Lemma Steps_extend code code' m m' :
 Steps code m m' -> Steps (code++code') m m'.
Proof.
  intro.
  induction H.
  - apply NoStep.
  - apply Steps_trans with m2.
    * apply OneStep. apply Step_extend. apply H.
    * apply IHSteps.
Qed.

Lemma Stepi_shift instr n m m' :
 Stepi instr m m' ->
 Stepi instr (shift_pc n m) (shift_pc n m').
Proof.
  intro.
  Check Nat.add_succ_r.
  induction H;simpl; try rewrite Nat.add_succ_r; auto.
   - remember (n+pc0) as pc.
      replace (n+(pc0-off)) with (pc-off).
      + constructor.
        * lia.
        * assumption.
      + lia.
Qed.

Lemma Step_shift code0 code m m' (n := List.length code0) :
 Step code m m' ->
 Step (code0 ++ code) (shift_pc n m) (shift_pc n m').
Proof.
  unfold Step.
  intro.
  elim (le_or_lt (List.length code) (pc m));intros.
  (* Hypothesis list_get outside code *)
  - rewrite <- get_None in H0.
    rewrite H0 in H.
    contradiction.
  (* Hypothesis list_get inside code *)
  - rewrite pc_shift in *; unfold n in *.
    rewrite get_app_r; destruct list_get.
     * apply Stepi_shift. assumption.
     * contradiction.
Qed.

Lemma Steps_shift code0 code  m m' (n := List.length code0) :
 Steps code m m' ->
 Steps (code0 ++ code) (shift_pc n m) (shift_pc n m').
Proof.
  intro.
  induction H.
  - destruct m . apply NoStep.
  - unfold n in *. apply SomeSteps with (shift_pc (length code0) m2).
     + apply Step_shift. apply H.
     + assumption.
Qed.

(** Composition d'exécutions complètes *)

Lemma Exec_trans code1 code2 stk1 vars1 stk2 vars2 stk3 vars3 :
 Exec code1 (stk1, vars1) (stk2, vars2) ->
 Exec code2 (stk2, vars2) (stk3, vars3) ->
 Exec (code1 ++ code2) (stk1, vars1) (stk3, vars3).
Proof.
  unfold Exec.
  intros.
  apply Steps_trans with ({| pc := length code1; stack := stk2; vars := vars2 |}).
  - apply Steps_extend. assumption.
  - apply Steps_shift with (code0:= code1) in H0.
    simpl in H0.
    rewrite app_length.
    rewrite <- plus_n_O in H0.
    assumption.
Qed.

(** Correction des sauts lors d'une boucle

    - La variable 0 est la variable de boucle a,
    - La variable 1 est l'accumulateur acc
    - Le haut de pile est la limite haute b de la variable de boucle

    On montre d'abord que si un code ajoute f(a) à acc et
    incrémente a, alors la répétition de ce code (via un Jump
    ultérieur) ajoutera (sum f a (b-a)) à acc.
    La variable N (valant b-a) est le nombre de tours à faire.
*)

(** Ce lemme est difficile. N'hésitez pas à le sauter et à y revenir
    après avoir fini la partie IV. *)

Global Hint Resolve le_n_S le_plus_r : core.

Lemma eqAddS_to_leq (a b N : nat) : b = S N + a -> S a <= b.
Proof.
  intro.
  apply Nat.lt_le_trans with (m:= a+S N);lia.
Qed.

Lemma Steps_jump code n (f:nat->nat) stk vars b :
  length code = n ->
  (forall a acc,
   Steps code
         (Mach 0 (b::stk) (a::acc::vars))
         (Mach n (b::stk) ((S a)::(acc + f a)::vars)))
  ->
  forall N a acc,
    b = N + a ->
    Steps (code++(Jump n)::nil)
          (Mach 0 (b::stk) (a::acc::vars))
          (Mach (S n) (b::stk) ((S b)::(acc + sum f a N)::vars)).
Proof.
  intro. intro.
  induction N; intros.
  - apply Steps_trans with (m2:= {| pc := n; stack := b :: stk; vars := S a :: acc + f a :: vars |}).
    + apply Steps_extend.
      apply H0.
    + apply OneStep.
      unfold Step.
      simpl in *.
      rewrite H1.
      (* [Jump n] goes from [pc = n] to [pc = S n] because [a < S a] *)
      rewrite get_app_r0; simpl; auto.
  - apply Steps_trans with (m2:= {| pc := n; stack := b :: stk; vars := S a :: acc + f a :: vars |}).
    + apply Steps_extend.
      apply H0.
    + apply Steps_trans with (m2:= {|pc := n - n; stack := b :: stk; vars := S a :: (acc + f a :: vars)|}).
      * apply OneStep.
        unfold Step; simpl.
        apply eqAddS_to_leq in H1.
        (* [Jump n] goes from [pc = n ] to [pc = 0] since [S a <= b] *)
        rewrite get_app_r0; simpl; auto.
      * simpl.
        rewrite Nat.add_assoc.
        rewrite Nat.sub_diag.
        apply IHN.
        rewrite <- plus_Snm_nSm.
        assumption.
Qed.

(** Version spécialisée du résultat précédent, avec des
    Exec au lieu de Step, et 0 comme valeur initiale des variables
    de boucle et d'accumulateurs. *)

Lemma Exec_jump code (f:nat->nat) stk vars b :
  (forall a acc,
     Exec code (b::stk, a::acc::vars)
               (b::stk, (S a)::(acc + f a)::vars))
  ->
  Exec (code++(Jump (length code))::nil)
      (b::stk, 0::0::vars)
      (b::stk, (S b)::(sum f 0 b)::vars).
Proof.
  intros.
  unfold Exec in *.
  apply Steps_jump with (b:=b) (a:=0) (acc:=0) (N:=b) in H.
  - simpl in *.
    rewrite last_length.
    assumption.
  - trivial.
  - trivial.
Qed.

(** IV) Le compilateur

    On transforme une expression en instructions pour
    notre machine à pile.

    Conventions:
     - à chaque entrée dans une boucle, on crée deux variables,
       la variable de boucle et l'accumulateur.
     - on s'arrange pour que les variables de boucles aient
       des indices pairs dans la pile des variables
     - l'environnement de compilation cenv ne contient que les
       variables de boucles.
    Voir également l'invariant EnvsOk ci-dessous. *)

Fixpoint comp (cenv:list string) e :=
  match e with
    | EInt n => Push n :: nil
    | EVar v =>
      let x := (index v cenv * 2) in
      GetVar x::nil
    | EOp o e1 e2 =>
      let x1 := comp cenv e1 in
      let x2 := comp cenv e2 in
      x1++x2++(Op o::nil)
    | ESum v efin ecorps =>
      let prologue := (comp cenv efin)++(NewVar::NewVar::nil) in
      let corps := comp (v::cenv) ecorps in
      let it := GetVar 1::Op Plus::SetVar 1::Push 1::GetVar 0::Op Plus::SetVar 0:: nil in

      let boucle := (corps ++ it) ++ [Jump (length (corps ++ it))]  in

      let epilogue := Pop::GetVar 1::DelVar::DelVar::nil in
      prologue ++ boucle ++ epilogue
  end.

Definition compile e := comp nil e.

(** Variables libres d'une expression *)

Inductive FV (v:var) : expr -> Prop :=
| FVVar : FV v (EVar v)
| FVOpL (o:op) (e1 e2 : expr) : FV v e1 -> FV v (EOp o e1 e2)
| FVOpR (o:op) (e1 e2 : expr) : FV v e2 -> FV v (EOp o e1 e2)
| FVSumFin (v' :var) (efin ecorps : expr) :  FV v efin -> FV v (ESum v' efin ecorps)
| FVSumCorps (v' :var) (efin ecorps : expr) : FV v ecorps -> FV v (ESum v' efin ecorps)
.

Global Hint Constructors FV : core.

Definition Closed e := forall v, ~ FV v e.

(** Invariants sur les environnements.
    env : environnement d'evaluation (list (string*nat))
    cenv : environnement de compilation (list string)
    vars : pile de variables pour nos machines *)

Definition EnvsOk e env cenv vars :=
 forall v, FV v e ->
   In v cenv /\
   list_get vars (index v cenv * 2) = Some (lookup v env 0).

Global Hint Unfold EnvsOk : core.

Lemma EnvsOk_ESum v e1 e2 env cenv vars a b :
  EnvsOk (ESum v e1 e2) env cenv vars ->
  EnvsOk e2 ((v,a)::env) (v::cenv) (a::b::vars).
Proof.
  intros.
  unfold EnvsOk in *.
  intros.
  elim (string_dec v0 v); intro; [rewrite a0|]; split; simpl.
  - left. reflexivity.
  - rewrite eqb_refl. simpl. reflexivity.
  - right. apply H. apply FVSumCorps. assumption.
  - rewrite <- eqb_neq in b0. rewrite b0. simpl.
    apply H. apply FVSumCorps. assumption.
Qed.

(** Correction du compilateur *)

Ltac basic_exec :=
  (* Cette tactique prouve des buts (Exec code m m')
     quand le code et la machine m sont connus en détail. *)
  unfold Exec; repeat (eapply SomeSteps; [constructor|]);
   try apply NoStep; try reflexivity.

(* Si vous avez l'impression de prouver quelque chose d'impossible,
   peut-être est-ce le signe que vous vous êtes trompé dans la définition
   de comp. *)

Theorem comp_ok e env cenv vars stk :
 EnvsOk e env cenv vars ->
 Exec (comp cenv e) (stk,vars) (eval env e :: stk, vars).
Proof.
  revert stk.
  revert vars.
  revert cenv.
  revert env.

  induction e; intros;basic_exec; simpl.
  - unfold EnvsOk in H.
    unfold eval.
    apply H.
    constructor.
  - apply Exec_trans with (stk2:= eval env e1::stk) (vars2:= vars0).
    + apply IHe1. auto.
    + apply Exec_trans with (stk2:= eval env e2::eval env e1::stk) (vars2:= vars0).
      * apply IHe2 with (stk:=eval env e1::stk).
        auto.
      * simpl.
        apply OneStep.
        constructor.
  - rewrite app_assoc.
    apply Exec_trans with (stk2:=(eval env e1)::stk) (vars2:= S (eval env e1) :: sum (fun i => eval ((v, i) :: env) e2) 0 (eval env e1)::vars0).
    apply Exec_trans with (vars2:=0::0::vars0) (stk2:=eval env e1::stk).
    (* prologue *)
    + apply Exec_trans with (vars2:= vars0) (stk2:= eval env e1::stk).
      * apply IHe1 with (stk:=stk) (vars:= vars0).
        intuition.
      * basic_exec.
    (* boucle *)
    + apply Exec_jump.
      intros.
      apply Exec_trans with (stk2:= eval ((v,a)::env) e2::eval env e1::stk) (vars2:= a::acc::vars0).
      * apply IHe2 .
        apply EnvsOk_ESum with (a:=a) (b:=acc) in H.
        assumption.
      * basic_exec.
        unfold eval_op.
        unfold list_set.
        simpl.
        rewrite Nat.add_comm.
        reflexivity.
    (* epilogue *)
    + basic_exec.
Qed.

Theorem compile_ok e : Closed e -> Run (compile e) (eval nil e).
Proof.
  unfold Closed.
  unfold Run.
  intro.
  apply comp_ok.
  unfold EnvsOk.
  intros.
  elim H with v.
  assumption.
Qed.

(** V) Sémantique exécutable

    A la place des relations précédentes (Step*, Exec, Run...),
    on cherche maintenant à obtenir une fonction calculant
    le résultat de l'exécution d'une machine à pile. *)

(** Cette partie est nettement plus difficile que les précédentes
    et est complètement optionnelle. *)

  Axiom TODO : forall {A:Type}, A.

Inductive step_result : Type :=
  | More : machine -> step_result (* calcul en cours *)
  | Stop : machine -> step_result (* calcul fini (pc hors code) *)
  | Bug : step_result. (* situation illégale, machine plantée *)

(** Pour la fonction [step] ci-dessous, ces deux opérateurs
    monadiques peuvent aider (même si c'est essentiellement
    une affaire de goût). *)

Definition option_bind {A} (o:option A) (f : A -> step_result) :=
  match o with
    | None => Bug
    | Some x => f x
  end.

Infix ">>=" := option_bind (at level 20, left associativity).

Definition list_bind {A} (l:list A) (f:A->list A->step_result) :=
 match l with
  | nil => Bug
  | x::l => f x l
 end.

Infix "::>" := list_bind (at level 20, left associativity).

(** Un pas de calcul *)

Definition step code (m:machine) : step_result :=
  let '(Mach pc stk vars) := m in
  (** réponse usuelle: *)
  let more := fun stk vars => More (Mach (S pc) stk vars) in
  match list_get code pc with
    | None => Stop m
    | Some instr => match instr with
      | Push n => more (n::stk) vars
      | Pop => TODO
      | Op o => TODO
      | NewVar => TODO
      | DelVar => TODO
      | GetVar i => TODO
      | SetVar i => TODO
      | Jump off => TODO
      end
    end.

(** La fonction [steps] itère [step] un nombre [count] de fois
    (ou moins si [Stop _] ou [Bug] sont atteints). *)

Fixpoint steps count (code:list instr)(m:machine) :=
  match count with
    | 0 => More m
    | S count' => TODO
  end.

(** La function [run] exécute un certain code à partir
    de la machine initiale, puis extrait le résultat obtenu.
    On répond [None] si le calcul n'est pas fini au bout
    des [count] étapes indiquées, ou bien en cas d'anomalies
    lors de l'exécution ou à la fin (p.ex. pile finale vide,
    variables finales non vides, etc). *)

Definition run (count:nat)(code : list instr) : option nat :=
  TODO.

Compute (run 1000 (compile test1)). (* attendu: Some 385 *)
Compute (run 1000 (compile test2)). (* attendu: Some 1705 *)

(** Equivalence entre sémantiques *)

(** TODO: dans cette partie, à vous de formuler les
    lemmes intermédiaires. *)

Lemma run_equiv code res :
 Run code res <-> exists count, run count code = Some res.
Proof.
Admitted.

(** Le theorème principal, formulé pour run *)

Theorem run_compile e :
 Closed e ->
 exists count, run count (compile e) = Some (eval nil e).
Proof.
Admitted.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf4 : natural) (lf2 : natural) : natural := plus lf2 lf4.


(** * Maps: Total and Partial Maps *)

(** Maps (or dictionaries) are ubiquitous data structures, both in
    software construction generally and in the theory of programming
    languages in particular; we're going to need them in many places
    in the coming chapters.  They also make a nice case study using
    ideas we've seen in previous chapters, including building data
    structures out of higher-order functions (from [Basics] and
    [Poly]) and the use of reflection to streamline proofs (from
    [IndProp]).

    We'll define two flavors of maps: _total_ maps, which include a
    "default" element to be returned when a key being looked up
    doesn't exist, and _partial_ maps, which return an [option] to
    indicate success or failure.  The latter is defined in terms of
    the former, using [None] as the default element. *)

(* ###################################################################### *)
(** * The Coq Standard Library *)

(** One small digression before we start.

    Unlike the chapters we have seen so far, this one does not
    [Require Import] the chapter before it (and, transitively, all the
    earlier chapters).  Instead, in this chapter and from now, on
    we're going to import the definitions and theorems we need
    directly from Coq's standard library stuff.  You should not notice
    much difference, though, because we've been careful to name our
    own definitions and theorems the same as their counterparts in the
    standard library, wherever they overlap. *)

Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Logic.FunctionalExtensionality.

(** Documentation for the standard library can be found at
    http://coq.inria.fr/library/.

    The [SearchAbout] command is a good way to look for theorems
    involving objects of specific types. *)

(* ###################################################################### *)
(** * Identifiers *)

(** First, we need a type for the keys that we use to index into our
    maps.  For this purpose, we again use the type [id] from the
    [Lists] chapter.  To make this chapter self contained, we repeat
    its definition here, together with the equality comparison
    function for [id]s and its fundamental property. *)

Inductive id : Type :=
  | Id : nat -> id.

Definition beq_id id1 id2 :=
  match id1,id2 with
    | Id n1, Id n2 => beq_nat n1 n2
  end.

Theorem beq_id_refl : forall id, true = beq_id id id.
Proof.
  intros [n]. simpl. rewrite <- beq_nat_refl.
  reflexivity. Qed.

(** The following useful property of [beq_id] follows from an
    analogous lemma about numbers: *)

Theorem beq_id_true_iff : forall id1 id2 : id,
  beq_id id1 id2 = true <-> id1 = id2.
Proof.
   intros [n1] [n2].
   unfold beq_id.
   rewrite beq_nat_true_iff.
   split.
   - (* -> *) intros H. rewrite H. reflexivity.
   - (* <- *) intros H. inversion H. reflexivity.
Qed.

(** Similarly: *)

Theorem beq_id_false_iff : forall x y : id,
  beq_id x y = false
  <-> x <> y.
Proof.
  intros x y. rewrite <- beq_id_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

(** This useful variant follows just by rewriting: *)

Theorem false_beq_id : forall x y : id,
   x <> y
   -> beq_id x y = false.
Proof.
  intros x y. rewrite beq_id_false_iff.
  intros H. apply H. Qed.

(* ###################################################################### *)
(** * Total Maps *)

(** Our main job in this chapter will be to build a definition of
    partial maps that is similar in behavior to the one we saw in the
    [Lists] chapter, plus accompanying lemmas about their behavior.

    This time around, though, we're going to use _functions_, rather
    than lists of key-value pairs, to build maps.  The advantage of
    this representation is that it offers a more _extensional_ view of
    maps, where two maps that respond to queries in the same way will
    be represented as literally the same thing (the same function),
    rather than just "equivalent" data structures.  This, in turn,
    simplifies proofs that use maps.

    We build partial maps in two steps.  First, we define a type of
    _total maps_ that return a default value when we look up a key
    that is not present in the map. *)

Definition total_map (A:Type) := id -> A.

(** Intuitively, a total map over an element type [A] _is_ just a
    function that can be used to look up [id]s, yielding [A]s.

    The function [t_empty] yields an empty total map, given a default
    element; this map always returns the default element when applied
    to any id. *)

Definition t_empty {A:Type} (v : A) : total_map A :=
  (fun _ => v).

(** More interesting is the [update] function, which (as before) takes
    a map [m], a key [x], and a value [v] and returns a new map that
    takes [x] to [v] and takes every other key to whatever [m] does. *)

Definition t_update {A:Type} (m : total_map A)
                    (x : id) (v : A) :=
  fun x' => if beq_id x x' then v else m x'.

(** This definition is a nice example of higher-order programming.
    The [t_update] function takes a _function_ [m] and yields a new
    function [fun x' => ...] that behaves like the desired map.

    For example, we can build a map taking [id]s to [bool]s, where [Id
    3] is mapped to [true] and every other key is mapped to [false],
    like this: *)

Definition examplemap :=
  t_update (t_update (t_empty false) (Id 1) false)
           (Id 3) true.

(** This completes the definition of total maps.  Note that we don't
    need to define a [find] operation because it is just function
    application! *)

Example update_example1 : examplemap (Id 0) = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap (Id 1) = false.
Proof. reflexivity. Qed.

Example update_example3 : examplemap (Id 2) = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap (Id 3) = true.
Proof. reflexivity. Qed.

(** To use maps in later chapters, we'll need several fundamental
    facts about how they behave.  Even if you don't work the following
    exercises, make sure you thoroughly understand the statements of
    the lemmas!  (Some of the proofs require the functional
    extensionality axiom discussed in the [Logic] chapter, which is
    also included in the standard library.) *)

(** **** Exercise: 2 stars, optional (t_update_eq)  *)
(** First, if we update a map [m] at a key [x] with a new value [v]
    and then look up [x] in the map resulting from the [update], we
    get back [v]: *)

Lemma t_update_eq : forall A (m: total_map A) x v,
  (t_update m x v) x = v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_neq)  *)
(** On the other hand, if we update a map [m] at a key [x1] and then
    look up a _different_ key [x2] in the resulting map, we get the
    same result that [m] would have given: *)

Theorem t_update_neq : forall (X:Type) v x1 x2
                         (m : total_map X),
  x1 <> x2 ->
  (t_update m x1 v) x2 = m x2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_shadow)  *)
(** If we update a map [m] at a key [x] with a value [v1] and then
    update again with the same key [x] and another value [v2], the
    resulting map behaves the same (gives the same result when applied
    to any key) as the simpler map obtained by performing just
    the second [update] on [m]: *)

Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
    t_update (t_update m x v1) x v2
  = t_update m x v2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** For the final two lemmas about total maps, it's convenient to use
    the reflection idioms introduced in chapter [IndProp].  We begin
    by proving a fundamental _reflection lemma_ relating the equality
    proposition on [id]s with the boolean function [beq_id]. *)

(** **** Exercise: 2 stars (beq_idP)  *)
(** Use the proof of [beq_natP] in chapter [IndProp] as a template to
    prove the following: *)

Lemma beq_idP : forall x y, reflect (x = y) (beq_id x y).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Now, given [id]s [x1] and [x2], we can use the [destruct (beq_idP
    x1 x2)] to simultaneously perform case analysis on the result of
    [beq_id x1 x2] and generate hypotheses about the equality (in the
    sense of [=]) of [x1] and [x2]. *)

(** **** Exercise: 2 stars (t_update_same)  *)
(** Using the example in chapter [IndProp] as a template, use
    [beq_idP] to prove the following theorem, which states that if we
    update a map to assign key [x] the same value as it already has in
    [m], then the result is equal to [m]: *)

Theorem t_update_same : forall X x (m : total_map X),
  t_update m x (m x) = m.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, recommended (t_update_permute)  *)
(** Use [beq_idP] to prove one final property of the [update]
    function: If we update a map [m] at two distinct keys, it doesn't
    matter in which order we do the updates. *)

Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2
                             (m : total_map X),
  x2 <> x1 ->
    (t_update (t_update m x2 v2) x1 v1)
  = (t_update (t_update m x1 v1) x2 v2).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** * Partial maps *)

(** Finally, we define _partial maps_ on top of total maps.  A partial
    map with elements of type [A] is simply a total map with elements
    of type [option A] and default element [None]. *)

Definition partial_map (A:Type) := total_map (option A).

Definition empty {A:Type} : partial_map A :=
  t_empty None.

Definition update {A:Type} (m : partial_map A)
                  (x : id) (v : A) :=
  t_update m x (Some v).

(** We can now lift all of the basic lemmas about total maps to
    partial maps.  *)

Lemma update_eq : forall A (m: partial_map A) x v,
  (update m x v) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (X:Type) v x1 x2
                       (m : partial_map X),
  x2 <> x1 ->
  (update m x2 v) x1 = m x1.
Proof.
  intros X v x1 x2 m H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall A (m: partial_map A) v1 v2 x,
  update (update m x v1) x v2 = update m x v2.
Proof.
  intros A m v1 v2 x1. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall X v x (m : partial_map X),
  m x = Some v ->
  update m x v = m.
Proof.
  intros X v x m H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (X:Type) v1 v2 x1 x2
                                (m : partial_map X),
  x2 <> x1 ->
    (update (update m x2 v2) x1 v1)
  = (update (update m x1 v1) x2 v2).
Proof.
  intros X v1 v2 x1 x2 m. unfold update.
  apply t_update_permute.
Qed.

(** $Date: 2015-12-11 17:17:29 -0500 (Fri, 11 Dec 2015) $ *)


(** Proof for the fact that square root of 2 is irrational. **)

Require Import Reals.Reals.
Require Import Bool.
(* Require Import Natural.Peano.NPeano.
*)

(* Count tailing zeros for positive type. *)
Fixpoint ctz_Pos (x : positive) : nat :=
  match x with
    | xH   => O                            (* 1 *)
    | xO t => S (ctz_Pos t)   (* t ~ 0 *)
    | xI t => O                            (* t ~ 1 *)
  end.

(* Lift to Z. *)
Definition ctz_Z (x : Z) : nat :=
  match x with
    | Z0     => O
    | Zpos t => ctz_Pos t
    | Zneg t => ctz_Pos t
  end.

(* If x = a * 2^k, then 2*x = a * 2^(k+1). *)
Lemma double_inc_ctz :
  forall x, (x <> 0%Z) -> ctz_Z (2 * x) = S (ctz_Z x).
Proof.
  destruct x; intuition || intro; reflexivity.
Qed.

(* For a suqare number, even_repeat(x) must be even. *)
Lemma square_ctz_even :
  forall x : Z, Nat.even (ctz_Z (x * x)) = true.
Proof.
  (* At first, prove the positive case. *)
  assert (hypothesis_positive : forall k : positive, Nat.even (ctz_Pos (k * k)) = true).
  + induction k.
    - reflexivity.
    - simpl; rewrite Pos.mul_comm; simpl; assumption.
    - reflexivity.
  + destruct x; simpl; rewrite hypothesis_positive || idtac; reflexivity.
Qed.

Lemma cannot_both_even :
  forall x, Nat.even x = negb (Nat.even (S x)).
Proof.
  induction x.
  + reflexivity.
  + simpl (Nat.even (S (S x))).
    rewrite IHx; rewrite negb_involutive; reflexivity.
Qed.

Lemma sqrt_mult_sqrt_eq_n :
  forall x : R, (0 <= x)%R -> (sqrt x * sqrt x)%R = x.
Proof.
  apply sqrt_def.
Qed.

Definition irrational (x : R) : Prop :=
  ~ exists p q : Z, (q > 0)%Z /\ (IZR p / IZR q)%R = x.

Theorem sqrt_2_irrational :
  irrational (sqrt 2%R)%R.
Proof.
  unfold irrational.
  (* Get two hypotheses, and now we need to find the contradiction (proof "False"). *)
  intros [p [q [q_gt_0_Z p'q_eq_sqrt_2_R]]].

  (* To be proved: "p*p = 2*q*q". *)

  assert (q_gt_0_R : (IZR q > 0)%R).
    replace 0%R with (IZR 0).
    apply Rlt_gt; apply IZR_lt; auto with zarith.
    reflexivity.

  assert (p_eq_sqrt_2_q_R : (IZR p = sqrt 2 * IZR q)%R).
    rewrite <- p'q_eq_sqrt_2_R.
    field; apply Rgt_not_eq; apply q_gt_0_R.

  assert (pp_eq_2qq_R : (IZR p * IZR p = (sqrt 2 * IZR q) * (sqrt 2 * IZR q))%R).
    rewrite <- p_eq_sqrt_2_q_R; reflexivity. (* Or use "congruence". *)

  assert (pp_eq_2qq_Z : (p * p = 2 * q * q)%Z).
    replace ((sqrt 2 * IZR q) * (sqrt 2 * IZR q))%R
      with ((sqrt 2 * sqrt 2) * IZR q * IZR q)%R
      in pp_eq_2qq_R
      by ring.
    rewrite sqrt_def in pp_eq_2qq_R
      by auto with real.
    replace 2%R with (IZR 2) in pp_eq_2qq_R
      by reflexivity.
    repeat rewrite <- mult_IZR in pp_eq_2qq_R.
    apply eq_IZR; assumption.

  (* Counting tailing zeros for "p*p" and "q*q". *)

  assert (ctz_p : Nat.even (ctz_Z (p * p)) = true).
    apply square_ctz_even.
  assert (ctz_q : Nat.even (ctz_Z (q * q)) = true).
    apply square_ctz_even.

  assert (ctz_p_eq_S_ctz_q : ctz_Z (p*p) = S (ctz_Z (q * q))).
    rewrite <- double_inc_ctz.
    rewrite pp_eq_2qq_Z; rewrite Z.mul_assoc; reflexivity.
    assert (q*q > 0)%Z.
      auto with zarith.
    auto with zarith.

  rewrite ctz_p_eq_S_ctz_q in ctz_p.
  rewrite cannot_both_even in ctz_q.
  rewrite ctz_p in ctz_q; inversion ctz_q.
Qed.


Require Export Subbases.
Require Export Relation_Definitions_Implicit.
Require Export SeparatednessAxioms.

Section OrderTopology.

Variable X:Type.
Variable R:relation X.
Hypothesis R_ord: order R.

Inductive order_topology_subbasis : Family X :=
  | intro_lower_interval: forall x:X, In order_topology_subbasis [ y:X | R y x /\ y <> x ]
  | intro_upper_interval: forall x:X, In order_topology_subbasis [ y:X | R x y /\ y <> x ].

Definition OrderTopology : TopologicalSpace :=
  Build_TopologicalSpace_from_subbasis X order_topology_subbasis.

Section if_total_order.

Hypothesis R_total: forall x y:X, R x y \/ R y x.

Lemma lower_closed_interval_closed: forall x:X,
  closed [ y:X | R y x ] (X:=OrderTopology).
Proof.
intro.
red.
match goal with |- open ?U => cut (U = interior U) end.
intro.
rewrite H; apply interior_open.
apply Extensionality_Ensembles; split.
2:apply interior_deflationary.
intros y ?.
red in H.
red in H.
assert (R x y).
destruct (R_total x y); trivial.
contradiction H.
constructor; trivial.
exists ([z:X | R x z /\ z <> x]).
constructor; split.
apply (Build_TopologicalSpace_from_subbasis_subbasis
  _ order_topology_subbasis).
constructor.
red; intros z ?.
destruct H1.
destruct H1.
intro.
destruct H3.
contradiction H2.
apply (ord_antisym R_ord); trivial.
constructor.
split; trivial.
intro.
contradiction H.
constructor.
destruct H1; apply (ord_refl R_ord).
Qed.

Lemma upper_closed_interval_closed: forall x:X,
  closed [y:X | R x y] (X:=OrderTopology).
Proof.
intro.
red.
match goal with |- open ?U => cut (U = interior U) end.
intro.
rewrite H; apply interior_open.
apply Extensionality_Ensembles; split.
2:apply interior_deflationary.
intros y ?.
red in H.
red in H.
assert (R y x).
destruct (R_total x y); trivial.
contradiction H.
constructor; trivial.
exists ([z:X | R z x /\ z <> x]).
constructor; split.
apply (Build_TopologicalSpace_from_subbasis_subbasis
  _ order_topology_subbasis).
constructor.
red; intros z ?.
destruct H1.
destruct H1.
intro.
destruct H3.
contradiction H2.
apply (ord_antisym R_ord); trivial.
constructor.
split; trivial.
intro.
contradiction H.
constructor.
destruct H1; apply (ord_refl R_ord).
Qed.

Lemma order_topology_Hausdorff: Hausdorff OrderTopology.
Proof.
red.
match goal with |- forall x y:point_set OrderTopology, ?P =>
  cut (forall x y:point_set OrderTopology, R x y -> P)
  end.
intros.
destruct (R_total x y).
exact (H x y H1 H0).
assert (y <> x).
auto.
destruct (H y x H1 H2) as [V [U [? [? [? []]]]]].
exists U; exists V; repeat split; trivial.
transitivity (Intersection V U); trivial.
apply Extensionality_Ensembles; split; red; intros.
destruct H8; constructor; trivial.
destruct H8; constructor; trivial.

intros.
pose proof (Build_TopologicalSpace_from_subbasis_subbasis
  _ order_topology_subbasis).
destruct (classic (exists z:X, R x z /\ R z y /\ z <> x /\ z <> y)).
destruct H2 as [z [? [? []]]].
exists ([w:X | R w z /\ w <> z]);
exists ([w:X | R z w /\ w <> z]).
repeat split; trivial.
apply H1.
constructor.
apply H1.
constructor.
auto.
auto.
apply Extensionality_Ensembles; split; red; intros.
destruct H6.
destruct H6.
destruct H7.
destruct H6.
destruct H7.
contradiction H8.
apply (ord_antisym R_ord); trivial.
destruct H6.

exists ([w:X | R w y /\ w <> y]);
exists ([w:X | R x w /\ w <> x]).
repeat split.
apply H1.
constructor.
apply H1.
constructor.
trivial.
trivial.
trivial.
auto.
apply Extensionality_Ensembles; split; red; intros.
destruct H3.
destruct H3.
destruct H4.
destruct H3.
destruct H4.
contradiction H2.
exists x0; repeat split; trivial.
destruct H3.
Qed.

End if_total_order.

End OrderTopology.

Arguments OrderTopology [X].