(* A supplemental list library to help ott users *)

(* Definitions used by ott-generated output *)
Require Export Ott.ott_list_core.

(* Support library (non-list-related content) *)
Require Export Ott.ott_list_support.

(* Supplemental lemmas and tactics about basic functions (length, map, rev) *)
Require Export Ott.ott_list_base.

(* The take and drop functions, and lemmas and tactics about them
   (n = take n l ++ drop n l) /\ (length (take n l) = n) *)
Require Export Ott.ott_list_takedrop.

(* Supplemental lemmas about taking the nth element of a list *)
Require Export Ott.ott_list_nth.

(* Lemmas about [In], [list_mem] and [list_minus] *)
Require Export Ott.ott_list_mem.

(* Lemmas about [flat_map] *)
Require Export Ott.ott_list_flat_map.

(* Lemmas and tactics about [Forall_list], [Exists_list], [forall_list]
   and [exists_list] *)
Require Export Ott.ott_list_predicate.

(* The repeat function, and lemmas about it
   (length (repeat n x) = n) /\ (forall y, In y (repeat n x) -> x = y) *)
Require Export Ott.ott_list_repeat.

(* The [disjoint] function (test that two lists have no common element),
   the [all_distinct] function (test that a list has no repeated element),
   and lemmas about them *)
Require Export Ott.ott_list_distinct.


Require Import Iron.Language.SystemF.SubstTypeType.
Require Import Iron.Language.SystemF.SubstTypeExp.
Require Import Iron.Language.SystemF.TyJudge.

(* Substitution of Values in Values preserves Typing ****************)
Theorem subst_value_value_ix
 :  forall ix ke te x1 t1 x2 t2
 ,  get  ix te = Some t2
 -> TYPE ke te           x1 t1
 -> TYPE ke (delete ix te) x2 t2
 -> TYPE ke (delete ix te) (substXX ix x2 x1) t1.
Proof.
 intros. gen ix ke te t1 x2 t2.
 induction x1; intros; inverts H0; simpl; eauto.

 Case "XVar".
  fbreak_nat_compare.
  SCase "n = ix".
   rewrite H in H3. inverts H3. auto.

  SCase "n < ix".
   apply TYVar.
   rewrite <- H3. apply get_delete_above. auto. auto.

  SCase "n > ix".
   apply TYVar. auto.
   rewrite <- H3.
   destruct n.
    burn.
    simpl. nnat. apply get_delete_below. omega.
    auto.

 Case "XLAM".
  eapply (IHx1 ix) in H5.
  apply TYLAM.
   unfold liftTE. rewrite map_delete. eauto.
   eapply get_map. eauto.
   unfold liftTE. rewrite <- map_delete.
    assert (map (liftTT 0) (delete ix te) = liftTE 0 (delete ix te)).
     unfold liftTE. auto. rewrite H0. clear H0.
    apply type_kienv_weaken. auto.

 Case "XLam".
  apply TYLam.
   auto.
   rewrite delete_rewind.
   eapply IHx1; eauto.
   simpl. apply type_tyenv_weaken. auto.
Qed.

Theorem subst_value_value
 :  forall ke te x1 t1 x2 t2
 ,  TYPE ke (te :> t2) x1 t1
 -> TYPE ke te x2 t2
 -> TYPE ke te (substXX 0 x2 x1) t1.
Proof.
 intros.
 assert (te = delete 0 (te :> t2)). auto.
 rewrite H1. eapply subst_value_value_ix; eauto. eauto.
Qed.


Require Import List.

(* A string is a list of symbols. *)
Notation string X := (list X).

Module RuleNotation.
Notation "x / y" := (x, y).
End RuleNotation.
Import RuleNotation.

(* A string rewriting system SRS is a list of rules x / y
  such that x rewrites to y. *)
Notation SRS X := (list (string X * string X)).

(* If u / v is a rewriting rule, then x ++ u ++ y rewrites to x ++ v ++ y. *)
Inductive rew {X : Type} (R : SRS X) : string X -> string X -> Prop :=
  rewB x y u v : In (u / v) R -> rew R (x ++ u ++ y) (x ++ v ++ y).
(* rewt is the reflexive, transitive closure of rew. *)
Inductive rewt {X : Type} (R : SRS X) : string X -> string X -> Prop :=
  rewR z : rewt R z z
| rewS x y z : rew R x y -> rewt R y z -> rewt R x z.

(* String rewriting SR is
  given a string rewriting system R and two strings x and y,
  determine whether x rewrites to y in R. *)
Definition SR : SRS nat * string nat * string nat -> Prop :=
  fun '(R, x, y) => rewt R x y.

Definition swap {X Y} : X * Y -> Y * X := fun '(x,y) => (y,x).

(* Thue system reachability TSR is
  given a string rewriting system R and two strings x and y,
  determine whether x is equivalent to y in R. *)
Definition TSR : SRS nat * string nat * string nat -> Prop :=
    fun '(R, x, y) => rewt (R ++ map swap R) x y.


(* Finite natural numbers. TODO: remove, probably unused *)

Require Import Coq.Arith.Arith Coq.Arith.Minus Coq.Arith.Plus Coq.Arith.EqNat Coq.Arith.Lt.
Require Import Coq.Logic.Decidable.
Require Export Coq.Init.Specif.
Require Import Helix.Tactics.HelixTactics.
Require Import Helix.Util.Misc.

Require Import Psatz.

Require Import MathClasses.interfaces.abstract_algebra.
Require Import MathClasses.orders.minmax.
Require Import MathClasses.implementations.peano_naturals.

Import ArithRing.

Notation FinNat n := {x:nat | (x<n)%nat}.
Definition mkFinNat {n} {j:nat} (jc:(j<n)%nat) : FinNat n := @exist _ (gt n) j jc.

Local Open Scope nat_scope.

Definition mkSFinNat {d: nat} (x:FinNat d): FinNat (S d) :=
  let (x, xc) := x in
  let sxc : x < S d := le_S xc in mkFinNat sxc.

Definition mkSFinNat' {d d': nat} (E: d ≡ S d'): FinNat d
  := @mkFinNat d d' (eq_ind_r (fun d0 => d' < d0) (le_n (S d')) E).

Lemma mkSFinNat_proj1_eq {d: nat} (x:FinNat d):
  proj1_sig x ≡ proj1_sig (mkSFinNat x).
Proof.
  unfold mkSFinNat.
  break_let.
  reflexivity.
Qed.

Program Definition expandFinNat {d d': nat} (E: d ≡ S d') (x:FinNat d'): FinNat d
  := @mkFinNat d (proj1_sig x) _.

(* TODO: rework *)
Definition castFinNat {n m:nat} {d:nat} (E:m+d=n) (a: FinNat m): FinNat n.
Proof.
  destruct a as [x xc].
  assert(C: x<n).
  {
    rewrite <- E.
    apply lt_plus_trans.
    apply xc.
  }
  exact (mkFinNat C).
Defined.

Definition FinNat_bloat
           {m n:nat}
           (mn: (m < n)%nat):
  FinNat m -> FinNat n.
Proof.
  intros H.
  destruct H.
  assert (xc:(x<n)%nat).
  apply Nat.lt_trans with (m:=m); auto.
  exact (mkFinNat xc).
Defined.

Global Instance FinNat_bloat_proper
       {m n:nat}
       (mn: (m<n)%nat):
  Proper ((=) ==> (=)) (FinNat_bloat mn).
Proof.
  intros x y H.
  destruct x, y.
  unfold FinNat_bloat.
  inversion H.
  simpl in H0.
  clear H.
  unfold mkFinNat.
  unfold equiv, Sig_Equiv.
  simpl.
  rewrite H0.
  reflexivity.
Qed.

(* Quick and dirty  *)
Program Definition FN_div {n m:nat} (a: FinNat n) (b: FinNat m) : FinNat n
  := let (x, xc) := a in
     let (y, yc) := b in
     let d := Nat.div x y in
     @mkFinNat n d _.
Next Obligation.
  destruct y.
  -
    crush.
  -
    apply PeanoNat.Nat.div_lt_upper_bound.
    auto.
    nia.
Defined.

(* Quick and dirty  *)
Program Definition FN_mod {n m:nat} (a: FinNat n) (b: FinNat m) : FinNat m
  := let (x, xc) := a in
     let (y, yc) := b in
     let d := Nat.modulo x y in
     @mkFinNat m d _.
Next Obligation.
  destruct y.
  -
    unfold Nat.modulo.
    auto.
  -
    pose proof PeanoNat.Nat.mod_upper_bound x (S y) as U.
    assert(S: S y ≢ 0) by auto.
    specialize (U S).
    nia.
Defined.

(* Quick and dirty  *)
Program Definition FN_plus {n m:nat} (a: FinNat n) (b: FinNat m) : FinNat (n + m)
  := let (x, xc) := a in
     let (y, yc) := b in
     let d := x + y in
     @mkFinNat _ d _.
Next Obligation.
  nia.
Defined.

Program Definition FN_minus {n m:nat} (a: FinNat n) (b: FinNat m) : FinNat n
  := let (x, xc) := a in
     let (y, yc) := b in
     let d := x - y in
     @mkFinNat _ d _.
Next Obligation.
  nia.
Defined.

Program Definition FN_mult {n m:nat} (a: FinNat n) (b: FinNat m) : FinNat (n * m)
  := let (x, xc) := a in
     let (y, yc) := b in
     let d := x * y in
     @mkFinNat _ d _.
Next Obligation.
  nia.
Defined.

Program Definition FN_min {n m:nat} (a: FinNat n) (b: FinNat m) : FinNat (min n m)
  := let (x, xc) := a in
     let (y, yc) := b in
     let d := min x y in
     @mkFinNat _ d _.
Next Obligation.
  unfold min.
  unfold sort.
  break_if; break_if; simpl; auto.
  -
    clear Heqd Heqd0 a b H0 H.
    apply Compare_dec.not_le in n0.
    destruct l; nia.
  -
    clear Heqd Heqd0 a b H H0.
    apply Compare_dec.not_le in n0.
    nia.
Defined.

Program Definition FN_max {n m:nat} (a: FinNat n) (b: FinNat m) : FinNat (max n m)
  := let (x, xc) := a in
     let (y, yc) := b in
     let d := max x y in
     @mkFinNat _ d _.
Next Obligation.
  unfold max.
  unfold sort.
  break_if; break_if; simpl; auto.
  -
    clear Heqd Heqd0 a b H0 H.
    apply Compare_dec.not_le in n0.
    destruct l; nia.
  -
    clear Heqd Heqd0 a b H H0.
    apply Compare_dec.not_le in n0.
    destruct l.
    nia.
    nia.
Defined.

Global Instance castFinNat_proper {n m d:nat} {E}:
  Proper ((=) ==> (=)) (@castFinNat n m d E).
Proof.
  intros x y Exy.
  unfold castFinNat.
  repeat break_let.
  unfold mkFinNat, equiv, Sig_Equiv.
  simpl.
  auto.
Qed.

Global Instance FN_div_proper {n m:nat}:
  Proper ((=) ==> (=) ==> (=)) (@FN_div n m).
Proof.
  intros x x' Ex y y' Ey.
  unfold FN_div.
  repeat break_let.
  unfold mkFinNat, equiv, Sig_Equiv in *.
  simpl in *.
  subst.
  rewrite Ex, Ey.
  reflexivity.
Qed.

Global Instance FN_mod_proper {n m:nat}:
  Proper ((=) ==> (=) ==> (=)) (@FN_mod n m).
Proof.
  intros x x' Ex y y' Ey.
  unfold FN_mod.
  repeat break_let.
  unfold mkFinNat, equiv, Sig_Equiv in *.
  simpl in *.
  subst.
  rewrite Ex, Ey.
  reflexivity.
Qed.

Global Instance FN_plus_proper {n m:nat}:
  Proper ((=) ==> (=) ==> (=)) (@FN_plus n m).
Proof.
  intros x x' Ex y y' Ey.
  unfold FN_plus.
  repeat break_let.
  unfold mkFinNat, equiv, Sig_Equiv in *.
  simpl in *.
  subst.
  rewrite Ex, Ey.
  reflexivity.
Qed.

Global Instance FN_minus_proper {n m:nat}:
  Proper ((=) ==> (=) ==> (=)) (@FN_minus n m).
Proof.
  intros x x' Ex y y' Ey.
  unfold FN_minus.
  repeat break_let.
  unfold mkFinNat, equiv, Sig_Equiv in *.
  simpl in *.
  subst.
  rewrite Ex, Ey.
  reflexivity.
Qed.

Global Instance FN_mult_proper {n m:nat}:
  Proper ((=) ==> (=) ==> (=)) (@FN_mult n m).
Proof.
  intros x x' Ex y y' Ey.
  unfold FN_mult.
  repeat break_let.
  unfold mkFinNat, equiv, Sig_Equiv in *.
  simpl in *.
  subst.
  rewrite Ex, Ey.
  reflexivity.
Qed.

Global Instance FN_min_proper {n m:nat}:
  Proper ((=) ==> (=) ==> (=)) (@FN_min n m).
Proof.
  intros x x' Ex y y' Ey.
  unfold FN_min.
  repeat break_let.
  unfold mkFinNat, equiv, Sig_Equiv in *.
  simpl in *.
  subst.
  rewrite Ex, Ey.
  reflexivity.
Qed.

Global Instance FN_max_proper {n m:nat}:
  Proper ((=) ==> (=) ==> (=)) (@FN_max n m).
Proof.
  intros x x' Ex y y' Ey.
  unfold FN_max.
  repeat break_let.
  unfold mkFinNat, equiv, Sig_Equiv in *.
  simpl in *.
  subst.
  rewrite Ex, Ey.
  reflexivity.
Qed.

Definition S_j_lt_0 {n p : nat}: S p ≡ n → 0 < n.
Proof.
  intros H.
  subst.
  apply zero_lt_Sn.
Defined.

Lemma FinNat_eq_dec {n:nat}  (a b: FinNat n): {a ≡ b} + {a ≢ b}.
Proof.
  destruct a as [a ac].
  destruct b as [b bc].
  destruct (eq_nat_dec a b) as [E | NE].
  -
    left.
    apply eq_exist_uncurried.
    unshelve econstructor.
    apply E.
    unfold eq_rect.
    break_match.
    apply NatUtil.lt_unique.
  -
    right.
    intros C.
    apply proj1_sig_eq in C.
    simpl in C.
    congruence.
Qed.


(* File contributed by Nicolas Magaud *)
(* Cf. "Transferring Arithmetic Decision Procedures (on Z) to Alternative Representations" *)
(* presented at CoqPL 2017 *)

From mathcomp Require Import ssrint ssrnum ssrbool.
From Coq Require Import ZArith Lia.
Require Import Transfer tactics iso_ssrint.

Notation "x + y" := (intZmod.addz x y).
Notation "x - y" := (x + intZmod.oppz y).
Notation "x * y" := (intRing.mulz x y).

Definition le3r' (x y z:int) : Prop := (ler' x y) /\ (ler' y z).

Instance le3_transfer : Related (R ##> R ##> R##> iff) (fun x y z => x <= y /\ y <= z) le3r'.
Proof.
repeat red; intros; split; unfold le3r'; intros.
inversion H2.
split.
eapply le_transfer; eassumption.
eapply le_transfer; eassumption.
inversion H2.
split.
eapply le_transfer; eassumption.
eapply le_transfer; eassumption.
Qed.

Notation "x <= y" := (ler' x y).
Notation " x < y" := (ltr' x y).
Notation "x <= y <= z" := (le3r' x y z).
Notation "x >= y" := (ger' x y).
Notation " x > y" := (gtr' x y).

Open Scope int_scope.
Notation "0" := 0%:Z.
Notation "1" := 1%:Z.
Notation "2" := 2%:Z.
Notation "27" := 27%:Z.
Notation "11" := 11%:Z.
Notation "13" := 13%:Z.
Notation "45" := 45%:Z.
Notation "- 10" := (intZmod.oppz 10%:Z).
Notation "7" := 7%:Z.
Notation "9" := 9%:Z.
Notation "4" := 4%:Z.

Close Scope int_scope.

Lemma two_x_eq_1 : forall x, 2 * x = 1 -> False.
Proof.
  tlia.
Qed.

Lemma two_x_y_eq_1 : forall x y, 2 * x + 2 * y = 1 -> False.
Proof.
  tlia.
Qed.

Lemma two_x_y_z_eq_1 : forall x y z, 2 * x + 2 * y + 2 * z= 1 -> False.
Proof.
  tlia.
Qed.

Lemma omega_nightmare : forall x y:int, 27 <= 11 * x + 13 * y <= 45 -> -10 <= 7 * x - 9 * y <= 4 -> False.
tlia.
Qed.

Lemma compact_proof : forall z:int,
 (z < 0) ->
 (z >= 0) ->
  (0 >= z \/ 0 < z) -> False.
Proof.
 tlia.
Qed.


(** matrix_lemmas.v:  Definitions and lemmas for error analysis
  of ODE systems using matrices.
 Copyright (C) 2021-2022 and Ariel Kellison.
*)

From Coq Require Import ZArith Reals Psatz.
From Coq Require Import Arith.Arith.
Require Import real_lemmas.
Require Import Init.Nat Arith.EqNat.

From Coq Require Import ssreflect.
From Coquelicot Require Import Coquelicot.
Require Import Interval.Tactic.

Set Bullet Behavior "Strict Subproofs".

Require Import Coq.Logic.FunctionalExtensionality.

Definition C0: C := (0,0).
Definition C1: C := (1,0).

(*********************************)
(* MATRIX TRANSPOSE       *)
(*********************************)

Definition matrix_conj_transpose (n m:nat) (M: @matrix C n m) : @matrix C m n :=
  mk_matrix m n (fun i j => Cconj (coeff_mat Hierarchy.zero M j i))
.

Lemma Cconj_plus (a b : C) :
  Cconj( Cplus a  b) = Cplus (Cconj a) (Cconj b).
Proof.
destruct a, b.
cbv [Cconj Cplus].
simpl.
apply pair_equal_spec; split; auto.
nra.
Qed.

Lemma Cconj_mult (a b : C) :
  Cconj( Cmult a  b) = Cmult (Cconj a) (Cconj b).
Proof.
destruct a, b.
cbv [Cconj Cmult].
simpl.
apply pair_equal_spec; split; auto.
nra.
field_simplify; nra.
Qed.

Lemma tranpose_rewrite (A: @matrix C 2 2) (x: @matrix C 2 1):
(matrix_conj_transpose 2 1 (Mmult A x)) =
Mmult (matrix_conj_transpose 2 1 x) (matrix_conj_transpose 2 2 A).
Proof.
unfold matrix_conj_transpose.
unfold Mmult.
apply mk_matrix_ext; intros.
rewrite coeff_mat_bij; try lia.
replace (Init.Nat.pred 2) with (S 0) by lia.
repeat rewrite sum_Sn.
repeat rewrite coeff_mat_bij; try lia.
repeat rewrite sum_O.
repeat rewrite coeff_mat_bij; try lia.
change plus with Cplus.
change mult with Cmult.
assert ( (i = 0)%nat) by lia.
subst.
assert ( (j = 0)%nat \/ (j <> 0)%nat) by lia; destruct H1.
-
subst.
unfold coeff_mat.
simpl.
rewrite Cconj_plus.
repeat rewrite Cconj_mult.
rewrite Cmult_comm.
rewrite Cplus_comm.
rewrite Cmult_comm.
rewrite Cplus_comm.
auto.
-
assert (j=1)%nat by lia.
subst.
unfold coeff_mat.
simpl.
rewrite Cconj_plus.
repeat rewrite Cconj_mult.
rewrite Cmult_comm.
rewrite Cplus_comm.
rewrite Cmult_comm.
rewrite Cplus_comm.
auto.
Qed.

(* multiply a matrix by a complex number *)
Definition mat_coeff_mult (a : C) (n m:nat) (V: @matrix C n m) : @matrix C n m :=
  @mk_matrix C n m (fun i j =>
      Cmult a (@coeff_mat C n m Hierarchy.zero V i j))
.

Lemma zero_d_matrices_eq (x y : @matrix C 0 1%nat) :
  x = y.
Proof.
destruct x , y; auto.
Qed.

(*********************************)
(* ID MATRIX & ZERO MATRIX       *)
(*********************************)

(* complex zero matrix and zero vector *)
Definition M0 (n:nat) : @matrix C n n := Mzero.
Definition V0 (n:nat) : @matrix C n 1%nat := mk_matrix n 1%nat (fun _ _ => C0)
.

(* identity *)
Definition M_ID (n:nat) : @matrix C n n :=
  mk_matrix n n (fun i j => if (eqb i j) then C1 else C0)
.

(* vector of ones *)
Definition v1 (n:nat) : @matrix C n 1%nat := mk_matrix n 1%nat (fun _ _ => C1).

Lemma M_ID_equiv_M1 :
  forall n : nat, M_ID n = Mone.
Proof.
intros.
apply mk_matrix_ext => i j Hi Hj.
assert (i = j \/ i <> j) by lia.
destruct H.
-
rewrite Mone_seq_diag; auto.
apply Nat.eqb_eq in H.
destruct eqb; try discriminate; auto.
-
rewrite Mone_seq_not_diag; auto.
apply Nat.eqb_neq in H.
destruct eqb; try discriminate; auto.
Qed.

Lemma Mmult_Mzero_r (n: nat) (M: @matrix C n n) :
  @Mmult C_Ring n n n M Mzero  = Mzero.
Proof.
apply mk_matrix_ext => i j Hi Hj.
pose proof @sum_n_ext_loc C_Ring
  (fun l : nat => mult (coeff_mat zero M i l) (@coeff_mat C n n zero Mzero l j))
  (fun l : nat => mult (coeff_mat zero M i l) zero)
  (pred n).
rewrite H; clear H; try apply sum_n_m_const_zero.
-
rewrite sum_n_mult_r; apply mult_zero_r.
-
intros.
f_equal.
apply coeff_mat_bij;lia.
Qed.

Lemma Mmult_Mzero_l (n: nat) (M: @matrix C n n) :
  @Mmult C_Ring n n n Mzero M  = Mzero.
Proof.
apply mk_matrix_ext => i j Hi Hj.
pose proof @sum_n_ext_loc C_Ring
  (fun l : nat => mult (@coeff_mat C n n zero Mzero i l) (coeff_mat zero M l j))
  (fun l : nat => mult zero (coeff_mat zero M l j))
  (pred n).
rewrite H; clear H; try apply sum_n_m_const_zero.
-
rewrite sum_n_mult_l; apply mult_zero_l.
-
intros.
f_equal.
apply coeff_mat_bij;lia.
Qed.

Lemma Mmult_M0_vec (n: nat) (V: @matrix C n 1%nat) :
  @Mmult C_Ring n n 1%nat (M0 n) V  = Mzero.
Proof.
apply mk_matrix_ext => i j Hi Hj.
pose proof @sum_n_ext_loc C_Ring
  (fun l : nat => @mult C_Ring (@coeff_mat C_Ring n n (@zero C_Ring) (M0 n) i l)
     (@coeff_mat C_Ring n 1 (@zero C_Ring) V l j))
  (fun l : nat => mult zero (coeff_mat zero V l j))
  (pred n).
rewrite H; clear H; try apply sum_n_m_const_zero.
-
rewrite sum_n_mult_l; apply mult_zero_l.
-
intros.
f_equal.
apply coeff_mat_bij;lia.
Qed.

Lemma Mcong_transpose_zero (n: nat) (M: @matrix C n n) :
matrix_conj_transpose n n M = (M0 n) <-> M = (M0 n).
Proof.
split; intros.
-
rewrite (@coeff_mat_ext_aux C_Ring n n zero zero) in H.
replace M with (mk_matrix n n (coeff_mat zero M)) by
  (apply mk_matrix_bij).
apply mk_matrix_ext => i j  Hi Hj.
unfold matrix_conj_transpose in H.
specialize (H j i Hj Hi).
unfold M0, Mzero, Cconj in H.
repeat rewrite coeff_mat_bij in H; try lia.
destruct (coeff_mat zero M i j); simpl in H; auto.
symmetry in H; inversion H. subst.
assert (r0 = 0) by nra; subst; auto.
-
subst.
unfold matrix_conj_transpose, M0, Mzero, Cconj.
apply mk_matrix_ext => i j  Hi Hj.
repeat rewrite coeff_mat_bij; try lia; simpl.
rewrite Ropp_0; auto.
Qed.

Lemma M0_coeff_zero (n: nat) :
forall i j, (i < n)%nat /\ (j < n)%nat -> @coeff_mat C n n (@zero C_AbelianGroup) (M0 n) i j = 0.
intros.
unfold M0, Mzero. apply coeff_mat_bij; lia.
Qed.

Lemma eq_M0_iff (n: nat) (M : @matrix C n n) :
  M = M0 n <-> forall i j, ((i < n)%nat /\ (j < n)%nat) -> (@coeff_mat C_Ring n n zero M i j) = zero.
Proof.
split; intros.
-
subst. unfold M0, Mzero.
apply coeff_mat_bij; try lia; auto.
-
destruct n.
+
destruct M; auto.
+
unfold M0, Mzero.
pose proof @mk_matrix_bij C_Ring (S n) (S n) zero M as Hm.
rewrite <- Hm.
apply mk_matrix_ext => i j Hi Hj.
apply H; auto.
Qed.

Lemma neq_M0_implies_aux1 (n: nat) (M1 : @matrix C n n) (M2 : @matrix C (S n) (S n)):
  (M1 = M0 n -> False) ->
  (forall i j, ((i < n)%nat /\ (j < n)%nat) -> (coeff_mat zero M2 i j) = (coeff_mat zero M1 i j)) ->
  (M2 = M0 (S n) -> False).
Proof.
intros.
contradiction H; clear H.
rewrite eq_M0_iff in H1.
apply eq_M0_iff; intros.
specialize (H0 i j H).
assert (HS: (i < S n)%nat /\ (j < S n)%nat) by lia.
specialize (H1 i j HS).
etransitivity. symmetry. eassumption.
auto.
Qed.

Lemma eq_V0_iff (n: nat) (V : @matrix C n 1%nat) :
  V = V0 n <-> forall i, (i < n)%nat -> (@coeff_mat C_Ring n 1%nat zero V i 0) = zero.
Proof.
split; intros.
-
subst. unfold V0, Mzero.
apply coeff_mat_bij; try lia; auto.
-
destruct n.
+
destruct V; auto.
+
unfold V0, Mzero.
pose proof @mk_matrix_bij C_Ring (S n) 1 zero V as Hm.
rewrite <- Hm.
apply mk_matrix_ext => i j Hi Hj.
assert (j=0%nat) by lia.
subst.
apply H; auto.
Qed.
(* end ID and 0 matrix lemmas *)

(******************)
(** ORTHOGONAL MATRICES *)
(*******************)
Definition is_orthogonal_matrix (n: nat ) (Q : @matrix C n n) :=
  Mmult (matrix_conj_transpose n n Q) Q = Mone /\
  Mmult Q (matrix_conj_transpose n n Q) = Mone
.

(*******************)
(* DIAGONAL MATRICES *)
(*******************)
(* a matrix is diagonal if *)
Definition diag_pred (n: nat) (M: @matrix C n n) :=
  forall i j, (i < n)%nat /\ (j < n)%nat /\ (i <> j)%nat -> (@coeff_mat C n n Hierarchy.zero M i j) = zero
.

(* construct a diagonal matrix from a vector *)
Definition vec_to_diag (n:nat) (V: @matrix C n 1%nat) : @matrix C n n :=
  (@mk_matrix C n n (fun i j => if (eqb i j) then
      (@coeff_mat C n 1%nat Hierarchy.zero V i 0) else C0))
.

(* vec_to_diag construction is a diagonal matrix *)
Lemma vec_to_diag_pred (n: nat) (L: matrix n 1%nat) :
  diag_pred n (vec_to_diag n L).
Proof.
unfold diag_pred, vec_to_diag; intros.
rewrite coeff_mat_bij; try lia.
destruct H as (A & B & C).
apply Nat.eqb_neq in C.
destruct eqb; auto; try discriminate.
Qed.

Lemma M_ID_diag (m: nat) :
diag_pred m (M_ID m).
Proof.
unfold diag_pred; intros.
unfold M_ID.
rewrite coeff_mat_bij; try auto; try lia.
destruct H as (A & B & C).
apply Nat.eqb_neq in C.
destruct eqb; auto; try discriminate.
Qed.

(*************************)
(* COMPLEX NUMBER LEMMAS *)
(*************************)
Lemma Czero_sqs (x : C) :
  0<= Cmod x /\ Cmod x <= 0 -> Cmod x = 0.
Proof.
unfold Cmod.
intros.
destruct H.
apply Rle_antisym; auto.
Qed.

Lemma Ceq_Cmod_eq (x y : C):
  x = y -> Cmod x = Cmod y.
Proof.
intros; subst; auto.
Qed.

Lemma C_sqr_ccong  (c : C) :
(Cmult c (Cconj c)) = fst(c)^2 + snd(c)^2.
Proof.
destruct c.
unfold Cconj.
cbv [Cmult RtoC].
simpl.
apply pair_equal_spec; split; nra.
Qed.

Lemma C_sqr_ccong2  (c : C) :
(Cmult (Cconj c) c ) = fst(c)^2 + snd(c)^2.
Proof.
destruct c.
unfold Cconj.
cbv [Cmult RtoC].
simpl.
apply pair_equal_spec; split; nra.
Qed.

Lemma Cmod_Ccong  (c : C) :
(Cmult c (Cconj c)) = (Cmod c)^2.
Proof.
destruct c.
unfold Cconj, Cmod.
cbv [Cmult RtoC].
simpl.
apply pair_equal_spec; split; try nra.
repeat rewrite Rmult_1_r.
rewrite sqrt_def; try nra.
Qed.

Lemma cmod_le_0 x:
Cmod x <= 0 -> x = 0.
Proof.
intros.
unfold Cmod in *.
pose proof sqrt_pos (fst x ^ 2 + snd x ^ 2).
apply Cmod_eq_0.
apply Czero_sqs.
split; auto.
Qed.

Lemma mult_aux1 (a b : R ) :
  @mult C_Ring (a , 0) (0 , b) = (0 , a * b).
Proof.
cbv. f_equal;
nra.
Qed.

Lemma mult_aux2 (a b c: R ) :
  @mult C_Ring (a , 0) (c , b) = (a * c , a * b).
Proof.
cbv. f_equal;
rewrite Rmult_0_l; nra.
Qed.

Lemma mult_aux3 (a b c: R ) :
  @mult C_Ring (0 , a) (b , c) = (-a * c , a * b).
Proof.
cbv. f_equal;
rewrite Rmult_0_l; nra.
Qed.

Lemma Rmult_le (a b :R):
  0 <= a * b ->  0 < a ->  0 <= b .
Proof.
intros.
nra.
Qed.

Lemma Cdiv_zero (a : C):
  a <> 0 -> Cdiv 0 a = C0.
Proof.
intros.
cbv [Cdiv Cinv].
destruct a.
unfold C0, fst, snd.
apply pair_equal_spec. unfold fst, snd; simpl.
repeat rewrite Rmult_0_l; nra.
Qed.

Lemma Cmult_zero (a b : C) :
  Cmult a b = 0 -> b <> 0 -> a = 0.
Proof.
intros.
assert (H1 : Cdiv (Cmult a b) b = Cdiv 0 b) by (rewrite H; auto).
assert (H2 : Cdiv (Cmult a b) b = Cmult a (Cdiv b b)).
destruct b; destruct a.
cbv [Cmult Cdiv]; simpl.
apply pair_equal_spec. nra.
rewrite H2 in H1.
replace (Cdiv b b ) with C1 in H1.
replace (Cmult a C1) with a in H1.
rewrite Cdiv_zero in H1; auto.
cbv [C1 Cmult]; destruct a; simpl; apply pair_equal_spec;split; nra.
replace (Cdiv b b) with (b * / b)%C.
rewrite Cinv_r; auto.
cbv [Cmult Cdiv]. apply pair_equal_spec;split; nra.
Qed.
(* end complex number lemmas *)

(******************)
(* EUCLIDEAN NORM *)
(******************)
Definition vec_two_norm (n: nat ) (u : @matrix C n 1) : R :=
   Coq.Reals.R_sqrt.sqrt (Cmod (@coeff_mat C 1%nat 1%nat Hierarchy.zero (Mmult (matrix_conj_transpose n 1 u) u) 0 0))
.

Definition vec_two_norm_2d (u : @matrix C 2 1) : R :=
  Rprod_norm (Cmod (@coeff_mat C 2 1%nat Hierarchy.zero u 0 0), Cmod (@coeff_mat C 2 1 Hierarchy.zero u 1 0))
.

Theorem two_norms_eq_2d (u : @matrix C 2 1%nat) :
vec_two_norm 2 u = vec_two_norm_2d u .
Proof.
unfold vec_two_norm_2d, Rprod_norm, vec_two_norm, Mmult, matrix_conj_transpose.
symmetry.
unfold fst at 1.
unfold snd at 1.
symmetry.
f_equal.
rewrite coeff_mat_bij; try lia.
etransitivity.
apply Ceq_Cmod_eq.
apply sum_Sn.
rewrite sum_O.
simpl.
repeat rewrite coeff_mat_bij; try lia.
change mult with Cmult.
rewrite Cmult_comm.
rewrite Cmod_Ccong.
rewrite Cmult_comm.
rewrite Cmod_Ccong.
repeat rewrite Rmult_1_r.
match goal with |-context[Cmod ?a * Cmod ?a] =>
replace (Cmod a * Cmod a) with (Cmod a ^ 2)
end.
match goal with |-context[Cmod ?a * Cmod ?a] =>
replace (Cmod a * Cmod a) with (Cmod a ^ 2)
end.
etransitivity.
unfold Cmod.
unfold RtoC.
repeat rewrite pow2_sqrt.
change plus with Cplus.
repeat match goal with |-context[R_sqrt.sqrt (fst (?a) ^2 + snd?b ^2)] =>
replace (snd b) with 0
end.
rewrite pow_i; try lia.
rewrite Rplus_0_r.
cbv [Cplus].
unfold fst at 1.
apply sqrt_pow2.
unfold fst at 1.
unfold fst at 2.
apply Rle_plus;
apply sqr_plus_pos.
simpl; try nra.
apply sqr_plus_pos.
apply sqr_plus_pos.
unfold fst at 1.
unfold fst at 2.
fold Cmod.
etransitivity.
assert (fst (coeff_mat zero u 0 0) ^ 2 + snd (coeff_mat zero u 0 0) ^ 2 +
(fst (coeff_mat zero u 1 0) ^ 2 + snd (coeff_mat zero u 1 0) ^ 2) =
(Cmod (coeff_mat zero u 0 0))^2  + (Cmod (coeff_mat zero u 1 0) )^2).
unfold Cmod.
repeat rewrite pow2_sqrt; try apply sqr_plus_pos; auto.
apply H; auto.
auto.
auto.
simpl.
rewrite Rmult_1_r; auto.
simpl.
rewrite Rmult_1_r; auto.
Qed.

(* multiplying two diagonal matrices preserves diag predicate*)
Lemma Matrix_diag_mult_diag (n: nat) (M1 M2 M3: @matrix C n n):
  diag_pred n M1 ->
  diag_pred n M2 ->
  (Mmult M1 M2) = M3 -> diag_pred n M3.
Proof.
intros.
unfold diag_pred in *.
intros.
unfold Mmult in H1.
subst.
rewrite coeff_mat_bij; try lia.
pose proof (@sum_n_m_ext_loc C_Ring
(fun l : nat => mult (coeff_mat zero M1 i l) (coeff_mat zero M2 l j))
(fun _ : nat => zero) 0 (pred n)).
unfold sum_n.
rewrite H1; clear H1.
apply sum_n_m_const_zero.
intros.
assert (HK: i <> k \/ j <> k) by lia; destruct HK as [A | B].
-
assert ((i < n)%nat /\ (k < n)%nat /\ i <> k) as Hk1 by lia.
specialize (H i k Hk1); rewrite H; rewrite mult_zero_l; auto.
-
assert ((k < n)%nat /\ (j < n)%nat /\ k <> j) as Hk2 by lia.
specialize (H0 k j Hk2); rewrite H0; rewrite mult_zero_r; auto.
Qed.

(* a more constructive result of multiplying two diagonal matrices :
  we know the exact components of the resulting matrix *)
Lemma Matrix_diag_mult ( n: nat) (M1 M2 M3: @matrix C n n):
  diag_pred n M1 ->
  diag_pred n M2 ->
  (Mmult M1 M2) = M3 ->
  forall i j, (i < n)%nat /\ (j < n)%nat ->
  @coeff_mat C n n Hierarchy.zero M3 i j =
  Cmult (@coeff_mat C n n Hierarchy.zero M1 i j) (@coeff_mat C n n Hierarchy.zero M2 i j).
Proof.
intros.
assert (Hij: i = j \/ i <> j) by lia; destruct Hij.
-
subst.
destruct j.
+
unfold coeff_mat at 1.
repeat rewrite coeff_Tn_bij; try lia.
assert (A: (0 <= 1)%nat) by lia.
assert (B: (0 <= pred n)%nat) by lia.
pose proof
  @sum_n_m_Chasles C_Ring (fun l : nat => mult (coeff_mat zero M1 0 l) (coeff_mat zero M2 l 0))
  0 0 (pred n) A B.
unfold sum_n.
rewrite H1; clear H1.
match goal with |- context [plus ?a ?b = _] =>
  assert (b = zero)
end.
*
unfold diag_pred in *.
pose proof (@sum_n_m_ext_loc C_Ring
(fun l : nat => mult (coeff_mat zero M1 0l) (coeff_mat zero M2 l 0))
(fun _ : nat => zero) 1 (pred n)).
rewrite H1; clear  H1.
rewrite sum_n_m_const_zero; auto.
intros k Hk.
assert (Hjk: (0 < n)%nat /\ (k < n)%nat /\ (0 <> k)%nat ) by lia.
specialize (H 0%nat k Hjk); rewrite H.
rewrite mult_zero_l; auto.
*
rewrite H1; clear H1.
rewrite plus_zero_r.
rewrite sum_n_n.
unfold mult, Ring.mult; simpl; auto.
+
rewrite coeff_mat_bij; try lia.
assert (Hj : (0 <= S (S j))%nat) by lia.
assert (Hjj: (S j <= pred n)%nat) by lia.
pose proof
  @sum_n_m_Chasles C_Ring (fun l : nat => mult (coeff_mat zero M1 (S j) l) (coeff_mat zero M2 l (S j)))
  0 (S j) (pred n) Hj Hjj.
unfold sum_n.
rewrite H1; clear H1.
match goal with |- context [plus ?a ?b = _] =>
  assert (b = zero)
end.
*
unfold diag_pred in *.
pose proof (@sum_n_m_ext_loc C_Ring
(fun l : nat => mult (coeff_mat zero M1 (S j) l) (coeff_mat zero M2 l (S j)))
(fun _ : nat => zero) (S (S j)) (pred n)).
rewrite H1; clear  H1.
rewrite sum_n_m_const_zero; auto.
intros k Hk.
assert (Hjk: (S j < n)%nat /\ (k < n)%nat /\ S j <> k) by lia.
specialize (H (S j) k Hjk); rewrite H.
rewrite mult_zero_l; auto.
*
rewrite H1; clear H1.
rewrite plus_zero_r.
assert (A: (0 < S j)%nat) by lia.
assert (B: (0 <= S j)%nat) by lia.
assert (C: (j <= S j)%nat) by lia.
pose proof
  @sum_n_m_Chasles C_Ring (fun l : nat => mult (coeff_mat zero M1 (S j) l) (coeff_mat zero M2 l (S j)))
  0 (j) (S j) B C.

rewrite H1; clear H1.
match goal with |- context [plus ?a ?b = _] =>
  assert (a = zero)
end.
--
unfold diag_pred in *.
pose proof (@sum_n_m_ext_loc C_Ring
(fun l : nat => mult (coeff_mat zero M1 (S j) l) (coeff_mat zero M2 l (S j)))
(fun _ : nat => zero) 0 j).
rewrite H1; clear  H1.
rewrite sum_n_m_const_zero; auto.
intros k Hk.
assert (Hjk: (S j < n)%nat /\ (k < n)%nat /\ S j <> k) by lia.
specialize (H (S j) k Hjk); rewrite H.
rewrite mult_zero_l; auto.
--
rewrite H1; clear H1.
rewrite plus_zero_l.
rewrite sum_n_n.
unfold mult, Ring.mult; simpl; auto.
-
unfold diag_pred in *.
subst.
rewrite coeff_mat_bij; try lia.
pose proof (@sum_n_m_ext_loc C_Ring
(fun l : nat => mult (coeff_mat zero M1 i l) (coeff_mat zero M2 l j))
(fun _ : nat => zero) 0 (pred n)).
unfold sum_n.
rewrite H1.
rewrite sum_n_m_const_zero; auto.
pose proof H i j as A.
rewrite A; try lia.
pose proof H0 i j as B.
rewrite B; try lia.
rewrite Cmult_0_l; auto.
intros.
assert (HK: i <> k \/ j <> k) by lia; destruct HK as [A | B].
+
assert ((i < n)%nat /\ (k < n)%nat /\ i <> k) as Hk1 by lia.
specialize (H i k Hk1); rewrite H; rewrite mult_zero_l; auto.
+
assert ((k < n)%nat /\ (j < n)%nat /\ k <> j) as Hk2 by lia.
specialize (H0 k j Hk2); rewrite H0; rewrite mult_zero_r; auto.
Qed.

(*[ a b ] [ x 0 ]   [ ax by ]
  [ c d ] [ 0 y ] = [ cx dy ] *)
Lemma Mmult_diagonal_implies (n: nat) (M L A: @matrix C n n) :
  diag_pred n L ->
  Mmult M L = A ->
  forall i j, (i < n)%nat /\ (j < n)%nat ->
  @coeff_mat C n n Hierarchy.zero A i j =
  Cmult (@coeff_mat C n n Hierarchy.zero M i j) (@coeff_mat C n n Hierarchy.zero L j j).
Proof.
intros.
subst.
destruct j.
+
unfold coeff_mat at 1.
repeat rewrite coeff_Tn_bij; try lia.
assert (A: (0 <= 1)%nat) by lia.
assert (B: (0 <= pred n)%nat) by lia.
pose proof
  @sum_n_m_Chasles C_Ring (fun l : nat => mult (coeff_mat zero M i l) (coeff_mat zero L l 0))
  0 0 (pred n) A B.
unfold sum_n.
rewrite H0; clear H0.
match goal with |- context [plus ?a ?b = _] =>
  assert (b = zero)
end.
*
unfold diag_pred in *.
pose proof (@sum_n_m_ext_loc C_Ring
(fun l : nat => mult (coeff_mat zero M i l) (coeff_mat zero L l 0))
(fun _ : nat => zero) 1 (pred n)).
rewrite H0; clear  H0.
rewrite sum_n_m_const_zero; auto.
intros k Hk.
assert (Hjk: (k < n)%nat /\ (0 < n)%nat /\ (k <> 0)%nat ) by lia.
specialize (H k 0%nat Hjk); rewrite H.
rewrite mult_zero_r; auto.
*
rewrite H0; clear H0.
rewrite plus_zero_r.
rewrite sum_n_n.
unfold mult, Ring.mult; simpl; auto.
+
rewrite coeff_mat_bij; try lia.
assert (Hj : (0 <= S (S j))%nat) by lia.
assert (Hjj: (S j <= pred n)%nat) by lia.
pose proof
  @sum_n_m_Chasles C_Ring (fun l : nat => mult (coeff_mat zero M i l) (coeff_mat zero L l (S j)))
  0 (S j) (pred n) Hj Hjj.
unfold sum_n.
rewrite H0; clear H0.
match goal with |- context [plus ?a ?b = _] =>
  assert (b = zero)
end.
*
unfold diag_pred in *.
pose proof (@sum_n_m_ext_loc C_Ring
(fun l : nat => mult (coeff_mat zero M i l) (coeff_mat zero L l (S j)))
(fun _ : nat => zero) (S (S j)) (pred n)).
rewrite H0; clear  H0.
rewrite sum_n_m_const_zero; auto.
intros k Hk.
assert (Hjk: (  k < n)%nat /\ (S j < n)%nat /\ k <> S j) by lia.
specialize (H k (S j) Hjk); rewrite H.
rewrite mult_zero_r; auto.
*
rewrite H0; clear H0.
rewrite plus_zero_r.
assert (A: (0 < S j)%nat) by lia.
assert (B: (0 <= S j)%nat) by lia.
assert (C: (j <= S j)%nat) by lia.
pose proof
  @sum_n_m_Chasles C_Ring (fun l : nat => mult (coeff_mat zero M i l) (coeff_mat zero L l (S j)))
  0 (j) (S j) B C.

rewrite H0; clear H0.
match goal with |- context [plus ?a ?b = _] =>
  assert (a = zero)
end.
--
unfold diag_pred in *.
pose proof (@sum_n_m_ext_loc C_Ring
(fun l : nat => mult (coeff_mat zero M i l) (coeff_mat zero L l (S j)))
(fun _ : nat => zero) 0 j).
rewrite H0; clear  H0.
rewrite sum_n_m_const_zero; auto.
intros k Hk.
assert (Hjk: (k < n)%nat /\ ((S j) < n)%nat /\ k <>  S j) by lia.
specialize (H k (S j) Hjk); rewrite H.
rewrite mult_zero_r; auto.
--
rewrite H0; clear H0.
rewrite plus_zero_l.
rewrite sum_n_n.
unfold mult, Ring.mult; simpl; auto.
Qed.

(**************************)
(* MATRIX POWERS *)
(**************************)
Fixpoint Mpow (m n: nat) (M: @matrix C m m): matrix m m:=
  match n with
    | 0 => (M_ID m)
    | S n' => Mmult (Mpow m n' M) M
  end.

Lemma Mpow_comm (m n : nat) (M: @matrix C m m) :
Mmult M (Mpow m n M) = Mmult (Mpow m n M) M .
Proof.
induction n.
-
simpl.
rewrite M_ID_equiv_M1.
rewrite Mmult_one_l; auto.
rewrite Mmult_one_r; auto.
-
unfold Mpow; fold Mpow.
rewrite <- IHn at 2.
rewrite <- Mmult_assoc.
auto.
Qed.

Lemma Mpow_pows_plus (m n n': nat) (M: @matrix C m m) :
 Mmult (Mpow m n M) (Mpow m n' M) = Mpow m (n + n') M.
Proof.
intros.
induction n.
-
simpl.
rewrite M_ID_equiv_M1.
rewrite Mmult_one_l; auto.
-
simpl.
rewrite <- IHn.
rewrite <- Mmult_assoc.
rewrite <- Mmult_assoc.
f_equal.
apply Mpow_comm.
Qed.

Lemma Mpow_Sn_l (m n: nat) (M: @matrix C m m) :
 Mmult M (Mpow m n M) = Mpow m (S n) M.
Proof.
unfold Mpow; fold Mpow.
apply Mpow_comm.
Qed.

Lemma Mpow_mult_vec_swap (m n: nat) (M: @matrix C m m) (V: @matrix C m m) :
  Mmult M (Mmult (Mpow m n M) V) =
  Mmult (Mmult (Mpow m n M) M) V.
Proof.
induction n.
-
simpl; auto.
rewrite M_ID_equiv_M1.
rewrite Mmult_one_l.
rewrite Mmult_one_l; auto.
-
unfold Mpow; fold Mpow.
rewrite <- IHn.
rewrite <- Mpow_comm.
rewrite <- Mmult_assoc.
rewrite <- Mmult_assoc.
f_equal.
rewrite Mmult_assoc.
rewrite  Mpow_comm.
rewrite  Mmult_assoc; auto.
Qed.

(* for diagonal D, (P D Pinv)^n = P D^n Pinv *)
Lemma Matrix_pow (m n: nat) (M: @matrix C m m) :
  forall P Pinv D : (matrix m m ),
  Mmult P Pinv = Mone ->
  Mmult Pinv P = Mone ->
  diag_pred m D = True ->
  Mmult P (Mmult D Pinv) = M ->
  Mpow m n M = Mmult P (Mmult (Mpow m n D) Pinv).
Proof.
intros.
induction n.
- simpl. replace (M_ID m) with (@Mone C_Ring m). rewrite Mmult_one_l.
rewrite H; auto. symmetry.
simpl; auto.
replace (M_ID m) with (@Mone C_Ring m); rewrite <- M_ID_equiv_M1; auto.
- unfold Mpow; fold Mpow.
  rewrite IHn. rewrite <- H2.
  rewrite <- Mmult_assoc; auto.
  rewrite <- Mmult_assoc; auto.
  replace (@Mmult C_Ring m m m Pinv
          (@Mmult C_Ring m m m P
             (@Mmult C_Ring m m m D Pinv))) with
  (@Mmult C_Ring m m m (@Mmult C_Ring m m m Pinv P)
             (@Mmult C_Ring m m m D Pinv)).
  rewrite H0.
  rewrite Mmult_one_l. f_equal.
  repeat rewrite Mmult_assoc; auto.
  repeat rewrite Mmult_assoc; auto.
Qed.

Fixpoint Cpow (c: C) (n : nat) :=
  match n with
    | 0 => C1
    | S n' => Cmult c (Cpow c n')
  end
.

Lemma Cpow_comm (a : C) (n : nat) :
  (a * Cpow a n)%C =  (Cpow a n * a)%C.
Proof.
destruct a, Cpow.
cbv [Cmult fst snd].
apply pair_equal_spec; split; try nra.
Qed.

Lemma Mpow_diag_is_diag (n m : nat) (D: @matrix C m m) :
  diag_pred m D ->
(diag_pred m (Mpow m n D)).
Proof.
intros.
induction n.
-
simpl.
apply M_ID_diag.
-
unfold Mpow; fold Mpow.
pose proof Matrix_diag_mult_diag m (Mpow m n D) D (@Mmult C_Ring m m m (Mpow m n D) D)
   IHn H eq_refl; auto.
Qed.

(* for diagonal D, D^n is coeff matrix with components d_{ii}^n *)
Lemma diag_mat_pow (m n: nat) (M: @matrix C m m) :
  forall D : (matrix m m ),
  diag_pred m D ->
  Mpow m n D = @mk_matrix C m m (fun i j =>
      if i =? j then Cpow (@coeff_mat C m m Hierarchy.zero D i j) n else C0).
Proof.
intros.
induction n.
-
simpl. unfold M_ID; auto.
-
assert (diag_pred m (Mpow m n D)) by (apply Mpow_diag_is_diag; auto).
unfold Mpow; fold Mpow.
rewrite IHn.
set ( D' :=
(@mk_matrix C m m
     (fun i j : nat =>
      if i =? j
      then Cpow (@coeff_mat C m m (@zero C_AbelianGroup) D i j) n
      else C0))).
replace (@Mmult C_Ring m m m D' D) with
(@mk_matrix C m m
     (fun i j : nat =>
      if i =? j
      then (Cmult (@coeff_mat C  m m (@zero C_AbelianGroup) D' i j)
        (@coeff_mat C m m (@zero C_AbelianGroup) D i j))
      else C0)).
unfold D'.
apply mk_matrix_ext => i j Hi Hj.
rewrite coeff_mat_bij; try lia.
destruct eqb.
unfold Cpow. fold Cpow; rewrite Cpow_comm; auto.
auto.
assert (diag_pred m D').
unfold diag_pred.
subst D'.
intros.
rewrite coeff_mat_bij; try lia.
destruct H1 as (A & B & C).
apply Nat.eqb_neq in C.
destruct eqb; try discriminate; cbv [C0]; auto.
pose proof Matrix_diag_mult m D' D (@Mmult C_Ring m m m D' D) H1 H eq_refl.
apply mk_matrix_ext => ii jj Hii Hjj.
assert (Hyp: (ii = jj)%nat \/ (ii <> jj)%nat) by lia; destruct Hyp.
+
pose proof Nat.eqb_eq ii jj.
destruct H4. specialize (H5 H3).
destruct eqb; try discriminate; subst.
assert ( (jj = 0)%nat \/ (jj <> 0)%nat) by lia.
destruct H3.
*
subst.
assert (A: (0 <= 1)%nat) by lia;
assert (B: (0 <= pred m)%nat) by lia;
pose proof
  @sum_n_m_Chasles C_Ring (fun l : nat =>
   @mult C_Ring (@coeff_mat C_Ring m m (@zero C_Ring) D' 0 l)
     (@coeff_mat C_Ring m m (@zero C_Ring) D l 0))
  0 0 (pred m) A B.
unfold sum_n.
rewrite H3; clear H3.
symmetry.
match goal with |- context [plus ?a ?b = _] =>
  assert (b = zero)
end.
--
unfold diag_pred in *.
pose proof (@sum_n_m_ext_loc C_Ring
  (fun l : nat =>
   @mult C_Ring (@coeff_mat C_Ring m m (@zero C_Ring) D' 0 l)
     (@coeff_mat C_Ring m m (@zero C_Ring) D l 0))
(fun _ : nat => zero) 1 (pred m)) as C.
rewrite C; clear  C.
rewrite sum_n_m_const_zero; auto.
intros k Hk.
assert (Hjk: (0 < m)%nat /\ (k < m)%nat /\ (0 <> k)%nat ) by lia.
specialize (H1 0%nat k Hjk); rewrite H1.
rewrite mult_zero_l; auto.
--
rewrite H3.
rewrite sum_n_n.
rewrite plus_zero_r.
unfold mult, Ring.mult; simpl; auto.
*
assert (Ha: (0<=S(pred jj))%nat) by lia.
assert (Hb: (pred jj <=  pred m)%nat) by lia.
pose proof
  @sum_n_m_Chasles C_Ring (fun l : nat =>
   @mult C_Ring (@coeff_mat C_Ring m m (@zero C_Ring) D' jj l)
     (@coeff_mat C_Ring m m (@zero C_Ring) D l jj ))
  0 (pred jj) (pred m) Ha Hb as Hc.
unfold sum_n.
rewrite Hc; clear Hc.
symmetry.
match goal with |- context [plus ?a ?b = _] =>
  assert (a = zero)
end.
--
unfold diag_pred in *.
pose proof (@sum_n_m_ext_loc C_Ring
  (fun l : nat =>
   @mult C_Ring (@coeff_mat C_Ring m m (@zero C_Ring) D' jj l)
     (@coeff_mat C_Ring m m (@zero C_Ring) D l jj))
(fun _ : nat => zero) 0 (pred jj)) as C.
rewrite C; clear  C.
rewrite sum_n_m_const_zero; auto.
intros k Hk.
assert (Hjk: ( jj < m)%nat /\ (k < m)%nat /\ ( jj <> k)%nat ) by lia.
specialize (H1 jj k Hjk); rewrite H1.
rewrite mult_zero_l; auto.
--
rewrite H6.
rewrite plus_zero_l.
replace (S (pred jj)) with jj by lia.
clear Ha; clear Hb.
assert (Ha: (jj <= S jj)%nat) by lia.
assert (Hb: (jj <= pred m)%nat) by lia.
pose proof
  @sum_n_m_Chasles C_Ring (fun l : nat =>
   @mult C_Ring (@coeff_mat C_Ring m m (@zero C_Ring) D' jj l)
     (@coeff_mat C_Ring m m (@zero C_Ring) D l jj ))
  jj jj (pred m)  Ha Hb as Hc.
unfold sum_n.
rewrite Hc; clear Hc.
match goal with |- context [plus ?a ?b = _] =>
  assert (b = zero)
end.
++
unfold diag_pred in *.
pose proof (@sum_n_m_ext_loc C_Ring
  (fun l : nat =>
   @mult C_Ring (@coeff_mat C_Ring m m (@zero C_Ring) D' jj l)
     (@coeff_mat C_Ring m m (@zero C_Ring) D l jj))
(fun _ : nat => zero) (S jj) (pred m)) as C.
rewrite C; clear  C.
rewrite sum_n_m_const_zero; auto.
intros k Hk.
assert (Hjk: ( jj < m)%nat /\ (k < m)%nat /\ ( jj <> k)%nat ) by lia.
specialize (H1 jj k Hjk); rewrite H1.
rewrite mult_zero_l; auto.
++
rewrite H7; clear H7.
rewrite plus_zero_r.
rewrite sum_n_n.
unfold mult, Ring.mult; simpl; auto.
+
pose proof (@sum_n_m_ext_loc C_Ring
(fun l : nat => mult (@coeff_mat C_Ring m m (@zero C_Ring) D' ii l) (@coeff_mat C_Ring m m (@zero C_Ring) D l jj))
(fun _ : nat => zero) 0 (pred m)).
unfold sum_n.
rewrite H4; clear H4.
*
apply Nat.eqb_neq in H3.
destruct eqb; try discriminate.
rewrite sum_n_m_const_zero.
cbv [C0] ; auto.
*
unfold diag_pred in *.
intros.
assert (HK: ii <> k \/ jj <> k) by lia; destruct HK as [A | B].
--
assert ((ii < m)%nat /\ (k < m)%nat /\ ii <> k) as Hk1 by lia.
specialize (H1 ii k Hk1); rewrite H1; rewrite mult_zero_l; auto.
--
assert ((k < m)%nat /\ (jj < m)%nat /\ k <> jj) as Hk2 by lia.
specialize (H k jj Hk2); rewrite H; rewrite mult_zero_r; auto.
Qed.

Close Scope R_scope.


Require Export prosa.analysis.facts.model.workload.
Require Export prosa.analysis.definitions.job_properties.
Require Export prosa.analysis.definitions.request_bound_function.

(** * Facts about Request Bound Functions (RBFs) *)

(** In this file, we prove some lemmas about request bound functions. *)

(** ** RBF is a Bound on Workload *)

(** First, we show that a task's RBF is indeed an upper bound on its
    workload. *)
Section ProofWorkloadBound.

  (** Consider any type of tasks ... *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.

  (**  ... and any type of jobs associated with these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** Consider any arrival sequence with consistent, non-duplicate arrivals... *)
  Variable arr_seq : arrival_sequence Job.
  Hypothesis H_arrival_times_are_consistent : consistent_arrival_times arr_seq.
  Hypothesis H_arr_seq_is_a_set : arrival_sequence_uniq arr_seq.

  (** ... and any ideal uni-processor schedule of this arrival sequence.*)
  Variable sched : schedule (ideal.processor_state Job).
  Hypothesis H_jobs_come_from_arrival_sequence : jobs_come_from_arrival_sequence sched arr_seq.

  (** Consider an FP policy that indicates a higher-or-equal priority relation. *)
  Context `{FP_policy Task}.
  Let jlfp_higher_eq_priority := FP_to_JLFP Job Task.

  (** Consider a task set ts... *)
  Variable ts : list Task.

  (** ...and let [tsk] be any task in ts. *)
  Variable tsk : Task.
  Hypothesis H_tsk_in_ts : tsk \in ts.

  (** Assume that the job costs are no larger than the task costs. *)
  Hypothesis H_valid_job_cost :
    arrivals_have_valid_job_costs arr_seq.

  (** Next, we assume that all jobs come from the task set. *)
  Hypothesis H_all_jobs_from_taskset : all_jobs_from_taskset arr_seq ts.

  (** Let max_arrivals be any arrival bound for task-set [ts]. *)
  Context `{MaxArrivals Task}.
  Hypothesis H_is_arrival_bound : taskset_respects_max_arrivals arr_seq ts.

  (** Let's define some local names for clarity. *)
  Let task_rbf := task_request_bound_function tsk.
  Let total_rbf := total_request_bound_function ts.
  Let total_hep_rbf := total_hep_request_bound_function_FP ts tsk.
  Let total_ohep_rbf := total_ohep_request_bound_function_FP ts tsk.

  (** Next, we consider any job [j] of [tsk]. *)
  Variable j : Job.
  Hypothesis H_j_arrives : arrives_in arr_seq j.
  Hypothesis H_job_of_tsk : job_task j = tsk.

  (** Next, we say that two jobs [j1] and [j2] are in relation
      [other_higher_eq_priority], iff [j1] has higher or equal priority than [j2] and
      is produced by a different task. *)
  Let other_higher_eq_priority j1 j2 := jlfp_higher_eq_priority j1 j2 && (~~ same_task j1 j2).

  (** Next, we recall the notions of total workload of jobs... *)
  Let total_workload t1 t2 := workload_of_jobs predT (arrivals_between arr_seq t1 t2).

  (** ...notions of workload of higher or equal priority jobs... *)
  Let total_hep_workload t1 t2 :=
    workload_of_jobs (fun j_other => jlfp_higher_eq_priority j_other j) (arrivals_between arr_seq t1 t2).

  (** ... workload of other higher or equal priority jobs... *)
  Let total_ohep_workload t1 t2 :=
    workload_of_jobs (fun j_other => other_higher_eq_priority j_other j) (arrivals_between arr_seq t1 t2).

  (** ... and the workload of jobs of the same task as job j. *)
  Let task_workload t1 t2 :=
    workload_of_jobs (job_of_task tsk) (arrivals_between arr_seq t1 t2).

  (** In this section we prove that the workload of any jobs is
       no larger than the request bound function. *)
  Section WorkloadIsBoundedByRBF.

    (** Consider any time t and any interval of length delta. *)
    Variable t : instant.
    Variable delta : instant.

    (** First, we show that workload of task [tsk] is bounded by the number of
        arrivals of the task times the cost of the task. *)
    Lemma task_workload_le_num_of_arrivals_times_cost:
      task_workload t (t + delta)
      <= task_cost tsk * number_of_task_arrivals arr_seq tsk t (t + delta).
    Proof.
      rewrite // /number_of_task_arrivals -sum1_size big_distrr /= big_filter.
      rewrite /task_workload_between /workload.task_workload_between /task_workload /workload_of_jobs.
      rewrite /same_task -H_job_of_tsk muln1.
      apply leq_sum_seq; move => j0 IN0 /eqP EQ.
      rewrite -EQ; apply in_arrivals_implies_arrived in IN0; auto.
        by apply H_valid_job_cost.
    Qed.

    (** As a corollary, we prove that workload of task is no larger the than
        task request bound function. *)
    Corollary task_workload_le_task_rbf:
      task_workload t (t + delta) <= task_rbf delta.
    Proof.
      apply leq_trans with
          (task_cost tsk *  number_of_task_arrivals arr_seq tsk t (t + delta));
        first by apply task_workload_le_num_of_arrivals_times_cost.
      rewrite leq_mul2l; apply/orP; right.
      rewrite -{2}[delta](addKn t).
        by apply H_is_arrival_bound; last rewrite leq_addr.
    Qed.

    (** Next, we prove that total workload of other tasks with higher-or-equal
        priority is no larger than the total request bound function. *)
    Lemma total_workload_le_total_rbf:
      total_ohep_workload t (t + delta) <= total_ohep_rbf delta.
    Proof.
      set l := arrivals_between arr_seq t (t + delta).
      apply leq_trans with
          (\sum_(tsk' <- ts | hep_task tsk' tsk && (tsk' != tsk))
            (\sum_(j0 <- l | job_task j0 == tsk') job_cost j0)).
      { intros.
        rewrite /total_ohep_workload /workload_of_jobs /other_higher_eq_priority.
        rewrite /jlfp_higher_eq_priority /FP_to_JLFP /same_task H_job_of_tsk.
        have EXCHANGE := exchange_big_dep (fun x => hep_task (job_task x) tsk && (job_task x != tsk)).
        rewrite EXCHANGE /=; last by move => tsk0 j0 HEP /eqP JOB0; rewrite JOB0.
        rewrite /workload_of_jobs -/l big_seq_cond [X in _ <= X]big_seq_cond.
        apply leq_sum; move => j0 /andP [IN0 HP0].
        rewrite big_mkcond (big_rem (job_task j0)) /=; first by rewrite HP0 andTb eq_refl; apply leq_addr.
          by apply in_arrivals_implies_arrived in IN0; apply H_all_jobs_from_taskset.
      }
      apply leq_sum_seq; intros tsk0 INtsk0 HP0.
      apply leq_trans with
          (task_cost tsk0 * size (task_arrivals_between arr_seq tsk0 t (t + delta))).
      { rewrite -sum1_size big_distrr /= big_filter.
        rewrite /workload_of_jobs.
        rewrite  muln1 /l /arrivals_between /arrival_sequence.arrivals_between.
        apply leq_sum_seq; move => j0 IN0 /eqP EQ.
          by rewrite -EQ; apply H_valid_job_cost; apply in_arrivals_implies_arrived in IN0.
      }
      { rewrite leq_mul2l; apply/orP; right.
        rewrite -{2}[delta](addKn t).
          by apply H_is_arrival_bound; last rewrite leq_addr.
      }
    Qed.

    (** Next, we prove that total workload of tasks with higher-or-equal
        priority is no larger than the total request bound function. *)
    Lemma total_workload_le_total_rbf':
      total_hep_workload t (t + delta) <= total_hep_rbf delta.
    Proof.
      set l := arrivals_between arr_seq t (t + delta).
      apply leq_trans with
          (n := \sum_(tsk' <- ts | hep_task tsk' tsk)
                 (\sum_(j0 <- l | job_task j0 == tsk') job_cost j0)).
      { rewrite /total_hep_workload /jlfp_higher_eq_priority /FP_to_JLFP H_job_of_tsk.
        have EXCHANGE := exchange_big_dep (fun x => hep_task (job_task x) tsk).
        rewrite EXCHANGE /=; clear EXCHANGE; last by move => tsk0 j0 HEP /eqP JOB0; rewrite JOB0.
        rewrite /workload_of_jobs -/l big_seq_cond [X in _ <= X]big_seq_cond.
        apply leq_sum; move => j0 /andP [IN0 HP0].
        rewrite big_mkcond (big_rem (job_task j0)) /=; first by rewrite HP0 andTb eq_refl; apply leq_addr.
          by apply in_arrivals_implies_arrived in IN0; apply H_all_jobs_from_taskset.
      }
      apply leq_sum_seq; intros tsk0 INtsk0 HP0.
      apply leq_trans with
          (task_cost tsk0 * size (task_arrivals_between arr_seq tsk0 t (t + delta))).
      { rewrite -sum1_size big_distrr /= big_filter.
        rewrite -/l /workload_of_jobs.
        rewrite muln1.
        apply leq_sum_seq; move => j0 IN0 /eqP EQ.
        rewrite -EQ.
        apply H_valid_job_cost.
          by apply in_arrivals_implies_arrived in IN0.
      }
      { rewrite leq_mul2l; apply/orP; right.
        rewrite -{2}[delta](addKn t).
          by apply H_is_arrival_bound; last rewrite leq_addr.
      }
    Qed.

    (** Next, we prove that total workload of tasks is no larger than the total
        request bound function. *)
    Lemma total_workload_le_total_rbf'':
      total_workload t (t + delta) <= total_rbf delta.
    Proof.
      set l := arrivals_between arr_seq t (t + delta).
      apply leq_trans with
          (n := \sum_(tsk' <- ts)
                 (\sum_(j0 <- l | job_task j0 == tsk') job_cost j0)).
      { rewrite /total_workload.
        have EXCHANGE := exchange_big_dep predT.
        rewrite EXCHANGE /=; clear EXCHANGE; last by done.
        rewrite /workload_of_jobs -/l big_seq_cond [X in _ <= X]big_seq_cond.
        apply leq_sum; move => j0 /andP [IN0 HP0].
        rewrite big_mkcond (big_rem (job_task j0)) /=.
        rewrite eq_refl; apply leq_addr.
          by apply in_arrivals_implies_arrived in IN0;
            apply H_all_jobs_from_taskset.
      }
      apply leq_sum_seq; intros tsk0 INtsk0 HP0.
      apply leq_trans with
          (task_cost tsk0 * size (task_arrivals_between arr_seq tsk0 t (t + delta))).
      { rewrite -sum1_size big_distrr /= big_filter.
        rewrite -/l /workload_of_jobs.
        rewrite muln1.
        apply leq_sum_seq; move => j0 IN0 /eqP EQ.
        rewrite -EQ.
        apply H_valid_job_cost.
          by apply in_arrivals_implies_arrived in IN0.
      }
      { rewrite leq_mul2l; apply/orP; right.
        rewrite -{2}[delta](addKn t).
          by apply H_is_arrival_bound; last rewrite leq_addr.
      }
    Qed.

  End WorkloadIsBoundedByRBF.

End ProofWorkloadBound.

(** ** RBF Properties *)
(** In this section, we prove simple properties and identities of RBFs. *)
Section RequestBoundFunctions.

  (** Consider any type of tasks ... *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.

  (** ... and any type of jobs associated with these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  Context `{JobArrival Job}.

  (** Consider any arrival sequence. *)
  Variable arr_seq : arrival_sequence Job.
  Hypothesis H_arrival_times_are_consistent:
    consistent_arrival_times arr_seq.

  (** Let [tsk] be any task. *)
  Variable tsk : Task.

  (** Let max_arrivals be a family of valid arrival curves, i.e., for any task [tsk] in ts
     [max_arrival tsk] is (1) an arrival bound of [tsk], and (2) it is a monotonic function
     that equals 0 for the empty interval delta = 0. *)
  Context `{MaxArrivals Task}.
  Hypothesis H_valid_arrival_curve : valid_arrival_curve tsk (max_arrivals tsk).
  Hypothesis H_is_arrival_curve : respects_max_arrivals arr_seq tsk (max_arrivals tsk).

  (** Let's define some local names for clarity. *)
  Let task_rbf := task_request_bound_function tsk.

  (** We prove that [task_rbf 0] is equal to 0. *)
  Lemma task_rbf_0_zero:
    task_rbf 0 = 0.
  Proof.
    rewrite /task_rbf /task_request_bound_function.
    apply/eqP; rewrite muln_eq0; apply/orP; right; apply/eqP.
      by move: H_valid_arrival_curve => [T1 T2].
  Qed.

  (** We prove that [task_rbf] is monotone. *)
  Lemma task_rbf_monotone:
    monotone task_rbf leq.
  Proof.
    rewrite /monotone; intros ? ? LE.
    rewrite /task_rbf /task_request_bound_function leq_mul2l.
    apply/orP; right.
      by move: H_valid_arrival_curve => [_ T]; apply T.
  Qed.

  (** Consider any job j of [tsk]. This guarantees that there exists at least one
      job of task [tsk]. *)
  Variable j : Job.
  Hypothesis H_j_arrives : arrives_in arr_seq j.
  Hypothesis H_job_of_tsk : job_task j = tsk.

  (** Then we prove that [task_rbf 1] is greater than or equal to task cost. *)
  Lemma task_rbf_1_ge_task_cost:
    task_rbf 1 >= task_cost tsk.
  Proof.
    have ALT: forall n, n = 0 \/ n > 0
      by clear; intros n; destruct n; [left | right].
    specialize (ALT (task_cost tsk)); destruct ALT as [Z | POS]; first by rewrite Z.
    rewrite leqNgt; apply/negP; intros CONTR.
    move: H_is_arrival_curve => ARRB.
    specialize (ARRB (job_arrival j) (job_arrival j + 1)).
    feed ARRB; first by rewrite leq_addr.
    rewrite addKn in ARRB.
    move: CONTR; rewrite /task_rbf /task_request_bound_function; move => CONTR.
    move: CONTR; rewrite -{2}[task_cost tsk]muln1 ltn_mul2l; move => /andP [_ CONTR].
    move: CONTR; rewrite -addn1 -{3}[1]add0n leq_add2r leqn0; move => /eqP CONTR.
    move: ARRB; rewrite CONTR leqn0 eqn0Ngt; move => /negP T; apply: T.
    rewrite /number_of_task_arrivals -has_predT.
    rewrite /task_arrivals_between.
    apply/hasP; exists j; last by done.
    rewrite /arrivals_between addn1 big_nat_recl; last by done.
    rewrite big_geq ?cats0; last by done.
    rewrite mem_filter.
    apply/andP; split.
    - by apply/eqP.
    - move: H_j_arrives => [t ARR].
      move: (ARR) => CONS.
      apply H_arrival_times_are_consistent in CONS.
      by rewrite CONS.
  Qed.

End RequestBoundFunctions.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal10.

Set Printing Depth 1000.
Definition lfind_eval  n l1:=
append (rev l1) (Cons n Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ Zero) (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Zero) (Cons (Succ (Succ (Succ Zero))) (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ Zero) (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Succ Zero) (Cons (Succ (Succ Zero)) (Cons (Succ (Succ (Succ Zero))) (Cons (Succ (Succ (Succ Zero))) Nil))).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Nil).

Compute lfind_eval  (Succ Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Zero) (Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil)))).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Zero) (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Nil).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Zero) (Cons Zero (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Zero) (Nil).


(************************************************************************)
(* Copyright (c) 2017, Ajay Kumar Eeralla <ae266@mail.missouri.edu>     *)
(*                   University of Missouri-Columbia.                   *)
(*                                                                      *)
(*                                                                      *)
(*                                                                      *)
(************************************************************************)

Load "eqbranch".

(** This library defines a theorem, [(eqb TRue FAlse)] = FAlse *)

Theorem Ex13bol:  (eqb  TRue FAlse) ##  FAlse.
Proof.
assert(H : (Bvar 1) ##  (ifb (Bvar 1) TRue FAlse) ) .
rewrite IFTF with (n :=1) . reflexivity.
apply Forall_ELM_EVAL_B with (n:=1)(b:= (eqb  TRue FAlse)) in H .
simpl in H.
assert(H1 : (ifb (eqb  (Bvar 1)  (Bvar 2))[3 := (Bvar 1)](Bvar 3) FAlse) ## (ifb (eqb  (Bvar 1)(Bvar 2)) [3 := (Bvar 2)](Bvar 3)  FAlse)).
rewrite eqbrbol_bol with (n1:= 1) (n2:= 2)(b2:=FAlse)(b1:=(Bvar 3)).
reflexivity.
simpl in H1.
apply Forall_ELM_EVAL_B with (n:=1)(b:= TRue) in H1 .
simpl in H1.
apply Forall_ELM_EVAL_B with (n:=2)(b:= FAlse) in H1 .
simpl in H1.
rewrite H1 in H.
rewrite IFSAME_B in H. apply H.
Qed.


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

(*i $Id: FunctionalExtensionality.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** This module states the axiom of (dependent) functional extensionality and (dependent) eta-expansion.
   It introduces a tactic [extensionality] to apply the axiom of extensionality to an equality goal. *)

(** The converse of functional extensionality. *)

Lemma equal_f : forall {A B : Type} {f g : A -> B},
  f = g -> forall x, f x = g x.
Proof.
  intros.
  rewrite H.
  auto.
Qed.

(** Statements of functional extensionality for simple and dependent functions. *)

Axiom functional_extensionality_dep : forall {A} {B : A -> Type},
  forall (f g : forall x : A, B x),
  (forall x, f x = g x) -> f = g.

Lemma functional_extensionality {A B} (f g : A -> B) :
  (forall x, f x = g x) -> f = g.
Proof.
  intros ; eauto using @functional_extensionality_dep.
Qed.

(** Apply [functional_extensionality], introducing variable x. *)

Tactic Notation "extensionality" ident(x) :=
  match goal with
    [ |- ?X = ?Y ] =>
    (apply (@functional_extensionality _ _ X Y) ||
     apply (@functional_extensionality_dep _ _ X Y)) ; intro x
  end.

(** Eta expansion follows from extensionality. *)

Lemma eta_expansion_dep {A} {B : A -> Type} (f : forall x : A, B x) :
  f = fun x => f x.
Proof.
  intros.
  extensionality x.
  reflexivity.
Qed.

Lemma eta_expansion {A B} (f : A -> B) : f = fun x => f x.
Proof.
  apply (eta_expansion_dep f).
Qed.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Exercise_2.

Coq < Goal forall k p q t:Prop, (((k /\ p) \/ (k /\ q)) /\ (p -> ~k)) -> (q \/ t).
1 subgoal

  ============================
   forall k p q t : Prop, (k /\ p \/ k /\ q) /\ (p -> ~ k) -> q \/ t

Unnamed_thm < intros.
1 subgoal

  k : Prop
  p : Prop
  q : Prop
  t : Prop
  H : (k /\ p \/ k /\ q) /\ (p -> ~ k)
  ============================
   q \/ t

Unnamed_thm < elim H.
1 subgoal

  k : Prop
  p : Prop
  q : Prop
  t : Prop
  H : (k /\ p \/ k /\ q) /\ (p -> ~ k)
  ============================
   k /\ p \/ k /\ q -> (p -> ~ k) -> q \/ t

Unnamed_thm < intro.
1 subgoal

  k : Prop
  p : Prop
  q : Prop
  t : Prop
  H : (k /\ p \/ k /\ q) /\ (p -> ~ k)
  H0 : k /\ p \/ k /\ q
  ============================
   (p -> ~ k) -> q \/ t

Unnamed_thm < intro.
1 subgoal

  k : Prop
  p : Prop
  q : Prop
  t : Prop
  H : (k /\ p \/ k /\ q) /\ (p -> ~ k)
  H0 : k /\ p \/ k /\ q
  H1 : p -> ~ k
  ============================
   q \/ t

Unnamed_thm < left.
1 subgoal

  k : Prop
  p : Prop
  q : Prop
  t : Prop
  H : (k /\ p \/ k /\ q) /\ (p -> ~ k)
  H0 : k /\ p \/ k /\ q
  H1 : p -> ~ k
  ============================
   q

Unnamed_thm < destruct H0.
2 subgoals

  k : Prop
  p : Prop
  q : Prop
  t : Prop
  H : (k /\ p \/ k /\ q) /\ (p -> ~ k)
  H0 : k /\ p
  H1 : p -> ~ k
  ============================
   q

subgoal 2 is:
 q

Unnamed_thm < firstorder.
1 subgoal

  k : Prop
  p : Prop
  q : Prop
  t : Prop
  H : (k /\ p \/ k /\ q) /\ (p -> ~ k)
  H0 : k /\ q
  H1 : p -> ~ k
  ============================
   q

Unnamed_thm < apply H0.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
left.
destruct H0.
 firstorder .

 apply H0.

Unnamed_thm is defined

Coq <
*)

Section Exercise_2.
Goal forall k p q t:Prop, (((k /\ p) \/ (k /\ q)) /\ (p -> ~k)) -> (q \/ t).
intros.
elim H.
intro.
intro.
left.
destruct H0.
 firstorder .
 apply H0.
Qed.


(*
 ============================================================================
 Project     : Nominal A, AC and C Unification
 File        : Alpha_Equiv.v
 Authors     : Washington Luís R. de Carvalho Segundo and
               Mauricio Ayala Rincón
               Universidade de Brasília (UnB) - Brazil
               Group of Theory of Computation

 Last Modified On: March 3, 2017.
 ============================================================================
*)

Require Export  w_Equiv.

Inductive alpha_equiv : Context -> term -> term -> Prop :=

 | alpha_equiv_Ut   : forall C, alpha_equiv C (<<>>) (<<>>)

 | alpha_equiv_At   : forall C a, alpha_equiv C (%a) (%a)

 | alpha_equiv_Pr   : forall C t1 t2 t1' t2', (alpha_equiv C t1 t1') -> (alpha_equiv C t2 t2') ->
                                          alpha_equiv C (<|t1,t2|>) (<|t1',t2'|>)

 | alpha_equiv_Fc   :  forall m n t t' C, (alpha_equiv C t t') ->
                              alpha_equiv C (Fc m n t) (Fc m n t')

 | alpha_equiv_Ab_1 : forall C a t t', (alpha_equiv C t t') ->
                               alpha_equiv C ([a]^t) ([a]^t')

 | alpha_equiv_Ab_2 : forall C a a' t t',
                a <> a' -> (alpha_equiv C t (|[(a,a')]| @ t')) -> C |- a # t' ->
                                    alpha_equiv C ([a]^t) ([a']^t')

 | alpha_equiv_Su   : forall (C: Context) p p' (X: Var),
               (forall a, (In_ds p p' a) -> set_In ((a,X)) C) ->
                            alpha_equiv C (p|.X) (p'|.X)
.

Hint Constructors alpha_equiv.

Notation "C |- t ~alpha t'" := (alpha_equiv C t t') (at level 67).

(** alpha_equiv intro and elim lemmas *)

Lemma alpha_equiv_At_elim : forall C a a', C |- (%a) ~alpha (%a') -> a = a'.
Proof. intros. inversion H. trivial. Qed.

Lemma alpha_equiv_At_intro : forall C a a', a = a' -> C |- (%a) ~alpha (%a').
Proof. intros. rewrite H. apply alpha_equiv_At. Qed.

Lemma alpha_equiv_Pr_elim : forall C t1 t2 t1' t2',
C |- (<|t1,t2|>) ~alpha (<|t1',t2'|>) -> ((C |- t1 ~alpha t1') /\ (C |- t2 ~alpha t2')).
Proof. intros. inversion H. split~; trivial. Qed.

Lemma alpha_equiv_Fc_elim : forall C m0 m1 n0 n1 t t',
C |- Fc m0 n0 t ~alpha Fc m1 n1 t' -> (m0 = m1 /\ n0 = n1 /\ C |- t ~alpha t').
Proof.
 intros. inversion H; split~; try split~; trivial.
Qed.

Lemma alpha_equiv_Ab_elim : forall C t t' a a',
C |- [a]^t ~alpha ([a']^t') ->
((a = a' /\ C |- t ~alpha t') \/
(a <> a' /\ ((C |- t ~alpha (|[(a,a')]| @ t')) /\ C |- a # t'))).
Proof.
 intros. inversion H.
 left~. right~.
Qed.

Lemma alpha_equiv_Ab_intro : forall C t t' a a',
((a = a' /\ C |- t ~alpha t') \/
 (a <> a' /\ ((C |- t ~alpha (|[(a,a')]| @ t'))) /\ C |- a # t')) ->
C |- [a]^t ~alpha ([a']^t') .
Proof.
 intros. destruct H.
 destruct H. rewrite H. apply alpha_equiv_Ab_1; trivial.
 destruct H. destruct H0. apply alpha_equiv_Ab_2; trivial.
Qed.

Lemma alpha_equiv_Su_elim : forall C p p' X,
C |- Su p X ~alpha Su p' X -> (forall a, (In_ds p p' a) -> set_In ((a,X)) C).
Proof. intros. inversion H. apply H3; trivial. Qed.

Hint Resolve alpha_equiv_At_elim.
Hint Resolve alpha_equiv_At_intro.
Hint Resolve alpha_equiv_Pr_elim.
Hint Resolve alpha_equiv_Fc_elim.
Hint Resolve alpha_equiv_Ab_elim.
Hint Resolve alpha_equiv_Ab_intro.
Hint Resolve alpha_equiv_Su_elim.

(** Intermediate transitivity for alpha_equiv with w_equiv *)

Lemma alpha_equiv_w_equiv_trans : forall C t1 t2 t3,
  C |- t1 ~alpha t2 -> t2 ~we t3 -> C |- t1 ~alpha t3.
Proof.
 intros. generalize t3 H0; clear t3 H0.
 induction H; intros; trivial.
 inversion H0; auto. inversion H0; auto.
 inversion H1. apply alpha_equiv_Pr; [apply IHalpha_equiv1 | apply IHalpha_equiv2]; trivial.
 inversion H0. apply alpha_equiv_Fc. apply IHalpha_equiv; trivial.
 inversion H0. apply alpha_equiv_Ab_1. apply IHalpha_equiv; trivial.
 inversion H2. apply alpha_equiv_Ab_2; trivial. apply IHalpha_equiv.
 apply w_equiv_equivariance; trivial.
 apply w_equiv_fresh with (t1 := t'); trivial.
 inversion H0. apply alpha_equiv_Su; intros.
 apply H. intro. apply H5. setoid_rewrite not_In_ds in H4.
 rewrite <- H4. trivial.
Qed.

(** Freshness preservation of alpha_equiv *)

Lemma alpha_equiv_fresh : forall C a t1 t2, C |- t1 ~alpha t2 ->
                                                 C |- a # t1 -> C |- a # t2.
Proof.
 intros. induction H; trivial.
 apply fresh_Pr_elim in H0. destruct H0.
 apply fresh_Pr; [apply IHalpha_equiv1 | apply IHalpha_equiv2]; trivial.
 apply fresh_Fc_elim in H0. apply fresh_Fc; apply IHalpha_equiv; trivial.
 apply fresh_Ab_elim in H0. destruct H0. rewrite H0. apply fresh_Ab_1.
 destruct H0. apply fresh_Ab_2; trivial. apply IHalpha_equiv; trivial.
 apply fresh_Ab_elim in H0. destruct H0. apply fresh_Ab_2.
 intro. apply H. rewrite <- H0. trivial. rewrite <- H0 in H2. trivial.
 destruct H0. case (atom_eqdec a a'); intros.
 rewrite e. apply fresh_Ab_1. apply fresh_Ab_2; trivial.
 assert (Q : C |- a # ((|[(a0, a')]|) @ t')).  apply IHalpha_equiv; trivial.
 apply fresh_lemma_1 in Q. simpl rev in Q. rewrite swap_neither in Q; trivial.
 intro. apply H0. rewrite H4; trivial. intro. apply n. rewrite H4; trivial.
 apply fresh_Su. apply fresh_Su_elim in H0.
 case (atom_eqdec ((!p) $ a) ((!p') $ a)); intros. rewrite <- e; trivial.
 apply H; intros. intro. apply n. gen_eq g : (!p'); intro.
 replace p' with (!g) in H1. rewrite perm_inv_atom in H1.
 replace ((!p) $ a) with ((!p) $ (p $ (g $ a))). rewrite perm_inv_atom. trivial.
 rewrite H1. trivial. rewrite H2. rewrite rev_involutive. trivial.
Qed.

(** Equivariance of alpha_equiv *)

Lemma alpha_equiv_equivariance : forall C t1 t2 pi,
 C |- t1 ~alpha t2 -> C |- (pi @ t1) ~alpha (pi @ t2).
Proof.
 intros. induction H; intros;
 simpl; auto.
 apply alpha_equiv_Ab_2. apply perm_diff_atom; trivial.
 apply alpha_equiv_w_equiv_trans with (t2 :=  (pi @ ((|[(a, a')]|) @ t'))).
 apply IHalpha_equiv. apply w_equiv_pi_comm. apply fresh_lemma_2; trivial.
 apply alpha_equiv_Su. intros. apply H. intro. apply H0.
 rewrite <- 2 perm_comp_atom. rewrite H1; trivial.
Qed.

(** Invariance of terms under alpha_equiv and the action of permutations *)

Lemma alpha_equiv_pi : forall C t pi pi',
                 (forall a, (In_ds pi pi' a) -> (C |- a # t)) <->
                  C |- pi @ t ~alpha (pi' @ t) .
Proof.
 intros C t pi.
 induction t; split~; autorewrite with perm; intros; auto.
 (* At *)
 apply alpha_equiv_At_intro. apply equiv_pi_atom; intros.
 assert (Q' : C |- a' # %a). apply H; trivial.
 apply fresh_At_elim in Q'; trivial.
 apply fresh_At. apply alpha_equiv_At_elim in H.
 unfold In_ds in H0. intro. rewrite H1 in H0. contradiction.
 (* Ab *)
  (* -> *)
 apply alpha_equiv_Ab_intro.
 case (atom_eqdec (pi $ a) (pi' $ a)); intros. left~; split~; trivial.
 apply IHt; intros. assert (Q : C |- a0 # Ab a t). apply H; trivial.
 apply fresh_Ab_elim in Q. destruct Q.  unfold In_ds in H0.
 rewrite H1 in H0. contradiction. destruct H1; trivial.
 right~. split~; trivial. split~.
 rewrite perm_comp. apply IHt; intros. unfold In_ds in H0.
 case (atom_eqdec a0 a); intros. apply False_ind. apply H0.
 rewrite e. rewrite <- perm_comp_atom. rewrite swap_right; trivial.
 apply ds_perm_left in H0. assert (Q : C |- a0 # Ab a t). apply H; trivial.
 apply fresh_Ab_elim in Q. destruct Q. contradiction.
 destruct H1; trivial.
 assert (Q : C |- ((!pi') $ (pi $ a)) # Ab a t). apply H.
   unfold In_ds. intro. apply n.
   gen_eq g : (!pi'); intro. replace pi' with (!g) in H0.
   rewrite perm_inv_atom in H0. apply perm_eq_atom with (p := pi) in H0.
   apply perm_inv_side_atom in H0. rewrite H1 in H0. rewrite rev_involutive in H0.
   trivial. rewrite H1. rewrite rev_involutive. trivial.
 apply fresh_Ab_elim in Q.
 destruct Q. apply perm_inv_side_atom in H0.
 rewrite rev_involutive in H0. contradiction.
 destruct H0. apply fresh_lemma_1 in H1. trivial.
  (* <- *)
 apply alpha_equiv_Ab_elim in H. destruct H.
 destruct H. case (atom_eqdec a0 a); intros. rewrite e in H0. unfold In_ds in H0. contradiction.
 apply fresh_Ab_2; trivial. apply (IHt pi'); trivial.
 destruct H. destruct H1.
 case (atom_eqdec a0 a); intros. rewrite e. apply fresh_Ab_1.
 apply fresh_Ab_2; trivial.
 case (atom_eqdec (pi $ a) (pi' $ a0)); intro.
 rewrite e in H2. apply fresh_lemma_1 in H2. rewrite perm_inv_atom in H2. trivial.
 rewrite perm_comp in H1.
 apply IHt with (pi' := pi' ++ (|[(pi $ a, pi' $ a)]|)); trivial.
 apply ds_perm_right; trivial.
 (* Pr *)
 apply alpha_equiv_Pr; [apply IHt1 | apply IHt2]; intros;
 assert (Q : C |- a # <|t1,t2|>); try apply H; trivial;
 apply fresh_Pr_elim in Q; destruct Q; trivial.
 apply alpha_equiv_Pr_elim in H. destruct H.
 apply fresh_Pr; [apply (IHt1 pi') | apply (IHt2 pi')]; trivial.
 (* Fc *)
 apply alpha_equiv_Fc. apply IHt; intros.
 assert (Q : C |- a # Fc n n0 t); try apply H; trivial.
 apply fresh_Fc_elim in Q; trivial.
 apply alpha_equiv_Fc_elim in H. destruct H. destruct H1.
 apply fresh_Fc; apply (IHt pi'); trivial.
 (* Su *)
 apply alpha_equiv_Su; intros.
 assert (Q : C |- (p $ a) # Su p v).
  apply H. intro. apply H0.
  rewrite <- 2 perm_comp_atom. trivial.
 apply fresh_Su_elim in Q. rewrite perm_inv_atom in Q. trivial.
 apply alpha_equiv_Su_elim with (a := (!p) $ a) in H. apply fresh_Su; trivial.
 unfold In_ds in *|-*. rewrite <- 2 perm_comp_atom.
 gen_eq g : (!p); intro. replace p with (!g). rewrite perm_inv_atom; trivial.
 rewrite H1. rewrite rev_involutive. trivial.
Qed.

(** A Corollary: the order of the atoms inside a swapping doesn't matter in alpha_equiv *)

Corollary alpha_equiv_swap_comm : forall C a b t, C |- |[(a, b)]| @ t ~alpha |[(b, a)]| @ t.
Proof.
 intros. apply alpha_equiv_pi. intros. unfold In_ds in H.
 apply False_ind. apply H. apply swap_comm.
Qed.

(** Second intermediate transitivity lemma *)

Lemma pi_alpha_equiv : forall C t1 t2 pi,
     C |- t1 ~alpha t2 -> C |- t2 ~alpha (pi @ t2) ->
     C |- t1 ~alpha (pi @ t2).
Proof.
 intros. gen pi H0.  induction H; intro pi;
 simpl; intros; auto.
(* Pr *)
 apply alpha_equiv_Pr_elim in H1. destruct H1.
 apply alpha_equiv_Pr;
 [apply IHalpha_equiv1 | apply IHalpha_equiv2]; trivial.
(* Fc *)
 apply alpha_equiv_Fc_elim in H0.
 destruct H0. destruct H1.
 apply alpha_equiv_Fc. apply IHalpha_equiv; trivial.
(* Ab *)
 apply alpha_equiv_Ab_elim in H0. destruct H0.

 (* a = a' *)

  (* a = pi $ a *)
  destruct H0. rewrite <- H0.
  apply alpha_equiv_Ab_1;
  apply IHalpha_equiv; trivial.
  destruct H0. destruct H1.

  (* a <> pi $ a *)
  apply alpha_equiv_Ab_2; trivial.
  rewrite perm_comp. apply IHalpha_equiv.
  rewrite perm_comp in H1. trivial.

(* a <> a' *)
  apply alpha_equiv_Ab_elim in H2. destruct H2.

 (* a' = pi $ a' *)
  destruct H2. case (atom_eqdec a (pi $ a')); intros.

    (* a = pi $ a' *)
     rewrite <- e in H2. symmetry in H2. contradiction.

    (* a <> pi $ a' *)
    apply alpha_equiv_Ab_2; trivial. rewrite <- H2.
    apply  alpha_equiv_w_equiv_trans with
    (t2 := (((a, a')::pi) ++ |[(a, a')]|) @ (|[(a, a')]| @ t')).
    apply IHalpha_equiv. rewrite <- perm_comp.
    apply alpha_equiv_equivariance.
    rewrite swap_app with (p := pi).
    apply alpha_equiv_w_equiv_trans with (t2 := pi @ t'); trivial.
    rewrite 2 perm_comp.
    apply w_equiv_sym. simpl.
    apply w_equiv_swap_cancel.
    rewrite 2 perm_comp. simpl.
    apply w_equiv_swap_cancel.
    apply alpha_equiv_fresh with (t1 := t'); trivial.

 (* a' <> pi $ a' *)
 destruct H2. destruct H3. case (atom_eqdec a (pi $ a')); intro.

   (* a = pi $ a' *)
   rewrite e. apply alpha_equiv_Ab_1. rewrite <- e in H3.
   apply alpha_equiv_w_equiv_trans with
   (t2 :=  (((a,a')::pi) @ ((|[(a, a')]|) @ t'))).
   apply IHalpha_equiv.
   rewrite perm_comp in *|-*; simpl.
   apply alpha_equiv_w_equiv_trans with
   (t2 := pi @ t').
   apply alpha_equiv_w_equiv_trans with
   (t2 := ((|[(a, a')]|) @ (pi ++ (|[(a', a)]|) @ t'))).
   apply alpha_equiv_equivariance; trivial.
   apply w_equiv_trans with
   (t2 := ((|[(a', a)]|) @ (pi ++ (|[(a', a)]|) @ t'))).
   apply w_equiv_swap_comm.
   rewrite perm_comp.
   apply w_equiv_swap_cancel2.
   apply w_equiv_sym.
   apply w_equiv_swap_cancel.
   rewrite perm_comp. simpl.
   apply w_equiv_swap_cancel.

(** The dificult case:
    a <> a', a' <> pi $ a', a <> pi $ a' *)

  (* a <> pi $ a' *)
   rewrite perm_comp in H3.

  assert (fresh_a : C |- a # (pi @ t')).
    assert (Q : C |- a # (pi ++ (|[(a', pi $ a')]|) @ t')).
    apply alpha_equiv_fresh with (t1 := t'); trivial.
    rewrite <- perm_comp in Q. apply fresh_lemma_1 in Q.
    simpl rev in Q. rewrite swap_neither in Q;
    try intro H5; try symmetry in H5; try contradiction; trivial.

  apply alpha_equiv_Ab_2; trivial.
  apply alpha_equiv_w_equiv_trans with
  (t2 :=
  ((|[(a, pi $ a')]|) @ (pi @ ((|[(a, a')]|) @ ((|[(a, a')]|) @ t'))))).
  rewrite 2 perm_comp. apply IHalpha_equiv.
  rewrite perm_comp.

  apply alpha_equiv_pi; intros.
  unfold In_ds in H5. repeat rewrite <- perm_comp_atom in H5.
  case (atom_eqdec a a0); intro H6.
  (* a = a0 *)
   rewrite H6 in *|-; trivial.
  (* a <> a0 *)
   case (atom_eqdec a' a0); intro H7.
    (* a' = a0 *)
    rewrite H7 in *|-. rewrite swap_right in H5.
    rewrite swap_left in H5. rewrite swap_right in H5. false.
    (* a' <> a0 *)
    rewrite 2 swap_neither with (c := a0) in H5; trivial.
    case (atom_eqdec a (pi $ a0)); intro H8.
      (* a = (pi $ a0) *)
      rewrite <- H8 in *|-. rewrite H8 in fresh_a.
      apply fresh_lemma_2 in fresh_a; trivial.
      (* a <> (pi $ a0) *)
      rewrite swap_neither in H5;
      try apply perm_diff_atom; trivial.
      case (atom_eqdec a' (pi $ a0)); intro H9.
        (* a' = (pi $ a0) *)
        rewrite H9 in H4.
        apply fresh_lemma_2 in H4; trivial.
        (* a' <> (pi $ a0) *)
        apply alpha_equiv_pi with
        (pi := []) (pi' := (pi ++ (|[(a', pi $ a')]|))).
        rewrite perm_id; trivial.
        unfold In_ds. rewrite perm_id_atom.
        rewrite <- perm_comp_atom.
        rewrite swap_neither;
        try apply perm_diff_atom; trivial.

  apply w_equiv_equivariance.
  apply w_equiv_equivariance.
  apply w_equiv_sym.
  apply w_equiv_swap_inv_side.
  apply w_equiv_refl.

(* Su *)
 apply alpha_equiv_Su. intros. case (In_ds_dec p' (p' ++ pi) a); intros.
 apply alpha_equiv_Su_elim with (a := a) in H0; trivial.
 apply not_In_ds in H2. apply H. intro. apply H1. rewrite H3; trivial.
Qed.

(** Reflexivity of alpha_equiv *)

Lemma alpha_equiv_refl : forall C t, C |- t ~alpha t.
Proof.
 intros. induction t.
 apply alpha_equiv_Ut. apply alpha_equiv_At. apply alpha_equiv_Ab_1; trivial.
 apply alpha_equiv_Pr; trivial. apply alpha_equiv_Fc; trivial.
 apply alpha_equiv_Su. intros. apply False_ind. apply H; trivial.
Qed.

(** Transitivity of alpha_equiv *)

Lemma alpha_equiv_trans : forall C t1 t2 t3,
 C |- t1 ~alpha t2 -> C |- t2 ~alpha t3 -> C |- t1 ~alpha t3.
Proof.
 intros. gen t3 H0. induction H; intros; trivial.
(* Pr *)
 inversion H1. apply alpha_equiv_Pr; [apply IHalpha_equiv1 | apply IHalpha_equiv2]; trivial.
(* Fc *)
 inversion H0. apply alpha_equiv_Fc.  apply IHalpha_equiv; trivial.
(* Ab *)
 inverts H0. apply alpha_equiv_Ab_1; apply IHalpha_equiv; trivial.
 apply alpha_equiv_Ab_2; trivial. apply IHalpha_equiv; trivial.
 inverts H2. apply alpha_equiv_Ab_2; trivial. apply IHalpha_equiv.
 apply alpha_equiv_equivariance; trivial.
 apply alpha_equiv_fresh with (t1 := t'); trivial.
 case (atom_eqdec a a'0); intros. rewrite e. apply alpha_equiv_Ab_1.
 apply IHalpha_equiv. apply alpha_equiv_w_equiv_trans with
  (t2 := (|[(a, a')]|) @ ((|[(a, a')]|) @ t'0)).
 apply alpha_equiv_equivariance. apply alpha_equiv_w_equiv_trans with
  (t2 := (|[(a', a)]|) @ t'0). rewrite e; trivial.
 apply w_equiv_swap_comm. apply w_equiv_sym.
 apply w_equiv_swap_inv_side. apply w_equiv_refl.
 assert (Q0 : C |- a # ((|[(a', a'0)]|) @ t'0)).
  apply alpha_equiv_fresh with (t1 := t'); trivial.
 apply fresh_lemma_1 in Q0. simpl rev in Q0.
 rewrite swap_neither in Q0; try intro H8; try symmetry in H8; try contradiction.
 apply alpha_equiv_Ab_2; trivial.
 apply IHalpha_equiv. apply alpha_equiv_equivariance with (pi := |[(a, a')]|) in H7.
 assert
  (Q : C |- ((a',a'0)::|[(a,a')]|) @ t'0 ~alpha (((a',a'0)::(a,a')::|[(a',a'0)]|) @ t'0)).
  apply alpha_equiv_pi; intros. unfold In_ds in H2.
  rewrite swap_app_atom in H2.
  rewrite swap_app_atom with (p := (a,a')::(|[(a',a'0)]|)) in H2.
  rewrite swap_app_atom with (p := |[(a',a'0)]|) in H2.
  case (atom_eqdec a' a0); intros. rewrite <- e; trivial.
  case (atom_eqdec a'0 a0); intros. rewrite e in H2.
  rewrite 2 swap_right in H2. rewrite swap_neither in H2.
  apply False_ind. apply H2; trivial.
  intro. symmetry in H3. contradiction.
  intro. rewrite <- e in H3. symmetry in H3. contradiction.
  rewrite swap_neither with (a := a') (b := a'0) in H2; trivial.
  case (atom_eqdec a a0); intros. rewrite <- e; trivial.
  rewrite 2 swap_neither in H2; trivial. apply False_ind. apply H2; trivial.
 rewrite swap_app in Q.
 rewrite swap_app with (p := (a,a')::(|[(a',a'0)]|)) in Q.
 rewrite swap_app with (p := |[(a',a'0)]|) in Q.
 gen_eq t1 : ((|[(a, a')]|) @ t'); intro.
 gen_eq t2 : ((|[(a, a')]|) @ ((|[(a', a'0)]|) @ t'0)); intro.
 assert (Q' : C |- t1 ~alpha ((|[(a', a'0)]|) @ t2)). apply pi_alpha_equiv; trivial.
 rewrite H3 in Q'. apply alpha_equiv_w_equiv_trans with
 (t2 := (|[(a', a'0)]|) @ ((|[(a, a')]|) @ ((|[(a', a'0)]|) @ t'0))); trivial.
 apply w_equiv_trans with
 (t2 := ((|[((|[(a', a'0)]|) $ a, (|[(a', a'0)]|) $ a')]|) @ ((|[(a', a'0)]|) @
        ((|[(a', a'0)]|) @ t'0)))). apply w_equiv_pi_comm.
 rewrite swap_neither with (c := a);
 try intro H10; try symmetry in H10; try contradiction. rewrite swap_left.
 apply w_equiv_equivariance. apply w_equiv_sym.
 apply w_equiv_swap_inv_side. apply w_equiv_refl.
(* Su *)
 inversion H0. apply alpha_equiv_Su; intros.
 case (In_ds_dec p p' a); intros. apply H; trivial.
 apply H5. apply not_In_ds in H7. unfold In_ds in *|-*.
 rewrite <- H7; trivial.
Qed.

(** Symmetry of alpha_equiv *)

Lemma alpha_equiv_sym : forall C t1 t2, C |- t1 ~alpha t2 -> C |- t2 ~alpha t1 .
Proof.
 intros. induction H; auto; trivial.
 assert (Q0 : C |- t' ~alpha ((|[(a', a)]|) @ t)).
  apply alpha_equiv_trans with (t2 := (|[(a, a')]|) @ t).
  apply alpha_equiv_trans with (t2 := (|[(a, a')]|) @ ((|[(a, a')]|) @ t')).
  apply alpha_equiv_w_equiv_trans with (t2 := t'). apply alpha_equiv_refl.
  apply w_equiv_swap_inv_side. apply w_equiv_refl.
  apply alpha_equiv_equivariance; trivial. apply alpha_equiv_swap_comm.
 assert (Q1 : C |- a # ((|[(a', a)]|) @ t)).
  apply alpha_equiv_fresh with (t1 := t'); trivial.
 apply fresh_lemma_1 in Q1. simpl rev in Q1. rewrite swap_right in Q1.
 apply alpha_equiv_Ab_2; trivial. intro. symmetry in H2. contradiction.
 apply alpha_equiv_Su. intros. apply H. apply ds_sym. trivial.
Qed.

(** Corollaries *)

Corollary alpha_equiv_pi_comm : forall C a b t pi,
C |- pi @ (|[(a,b)]| @ t) ~alpha (|[(pi $ a, pi $ b)]| @ (pi @ t)) .
Proof.
  intros. rewrite 2 perm_comp. apply alpha_equiv_pi; intros.
  false. apply H. rewrite <- 2 perm_comp_atom.
  rewrite pi_comm_atom. trivial.
Qed.

Corollary alpha_equiv_perm_inv : forall C pi t,
C |- (pi ++ !pi) @ t ~alpha t.
Proof.
  intros. replace t with ([]@t).
  rewrite perm_comp. apply alpha_equiv_pi; intros.
  false. apply H. simpl. rewrite <- perm_comp_atom.
  rewrite perm_inv_atom. trivial.
  autorewrite with perm; trivial.
Qed.

Corollary alpha_equiv_pi_inv_side_left : forall C pi t1 t2,
 C |- (!pi) @ t1 ~alpha t2 -> C |- t1 ~alpha (pi @ t2).
Proof.
 intros. apply alpha_equiv_trans with (t2 := pi @ ((!pi) @ t1)).
 apply alpha_equiv_sym. rewrite perm_comp. gen_eq g : (!pi); intros.
 replace pi with (!g). apply alpha_equiv_perm_inv.
 rewrite H0. apply rev_involutive. apply alpha_equiv_equivariance; trivial.
Qed.

Corollary alpha_equiv_pi_inv_side_right : forall C pi t1 t2,
C |- t1 ~alpha (pi @ t2) -> C |- (!pi) @ t1 ~alpha t2.
Proof.
 intros. apply alpha_equiv_sym in H. gen_eq g : (!pi); intros.
 replace pi with (!g) in H. apply alpha_equiv_pi_inv_side_left in H.
 apply alpha_equiv_sym; trivial. rewrite H0. apply rev_involutive.
Qed.

Corollary alpha_equiv_pi_inv_side: forall C pi t1 t2,
 C |- (!pi) @ t1 ~alpha t2 <-> C |- t1 ~alpha (pi @ t2).
Proof.
 split~; intros;
   [apply alpha_equiv_pi_inv_side_left |
    apply  alpha_equiv_pi_inv_side_right];
 trivial.
Qed.

Corollary alpha_equiv_swap_inv_side : forall C a b t1 t2,
 C |- (|[(a,b)]|) @ t1 ~alpha t2 <-> C |- t1 ~alpha ((|[(a,b)]|) @ t2).
Proof.
  intros. split~; intro.
  apply alpha_equiv_pi_inv_side. simpl rev; trivial.
  apply alpha_equiv_sym.
  apply alpha_equiv_pi_inv_side.
  apply alpha_equiv_sym. simpl rev; trivial.
Qed.

Corollary alpha_equiv_swap_commutes : forall C a b t1 t2,
 C |- t1 ~alpha ((|[(a,b)]|) @ t2) -> C |- t1 ~alpha ((|[(b,a)]|) @ t2).
Proof.
  intros. apply alpha_equiv_trans with (t2:= (|[(a, b)]|) @ t2); trivial.
  apply alpha_equiv_pi; intros. false. apply H0.
  apply swap_comm.
Qed.

Corollary alpha_equiv_equivariance_right : forall C pi t1 t2,
C |- pi @ t1 ~alpha (pi @ t2) -> C |- t1 ~alpha t2.
Proof.
 intros. apply alpha_equiv_trans with (t2 := (!pi) @ (pi @ t1)).
 apply alpha_equiv_sym. rewrite perm_comp. apply alpha_equiv_perm_inv.
 apply alpha_equiv_trans with (t2 := (!pi) @ (pi @ t2)).
 apply alpha_equiv_equivariance; trivial.
 rewrite perm_comp. apply alpha_equiv_perm_inv.
Qed.

Corollary alpha_equiv_swap_neither : forall C a a' t,
C |- a # t -> C |- a' # t -> C |- (|[(a, a')]|) @ t ~alpha t.
Proof.
 intros. replace t with ([] @ t).
 rewrite perm_comp. simpl.
 apply alpha_equiv_pi; intros. gen H1. unfold In_ds.
 case (atom_eqdec a a0); intro H2. rewrite <- H2; intro; trivial.
 case (atom_eqdec a' a0); intro H3. rewrite <- H3; intro; trivial.
 rewrite swap_neither; auto. intro H4. false. apply H4.
 simpl; trivial. autorewrite with perm. trivial.
Qed.

Corollary alpha_equiv_inv_swap : forall C a b c t,
          a <> b -> b <> c -> a <> c ->
          C |- a # t -> C |- b # t ->
          C |- (|[(a, b)]|) @ ((|[(b, c)]|) @ t) ~alpha ((|[(a, c)]|) @ t).
Proof.
  intros.
  rewrite perm_comp. apply alpha_equiv_pi; intros.
  unfold In_ds in H4. rewrite <- perm_comp_atom in H4.
  case (atom_eqdec a a0); intro H5. rewrite <- H5; trivial.
  case (atom_eqdec c a0); intro H6.
  rewrite <- H6 in *|-. false.
  apply H4. rewrite 3 swap_right; trivial.
  case (atom_eqdec b a0); intro H7. rewrite <- H7; trivial.
  false. apply H4. rewrite 3 swap_neither with (c:=a0); trivial.
Qed.


Require Import Lia.
Require Import Arith.
From Coq Require Import Unicode.Utf8.

Class EqDec (A : Type) :=
{
    eqb : A -> A -> bool;
    eqb_leibniz : forall x y, eqb x y = true -> x = y;
    beq_nat_false : forall x y, eqb x y = false -> x <> y
}.
Notation "x =? y" := (eqb x y) (at level 70).

Definition total_map (A B: Type) `{EqDec A} := A -> B.

(* Default value *)
Definition t_empty {A B : Type} `{EqDec A}  (v : B) :=
    (fun _ : A => v).

Definition t_update {A B : Type} `{EqDec A} (m : total_map A B)
                    (x : A) (v : B) :=
    fun y => if eqb x y then v else m y.

Notation "'_' ':' A '!->' v" := (@t_empty A _ _ v) (at level 100, right associativity).

Example empt (A : Type ) `{EqDec A} :=  _ : A !-> false.

Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

#[refine] Instance nat_EqDec : EqDec nat := {eqb := Nat.eqb }.
Proof.
    - intros [] [] H; auto; try inversion H. apply beq_nat_true in H1. rewrite H1.
    reflexivity.
    - intros x y H. rewrite Nat.eqb_neq in H. auto.
Defined.

Definition examplemap :=
    (1 !-> 0 ;
     2 !-> 1 ;
     @t_empty nat _ nat_EqDec 4
    ).
(* We can leave out the annotations. Coq infers all of them *)
Definition examplemap' :=
    (1 !-> 0 ;
    2 !-> 1 ;
    t_empty 4
    ).

Check (t_empty 4).

Print examplemap'.

Section list_test.
Print list.
Check list.

Inductive total_map' (A B : Type) (H : EqDec A) : Type :=
| T_empty : total_map' A B H
| T_update : forall (x : A) (v : B) (m : total_map' A B H),
            total_map' A B H
.

Arguments T_empty : default implicits.
Arguments T_update : default implicits.
Print Implicit T_empty.
Check (T_update 2 3 (@T_empty nat _ _) ).

End list_test.

Section t_map_lemmas.

Context {A B : Type} (x : A) (v : B).
Context `{EqDec A}.
Context (m : total_map A B ).
Lemma t_apply_empty : (t_empty v) x = v.
Proof.
     cbn. simpl. unfold t_empty. auto.
Qed.
Print Instances EqDec.

Lemma t_update_eq : (x !-> v ; m) x = v.
Proof.
    unfold t_update. destruct (x =? x) eqn:H2; try auto. Search Nat.eqb.
    apply beq_nat_false in H2. exfalso. apply H2. reflexivity.
Qed.

Lemma t_update_neq : ∀ y, x <> y -> (x !-> v ; m) y = m y.
Proof.
    intros y Heq. unfold t_update. destruct (x =? y) eqn:H3; try auto.
    apply eqb_leibniz in H3. congruence.
Qed.

(* careful here  *)
Require Import Coq.Logic.FunctionalExtensionality.
Lemma t_update_shadow : ∀ v1,
  (x !-> v ; x !-> v1 ; m) = (x !-> v ; m).
Proof.
    intros v1. unfold t_update.
    apply functional_extensionality. intros a.
    destruct (x =? a) eqn:H3; try auto.
Qed.

Theorem t_update_same :
  (x !-> m x ; m) = m.
Proof.
    unfold t_update. apply functional_extensionality. intros y.
    destruct (x =? y) eqn:H3; try auto.
    apply eqb_leibniz in H3. now rewrite H3.
Qed.

Theorem t_update_permute : ∀ v' y,
  x ≠ y →
  (x !-> v ; y !-> v' ; m)
  =
  (y !-> v' ; x !-> v ; m).
Proof.
    intros v' y H1. apply functional_extensionality. unfold t_update. intros z.
    destruct (x =? z) eqn:H3; try auto. apply eqb_leibniz in H3.
    destruct (y =? z) eqn:H4; try auto.
    apply eqb_leibniz in H4. rewrite <- H3 in H4. symmetry in H4. congruence.
Qed.

End t_map_lemmas.
Definition partial_map (A B : Type) `{EqDec A}:= total_map A (option B).


Require Import  month.

(** explicit use of month_rect

*)
Definition is_January_clumsy : month -> Prop :=
 month_rect (fun m => Prop)
  True
  False
  False
  False
  False
  False
  False
  False
  False
  False
  False
  False.

(** Tests:

Compute is_January_clumsy February.

Compute is_January_clumsy January.
*)

(* alternate solution *)

Definition is_January (m : month) : Prop :=
 match m with
 | January => True
 | _ => False
 end.

Remark both_versions_are_convertible :
    is_January = is_January_clumsy.
Proof. reflexivity. Qed.


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

- Frederic Blanqui, 2005-06-17

general results on booleans
*)

Set Implicit Arguments.

From Coq Require Import ZArith Lia.
From Coq Require Export Bool.
From Coq Require Setoid.

From CoLoR Require Import LogicUtil.

Arguments orb_false_elim [b1 b2] _.
Arguments orb_true_elim [b1 b2] _.

Global Hint Rewrite negb_orb negb_andb negb_involutive eqb_negb1 eqb_negb2
  orb_true_r orb_true_l orb_false_r orb_false_l orb_negb_r orb_assoc
  andb_false_r andb_false_l andb_true_r andb_true_l andb_negb_r andb_assoc
  absoption_andb absoption_orb
  xorb_false_r xorb_false_l xorb_nilpotent xorb_assoc_reverse
  : bool.

Ltac bool := autorewrite with bool.

(***********************************************************************)
(** equality *)

Lemma false_not_true : forall b, b = false <-> ~(b = true).

Proof. destruct b; intuition. Qed.

Lemma beq_true : forall b c, b = c <-> (b = true <-> c = true).

Proof.
  split; intro h. subst. tauto. destruct c.
  tauto. rewrite false_not_true. intuition.
Qed.

(***********************************************************************)
(** implication *)

Lemma implb1 : forall b, implb b b = true.

Proof. induction b; refl. Qed.

Lemma implb2 : forall b, implb b true = true.

Proof. induction b; refl. Qed.

(***********************************************************************)
(** conjunction *)

Lemma andb_elim : forall b c, b && c = true -> b = true /\ c = true.

Proof. destruct b; destruct c; intuition. Qed.

Arguments andb_elim [b c] _.

Lemma andb_eliml : forall b c, b && c = true -> b = true.

Proof. destruct b; destruct c; intuition. Qed.

Arguments andb_eliml [b c] _.

Lemma andb_elimr : forall b c, b && c = true -> c = true.

Proof. destruct b; destruct c; intuition. Qed.

Arguments andb_elimr [b c] _.

Lemma andb_intro : forall b c, b = true -> c = true -> b && c = true.

Proof. intros. subst b. subst c. refl. Qed.

Lemma andb_eq : forall b c, b && c = true <-> b = true /\ c = true.

Proof. split. intro. apply andb_elim. hyp. intuition. Qed.

Lemma andb_eq_false : forall b c, b && c = false <-> b = false \/ c = false.

Proof. destruct b; destruct c; bool; intuition. Qed.

(***********************************************************************)
(** negation *)

Definition neg (A : Type) (f : A->A->bool) x y := negb (f x y).

Lemma negb_lr : forall b c, negb b = c <-> b = negb c.

Proof. destruct b; destruct c; intuition. Qed.

(***********************************************************************)
(** disjonction *)

Lemma orb_intror : forall b c, c = true -> b || c = true.

Proof. intros. subst. bool. refl. Qed.

Lemma orb_introl : forall b c, c = true -> b || c = true.

Proof. intros. subst. bool. refl. Qed.

Lemma orb_eq : forall b c, b || c = true <-> b = true \/ c = true.

Proof. intuition. destruct b; auto. Qed.

(***********************************************************************)
(** equality *)

Lemma eqb_equiv : forall b b', b = b' <-> (b = true <-> b' = true).

Proof.
  intros b b'. split; intro H. subst b'. refl.
  destruct b. sym. rewrite <- H. refl.
  destruct b'. rewrite H. refl. refl.
Qed.

(***********************************************************************)
(** decidability *)

Section dec.

  Variables (A : Type) (P : A -> Prop)
    (f : A -> bool) (f_ok : forall x, f x = true <-> P x).

  Lemma ko : forall x, f x = false <-> ~P x.

  Proof. intro x. rewrite <- f_ok. destruct (f x); intuition; discr. Qed.

  Lemma dec : forall x, {P x}+{~P x}.

  Proof.
    intro x. case_eq (f x); intros.
    left. rewrite <- f_ok. hyp. right. rewrite <- ko. hyp.
  Defined.

End dec.

Arguments ko [A P f] _ x.
Arguments dec [A P f] _ x.

(***********************************************************************)
(** correspondance between boolean functions and logical connectors *)

Section bool_ok.

  Variables (A : Type) (P Q : A->Prop) (bP bQ : A-> bool)
    (bP_ok : forall x, bP x = true <-> P x)
    (bQ_ok : forall x, bQ x = true <-> Q x).

  Lemma negb_ok : forall x, negb (bP x) = true <-> ~P x.

  Proof. intro. rewrite <- (ko bP_ok). destruct (bP x); simpl; intuition. Qed.

  Lemma andb_ok : forall x, bP x && bQ x = true <-> P x /\ Q x.

  Proof. intro. rewrite andb_eq, bP_ok, bQ_ok. refl. Qed.

  Lemma orb_ok : forall x, bP x || bQ x = true <-> P x \/ Q x.

  Proof. intro. rewrite orb_eq, bP_ok, bQ_ok. refl. Qed.

  Lemma implb_ok : forall x, implb (bP x) (bQ x) = true <-> (P x -> Q x).

  Proof.
    intro x. unfold implb. case_eq (bP x).
    rewrite bP_ok, bQ_ok. tauto.
    rewrite (ko bP_ok). tauto.
  Qed.

End bool_ok.

(***********************************************************************)
(** checking a property (P i) for all i<n *)

Section bforall_lt.

  Variables (P : nat->Prop) (bP : nat->bool)
    (bP_ok : forall x, bP x = true <-> P x).

  Definition forall_lt n := forall i, i < n -> P i.

  Fixpoint bforall_lt_aux b n := b &&
    match n with
      | 0 => true
      | S n' => bforall_lt_aux (bP n') n'
    end.

  Lemma bforall_lt_aux_ok : forall n b,
    bforall_lt_aux b n = true <-> b = true /\ forall_lt n.

  Proof.
    unfold forall_lt. induction n; simpl; intros. bool. firstorder auto with zarith.
    rewrite andb_eq, IHn, bP_ok. intuition.
    destruct (Nat.eq_dec i n). subst. hyp. apply H2. lia.
  Qed.

  Definition bforall_lt := bforall_lt_aux true.

  Lemma bforall_lt_ok : forall n, bforall_lt n = true <-> forall_lt n.

  Proof. intro. unfold bforall_lt. rewrite bforall_lt_aux_ok. tauto. Qed.

End bforall_lt.


From algebra Require Import preamble semigroup monoid group ring.
From HB Require Import structures.

Definition field_property (A : CRing.type) :=
  forall x : A, ~ (x = zero) <-> is_unit x.

Definition residue_field_property (A : CRing.type) :=
  forall x : A, (x = zero) <-> ~ (is_unit x).

Definition geometric_field_property (A : CRing.type) :=
 ~ ((zero : A) = one) /\ forall x : A, x = zero \/ is_unit x.