Require Export SpecSyntax.
Require Export BoilerplateFunctions.
Set Implicit Arguments.

(*************************************************************************)
(* Reduction relation                                                    *)
(*************************************************************************)

Fixpoint Value (t : Tm) : Prop :=
  match t with
    | tt       => True
    | abs _ _  => True
    | prod x y => Value x ∧ Value y
    | _        => False
  end.

Inductive Match : Pat → Tm → Tm → Tm → Prop :=
  | M_Var {T v t} :
      Match (pvar T) v t (substTm 0 v t)
  | M_Prod {p1 p2 v1 v2 t t' t''} :
      Match p2 (weakenTm v2 (bindPat p1)) t t' →
      Match p1 v1 t' t'' →
      Match (pprod p1 p2) (prod v1 v2) t t''.

Inductive red : Tm → Tm → Prop :=
  | appabs {T11 t12 t2} :
      Value t2 → red (app (abs T11 t12) t2) (substTm 0 t2 t12)
  | appfun {t1 t1' t2} :
      red t1 t1' → red (app t1 t2) (app t1' t2)
  | apparg {t1 t2 t2'} :
      Value t1 → red t2 t2' → red (app t1 t2) (app t1 t2')
  | prodl {t1 t1' t2} :
      red t1 t1' → red (prod t1 t2) (prod t1' t2)
  | prodr {t1 t2 t2'} :
      Value t1 → red t2 t2' → red (prod t1 t2) (prod t1 t2')
  | lettp {p t1 t1' t2} :
      red t1 t1' → red (lett p t1 t2) (lett p t1' t2)
  | lettv {p t1 t3 t2} :
      Value t1 → Match p t1 t2 t3 → red (lett p t1 t2) t3.

(******************************************************************************)
(* Typing relation.                                                           *)
(******************************************************************************)

Inductive PTyping (Γ: Env) : Pat → Ty → Ext → Prop :=
  | P_Var {T} :
      PTyping Γ (pvar T) T (exvar exempty T)
  | P_Prod {p1 p2 T1 T2 Δ1 Δ2} :
      PTyping Γ p1 T1 Δ1 → PTyping (extend Γ Δ1) p2 T2 Δ2 →
      PTyping Γ (pprod p1 p2) (tprod T1 T2) (append Δ1 Δ2).

Inductive Typing (Γ: Env) : Tm → Ty → Prop :=
  | T_Var {y T} :
      lookup_evar Γ y T → Typing Γ (var y) T
  | T_Unit :
      Typing Γ tt tunit
  | T_Abs {t T1 T2} :
      Typing (evar Γ T1) t T2 →
      Typing Γ (abs T1 t) (tarr T1 T2)
  | T_App {t1 t2 T11 T12} :
      Typing Γ t1 (tarr T11 T12) → Typing Γ t2 T11 →
      Typing Γ (app t1 t2) T12
  | T_Prod {t1 T1 t2 T2} :
      Typing Γ t1 T1 → Typing Γ t2 T2 →
      Typing Γ (prod t1 t2) (tprod T1 T2)
  | T_Let {p t1 t2 T1 T2 Δ} :
      Typing Γ t1 T1 → PTyping Γ p T1 Δ →
      Typing (extend Γ Δ) t2 T2 →
      Typing Γ (lett p t1 t2) T2.
Arguments T_Unit {Γ}.


Require Import Rbase MyRIneq.
Require Import Rsequence_def Rsequence_facts Rsequence_cv_facts.

Require Import List.
Require Import Option.
Require Import Tactics.

(* Reifications of sequences, limits and being the limit of a
   particular sequence. *)

Inductive rseq :=
  | rseq_cst   : forall (r : R), rseq
  | rseq_var   : forall (n : nat), rseq
  | rseq_opp   : forall (r : rseq), rseq
  | rseq_plus  : forall (rl rr : rseq), rseq
  | rseq_minus : forall (rl rr : rseq), rseq.

Inductive rseq_limit :=
  | minus_inf : rseq_limit
  | finite : forall (l : R), rseq_limit
  | plus_inf : rseq_limit.

Definition is_limit r l := match l with
  | minus_inf => Rseq_cv_neg_infty r
  | finite l => Rseq_cv r l
  | plus_inf => Rseq_cv_pos_infty r
end.

(* Two extensionally equal sequences have the same limit. *)

Lemma is_limit_ext : forall r s k l,
  is_limit r k ->
  r == s -> k = l ->
  is_limit s l.
Proof.
intros r s k [] Hrk Hrs Hkl ;
 [ eapply Rseq_cv_neg_infty_eq_compat
 | eapply Rseq_cv_eq_compat ; [symmetry |]
 | eapply Rseq_cv_pos_infty_eq_compat ]
 ; subst ; eassumption.
Qed.

Definition Rseq_with_limit := {r : Rseq & {l : rseq_limit | is_limit r l}}.

Definition rseq_limit_opp l := match l with
  | minus_inf => plus_inf
  | finite u  => finite (- u)
  | plus_inf  => minus_inf
end.

Lemma rseq_limit_opp_is_limit : forall r l,
  is_limit r l ->
  is_limit (- r) (rseq_limit_opp l).
Proof.
intros r [] Hl ; simpl ;
 [ apply Rseq_cv_neg_infty_opp_compat
 | apply Rseq_cv_opp_compat
 | apply Rseq_cv_pos_infty_opp_compat] ;
 assumption.
Qed.

Definition rseq_limit_add ll lr := match ll, lr with
  | minus_inf, plus_inf  => None
  | plus_inf , minus_inf => None
  | minus_inf, _         => Some minus_inf
  | _        , minus_inf => Some minus_inf
  | plus_inf , _         => Some plus_inf
  | _        , plus_inf  => Some plus_inf
  | finite u , finite v  => Some (finite (u + v))
end.

Fixpoint comp_limit (r : rseq) (env : list Rseq_with_limit) : option rseq_limit :=
match r with
  | rseq_cst r => Return (finite r)
  | rseq_var n => Bind (nth_error env n) (fun x => Return (proj1_sig (projT2 x)))
  | rseq_opp r => Bind (comp_limit r env) (fun l => Some (rseq_limit_opp l))
  | rseq_plus rl rr => Bind (comp_limit rl env) (fun ll =>
                       Bind (comp_limit rr env) (fun lr => rseq_limit_add ll lr))
  | rseq_minus rl rr => Bind (comp_limit rl env) (fun ll =>
                        Bind (comp_limit rr env) (fun lr => rseq_limit_add ll (rseq_limit_opp lr)))
end.

Fixpoint comp_rseq (r : rseq) (env : list Rseq_with_limit) := match r with
  | rseq_cst r => Return (Rseq_constant r)
  | rseq_var n => Bind (nth_error env n) (fun un => Some (projT1 un))
  | rseq_opp r => Bind (comp_rseq r env) (fun un => Some (Rseq_opp un))
  | rseq_plus rl rr => Bind (comp_rseq rl env) (fun un =>
                       Bind (comp_rseq rr env) (fun vn => Some (Rseq_plus un vn)))
  | rseq_minus rl rr => Bind (comp_rseq rl env) (fun un =>
                       Bind (comp_rseq rr env) (fun vn => Some (Rseq_minus un vn)))
end.

Ltac fold_is_limit := match goal with
  | |- Rseq_cv ?r ?l => fold (is_limit r (finite l))
  | |- Rseq_cv_neg_infty ?r => fold (is_limit r minus_inf)
  | |- Rseq_cv_pos_infty ?r => fold (is_limit r plus_inf)
end.

Lemma comp_rseq_limit_compat : forall r env un l,
  comp_rseq r env = Some un ->
  comp_limit r env = Some l ->
  is_limit un l.
Proof.
intros r env ; induction r ; intros un l Hun Hl ; simpl in *.
 inversion Hun ; inversion Hl ; apply Rseq_constant_cv.
 destruct (nth_error env n) as [Hget |].
  inversion Hun ; inversion Hl ; apply (proj2_sig (projT2 Hget)).
  inversion Hl.
 destruct (comp_rseq r env) as [vn |] ; [| inversion Hun] ;
  destruct (comp_limit r env) as [lo |] ; [| inversion Hl] ;
  inversion Hun ; inversion Hl.
  apply rseq_limit_opp_is_limit, IHr ; reflexivity.
 destruct (comp_rseq r1 env) as [vn |] ; [| inversion Hun] ;
  destruct (comp_limit r1 env) as [ll |] ; [| inversion Hl] ;
  destruct (comp_rseq r2 env) as [wn |] ; [| inversion Hun] ;
  destruct (comp_limit r2 env) as [lr |] ; [| inversion Hl].
   destruct ll ; destruct lr ; inversion Hun ; inversion Hl ;
   subst.
    apply Rseq_cv_neg_infty_plus_compat ; fold_is_limit ;
     [apply IHr1 | apply IHr2] ; reflexivity.
    eapply Rseq_cv_finite_plus_neg_infty_l ; fold_is_limit ;
     [apply IHr1 | apply IHr2] ; reflexivity.
    eapply Rseq_cv_finite_plus_neg_infty_r ; fold_is_limit ;
     [apply IHr1 | apply IHr2] ; reflexivity.
    eapply Rseq_cv_plus_compat ; fold_is_limit ;
     [apply IHr1 | apply IHr2] ; reflexivity.
    eapply Rseq_cv_finite_plus_pos_infty_r ; fold_is_limit ;
     [apply IHr1 | apply IHr2] ; reflexivity.
    eapply Rseq_cv_finite_plus_pos_infty_l ; fold_is_limit ;
     [apply IHr1 | apply IHr2] ; reflexivity.
    apply Rseq_cv_pos_infty_plus_compat ; fold_is_limit ;
     [apply IHr1 | apply IHr2] ; reflexivity.
 destruct (comp_rseq r1 env) as [vn |] ; [| inversion Hun] ;
  destruct (comp_limit r1 env) as [ll |] ; [| inversion Hl] ;
  destruct (comp_rseq r2 env) as [wn |] ; [| inversion Hun] ;
  destruct (comp_limit r2 env) as [lr |] ; [| inversion Hl].
   inversion Hun ; eapply (is_limit_ext (Rseq_plus vn (Rseq_opp wn))) ;
    [| intro n ; unfold Rseq_plus, Rseq_minus, Rseq_opp ; ring | reflexivity].
   destruct ll ; destruct lr ; inversion Hl ; subst.
    apply Rseq_cv_finite_plus_neg_infty_l with (- l0)%R ; fold_is_limit ;
     [apply IHr1 | fold (rseq_limit_opp (finite l0)) ;
     apply rseq_limit_opp_is_limit, IHr2] ; reflexivity.
    apply Rseq_cv_neg_infty_plus_compat ; fold_is_limit ;
     [apply IHr1 | fold (rseq_limit_opp plus_inf) ;
     apply rseq_limit_opp_is_limit, IHr2] ; reflexivity.
    apply Rseq_cv_finite_plus_pos_infty_r with l0 ; fold_is_limit ;
     [apply IHr1 | fold (rseq_limit_opp minus_inf) ;
     apply rseq_limit_opp_is_limit, IHr2] ; reflexivity.
    apply Rseq_cv_plus_compat ; fold_is_limit ;
     [apply IHr1 | fold (rseq_limit_opp (finite l1)) ;
     apply rseq_limit_opp_is_limit, IHr2] ; reflexivity.
    eapply Rseq_cv_finite_plus_neg_infty_r ; fold_is_limit ;
     [apply IHr1 | fold (rseq_limit_opp plus_inf) ;
     apply rseq_limit_opp_is_limit, IHr2] ; reflexivity.
    apply Rseq_cv_pos_infty_plus_compat ; fold_is_limit ;
     [apply IHr1 | fold (rseq_limit_opp minus_inf) ;
     apply rseq_limit_opp_is_limit, IHr2] ; reflexivity.
    apply Rseq_cv_finite_plus_pos_infty_l with (- l0)%R ; fold_is_limit ;
     [apply IHr1 | fold (rseq_limit_opp (finite l0)) ;
     apply rseq_limit_opp_is_limit, IHr2] ; reflexivity.
Qed.

Definition rseq_precondition r env un l :=
match comp_rseq r env with
  | None    => False
  | Some vn =>
  match comp_limit r env with
    | None => False
    | Some v => (un == vn) /\ (l = v)
  end
end.

Lemma tactic_correctness : forall r env un l,
   rseq_precondition r env un l ->
   is_limit un l.
Proof.
unfold rseq_precondition ; intros r env un l ;
 destruct (comp_rseq r env) eqn:E; symmetry in E;
 destruct (comp_limit r env) eqn:E'; symmetry in E';
 intros [].
 intros ; eapply is_limit_ext ;
  [ eapply comp_rseq_limit_compat | |] ;
  symmetry ; eassumption.
Qed.

(*

Section Test.

Ltac add_var v l :=
  let rec aux v l n := match l with
    | nil       => constr: (n , v :: nil)
    | v  :: _   => constr: (n , l)
    | ?a :: ?tl => match aux v tl (S n) with | (?m , ?tl') => constr: (m , cons a tl') end
    end in
  aux v l O.

Ltac known_limit An := match goal with
  | [ H: is_limit An ?a |- _ ] => constr: (Some (An , a , H))
  | _                          => constr: (None  )
end.

Ltac reify_rseq_aux f l := match f with
  | Rseq_constant ?v  => constr: (rseq_cst v , l)
  | Rseq_opp  ?un     =>
        match reify_rseq_aux un l  with | (?UN , ?l1) => constr: (rseq_opp UN , l1) end
  | Rseq_plus ?un ?vn =>
        match reify_rseq_aux un l  with | (?UN , ?l1) =>
        match reify_rseq_aux vn l1 with | (?VN , ?l2) => constr: (rseq_plus UN VN , l2) end end
  | Rseq_minus ?un ?vn =>
        match reify_rseq_aux un l  with | (?UN , ?l1) =>
        match reify_rseq_aux vn l1 with | (?VN , ?l2) => constr: (rseq_minus UN VN , l2) end end
  | ?An =>
        match known_limit An with | None => fail | Some ?a =>
        match add_var a l with | (?A , ?l1) => constr: (rseq_var A , l1) end end
end.

Check tactic_correctness.

Ltac reify_rseq := match goal with
  | |- Rseq_cv ?f ?l =>
        match reify_rseq_aux f (@nil Rseq_with_limit) with | (?r , ?env) =>
        change (is_limit f (finite l)) end end.

Variable Un Vn : Rseq.
Variable u  v  : R.

Hypothesis Un_cv : Rseq_cv Un u.
Hypothesis Vn_cv : Rseq_cv Vn v.

Goal Rseq_cv Un u.
Proof.
fold (is_limit Un (finite u)) in *.
fold (is_limit Vn (finite v)) in *.
reify_rseq.
  apply (tactic_correctness (rseq_var 0) (Un :: nil) Un (finite u)).

  with (r := r) (env := env)
 eapply tactic_correctness.
*)


(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
From mathcomp Require Import all_ssreflect ssralg finalg poly polydiv.
From mathcomp Require Import cyclic perm matrix mxpoly vector mxalgebra zmodp.
From mathcomp Require Import finfield falgebra fieldext.
Require Import ssr_ext ssralg_ext vandermonde linearcode.
Require Import dft poly_decoding grs bch.

(******************************************************************************)
(*            Work in progress about alternant and Goppa codes                *)
(******************************************************************************)

(* OUTLINE:
- Section location_polynomial.
- Section grs_polynomial.
- Section injection_into_extension_field.
- Section alternant_code.
- Section narrow_sense_BCH_are_Goppa. (wip)
*)

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

Import GRing.Theory.
Local Open Scope ring_scope.

Local Open Scope vec_ext_scope.

Section location_polynomial.

Variables (n : nat) (F : finFieldType) (a : 'rV[F]_n).

(** the values of the location polynomial at points a``_i,
   they determine uniquely the location polynomial of size n (i.e., deg <= n.-1) *)
Definition location_polynomial_points :=
  \row_i \prod_(j < n | j != i) (a ``_ i - a ``_ j).

End location_polynomial.

(* NB: the notation GRS_k(kappa, g) in the classification book *)
Section grs_polynomial.

Variables (n : nat) (F : finFieldType) (a : 'rV[F]_n).
Variable g : {poly F}.
Let b := \row_(i < n) (((location_polynomial_points a) ``_ i)^-1 * g.[a ``_ i]).
Variable (r : nat).

Definition GRS_PCM_polynomial := @GRS.PCM _ F a b r.

End grs_polynomial.

Section injection_into_extension_field.

Variables (F0 : finFieldType) (F1 : fieldExtType F0).

Definition ext_inj : {rmorphism F0 -> F1} := @GRing.in_alg_rmorphism F0 F1.

Definition ext_inj_tmp : {rmorphism F0 -> (FinFieldExtType F1)} := ext_inj.

Variable n : nat.

Definition ext_inj_rV : 'rV[F0]_n -> 'rV[F1]_n := @map_mx _ _ ext_inj 1 n.

End injection_into_extension_field.

Section alternant_code.

(** declare F_q *)
Variable p u' : nat.
Let u := u'.+1.
Hypothesis primep : prime p.

Let Fq : finFieldType := GF u primep.
Let q := p ^ u.
Let p_char : p \in [char Fq].
Proof. apply char_GFqm. Qed.

(** declare F_{q^m} *)
Variable m' : nat.
Let m := m'.+1.
Variable Fqm : fieldExtType Fq.
Hypothesis card_Fqm : #| FinFieldExtType Fqm | = q ^ m.

(** build GRS_k(kappa, g) *)
Variable n : nat.
Variable a : 'rV[Fqm]_n.
Variable g : {poly Fqm}.
Variable k : nat.

Definition alternant_PCM : 'M_(k, n) := @GRS_PCM_polynomial n (FinFieldExtType Fqm) a g k.

Definition alternant_code := Rcode.t (@ext_inj_tmp Fq Fqm) (kernel alternant_PCM).

(** Goppa codes are a special case of alternant codes *)
Definition goppa_code_condition := size g = (n - k).+1.

End alternant_code.

Section narrow_sense_BCH_are_Goppa.

(** declare F_q *)
Variable p u' : nat.
Let u := u'.+1.
Hypothesis primep : prime p.

Let Fq : finFieldType := GF u primep.
Let q := p ^ u.
Let p_char : p \in [char Fq].
Proof. apply char_GFqm. Qed.

(** declare F_{q^m} *)
Variable m' : nat.
Let m := m'.+1.
Variable Fqm : fieldExtType Fq.
Hypothesis card_Fqm : #| FinFieldExtType Fqm | = q ^ m.

(** we are talking about narrow-sense Goppa codes *)
Let n : nat := (q^m).-1.
Variable e : Fqm.
Hypothesis e_prim : n.-primitive_root e.
Let a : 'rV[Fqm]_n := rVexp e n.
Variable t : nat.

(** we have to instantiate Goppa codes with a monomial to recover BCH codes *)
Let g : {poly (FinFieldExtType Fqm)} := 'X^(n - t).

(** from the Goppa code condition, we have only one choice for its degree *)
Let goppa_code_condition_check : goppa_code_condition n g t.
Proof. by rewrite /goppa_code_condition size_polyXn. Qed.

(* NB: we only have binary BCH codes, so we should maybe restrict q at
this point *)

(** wip *)
Lemma narrow_sense_BCH_are_Goppa :
  @BCH.PCM (FinFieldExtType _) _ a t =
  @alternant_PCM _ u' primep Fqm _ a g t(*?*).
Proof.
rewrite /BCH.code /alternant_code.
Abort.

End narrow_sense_BCH_are_Goppa.


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.euclidean_tactics.
Require Import ProofCheckingEuclid.lemma_ABCequalsCBA.
Require Import ProofCheckingEuclid.lemma_NCdistinct.
Require Import ProofCheckingEuclid.lemma_NCorder.
Require Import ProofCheckingEuclid.lemma_betweennotequal.
Require Import ProofCheckingEuclid.lemma_collinearorder.
Require Import ProofCheckingEuclid.lemma_congruencesymmetric.
Require Import ProofCheckingEuclid.lemma_doublereverse.
Require Import ProofCheckingEuclid.lemma_equalanglessymmetric.
Require Import ProofCheckingEuclid.lemma_equalanglestransitive.
Require Import ProofCheckingEuclid.lemma_inequalitysymmetric.
Require Import ProofCheckingEuclid.lemma_layoff.
Require Import ProofCheckingEuclid.lemma_onray_impliescollinear.
Require Import ProofCheckingEuclid.lemma_onray_strict.
Require Import ProofCheckingEuclid.lemma_s_conga.
Require Import ProofCheckingEuclid.lemma_s_inangle.
Require Import ProofCheckingEuclid.lemma_s_ncol_ABD_col_ABC_ncol_ACD.
Require Import ProofCheckingEuclid.lemma_s_ncol_n_col.
Require Import ProofCheckingEuclid.lemma_s_onray_assert_ABB.
Require Import ProofCheckingEuclid.proposition_10.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma proposition_09 :
	forall A B C,
	nCol B A C ->
	exists X, CongA B A X X A C /\ InAngle B A C X.
Proof.
	intros A B C.
	intros nCol_B_A_C.

	pose proof (lemma_NCorder _ _ _ nCol_B_A_C) as (nCol_A_B_C & nCol_A_C_B & _ & _ & _).
	pose proof (lemma_s_ncol_n_col _ _ _ nCol_A_B_C) as n_Col_A_B_C.
	pose proof (lemma_NCdistinct _ _ _ nCol_A_B_C) as (neq_A_B & _ & neq_A_C & _ & _ & _).

	pose proof (lemma_s_onray_assert_ABB _ _ neq_A_B) as OnRay_AB_B.

	pose proof (lemma_layoff _ _ _ _ neq_A_C neq_A_B) as (E & OnRay_AC_E & Cong_AE_AB).

	pose proof (lemma_onray_impliescollinear _ _ _ OnRay_AC_E) as Col_A_C_E.
	pose proof (lemma_onray_strict _ _ _ OnRay_AC_E) as neq_A_E.

	pose proof (lemma_s_ncol_ABD_col_ABC_ncol_ACD _ _ _ _ nCol_A_C_B Col_A_C_E neq_A_E) as nCol_A_E_B.
	pose proof (lemma_NCorder _ _ _ nCol_A_E_B) as (_ & _ & _ & _ & nCol_B_E_A).
	pose proof (lemma_NCdistinct _ _ _ nCol_A_E_B) as (_ & _ & _ & _ & neq_B_E & _).

	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_AE_AB) as Cong_AB_AE.

	pose proof (proposition_10 _ _ neq_B_E) as (F & BetS_B_F_E & Cong_FB_FE).

	pose proof (cn_congruencereflexive A F) as Cong_AF_AF.

	pose proof (lemma_betweennotequal _ _ _ BetS_B_F_E) as (_ & neq_B_F & _).

	assert (Col B F E) as Col_B_F_E by (unfold Col; one_of_disjunct BetS_B_F_E).
	pose proof (lemma_collinearorder _ _ _ Col_B_F_E) as (_ & _ & _ & Col_B_E_F & _).

	pose proof (lemma_s_inangle _ _ _ _ _ _ OnRay_AB_B OnRay_AC_E BetS_B_F_E) as InAngle_BAC_F.

	pose proof (lemma_s_ncol_ABD_col_ABC_ncol_ACD _ _ _ _ nCol_B_E_A Col_B_E_F neq_B_F) as nCol_B_F_A.
	pose proof (lemma_NCorder _ _ _ nCol_B_F_A) as (_ & _ & _ & nCol_B_A_F & _).

	pose proof (lemma_NCdistinct _ _ _ nCol_B_A_F) as (_ & neq_A_F & _ & _ & _ & _).
	pose proof (lemma_s_onray_assert_ABB _ _ neq_A_F) as OnRay_AF_F.

	pose proof (lemma_doublereverse _ _ _ _ Cong_FB_FE) as (Cong_EF_BF & _).
	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_EF_BF) as Cong_BF_EF.

	pose proof (
		lemma_s_conga
		B A F C A F
		_ _ _ _
		OnRay_AB_B
		OnRay_AF_F
		OnRay_AC_E
		OnRay_AF_F
		Cong_AB_AE
		Cong_AF_AF
		Cong_BF_EF
		nCol_B_A_F
	) as CongA_BAF_CAF.

	pose proof (lemma_equalanglessymmetric _ _ _ _ _ _ CongA_BAF_CAF) as CongA_CAF_BAF.
	assert (CongA_CAF_BAF2 := CongA_CAF_BAF).
	destruct CongA_CAF_BAF2 as (_ & _ & _ & _ & _ & _ & _ & _ & _ & _ & _ & nCol_C_A_F).
	pose proof (lemma_ABCequalsCBA _ _ _ nCol_C_A_F) as CongA_CAF_FAC.
	pose proof (lemma_equalanglestransitive _ _ _ _ _ _ _ _ _ CongA_BAF_CAF CongA_CAF_FAC) as CongA_BAF_FAC.

	exists F.
	split.
	exact CongA_BAF_FAC.
	exact InAngle_BAC_F.
Qed.

End Euclid.


Require Export BinInt.
Require Import BinNat.
Require Import Karatsuba.

Definition Zmult x y :=
match x, y with
|Z0, _ => Z0
|_, Z0 => Z0
|(Zpos x'), (Zpos y') => Z_of_N (KaratsubaMult (Npos x') (Npos y'))
|(Zpos x'), (Zneg y') => Zopp (Z_of_N (KaratsubaMult (Npos x') (Npos y')))
|(Zneg x'), (Zpos y') => Zopp (Z_of_N (KaratsubaMult (Npos x') (Npos y')))
|(Zneg x'), (Zneg y') => Z_of_N (KaratsubaMult (Npos x') (Npos y'))
end.

Theorem ZmultCorrect : forall x y, (Zmult x y)=(BinInt.Zmult x y).
Proof.
intros.
destruct x; destruct y; try reflexivity;
simpl;
rewrite KaratsubaMultCorrect;
reflexivity.
Qed.


Require Import ssreflect ssrbool ssrnat fintype.
Set Implicit Arguments.

Record pos := mkPos { n :> nat ; N_pos : (0 < n)%coq_nat }.

Lemma is_pos (p : pos) : 0 < p.
Proof. by case: p=> m pf; apply/ltP. Qed.

Definition i0 (p : pos) : 'I_p := Ordinal (is_pos p).


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.

Definition inter n (bs bs': BITS n) : BITS n := andB bs bs'.

Lemma inter_repr n (bs bs' : BITS n) E E' : repr bs E -> repr bs' E' ->
    repr (inter bs bs') (E :&: E').
Proof. by move=> -> ->; apply/setP => i; rewrite !inE getBit_liftBinOp. Qed.


(*|
####################################
Split conjunction goal into subgoals
####################################

:Link: https://stackoverflow.com/q/43945888
|*)

(*|
Question
********

Consider the following toy exercise:
|*)

Theorem swap_id : forall (m n : nat), m = n -> (m, n) = (n, m).
Proof.
  intros m n H.

(*| At this point I have the following: |*)

  Show. (* .unfold .messages *)
Abort. (* .none *)

(*|
I would like to split the goal into two subgoals, ``m = n`` and ``n =
m``. Is there a tactic which does that?
|*)

(*|
Answer
******

Solve using the `f_equal
<https://coq.inria.fr/refman/Reference-Manual010.html#hevea_tactic169>`__
tactic:
|*)

Theorem test : forall (m n : nat), m = n -> (m, n) = (n, m).
Proof.
  intros m n H. f_equal.

(*| With state: |*)

  Show. (* .unfold .messages *)

(*|
----

**A:** A comment about the reason ``f_equal`` works: if we unfold some
notations, we'll get from the goal ``(m, n) = (n, m)`` to ``pair m n =
pair n m``, where ``pair`` is the only constructor of the ``prod``
datatype. At this point it should be obvious why ``f_equal`` splits
the goal into two subgoals.
|*)


(* Author: Yubo CAI, Junyuan WANG *)
(* CSE203 Logic and Proof Final Project *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect.
(* --------------- *) Import Monoid.

(* -------------------------------------------------------------------- *)
Set   Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set   Printing Projections.
Set   Printing Projections.
Unset SsrOldRewriteGoalsOrder.

(* -------------------------------------------------------------------- *)
Notation "[ 'seq' E | i < n ]" := (mkseq (fun i => E) n)
  (at level 0, E at level 99, i name,
   format "[ 'seq'  E  |  i  <  n ]") : seq_scope.

(* ==================================================================== *)
Lemma mkseqS {T : Type} (f : nat -> T) (n : nat) :
  [seq f i | i < n.+1] = rcons [seq f i | i < n] (f n).
Proof.
by rewrite /mkseq -addn1 iotaD map_cat /= add0n cats1.
Qed.

(* ==================================================================== *)
(* Some extras arithmetic lemmas that are needed later                  *)
Lemma sum_pow2 (n : nat) :
  \sum_(i < n) 2^i = (2^n).-1.
Proof.
elim: n => [|n ih]; first by rewrite big_ord0.
rewrite big_ord_recr //= ih [LHS]addnC -subn1.
rewrite addnBA ?expn_gt0 // subn1; congr _.-1.
by rewrite addnn -mul2n -expnS.
Qed.

(* -------------------------------------------------------------------- *)
Lemma modn2_neq0 (n : nat) : (n %% 2 != 0) = n %% 2 :> nat.
Proof. by rewrite modn2 eqb0 negbK. Qed.

(* -------------------------------------------------------------------- *)
Lemma divnE (n : nat) (p : nat) (k : nat) :
  p != 0 -> k * p <= n < k.+1 * p -> n %/ p = k.
Proof.
move=> nz_p; elim: k n => [|k ih] n.
- by rewrite !simpm => lt; rewrite divn_small.
rewrite [X in X <= _]mulSn [X in _ < X]mulSn => rg; have le_pn: p <= n.
- by case/andP: rg => [+ _] => /(leq_trans _); apply; apply/leq_addr.
move: rg; rewrite -leq_subRL // -ltn_subLR //.
move/ih => <-; rewrite -{1}[n](subnK le_pn) divnDr //.
by rewrite divnn lt0n nz_p addn1.
Qed.

(* -------------------------------------------------------------------- *)
Lemma divn_sumr {I : Type} (P : pred I) (F : I -> nat) (r : seq I) (d : nat) :
  (forall i, P i -> d %| F i) ->
    (\sum_(i <- r | P i) F i) %/ d = \sum_(i <- r | P i) (F i) %/ d.
Proof.
move=> hdvd; elim/big_rec2: _ => //=; first by rewrite div0n.
by move=> i _ n Pi <-; rewrite divnDl ?hdvd.
Qed.

(* ==================================================================== *)
(* We define the discrete logarithm in base 2.                          *)
(*                                                                      *)
(*   - log2(n) = the number of bits needed to represent all `n`         *)
(*               differents values or the range [0..n[                  *)

Definition log2 (n : nat) := trunc_log 2 n.

Lemma log2_0 : log2 0 = 0.
Proof. exact: trunc_log0. Qed.

Lemma log2_1 : log2 1 = 0.
Proof. exact: trunc_log1. Qed.

Lemma log2_expnK n : log2 (2 ^ n) = n.
Proof. exact: trunc_expnK. Qed.

Lemma log2_eq n k : 2 ^ n <= k < 2 ^ n.+1 -> log2 k = n.
Proof. exact: trunc_log_eq. Qed.

Lemma log2_homo : {homo log2 : m n / m <= n}.
Proof. exact: leq_trunc_log. Qed.

Lemma log2_double (n : nat) : 0 < n -> log2 n.*2 = (log2 n).+1.
Proof. exact: trunc_log2_double. Qed.

Lemma log2S (n : nat) : 1 < n -> log2 n = (log2 n./2).+1.
Proof. exact: trunc_log2S. Qed.

Lemma log2_eq0 (n : nat) : (log2 n == 0) = (n < 2).
Proof. by rewrite trunc_log_eq0 /= ltnS. Qed.

Lemma log2_lt2 (n : nat) : n < 2 -> log2 n = 0.
Proof. by rewrite -log2_eq0 => /eqP. Qed.

Lemma log2_ltn (n : nat) : n < 2 ^ (log2 n).+1.
Proof. exact: trunc_log_ltn. Qed.

Lemma log2_bounds (n : nat) : n != 0 -> 2 ^ (log2 n) <= n < 2 ^ (log2 n).+1.
Proof.
by move=> nz_n; apply: (@trunc_log_bounds 2 n) => //; rewrite lt0n.
Qed.

(* ==================================================================== *)
(* We provide a library for bit-vectors. A bit-vector is any sequence   *)
(* of booleans whose last element is not `false`.                       *)

Record bits := Bitseq { bitseq :> seq bool; _ : last true bitseq; }.

Canonical  bits_subType := Eval hnf in [subType for bitseq].
Definition bits_eqMixin := Eval hnf in [eqMixin of bits by <:].
Canonical  bits_eqType  := Eval hnf in EqType bits bits_eqMixin.

Lemma bits_inj : injective bitseq.
Proof. exact: val_inj. Qed.

(* -------------------------------------------------------------------- *)
(* The notation `b.[i]` allows to access the `i`-th bit of a bit-       *)
(* vector `b`. The bit-vector is implicitly padded with a infinite      *)
(* sequence of `false`.                                                 *)

Definition bit i (b : seq bool) := nosimpl (nth false b i).

Notation "b .[ i ]" := (bit i b).

Lemma bit_oversize (b : bits) (i : nat) :
  size b <= i -> b.[i] = false.
Proof. by case: b => /= b _ lti; rewrite /bit nth_default. Qed.

(* -------------------------------------------------------------------- *)
(* We now prove that for any sequence `s` of booleans, there exists a   *)
(* bit-vector `t` with the same bits (once padded with an infinite      *)
(* sequence of `false`), i.e. `t` is `s` with the final `false`         *)
(* elements trimed.                                                     *)

Lemma bits_canon_spec (s : seq bool) :
  { t : seq bool |
        forall i, nth false s i = nth false t i
      & last true t }.
Proof.
elim/last_ind: s => [|s [] ih]; first by exists [::].
- by exists (rcons s true) => //; rewrite last_rcons.
case: ih => bs h1 h2; exists bs => //.
move=> i; rewrite nth_rcons; case: ltnP => // le.
rewrite if_same; apply/esym; case: (ltnP i (size bs)); last first.
- by move=> ?; rewrite nth_default.
move/(leq_ltn_trans le) => {le} lt; absurd false => //.
move: h2; rewrite (last_nth false) -[size bs]prednK //=.
- by apply: (leq_ltn_trans _ lt).
rewrite -h1 nth_default // -ltnS prednK //.
by apply: (leq_ltn_trans _ lt).
Qed.

(* -------------------------------------------------------------------- *)
(* The function `mkbits` allows the creation of a bit-vector from a     *)
(* given sequence of booleans.                                          *)

Definition mkbits_def (s : seq bool) :=
  Bitseq (s2valP' (bits_canon_spec s)).

Fact mkbits_key : unit.
Proof. by []. Qed.

Definition mkbits := locked_with mkbits_key mkbits_def.
Canonical mkbits_unlockable := [unlockable fun mkbits].

(* -------------------------------------------------------------------- *)
Lemma mkbitsE (s : seq bool) (i : nat) : (mkbits s).[i] = s.[i].
Proof. by rewrite unlock; move: (s2valP (bits_canon_spec s) i). Qed.

(* -------------------------------------------------------------------- *)
Lemma size_mkbits_le (s : seq bool) :
  size (mkbits s) <= size s.
Proof.
rewrite leqNgt; apply/negP => lt.
have := mkbitsE s (size (mkbits s)).-1; rewrite [X in _ = X]nth_default.
- by rewrite -ltnS prednK // (leq_ltn_trans _ lt).
rewrite /bit (@set_nth_default _ _ true) ?prednK //.
- by apply: (leq_ltn_trans _ lt).
by rewrite nth_last unlock (s2valP' (bits_canon_spec s)).
Qed.

(* -------------------------------------------------------------------- *)
Lemma mkbitsK (s : seq bool) : last true s -> mkbits s = s :> seq _.
Proof.
move=> h; apply: (@eq_from_nth _ false); last first.
- by move=> i lti; apply: mkbitsE.
have := size_mkbits_le s; rewrite leq_eqVlt => /orP[/eqP //|lt].
absurd (last true s) => //; rewrite -nth_last.
rewrite (@set_nth_default _ _ false).
- by rewrite prednK // (leq_ltn_trans _ lt).
rewrite -/(bit _ _) -mkbitsE /bit nth_default //.
by rewrite -ltnS prednK // (leq_ltn_trans _ lt).
Qed.

(* -------------------------------------------------------------------- *)
(* Two bit-vectors are equal (i.e. represented by the same sequence)    *)
(* iff they have the same bits (once padded with an infinite sequence   *)
(* of `false`.                                                          *)

Lemma bits_eqP (b1 b2 : bits) :
  reflect (forall i, b1.[i] = b2.[i]) (b1 == b2).
Proof.
apply: (iffP eqP) => [->//|].
case: b1 b2 => [b1 h1] [b2 h2] /= eq_bits.
apply/val_eqP/eqP => /=; apply: (@eq_from_nth _ false); last first.
- by move=> i _; apply: eq_bits.
wlog: b1 h1 b2 h2 eq_bits / (size b1 <= size b2) => [wlog|].
- case: (leqP (size b1) (size b2)); first by apply: wlog.
  by move/ltnW => le; apply/esym/wlog.
rewrite leq_eqVlt => /orP[/eqP //|lt_sz].
absurd false => //; move/(_ (size b2).-1): eq_bits.
rewrite [X in _ = X]/bit (set_nth_default true).
- by rewrite ltn_predL (leq_ltn_trans _ lt_sz).
rewrite nth_last h2 -/(is_true _) /bit nth_default //.
by rewrite -ltnS prednK // (leq_ltn_trans _ lt_sz).
Qed.

Lemma bits_eqW (b1 b2 : bits) :
  (forall i, b1.[i] = b2.[i]) <-> (b1 = b2).
Proof. by rewrite (rwP eqP); split=> /bits_eqP. Qed.

(* -------------------------------------------------------------------- *)
(* The empty bit-vector and some related lemmas.                        *)

Definition bits0 := mkbits [::].

Notation "0%:B" := bits0 (at level 0).

Lemma b0E (i : nat) : 0%:B.[i] = false.
Proof. by rewrite mkbitsE /bit nth_nil. Qed.

Lemma val_b0E : val 0%:B = [::].
Proof. by rewrite /mkbits /= mkbitsK. Qed.

Lemma size_b0 : size 0%:B = 0.
Proof. by rewrite val_b0E. Qed.

(* -------------------------------------------------------------------- *)
Lemma size_bits_eq0P (b : bits) :
  (size b == 0) = (b == 0%:B).
Proof. by rewrite -val_eqE /= val_b0E size_eq0. Qed.

(* -------------------------------------------------------------------- *)
Lemma bits_neq0P (b : bits) :
  reflect (exists i, b.[i]) (b != 0%:B).
Proof.
apply: (iffP idP); last first.
- by case=> i nz_bi; apply/contraL: nz_bi => /eqP->; rewrite b0E.
case: b => b hb /=; rewrite -size_bits_eq0P /= => nz_szb.
move: hb; rewrite (last_nth false) -[size b]prednK ?lt0n //=.
by move: _.-1 => i h; exists i.
Qed.

(* -------------------------------------------------------------------- *)
Lemma bits_neq0W (b : bits) : (exists i, b.[i]) <-> (b <> 0%:B).
Proof. by split=> [|/eqP] /bits_neq0P => // /eqP. Qed.

(* -------------------------------------------------------------------- *)
Lemma hibit_neq0P (b : bits) : (b != 0%:B) = b.[(size b).-1].
Proof.
rewrite -size_bits_eq0P; case: b => /= b hb.
by rewrite /bit nth_last; case: b hb.
Qed.

(* -------------------------------------------------------------------- *)
Lemma hibit_neq0W (b : bits) : (b <> 0%:B) <-> b.[(size b).-1].
Proof. by rewrite -hibit_neq0P; split=> /eqP. Qed.

(* -------------------------------------------------------------------- *)
(* The bitwise xor (eXclusive OR) of two bit-vectors                    *)

Definition bxor (b1 b2 : bits) : bits :=
  mkbits [seq b1.[i] (+) b2.[i] | i < maxn (size b1) (size b2)].

Lemma bxorE (b1 b2 : bits) (i : nat) :
  (bxor b1 b2).[i] = b1.[i] (+) b2.[i].
Proof.
rewrite mkbitsE /=; case: (ltnP i (maxn (size b1) (size b2))) => [lt|ge].
- by rewrite /bit nth_mkseq.
rewrite /bit !nth_default ?size_mkseq //;
  by move: ge; rewrite geq_max => /andP[].
Qed.

(* -------------------------------------------------------------------- *)
(* We prove that the set of bitvectors, with 0%:B and (.+), forms a     *)
(* commutative monoid.                                                  *)

Lemma bxor0b : left_id 0%:B bxor.
Proof.
by move=> b; apply/eqP/bits_eqP => i; rewrite !(bxorE, b0E) addFb.
Qed.

Lemma bxorC : commutative bxor.
Proof.
by move=> b1 b2; apply/eqP/bits_eqP => i; rewrite !bxorE addbC.
Qed.

Lemma bxorA : associative bxor.
Proof.
by move=> b1 b2 b3; apply/eqP/bits_eqP => i; rewrite !bxorE addbA.
Qed.

Lemma bxorb0 : right_id 0%:B bxor.
Proof. by move=> b; rewrite bxorC bxor0b. Qed.

Lemma bxorbb : self_inverse 0%:B bxor.
Proof.
by  move=> b; apply/eqP/bits_eqP => i; rewrite bxorE b0E addbb.
Qed.

Notation "b1 .+ b2" := (bxor b1 b2) (at level 50, left associativity).

Canonical bxor_monoid := Monoid.Law bxorA bxor0b bxorb0.
Canonical bxor_comoid := Monoid.ComLaw bxorC.

(* -------------------------------------------------------------------- *)
Lemma bigxorE {I : Type} (P : pred I) (F : I -> bits) (r : seq I) (i : nat) :
    (\big[bxor/0%:B]_(x <- r | P x) F x).[i]
  = \big[addb/false]_(x <- r | P x) (F x).[i].
Proof.
elim/big_ind2: _ => //; first by rewrite b0E.
by move=> _ bs _ cs <- <-; rewrite bxorE.
Qed.

(* ==================================================================== *)
(* We now define functions from converting from bit-vectors to natural  *)
(* numbers, following the 1-complement convention.                      *)
(*                                                                      *)
(* We prove that b2n / n2b are the inverse of each other, along with    *)
(* some more basic properties.                                          *)

Definition b2n (b : bits) : nat :=
  \sum_(i < size b) 2^i * b.[i].

Definition n2b (n : nat) : bits :=
  mkbits [seq (n %/ (2 ^ i)) %% 2 != 0 | i < (log2 n).+1].

(* -------------------------------------------------------------------- *)
Lemma b2nWE (n : nat) (b : bits) :
  size b <= n -> b2n b = \sum_(i < n) 2^i * b.[i].
Proof.
pose F i := 2^i * b.[i]; move=> le; rewrite /b2n.
rewrite (big_ord_widen n F) // big_mkcond /=.
apply: eq_bigr; case=> /= i lti _; rewrite {}/F.
by case: ltnP => // gei; rewrite /bit nth_default ?simpm.
Qed.

(* -------------------------------------------------------------------- *)
Lemma n2b0 : n2b 0 = 0%:B.
Proof.
apply/eqP/bits_eqP => i; rewrite b0E /n2b mkbitsE.
rewrite log2_0 -(@eq_mkseq _ (fun=> false)) //.
- by move=> j /=; rewrite div0n mod0n eqxx.
case: (ltnP i 1) => ?; first by rewrite /bit nth_mkseq.
by rewrite /bit nth_default.
Qed.

(* -------------------------------------------------------------------- *)
Lemma n2bE (n : nat) (i : nat) :
  (n2b n).[i] = ((n %/ 2 ^ i) %% 2 != 0).
Proof.
case: (n =P 0) => [->|/eqP nz_n].
- by rewrite n2b0 b0E div0n mod0n eqxx.
rewrite mkbitsE; case: (ltnP i (log2 n).+1) => [lt|ge].
- by rewrite /bit nth_mkseq.
rewrite /bit nth_default ?size_mkseq //.
apply/esym/negbTE; rewrite negbK divn_small //.
have /andP [_ +] := log2_bounds nz_n.
by move/leq_trans; apply; apply: leq_pexp2l.
Qed.

(* -------------------------------------------------------------------- *)
Lemma size_n2b (i : nat) : i != 0 -> size (n2b i) = (log2 i).+1.
Proof.
move=> nz_i; set d := (log2 i).+1.
suff nz: (n2b i).[d.-1].
- apply/eqP; rewrite /n2b; set s := (X in mkbits X).
  have := size_mkbits_le s; rewrite size_mkseq -/d.
  rewrite leq_eqVlt => /orP[//|lt]. absurd (n2b i).[d.-1] => //.
  by rewrite bit_oversize.
have := log2_bounds nz_i; rewrite n2bE /d /=.
rewrite -[X in X <= _]mul1n expnS => /divnE -> //.
by rewrite -lt0n expn_gt0.
Qed.

(* -------------------------------------------------------------------- *)
Lemma size_n2b_half (i : nat) :
  size (n2b i./2) = (size (n2b i)).-1.
Proof.
case: i => /= [|i]; first by rewrite n2b0 /= size_b0.
case: i => /= [|i].
- by rewrite n2b0 size_b0 /n2b log2_1 mkbitsK.
by rewrite !size_n2b //= [in RHS]log2S.
Qed.

(* -------------------------------------------------------------------- *)
Lemma b2nE (b : bits) (i : nat) :
  ((b2n b) %/ 2 ^ i) %% 2 = b.[i].
Proof.
pose F (i : nat) := 2 ^ i * b.[i]; rewrite /b2n.
have dvdF (j : nat) : i <= j -> 2 ^ i %| F j.
- by move=> le_ij; rewrite dvdn_mulr // dvdn_exp2l.
case: (ltnP i (size b)) => [lti|gei]; last first.
- rewrite bit_oversize //= divn_small ?mod0n //.
  apply: (@leq_ltn_trans (\sum_(j < size b) 2 ^ j)).
  - apply: leq_sum; case=> /= j ltj _.
    by case: b.[_]; rewrite simpm.
  by rewrite sum_pow2 prednK ?expn_gt0 // leq_pexp2l.
rewrite -(big_mkord xpredT F) (big_cat_nat _ (n := i.+1)) //=.
rewrite divnDr; first rewrite big_nat dvdn_sum //.
- by move=> j /andP[/ltnW + _]; apply: dvdF.
rewrite -[X in (_ + X)](@divnK 2); last rewrite addnC modnMDl.
- rewrite big_nat divn_sumr.
  - by move=> j /andP[/ltnW + _]; apply: dvdF.
  rewrite dvdn_sum // => j /andP[/[dup] lt_ik / ltnW le_ij _].
  rewrite /F mulnC -muln_divA ?dvdn_exp2l //.
  by rewrite dvdn_mull // -expnB // dvdn_exp // subn_gt0.
rewrite big_nat_recr //= divnDr ?dvdn_mulr //.
rewrite mulKn ?expn_gt0 // [X in X+_](_ : _ = 0); last first.
- by rewrite add0n modn_small // ltnS leq_b1.
rewrite divn_small // (@leq_ltn_trans (\sum_(j < i) 2 ^ j)) //.
- rewrite big_mkord; apply: leq_sum => /= -[/= k ltk] _.
  apply/(@leq_trans (2 ^ k))/leq_pexp2l => //.
  by rewrite /F; case: b.[k]; rewrite simpm.
- by rewrite sum_pow2 ltn_predL expn_gt0.
Qed.

(* -------------------------------------------------------------------- *)
Lemma b2nK : cancel b2n n2b.
Proof.
by move=> b; apply/eqP/bits_eqP => i; rewrite n2bE b2nE eqb0 negbK.
Qed.

(* -------------------------------------------------------------------- *)
Lemma n2bK : cancel n2b b2n.
Proof.
suff: forall l, forall i, log2 i = l -> b2n (n2b i) = i.
- by move=> ih i; apply: (ih (log2 i)).
elim=> [|l ih] i logiE.
- rewrite /n2b logiE mkseqS /= expn0 divn1.
  rewrite (b2nWE (size_mkbits_le _)) /=.
  rewrite big_ord_recl /= big_ord0 addn0.
  rewrite expn0 mul1n mkbitsE /bit /= modn2_neq0.
  by rewrite modn_small // -log2_eq0; apply/eqP.
have gt1_n: 1 < i by rewrite ltnNge -ltnS -log2_eq0 logiE.
pose F i k := 2 ^ k * (n2b i).[k].
have gt0_size: 0 < size (n2b i).
- by rewrite lt0n size_n2b //; case: {+}i gt1_n.
rewrite /b2n -(big_mkord predT (F i)) /= -[size _]prednK //.
rewrite big_nat_recl //= {1}/F expn0 mul1n.
rewrite -(eq_big_nat _ _ (F1 := fun j => (F i./2 j) * 2)).
- move=> k rg_k; rewrite /F n2bE modn2_neq0.
  rewrite mulnAC -expnSr; congr (_ * _).
  by rewrite n2bE modn2_neq0 -divn2 -divnMA -expnS.
rewrite -big_distrl /= -size_n2b_half big_mkord -/(b2n _) ih.
- by rewrite log2S // in logiE; case: logiE.
rewrite n2bE expn0 divn1 modn2_neq0.
by rewrite addnC -divn2; apply/esym/divn_eq.
Qed.

(* -------------------------------------------------------------------- *)
Lemma lt_n2b (b1 b2 : bits) :
  (exists2 k,
      (forall i, k < i -> b1.[i] = b2.[i])
    & b1.[k] < b2.[k])
  -> b2n b1 < b2n b2.
Proof.
case=> k eq lt; pose s := maxn (size b1) (size b2).
rewrite !(@b2nWE s) /=; try by rewrite leq_max leqnn simpm.
pose g (b : bits) (i : nat) := 2^i * b.[i].
have [z_b1k nz_b2k] : (~~ b1.[k]) /\ b2.[k].
- by case: b1.[k] b2.[k] lt => [] [].
rewrite -(big_mkord predT (g b1)) -(big_mkord predT (g b2)) /=.
have lek: k < s.
- apply/(@leq_trans (size b2))/leq_maxr.
  apply/contraLR: lt; rewrite -!(leqNgt, ltnNge).
  by move/bit_oversize => ->.
rewrite [X in X<_](big_cat_nat _ (n := k.+1)) //=.
rewrite [X in _<X](big_cat_nat _ (n := k.+1)) //=.
rewrite -!addSn; apply: leq_add; last first.
- rewrite leq_eqVlt -(rwP orP) /g; left; apply/eqP.
  by apply/eq_big_nat => i /andP[+ _] => /eq ->.
rewrite !big_nat_recr //= {2 4}/g.
rewrite (negbTE z_b1k) nz_b2k ?simpm.
apply: (@leq_trans (2 ^ k)); last by apply: leq_addl.
apply: (@leq_ltn_trans (\sum_(0 <= i < k) 2 ^ i)).
- apply: leq_sum => i _; rewrite {}/g.
  by case: b1.[i]; rewrite ?simpm.
suff ->: \sum_(0 <= i < k) 2 ^ i = (2 ^ k).-1.
- by rewrite prednK // expn_gt0.
- by rewrite big_mkord; apply/sum_pow2.
Qed.

(* ==================================================================== *)
Module Nim.
Context (p : nat).

(* A Nim game is composed of `p` rows of matches. We represents this    *)
(* as a function from [s : 'I_p -> nat] where [s i] denotes the number  *)
(* of matches in the row [i].                                           *)
(*                                                                      *)
(* The type ['I_p] stands for the range [0..p[, i.e. for the set of the *)
(* natural numbers lower then [p].                                      *)
(*                                                                      *)
(* It is defined as the following induction predicate/type:             *)
(*                                                                      *)
(* Inductive ordinal (p : nat) :=                                       *)
(* | Ordinal : forall (i : nat), (i < p) -> ordinal p.                  *)

Definition state := 'I_p -> nat.

(* We now define a function that, given a state [s], returns a list     *)
(* of natural numbers [r] s.t. for any natural number [i] lower than    *)
(* [p], the [i]-th element of [r] is equal to the number of matches     *)
(* in the [i]-th row of [s] (i.e. is equal to [s i])                    *)
(*                                                                      *)
(* The function [map] is defined as follows:                            *)
(*                                                                      *)
(* Fixpoint map (f : T -> U) (s : list T) : list U :=                   *)
(*   match s with                                                       *)
(*   | nil => nil                                                       *)
(*   | cons x s' => cons (f x) (map f s')                               *)
(*   end.                                                               *)
(*                                                                      *)
(* Note that [map (fun i => f i) s] is printed as:                      *)
(*                                                                      *)
(*   [seq s i | i <- s]                                                 *)
(*                                                                      *)
(* Also, note that [enum 'I_p] is the list that contains all the        *)
(* natural numbers from [0] to [p] (excluded).                          *)

Definition rows (s : state) : list nat :=
  map (fun i => s i) (enum 'I_p).

(* We prove that the size of [rows s] if equal to [p] where [size] is   *)
(* defined as follow:                                                   *)
(*                                                                      *)
(* Fixpoint size (s : seq T) :=                                         *)
(*   match s with                                                       *)
(*   | nil => 0                                                         *)
(*   | cons _ s' => S (size s)                                          *)
(*   end.                                                               *)

Lemma size_rows (s : state) : size (rows s) = p.
Proof. by rewrite /rows size_map size_enum_ord. Qed.

(* We also prove that the [i]-th element of [rows s] is equal to [s i]. *)
(* We use the function [nth] for that purpose, whose definition is:     *)
(*                                                                      *)
(* Fixpoint nth (x0 : T) (s : list T) (i : nat) {struct i} :=           *)
(*   match s with                                                       *)
(*   | nil =>                                                           *)
(*       x0                                                             *)
(*   | cons y s' =>                                                     *)
(*       match i with                                                   *)
(*       | O => y                                                       *)
(*       | S j => nth x0 s j                                            *)
(*       end                                                            *)
(*   end.                                                               *)

Lemma nth_rows (s : state) (i : 'I_p) : nth 0 (rows s) i = s i.
Proof. by rewrite (nth_map i) ?size_enum_ord // nth_ord_enum. Qed.

(* At each turn, the running player must select a row and remove at     *)
(* least 1 match from this row. We here denote a binary relation [R]    *)
(* over states s.t. [s1 R_i s2] iff it is possible to move from [s1] to *)
(* [s2] in one turn on row [i].                                         *)

Inductive R (i : 'I_p) (s1 s2 : state) : Prop :=
| Turn :
      (s2 i < s1 i)
   -> (forall j : 'I_p, j != i -> s2 j = s1 j)
   -> R i s1 s2.

(* -------------------------------------------------------------------- *)
(* The weight a of Nim state is obtained by xor'ing the number of       *)
(* matches (in 1-complement) for all the game rows.                     *)

(* First, write a function [weight_r] that takes a list [s] of natural  *)
(* numbers, and that returns bit-vector obtained by xor'ing all the     *)
(* elements [s] (in 1-complement).                                      *)
(*                                                                      *)
(* Hint: define a Fixpoint over [s] & use [bits0], [bxor] & [n2b].      *)

Fixpoint weight_r (s : seq nat) {struct s} : bits :=
  match s with
  | nil => bits0
  | cons n s' => bxor (n2b n) (weight_r s')
  end.

(* We define the function [weight] s.t. [weight s] returns the weight   *)
(* of the game state [s].                                               *)

Definition weight (s : state) : bits :=
  weight_r (rows s).

(* -------------------------------------------------------------------- *)
(* Prove that the empty game board has a weight of 0                    *)
(*                                                                      *)
(* Here, [fun=> 0] denotes the constant function equal to 0.            *)

Lemma weight_empty : weight (fun=> 0) = 0%:B.
Proof.
(* We start by unfolding the definition of [weight] & [rows]            *)
rewrite /weight /rows.
(* The proof can now be done by induction over [enum 'I_p]              *)
(* FIXME *)
elim: (enum 'I_p) => [|i s IHs] /=.
- auto.
- rewrite IHs.
  rewrite n2b0.
  rewrite bxor0b.
  auto.
Qed.

(* -------------------------------------------------------------------- *)
(* We now prove some extra lemmas about [weight_r].                     *)
(*                                                                      *)
(* Hint: you can use the lemmas [bxor??] here.                          *)

Lemma weight_r0: weight_r nil = bits0.
Proof.
rewrite /weight_r.
auto.
Qed.

Lemma weight_r1 (n : nat): weight_r [:: n] = n2b n.
Proof.
rewrite /weight_r.
rewrite bxorb0.
auto.
Qed.

Lemma weight_rS (n : nat) (ns : list nat) :
  weight_r (n :: ns) = n2b n .+ weight_r ns.
Proof.
rewrite /weight_r //=.
Qed.

(* Here, [++] denotes [cat], the list-concatenation function.           *)
(*                                                                      *)
(* The function [cat] is defined as follows:                            *)
(*                                                                      *)
(* Fixpoint cat (r s : seq T) {struct r} :=                             *)
(*   match r with                                                       *)
(*   | nil => s                                                         *)
(*   | cons y r' => cons y (cat r' s)                                   *)
(*   end.                                                               *)

Lemma weight_rD (r s : list nat) :
  weight_r (r ++ s) = bxor (weight_r r) (weight_r s).
Proof.
(* FIXME *)
induction r.
- simpl. rewrite bxor0b. auto.
- simpl. rewrite IHr. rewrite bxorA. auto.
Qed.

(* -------------------------------------------------------------------- *)
(* We can describe how the weight evolves after one turn                *)
(*                                                                      *)
(* We first  prove a characterization of [R]                            *)

Lemma RP (i : 'I_p) (s1 s2 : state) : R i s1 s2 ->
  exists (p : seq nat) (q : seq nat),
    [/\ size p = i
      , rows s1 = p ++ (s1 i) :: q
      & rows s2 = p ++ (s2 i) :: q].
Proof.
case=> lt_s eq_s; exists (take i (rows s1)), (drop i.+1 (rows s1)); split.
- by rewrite size_take size_rows ltn_ord.
- rewrite -cat1s catA cats1 -[s1 i]nth_rows /=.
  by rewrite -take_nth ?size_rows // cat_take_drop.
rewrite -cat1s catA cats1 -[s2 i]nth_rows /=.
have ->: take i (rows s1) = take i (rows s2).
- rewrite -!(map_nth_iota0 0) ?size_rows 1?ltnW //.
  apply/eq_in_map=> j; rewrite mem_iota /= add0n => lt_ji.
  have lt_jp: j < p by apply: (ltn_trans lt_ji).
  rewrite !(nth_rows _ (Ordinal lt_jp)) /=.
  by apply/esym/eq_s; rewrite -val_eqE /= ltn_eqF.
have ->: drop i.+1 (rows s1) = drop i.+1 (rows s2).
- rewrite -[LHS](take_oversize (n := p - i.+1)).
  - by rewrite size_drop size_rows.
  rewrite -[RHS](take_oversize (n := p - i.+1)).
  - by rewrite size_drop size_rows.
  rewrite -!(map_nth_iota 0) ?size_rows //.
  apply/eq_in_map=> j; rewrite mem_iota => /andP[lt_ij].
  rewrite subnKC // => lt_jp.
  rewrite !(nth_rows _ (Ordinal lt_jp)) /=.
  by apply/esym/eq_s; rewrite -val_eqE /= gtn_eqF.
by rewrite -take_nth ?size_rows // cat_take_drop.
Qed.

(* We can now state and prove how the weight of the state evolves       *)
(* between two states related by [R].                                   *)
(*                                                                      *)
(* Hint: use [RP] and the [weight_rX] lemmas.                           *)
(* Hint: you will also need the [bxorX] lemmas family.                  *)

(* We write an auxiliary bxor operation here *)
Lemma bxorACA b1 b2 b3: (b1 .+ b2) .+ b3 = (b1 .+ b3) .+ b2.
Proof.
by rewrite -bxorA [b2 .+ b3] bxorC bxorA.
Qed.

Lemma turn_weight (i : 'I_p) (s1 s2 : state) :
  R i s1 s2 -> weight s2 = weight s1 .+ n2b (s1 i) .+ n2b (s2 i).
Proof.
(* FIXME *)
move=> H. apply RP in H.
case: H => p H. case: H => q H. case: H => H1 H2 H3.
rewrite /weight.
rewrite H2 H3.
rewrite weight_rD.
rewrite weight_rD.
rewrite weight_rS.
rewrite weight_rS.
rewrite bxorA.
rewrite bxorA.
rewrite ![(_ .+ n2b (s1 i)) .+ _]bxorACA.
rewrite -!bxorA.
rewrite bxorbb.
rewrite bxorb0.
rewrite bxorA.
rewrite bxorC.
rewrite bxorA.
rewrite bxorA.
rewrite ![( _ .+ weight_r q)]bxorC.
auto.
Qed.

(* -------------------------------------------------------------------- *)
(* Any move from a 0-weighted game leads to a non 0-weighted game       *)
(*                                                                      *)
(* Hint: you should use [turn_weight] here.                             *)
(* Hint: you can use the injectivity of n2b.                            *)
(* Hint: b1 (+) b2 = true iff b1 = b2.                                  *)
(* Hint: you can use contraposition, e.g. [contra_neq_not].             *)

Lemma ltf (n : nat):
  n < n -> false.
Proof.
intros.
induction n.
- done.
- by apply IHn in H.
Qed.

Lemma b02bnbb (x : 'I_p) (s : state):
  0%:B = n2b (s x) .+ n2b (s x).
Proof.
by rewrite bxorbb.
Qed.

Lemma z2nz (i : 'I_p) (s1 s2 : state) :
  R i s1 s2 -> weight s1 = 0%:B -> weight s2 <> 0%:B.
Proof.
have n2b_inj: forall m n, n2b m = n2b n -> m = n.
- by move=> m n /(can_inj n2bK).
(* FIXME *)

move => H1 H2.
have HR: R i s1 s2.
apply H1.
destruct HR.
apply turn_weight in H1.
rewrite H2 in H1.
rewrite bxor0b in H1.
move => H3.
rewrite H1 in H3.
rewrite (b02bnbb i s2) in H3.
have contra: n2b (s1 i) .+ n2b (s2 i) .+ n2b (s2 i) = n2b (s2 i) .+ n2b (s2 i) .+ n2b (s2 i).
by rewrite H3.
move: contra.
rewrite -bxorA.
rewrite -bxorA.
rewrite bxorbb.
rewrite bxorb0.
rewrite bxorb0.
move => contra.
apply n2b_inj in contra.
rewrite contra in H.
apply ltf  in H.
auto.
Qed.

(* -------------------------------------------------------------------- *)
(* From any non 0-weight game, it is possible to move to a              *)
(* 0-weighted game.                                                     *)
(*                                                                      *)
(* Hint: for this one, you are on your own.                             *)
(* Hint: https://en.wikipedia.org/wiki/Nim#Proof_of_the_winning_formula *)

Lemma nz2z (s : state) : weight s <> 0%:B ->
  exists (i : 'I_p), exists (s' : state), weight s' = 0%:B /\ R i s s'.
Proof.

(* FIXME *)
intros.
pose w := weight s.
remember (size w).-1 as d.

(* Prove that w.[d] not equal to 0 *)
have hi: w.[d].
rewrite Heqd.
apply hibit_neq0W.
apply H.
have hd := ((hibit_neq0W (weight s)).1 H).
rewrite -Heqd in hd.

(* Prove exist k such that x_k[d] not zero, prove by contradiction *)
have somek : exists (k : 'I_p), (n2b (s k)).[d].
- apply/existsP/existsPn => //=.
intro h2.
unfold weight in hd.
unfold rows in hd.
induction (enum 'I_p).
- rewrite //b0E// in hd.
- rewrite //bxorE in hd.
apply IHl.
rewrite (negbTE (h2 a))// in hd.
move: somek => [k HX].
(* pose x := n2b (s k) .
pose y := w .+ x. *)
remember (weight s) as hw.
remember (n2b (s k)) as x.
remember  ( hw .+ x ) as y.
remember (fun i => if i == k then b2n y else s i) as s'.

have sk' : s' k = b2n y.
    rewrite Heqs'.
    rewrite ifT.
    auto.
    auto.

have sk : s k = b2n x.
    rewrite Heqx.
    rewrite n2bK.
    auto.

have HY: negb y.[d].
    rewrite Heqy.
    rewrite bxorE.
    rewrite hi.
    rewrite HX.
    simpl.
    apply is_true_true.

(* Claim that y_k < x_k *)
have yltx: b2n y < b2n x.
    apply lt_n2b.
    exists d.

(* prove for all d<i x_k = y_k *)
have yxw: forall i, d < i -> y.[i] = x.[i].
    intros i h_i.
    rewrite Heqx.
    rewrite Heqy.
    rewrite Heqhw.
    rewrite bxorE - Heqx.
    rewrite Heqd in h_i.
    have hs: (size (weight s)) <= i.
    unfold w in h_i. rewrite Heqhw in h_i.
    - by (induction (size (weight s)) => //=; rewrite ltnS; apply IHn).
    - rewrite (bit_oversize hs) //. apply yxw.

have yx: y.[d] < x.[d].
    rewrite HX.
    have yf: y.[d] = false.
    apply negbTE.
    apply HY.
    rewrite yf.
    simpl.
    auto.
    apply yx.

exists k.
exists s'.

(* Finish the prove with weight s' = 0%:B /\ R k s s' *)
have rr: R k s s'.
    split.
    rewrite sk.
    rewrite sk'.
    apply yltx.
    intros.
    rewrite Heqs'.
    rewrite ifF.
    revert H0.
    rewrite neq_ltn => /orP [].
    apply ltn_eqF.
    apply gtn_eqF.
    auto.

split.
revert rr.
have w0: (weight s .+ n2b (s k) .+ n2b (s' k) = 0%:B).
rewrite <- Heqhw.
rewrite <- Heqx.
rewrite <- Heqy.
have skrev': (n2b (s' k) = y).
rewrite sk'.
rewrite b2nK.
auto.
rewrite skrev'.
rewrite bxorbb.
auto.
rewrite <- w0.
apply turn_weight.
apply rr.
Qed.

End Nim.


(** * Tutoriel 6 - Ltac *)

(** Dans ce tutoriel plus avancé, nous allons voir comment
    écrire nos propres tactiques, à l'aide de Ltac. *)

(** ** I. Un premier exemple *)

(** Un premier cas d'utilisation de Ltac  *)

Module Ltac_example.
  Require Import ZArith Lia.
  Open Scope Z_scope.

 (* Définition du type des listes de couples. *)
 Inductive elt_list :=
  | Nil : elt_list
  | Cons : Z -> Z -> elt_list -> elt_list.

 (* Un invariant exprimant que les couples sont rangés
    par ordre croissant, ne se chevauchent pas, et sont
    séparés d'au moins deux entiers. *)
 Inductive Inv_elt_list : Z -> elt_list -> Prop :=
  | invNil  : forall b, Inv_elt_list b Nil
  | invCons : forall (a b j : Z) (q : elt_list),
     j <= a -> a <= b ->  Inv_elt_list (b+2) q ->
     Inv_elt_list j (Cons a b q).

 (* Un théorème exprimant que si y est plus petit que
    tous les éléments de l, et que z est plus petit que y,
    alors z est plus petit que tous les éléments de l. *)
 Theorem inv_elt_list_monoton : forall l y z,
 Inv_elt_list y l -> z <= y -> Inv_elt_list z l.
 Proof.
 intros l y z Hinv Hle.
 induction Hinv.
  - constructor.
  - constructor;(lia||assumption).
 Qed.

 (* La tactique [Inv_monotony z] prend en argument une valeur [z] pour
    la variable nommée [y] dans le théorème précédent, valeur difficile
    à inférer pour Coq.
    Deux buts seront alors générés :
       - un de la forme [Inv_elt_list y l], noté B1
       - et l'autre de la forme [z <= y],   noté B2.
    La tactique [Inv_monotony] permet de finir la preuve si B1 est dans
    les hypothèses et si B2 peut être déduit grâce à la tactique [lia]. *)
 Ltac Inv_monotony z :=
   apply inv_elt_list_monoton with (y:=z);
    [assumption|lia].

End Ltac_example.

(** ** II. Quelques cas d'usage de Ltac *)

  (** Avec Ltac, il est possible de faire bien plus que d'enchainer des
      tactiques les unes à la suite des autres, comme nous l'avons vu dans
      l'exemple précédent.
      Une fonctionnalité très puissante de Ltac est de pouvoir faire du
      pattern-matching sur le but courant. *)

(** *** A. Un premier pattern-matching très simple *)

  (** Voici un premier exemple pour vous montrer la syntaxe d'un
      pattern-matching dans le langage de Ltac :  *)
  Ltac my_trivial_tactic :=
   match goal with
      | [ |- _ ] => intro
      | [ |- True ] => constructor
    end.

  (** Avec la tactique précédente, nous pouvons prouver : *)
  Theorem m1 : True.
  Proof. my_trivial_tactic. Qed.

  (** Notez que [True] matche le 1er cas du pattern-matching de
      [my_trival_tactic] et pourtant ce n'est pas ce cas de figure qui est
      utilisé pour construire le terme de preuve, mais bien le 2ème.
      En effet, le 1er cas du pattern-matching renvoie une erreur car la
      tactique [intro] ne peut pas être utilisée sur le but [True]. *)

(** *** B. Ecrire un pattern-matching plus compliqué *)

  (** La tactique [find_if] vérifie si la conclusion est un if, puis,
      si c'est le cas, détruit l'expression de test. *)
  Ltac find_if :=
    match goal with
      | [ |- if ?X then _ else _ ] => destruct X
    end.

  (** Certaines classes de théorèmes sont triviales à prouver
      automatiquement avec une telle tactique, comme par exemple : *)
  Goal forall (a b c : bool),
    if a
      then if b
        then True
        else True
      else if c
        then True
        else True.
  Proof.
    intros.
    repeat find_if.
      + constructor.
      + constructor.
      + constructor.
      + constructor.
    (* ou encore : [intros; repeat find_if; constructor.] *)
  Qed.

  (** Malheureusement, la tactique [find_if] n'est pas capable de détecter
      qu'un if apparait dans un sous-terme du but, comme le montre l'exemple
      suivant : *)
  Goal forall (a b : bool),
    (if a then 42 else 42) = (if b then 42 else 42).
  Proof.
    intros.
    repeat find_if. (* Rien ne se passe. *)
  Abort.

  (** Le pattern [context] permet de résoudre ce problème. *)

  (** Le comportement de la tactique [find_if_inside] est de trouver tout
      sous-terme de la conclusion qui est un if, et ensuite de détruire
      l'expression de test. *)
  Ltac find_if_inside :=
    match goal with
      | [ |- context[if ?X then _ else _] ] => destruct X
    end.

  (** Cette version étend ce que pouvait résoudre la tactique [find_if],
      car nous pouvons toujours démontrer : *)
  Goal forall (a b c : bool),
    if a
      then if b
        then True
        else True
      else if c
        then True
        else True.
  Proof.
    intros; repeat find_if_inside; constructor.
  Qed.

  (** Mais nous pouvons également utiliser [find_if_inside] pour prouver
      les objectifs que [find_if] ne simplifie pas suffisamment : *)
  Goal forall (a b : bool),
    (if a then 42 else 42) = (if b then 42 else 42).
  Proof.
    intros; repeat find_if_inside; reflexivity.
  Qed.

(** *** C. Faire référence à une hypothèse dans un pattern-matching *)

  (** Lorsque nous avons écrit les tactiques [find_if] et [find_if_inside],
      nous avons vu la syntaxe [?X], permettant de faire référence à un
      sous-terme. *)

  (** Notez ici comment faire référence à une hypothèse dans le
      pattern-matching : *)
  Ltac intro_exact := intros; match goal with
      | [ H : _ |- _ ] => exact H
    end.

  (** Avec la tactique [intro_exact], il est possible de prouver le but
      suivant : *)
  Goal forall P Q R : Prop, P -> Q -> R -> Q.
  Proof. intro_exact. Qed.

(** *** D. Pour le débuggage : [idtac] *)

(** Ltac n'est pas très simple à prendre en main.
    Pour vous aider à mieux comprendre pourquoi la tactique que vous
    avez écrit ne fait pas ce que vous voulez, vous pouvez utiliser la
    tactique [idtac]. *)

Ltac ex_idtac :=
  intros; match goal with
              | [ H : ?P |- _ ] => idtac H ; idtac P
          end.

Goal forall P, P -> P.
Proof. ex_idtac. apply X. Qed.

(** ** III. Quelques exercices *)

  (** *** Exercice 1 - Votre version de la tactique [tauto] *)

  (** Cet exercice vous propose d'utiliser le langage de Ltac pour écrire
      une version la plus proche possible de la tactique [tauto].
      Vous nommerez votre tactique [my_tauto]. *)

Ltac my_tauto :=
  intros; repeat match goal with
      | [ |- True ] => constructor ; idtac "1"
      | [ _ : ?X |- ?X ] => assumption ; idtac "2"
      | [ H : False |- _ ] => contradiction ; idtac "3"
      | [ H : _/\_ |- _ ] => destruct H ; idtac "4"
      | [ |- _/\_ ] => split ; idtac "5"
      | [ H : _\/_ |- _ ] => destruct H ; idtac "6"
      | [ H : ?P->?Q |- ?Q ] => apply H ; idtac "7"
      | [ H2 : _->_ |- _ ] => destruct H2 ; idtac H2 ; idtac "8"
      | [ x : _ |- ex _ ] => exists x ; idtac "9"
      | [ H : exists _,_  |- _] => destruct H ; idtac H ; idtac "10"
      end.

  (** Voici quelques cas de tests pour vous aider à tester votre tactique : *)

  (* Niveau 1 : Une première version *)
  Goal forall P, P -> True.
  Proof. my_tauto. Qed.

  Goal forall P Q R : Prop, P -> Q -> R -> Q.
  Proof. my_tauto. Qed.

  Goal forall P Q R : Prop,
    P /\ R /\ Q -> Q /\ R /\ P.
  Proof. my_tauto. Qed.

  Goal forall P Q : Prop,
    Q /\ (P /\ False) /\ P -> P /\ Q.
  Proof. my_tauto. Qed.

  Goal forall P Q,
    False /\ P -> Q.
  Proof. my_tauto. Qed.

  (* Niveau 2 : Avec le modus ponens *)
  Goal forall P Q : Prop,
    (P -> Q) -> (P -> True /\ Q).
  Proof. my_tauto. Qed.

  Goal forall P Q R : Prop,
    (Q -> R) -> (P /\ Q -> P /\ R).
  Proof. my_tauto. Qed.

  Goal forall P Q R S,
    (S -> P /\ (Q /\ R)) -> (S -> (P /\ Q) /\ R).
  Proof. my_tauto. Qed.

  Goal forall P Q R S,
    (S -> Q /\ (P /\ R)) -> (S -> (P /\ Q) /\ R).
  Proof. my_tauto. Qed.

  Goal forall P Q R,
    (R -> P /\ Q) -> (R -> Q /\ P).
  Proof. my_tauto. Qed.

  Goal forall P Q,
    (P -> Q /\ True) -> (P -> Q).
  Proof. my_tauto. Qed.

  (* Niveau 3 : Quelques cas plus avancés *)
  Goal forall P Q R : Prop,
    (P \/ Q \/ False) /\ (P -> Q) -> True /\ Q.
  Proof. my_tauto. Qed.

  Goal forall P Q,
    (P /\ True -> Q) -> (P -> Q).
  Proof. my_tauto. Qed.

  Goal forall P Q R S,
    (P /\ (Q /\ R) -> S) -> ((P /\ Q) /\ R -> S).
  Proof. my_tauto. Qed.

  Goal forall P Q R S,
    (Q /\ (P /\ R) -> S) -> ((P /\ Q) /\ R -> S).
  Proof. my_tauto. Qed.

  Goal forall P Q R,
    (P /\ Q -> R) -> (Q /\ P -> R).
  Proof. my_tauto. Qed.

  (* Niveau 4 : Pour aller plus loin que la tactique [tauto] *)
  Goal forall (T : Type) (P : T -> Prop) (Q R : Prop),
    (forall x, P x /\ Q -> R) -> (exists y, P y /\ Q -> R).
  Proof. my_tauto. Abort. (* L'énoncé est faux en l'état, nous ne savons pas si il existe un élément de type  T*)

  Goal forall (T : Type) (P : T -> Prop) (Q R : Prop) x,
    (Q -> P x /\ R) -> (Q -> ex P /\ R).
  Proof. my_tauto. Qed.

  Goal forall (P : nat -> Prop) Q, (exists x, P x /\ Q) -> Q /\ (exists x, P x).
  Proof. my_tauto. Qed.

  (** *** Exercice 2 - Passer de [bool] à [Prop] *)

  Require Import Arith Lia.

  (** Vous avez peut-être déjà remarqué que, parfois, Coq fait apparaitre des
      "notations" un peu étranges, comme [<=?]. *)

  (** En réalité, [<=] est une notation pour [le], qui lui-même est un
      prédicat inductif. Son type de retour est donc [Prop]. *)

  Check le.
  Check 1 <= 2.

  (** Par contre, [<=?] a pour type de retour [bool], comme vous le montre
  les commandes suivantes : *)
  Check  1 <=? 2.
  Check (1 <=? 2) = true.

  (** Il est tout à fait possible de passer d'une notation à l'autre : *)
  Lemma le_bool_imp_le : forall n m, (n <=? m) = true -> (n <= m).
  Proof.
    induction n.
    + destruct m.
      { intros. constructor.                     }
      { intros. constructor. apply Peano.le_0_n. }
    + destruct m.
      { simpl. intro H. discriminate H.                                 }
      { simpl. intro H. apply IHn in H. apply Peano.le_n_S. assumption. }
  Qed.

Lemma le_imp_le_bool : forall n m, (n <= m) -> (n <=? m)=true.
Proof.
  induction n.
  + intros. simpl. reflexivity.
  + intros. simpl. destruct m. inversion H. inversion H.
    ++ pose proof (IHn m). rewrite H1 in H0. apply H0. constructor.
    ++ apply Peano.le_S_n in H. apply (IHn m). exact H.
Qed.

  (** Mais comme [lia] ne raisonne que sur [Prop], cette tactique est capable
      de prouver le but [lt_impl_le_prop], mais pas le but [lt_impl_le_bool]. *)
  Lemma lt_impl_le_prop : forall n m, n < m -> n <= m.
  Proof. intros. lia. Qed.

Ltac conv_bool_to_prop := repeat match goal with
  | [ H : _ <? _ = true|- _ ] => apply le_bool_imp_le in H ; idtac "1"
  | [ H : _ <=? _ = true|- _ ] => apply le_bool_imp_le in H ; idtac "1.2"
  | [ |-  _ <? _ = true ] => apply le_imp_le_bool ; idtac "2"
  | [ |-  _ <=? _ = true ] => apply le_imp_le_bool ; idtac "2.2"

end.

  Lemma lt_impl_le_bool : forall n m, (n <? m) = true -> (n <=? m) = true.
  Proof. intros. conv_bool_to_prop. lia. Qed.

  (** Votre objectif est donc d'écrire une tactique qui réécrit des notations
      [bool] en des notations sur [Prop].
      L'utilisation de la bibliothèque standard de Coq est fortement
      recommandée. *)

  (** Vous commencerez par écrire une tactique qui transforme uniquement les
      hypothèses.
      Ensuite, il sera plus simple d'écrire une tactique qui transforme le but
      courant, en adaptant la tactique écrite précédemment. *)

(** ** IV. Des références pour aller plus loin *)

(** Ltac :
      - http://adam.chlipala.net/cpdt/html/Match.html
      - http://www.lirmm.fr/~delahaye/papers/ltac%20(LPAR%2700).pdf

    Ltac2, une version typée de Ltac :
      - https://coq.inria.fr/refman/proof-engine/ltac2.html *)


Lemma structured_intro_example1: forall A B C:Prop, A/\B/\C -> A.
Proof.
  intros A B C [Ha [Hb Hc]].

(*

 A : Prop
 B : Prop
 C : Prop
 Ha : A
 Hb : B
 Hc : C
 ============================
  A
*)

Abort.

Lemma structured_intro_example2: forall A B:Prop, A\/B/\(B->A)->A.
Proof.
 intros A B [Ha | [Hb Hi]].