From Coq Require Import Arith Program Omega.

Inductive four_expr : Set :=
| Four : four_expr
| Factorial : four_expr -> four_expr
| SqrtF : four_expr -> four_expr
| SqrtC : four_expr -> four_expr
| LogF : four_expr -> four_expr
| LogC : four_expr -> four_expr
.

Fixpoint fact (n : nat) : nat :=
  match n with
  | 0 => 1
  | S n' => n * fact n'
  end.

Lemma fact_pos : forall n, fact n > 0.
Proof.
  induction n.
  simpl; omega.
  simpl.
  apply Nat.lt_lt_add_r.
  trivial.
Qed.

Lemma fact_inc : forall n, n > 0 -> fact (S n) > fact n.
Proof.
  intros.
  simpl.
  assert (n * fact n > 0).
  assert (fact n > 0).
  apply fact_pos.
  apply Nat.mul_pos_pos; trivial.
  omega.
Qed.

Lemma fact_inc' : forall n m, n > 0 -> n < m -> fact n < fact m.
Proof.
  intros.
  induction H0.
  apply fact_inc.
  assumption.
  assert (fact m < fact (S m)).
  apply fact_inc.
  omega.
  omega.
Qed.

Lemma fact_nondec : forall n m, n < m -> fact n <= fact m.
Proof.
  intros.
  induction n.
  simpl.
  assert (fact m > 0).
  apply fact_pos.
  omega.
  assert (fact (S n) < fact m).
  apply fact_inc'; try assumption; try omega.
  omega.
Qed.

Inductive Op : Type :=
| EQ
| LE
| GE.

Fixpoint gwp (n : nat) (g : nat) (cond : nat -> nat -> nat) : nat :=
  match g with
  | 0 => 0
  | S g' => match cond n g' with
           | 0 => g
           | S k => gwp n g' cond
           end
  end.

Definition logf (n : nat) : nat :=
  n - gwp n n (fun n g' => 1 + n - Nat.pow 10 (n - g')).

Definition logc (n : nat) : nat :=
  n - gwp n n (fun n g' => n - Nat.pow 10 (n - S g')).

Compute logc 10.

Fixpoint comp (f : four_expr) : nat :=
  match f with
  | Four => 4
  | Factorial f' => fact (comp f')
  | SqrtF f' => Nat.sqrt (comp f')
  | SqrtC f' => Nat.sqrt_up (comp f')
  | LogF f' => Nat.log2 (comp f')
  | LogC f' => Nat.log2_up (comp f')
  end.

Fixpoint fact_tower (n : nat) :=
  match n with
  | 0 => Four
  | S n' => Factorial (fact_tower n')
  end.

Lemma fact_tower_pos : forall n, comp (fact_tower n) > 0.
Proof.
  intros.
  induction n.
  simpl; omega.
  simpl.
  apply fact_pos.
Qed.

Definition sqrt_ft (n : nat) :=
  SqrtF (fact_tower n).

Lemma mul2_gt : forall n, n > 0 -> n < 2 * n.
Proof.
  intros.
  omega.
Qed.

Lemma sqrt_nondec : forall n, Nat.sqrt n <= Nat.sqrt (S n).
Proof.
  intros.
  apply Nat.sqrt_le_mono.
  omega.
Qed.

Lemma sqrt_pos : forall n, n > 0 -> Nat.sqrt n > 0.
Proof.
  intros.
  induction H.
  rewrite Nat.sqrt_1; omega.
  assert (Nat.sqrt (S m) >= Nat.sqrt m).
  apply sqrt_nondec.
  omega.
Qed.

Lemma sqrt_lt' : forall n, n > 0 -> Nat.sqrt n < Nat.sqrt (4 * n).
Proof.
  intros.
  assert (Nat.sqrt 4 * Nat.sqrt n <= Nat.sqrt(4 * n)).
  apply Nat.sqrt_mul_below.
  assert (Nat.sqrt n < Nat.sqrt 4 * Nat.sqrt n).
  apply mul2_gt.
  apply sqrt_pos; trivial.
  omega.
Qed.

Lemma sqrt_lt : forall m n, n > 0 -> m > 4 * n -> Nat.sqrt m > Nat.sqrt n.
Proof.
  intros.
  assert (Nat.sqrt n < Nat.sqrt (4 * n)).
  apply sqrt_lt'; apply H.
  assert (Nat.sqrt m >= Nat.sqrt (4 * n)).
  apply Nat.sqrt_le_mono.
  omega.
  omega.
Qed.

Lemma sqrt_fold_below : forall m n, n * Nat.sqrt m <= Nat.sqrt (n * n * m).
Proof.
  intros.
  assert (Nat.sqrt (n * n) = n).
  apply Nat.sqrt_square.
  rewrite <- H at 1.
  apply Nat.sqrt_mul_below.
Qed.

Lemma sqrt_fold_above : forall m n, S n * S (Nat.sqrt m) >= S (Nat.sqrt (n * n * m)).
Proof.
  intros.
  assert (Nat.sqrt (n * n) = n).
  apply Nat.sqrt_square.
  rewrite <- H at 1.
  apply Nat.sqrt_mul_above.
Qed.

Lemma sqrt_sqrt_lt : forall m n, n > 0 -> m > 25 * n -> Nat.sqrt (Nat.sqrt m) > Nat.sqrt (Nat.sqrt n).
Proof.
  intros.
  apply sqrt_lt.
  apply sqrt_pos; trivial.
  assert (Nat.sqrt m >= Nat.sqrt (25 * n)).
  apply Nat.sqrt_le_mono; omega.
  assert (Nat.sqrt (25 * n) >= 5 * Nat.sqrt n).
  apply sqrt_fold_below.
  assert (5 * Nat.sqrt n > 4 * Nat.sqrt n).
  apply mult_lt_compat_r.
  auto.
  apply sqrt_pos.
  trivial.
  omega.
Qed.

Lemma mul_nondec : forall n p, p > 0 -> p * n >= n.
Proof.
  intros.
  induction p.
  inversion H.
  assert (S p * n = n + n * p).
  simpl.
  ring.
  rewrite H0.
  case (n * p).
  omega.
  intros.
  omega.
Qed.

Theorem exists_increasing_seq :
  exists (f : nat -> four_expr),
    comp (f 0) = 2
    /\ forall n, comp (f n) < comp (f (S n)).
Proof.
  exists sqrt_ft.
  split.
  trivial.
  intros.
  simpl.
  case n.
  unfold Nat.sqrt; simpl; omega.
  intros.
  apply sqrt_lt.
  apply fact_tower_pos.
  assert (comp (fact_tower (S n0)) >= 24).
  induction n0.
  simpl; omega.
  simpl in *.
  assert (24 = fact 4).
  simpl; trivial.
  rewrite H.
  apply fact_nondec.
  omega.
  induction H.
  assert (fact 24 = 24 * (23 * fact 22)).
  unfold fact.
  trivial.
  rewrite H.
  assert (24 * (23 * fact 22) = 24 * 23 * fact 22).
  omega.
  rewrite H0.
  assert (24 * 23 * 22 > 4 * 24).
  omega.
  assert (fact 22 > 0).
  apply fact_pos.
  omega.
  simpl (fact (S m)).
  assert (4 * S m = 4 + 4 * m).
  omega.
  rewrite H0.
  assert (m * fact m > 25).
  assert (fact m > 25).
  omega.
  assert (m * fact m >= fact m).
  apply mul_nondec.
  omega.
  omega.
  omega.
Qed.

Fixpoint sqrt_repeated' (l : nat) (n : four_expr) (c : nat) : four_expr :=
  match c with
  | 0 => n
  | S c' => match comp n - l * l with
           | 0 => n
           | S k => sqrt_repeated' l (SqrtC n) c'
           end
  end.

Definition sqrt_repeated (l : nat) (n : four_expr) : four_expr :=
  sqrt_repeated' l n (comp n).

Fixpoint sqrt_repeated_elem (seq : nat -> four_expr) (n : nat) :=
  match n with
  | 0 => seq 0
  | S n' => sqrt_repeated (comp (sqrt_repeated_elem seq n')) (seq n)
  end.

Lemma sqrt_repeated_increasing' :
  forall x y z, x < comp y -> x < comp (sqrt_repeated' x y z).
Proof.
  intros.
  dependent induction z generalizing y.
  simpl.
  apply H.
  simpl.
  remember (comp y - x * x) as d.
  destruct d.
  apply H.
  apply IHz.
  simpl.
  assert (x * x < comp y).
  omega.
  assert (comp y <= Nat.sqrt_up (comp y) * Nat.sqrt_up (comp y)).
  apply Nat.sqrt_sqrt_up_spec.
  omega.
  assert (x * x < Nat.sqrt_up (comp y) * Nat.sqrt_up (comp y)).
  omega.
  apply Nat.square_lt_mono.
  apply H2.
Qed.

Lemma sqrt_repeated_increasing :
  forall x y, x < comp y -> x < comp (sqrt_repeated x y).
Proof.
  intros.
  unfold sqrt_repeated.
  apply sqrt_repeated_increasing'.
  apply H.
Qed.

Lemma sqrt_repeated_dec' :
  forall l n z, comp (sqrt_repeated' l n z) <= comp n.
Proof.
  intros.
  dependent induction z generalizing n.
  auto.
  simpl.
  destruct (comp n - l * l).
  auto.
  specialize IHz with (n := (SqrtC n)).
  assert (comp (SqrtC n) <= comp n).
  simpl.
  apply Nat.sqrt_up_le_lin.
  omega.
  omega.
Qed.

Lemma sqrt_repeated_dec :
  forall l n, comp (sqrt_repeated l n) <= comp n.
Proof.
  intros.
  apply sqrt_repeated_dec'.
Qed.

Lemma sqrt_repeated_elem_dec :
  forall seq n, comp (sqrt_repeated_elem seq n) <= comp (seq n).
Proof.
  intros.
  induction n.
  auto.
  simpl.
  apply sqrt_repeated_dec.
Qed.

Lemma sqrt_repeated_elem_inc :
  forall seq n, comp (seq 0) = 2 -> (forall p, comp (seq p) < comp (seq (S p))) -> comp (sqrt_repeated_elem seq n) > 1.
Proof.
  intros.
  induction n.
  simpl.
  omega.
  assert (comp (sqrt_repeated_elem seq (S n)) > comp (sqrt_repeated_elem seq n)).
  simpl.
  apply sqrt_repeated_increasing.
  assert (comp (sqrt_repeated_elem seq n) <= comp (seq n)).
  apply sqrt_repeated_elem_dec.
  specialize H0 with (p := n).
  omega.
  omega.
Qed.

Lemma sqrt_repeated_bound' :
  forall l n z , l > 1 -> z >= comp n \/ comp n <= 2 -> l * l >= comp (sqrt_repeated' l n z).
Proof.
  intros.
  dependent induction z generalizing n.
  simpl.
  destruct H0.
  inversion H0.
  rewrite H2.
  apply Nat.le_0_l.
  assert (l * l >= l).
  apply mul_nondec.
  omega.
  omega.
  simpl.
  remember (comp n - l * l) as d.
  destruct d.
  omega.
  apply IHz.
  assumption.
  simpl.
  destruct H0.
  remember (comp n - 2) as c.
  destruct c.
  assert (comp n <= 2).
  omega.
  right.
  assert (Nat.sqrt_up (comp n) <= (comp n)).
  apply Nat.sqrt_up_le_lin.
  omega.
  omega.
  assert (comp n > 2).
  omega.
  left.
  assert (Nat.sqrt_up (comp n) < comp n).
  apply Nat.sqrt_up_lt_lin.
  trivial.
  omega.
  right.
  assert (Nat.sqrt_up (comp n) <= comp n).
  apply Nat.sqrt_up_le_lin.
  omega.
  omega.
Qed.

Lemma sqrt_repeated_bound :
  forall l n, l > 1 -> l * l >= comp (sqrt_repeated l n).
Proof.
  intros.
  apply sqrt_repeated_bound'.
  assumption.
  left.
  omega.
Qed.

Theorem exists_square_bound_seq' :
  (exists (f : nat -> four_expr),
    comp (f 0) = 2
    /\ forall n, comp (f n) < comp (f (S n)))
   -> (exists (f : nat -> four_expr),
    comp (f 0) = 2
    /\ forall n, comp (f n) < comp (f (S n)) /\ comp (f n) * comp (f n) >= comp (f (S n))).
Proof.
  intros.
  inversion H.
  rename x into seq.
  exists (sqrt_repeated_elem seq).
  split.
  simpl.
  apply H0.
  intros.
  split.
  simpl.
  apply sqrt_repeated_increasing.
  destruct H0.
  specialize H1 with (n := n).
  assert (comp (sqrt_repeated_elem seq n) <= comp (seq n)).
  dependent induction n.
  simpl.
  trivial.
  apply sqrt_repeated_elem_dec.
  omega.
  simpl.
  remember (comp (sqrt_repeated_elem seq n)) as x.
  destruct n.

  apply sqrt_repeated_bound.
  simpl in Heqx.
  omega.
  apply sqrt_repeated_bound.
  induction n.
  simpl in Heqx.
  destruct H0.
  rewrite H0 in Heqx.
  assert (2 < comp (sqrt_repeated 2 (seq 1))).
  apply sqrt_repeated_increasing.
  specialize H1 with (n := 0).
  omega.
  omega.
  rewrite Heqx.
  apply sqrt_repeated_elem_inc.
  apply H0.
  apply H0.
Qed.

Theorem exists_square_bound_seq :
(exists (f : nat -> four_expr),
    comp (f 0) = 2
    /\ forall n, comp (f n) < comp (f (S n)) /\ comp (f n) * comp (f n) >= comp (f (S n))).
Proof.
  apply exists_square_bound_seq'.
  apply exists_increasing_seq.
Qed.

Definition logloglog_seq (seq : nat -> four_expr) (n : nat) :=
  LogF (LogF (LogF (seq n))).

Ltac cases N :=
  match type of N with
  | ?n <= S ?k => remember (n - k) as n';
                destruct n';
                try assert (n = S k) as N' by omega;
                try assert (n <= k) as N' by omega;
                clear N;
                rename N' into N
  end.

Lemma loglog_ok_5 :
  forall n, n <= 5 -> n > 3 -> Nat.log2 (Nat.log2 (n * n)) <= 2 * Nat.log2 (Nat.log2 n).
Proof.
  intros.
  do 2 try cases H; match goal with
                | [ H : n = ?k |- _ ] => rewrite H; simpl; trivial
                | _ => idtac
                end.
Qed.

Lemma loglog_ok_10 :
  forall n, n <= 10 -> n > 3 -> Nat.log2 (Nat.log2 (n * n)) <= 2 * Nat.log2 (Nat.log2 n).
Proof.
  intros.
  do 5 try cases H; match goal with
                | [ H : n = ?k |- _ ] => rewrite H; simpl; trivial
                | _ => idtac
                end.
  apply loglog_ok_5; trivial.
Qed.

Lemma loglog_ok_15 :
  forall n, n <= 15 -> n > 3 -> Nat.log2 (Nat.log2 (n * n)) <= 2 * Nat.log2 (Nat.log2 n).
Proof.
  intros.
  do 5 try cases H; match goal with
                | [ H : n = ?k |- _ ] => rewrite H; simpl; trivial
                | _ => idtac
                end.
  apply loglog_ok_10;
  trivial.
Qed.

Lemma loglog_ok :
  forall n, n > 3 -> Nat.log2 (Nat.log2 (n * n)) <= 2 * (Nat.log2 (Nat.log2 n)).
Proof.
  intros.
  rename H into Hgt3.
  assert (Nat.log2 (n * n) <= Nat.log2 n + Nat.log2 n + 1).
  apply Nat.log2_mul_above; omega.
  remember (n-1) as nm1.
  destruct nm1.
  assert (n = 1 \/ n = 0).
  omega.
  destruct H0.
  rewrite H0.
  auto.
  rewrite H0.
  auto.
  assert (n > 1).
  omega.
  assert (Nat.log2 n >= Nat.log2 2).
  apply Nat.log2_le_mono.
  omega.
  assert (Nat.log2 2 = 1). auto.
  assert (Nat.log2 n + Nat.log2 n + 1 <= 3 * Nat.log2 n).
  omega.
  assert (Nat.log2 (3 * Nat.log2 n) <= Nat.log2 3 + Nat.log2 (Nat.log2 n) + 1).
  apply Nat.log2_mul_above; omega.
  assert (Nat.log2 3 = 1); auto.
  rewrite H5 in H4.
  apply Nat.log2_le_mono in H.
  apply Nat.log2_le_mono in H3.
  assert (1 + Nat.log2 (Nat.log2 n) + 1 = Nat.log2 (Nat.log2 n) + 2).
  omega.
  rewrite H6 in H4.
  remember (n - 15) as nm15.
  destruct nm15.
  2: {
    assert (16 <= n).
    omega.
    assert (2 <= Nat.log2 (Nat.log2 n)).
    apply Nat.log2_le_pow2.
    omega.
    simpl.
    apply Nat.log2_le_pow2.
    omega.
    simpl.
    trivial.
    assert (Nat.log2 (Nat.log2 n) + 2 <= 2 * Nat.log2 (Nat.log2 n)).
    omega.
    omega.
  }
  assert (n <= 15) by omega.
  apply loglog_ok_15; trivial.
Qed.

Theorem exists_cover_seq' :
(exists (f : nat -> four_expr),
    comp (f 0) = 2
    /\ (forall n, comp (f n) < comp (f (S n)) /\ comp (f n) * comp (f n) >= comp (f (S n))))
-> (exists (f : nat -> four_expr),
      comp (f 0) = 0
      /\ (forall n, (comp (f n) <= comp (f (S n)) /\ comp (f (S n)) <= S (comp (f n))))
      /\ forall n, exists m, comp (f m) > n).

Proof.
  intros.
  inversion H.
  rename x into seq.
  exists (logloglog_seq seq).
  split.
  simpl.
  destruct H0.
  rewrite H0.
  auto.
  split.
  split.
  simpl.
  do 3 apply Nat.log2_le_mono.
  destruct H0.
  specialize (H1 n).
  omega.
  simpl.
  destruct H0.
  specialize (H1 n).
  remember (comp (seq n)) as cn.
  remember (comp (seq (S n))) as csn.
  remember (cn - 3) as cnm3.
  destruct H1.
  destruct cnm3.
  assert (cn <= 3).
  omega.
  do 4 try cases H3;
  match type of H3 with
  | cn <= 0 => assert (cn = 0) as H3'; try omega; clear H3; rename H3' into H3
  | _ => idtac
  end;
  match type of H3 with
  | cn = ?k =>
      rewrite H3 in *;
      assert (csn <= k * k);
      try omega;
      assert (Nat.log2 (Nat.log2 (Nat.log2 csn)) <= Nat.log2 (Nat.log2 (Nat.log2 (k * k))));
      try do 3 apply Nat.log2_le_mono; auto
  | _ => idtac
  end.
  assert (cn > 3).
  omega.
  rewrite <- Nat.log2_double.
  apply Nat.log2_le_mono.
  assert (Nat.log2 csn <= Nat.log2 (cn * cn)).
  apply Nat.log2_le_mono.
  omega.
  apply Nat.log2_le_mono in H4.
  assert (Nat.log2 (Nat.log2 (cn * cn)) <= 2 * Nat.log2 (Nat.log2 cn)).
  apply loglog_ok.
  trivial.
  omega.
  do 2 apply Nat.log2_le_mono in H3.
  auto.
  intros.
  simpl.
  destruct H0.
  assert (forall n, comp (seq n) >= n).
  intros.
  induction n0.
  omega.
  assert (comp (seq (S n0)) > comp (seq n0)).
  apply H1.
  omega.
  exists (2 ^ 2 ^ 2 ^ (n + 1)).
  assert (comp (seq (2 ^ 2 ^ 2 ^ (n + 1))) >= 2 ^ 2 ^ 2 ^ (n + 1)).
  trivial.
  do 3 apply Nat.log2_le_mono in H3.
  assert (Nat.log2 (2 ^ 2 ^ 2 ^ (n + 1)) = 2 ^ 2 ^ (n + 1)).
  apply Nat.log2_pow2.
  omega.
  assert (Nat.log2 (2 ^ 2 ^ (n + 1)) = 2 ^ (n + 1)).
  apply Nat.log2_pow2.
  omega.
  assert (Nat.log2 (2 ^ (n + 1)) = n + 1).
  apply Nat.log2_pow2.
  omega.
  assert (Nat.log2 (Nat.log2 (Nat.log2 (2 ^ 2 ^ 2 ^ (n + 1)))) = (n + 1)).
  rewrite H4.
  rewrite H5.
  rewrite H6.
  trivial.
  omega.
Qed.

Theorem exists_cover_seq :
  exists (f : nat -> four_expr),
      comp (f 0) = 0
      /\ (forall n, (comp (f n) <= comp (f (S n)) /\ comp (f (S n)) <= S (comp (f n))))
      /\ forall n, exists m, comp (f m) > n.
Proof.
  apply exists_cover_seq'.
  apply exists_square_bound_seq.
Qed.

Lemma seq_no_jump :
  (forall seq,
      (comp (seq 0) = 0
      /\ forall n, (comp (seq n) <= comp (seq (S n)) /\ comp (seq (S n)) <= S (comp (seq n)))
      /\ forall n, exists m, comp (seq m) > n)
  -> forall n, forall m, m < comp (seq n) -> exists p, comp (seq p) = m).
Proof.
  intros until 1.
  inversion H.
  clear H.
  induction n; intros.
  rewrite H0 in H.
  inversion H.
  specialize (H1 n).
  destruct H1.
  destruct H1.
  remember (comp (seq (S n)) - comp (seq n)) as dseq.
  destruct dseq.
  assert (comp (seq (S n)) = comp (seq n)).
  omega.
  rewrite <- H4 in IHn.
  auto.
  assert (comp (seq (S n)) = S (comp (seq n))).
  omega.
  assert (m <= comp (seq n)).
  omega.
  apply le_lt_or_eq in H5.
  destruct H5.
  auto.
  exists n.
  auto.
Qed.

Lemma seq_cover :
  (forall seq,
      comp (seq 0) = 0
      -> (forall n, comp (seq n) <= comp (seq (S n)) /\ comp (seq (S n)) <= S (comp (seq n)))
      -> (forall n, exists m, comp (seq m) > n)
      -> (forall n, exists p, comp (seq p) = n)).
Proof.
  intros.
  assert ((forall n, forall m, m < comp (seq n) -> exists p, comp (seq p) = m)).
  apply seq_no_jump.
  auto.
  intros.
  specialize (H1 n).
  destruct H1.
  specialize (H2 x n).
  auto.
Qed.

Theorem four_seq_express_all_n :
  forall a, exists f, comp f = a.
Proof.
  intros.
  pose proof seq_cover.
  pose proof exists_cover_seq.
  destruct H0.
  rename x into seq.
  specialize (H seq).
  destruct H0.
  destruct H1.
  assert (forall n0 : nat, exists p : nat, comp (seq p) = n0).
  apply H.
  apply H0.
  apply H1.
  apply H2.
  clear H.
  specialize (H3 a).
  destruct H3.
  exists (seq x).
  auto.
Qed.


(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
From mathcomp Require Import all_ssreflect ssralg fingroup finalg matrix.
Require Import Reals Lra.
From mathcomp Require Import Rstruct.
Require Import ssrZ ssrR Reals_ext ssr_ext logb ssralg_ext bigop_ext Rbigop.
Require Import fdist proba entropy aep typ_seq channel.

(******************************************************************************)
(*                        Jointly typical sequences                           *)
(*                                                                            *)
(* Definitions:                                                               *)
(*   JTS P W n epsilon == epsilon-jointly typical sequences of size n for an  *)
(*                        input distribution P and  a channel W               *)
(*                        JTS(n,e) is a subset of TS_{P,W}(n,e) such that     *)
(*                        (x,y) \in JTS(n,e) <->                              *)
(*                        x \in TS_P(n,e) /\ y \in TS_{PW}(n,e)               *)
(*                                                                            *)
(* Lemmas:                                                                    *)
(*  JTS_sup               == Upper-bound for the set of jointly typical       *)
(*                           sequences                                        *)
(*  JTS_1                 == when they are very long, the jointly typical     *)
(*                           sequences coincide with the typical sequences of *)
(*                           the joint distribution                           *)
(*  non_typical_sequences == the probability of the same event (joint         *)
(*                           typicality) taken over the product distribution  *)
(*                           of the inputs and the out-puts considered        *)
(*                           independently tends to 0 asngets large           *)
(*                                                                            *)
(* For details, see Reynald Affeldt, Manabu Hagiwara, and Jonas Sénizergues.  *)
(* Formalization of Shannon's theorems. Journal of Automated Reasoning,       *)
(* 53(1):63--103, 2014                                                        *)
(******************************************************************************)

Declare Scope jtyp_seq_scope.
Reserved Notation "'`JTS'".

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope typ_seq_scope.
Local Open Scope fdist_scope.
Local Open Scope channel_scope.
Local Open Scope entropy_scope.
Local Open Scope R_scope.

Section joint_typ_seq_definition.

Variables A B : finType.
Variable P : fdist A.
Variable W : `Ch(A, B).
Variable n : nat.
Variable epsilon : R.

Definition jtyp_seq (t : 'rV[A * B]_n) :=
  [&& typ_seq P epsilon (rV_prod t).1,
      typ_seq (`O(P , W)) epsilon (rV_prod t).2 &
      typ_seq ((P `X W)) epsilon t].

Definition set_jtyp_seq : {set 'rV[A * B]_n} := [set tab | jtyp_seq tab].

Local Notation "'`JTS'" := (set_jtyp_seq).

Lemma typical_sequence1_JTS x : prod_rV x \in `JTS ->
  exp2 (- INR n * (`H P + epsilon)) <= P `^ n x.1 <= exp2 (- INR n * (`H P - epsilon)).
Proof.
rewrite inE => /and3P[/andP[/leRP JTS11 /leRP JTS12] _ _].
by rewrite prod_rVK in JTS11, JTS12.
Qed.

Lemma typical_sequence1_JTS' x : prod_rV x \in `JTS ->
  exp2 (- INR n * (`H (`O( P , W)) + epsilon)) <= (`O( P , W)) `^ n x.2 <=
  exp2 (- INR n * (`H (`O( P , W)) - epsilon)).
Proof.
rewrite inE => /and3P[_ /andP[/leRP JTS11 /leRP JTS12] _].
by rewrite prod_rVK in JTS11, JTS12.
Qed.

End joint_typ_seq_definition.

Notation "'`JTS'" := (set_jtyp_seq) : jtyp_seq_scope.
Local Open Scope jtyp_seq_scope.

Section jtyp_seq_upper.

Variables (A B : finType) (P : fdist A) (W : `Ch(A, B)).
Variable n : nat.
Variable epsilon : R.

Lemma JTS_sup : INR #| `JTS P W n epsilon| <= exp2 (INR n * (`H(P , W) + epsilon)).
Proof.
have : INR #|`JTS P W n epsilon| <= INR #|`TS ((P `X W)) n epsilon|.
  suff : `JTS P W n epsilon \subset `TS ((P `X W)) n epsilon.
    by move/subset_leq_card/leP/le_INR.
  apply/subsetP => tab.
  by rewrite /set_jtyp_seq inE /jtyp_seq inE => /and3P[].
move/leR_trans; apply; exact: (@TS_sup _ ((P `X W)) epsilon n).
Qed.

End jtyp_seq_upper.

Section jtyp_seq_transmitted.
Variables (A B : finType) (P : fdist A) (W : `Ch(A, B)).
Variable epsilon : R.

Local Open Scope zarith_ext_scope.

Definition JTS_1_bound :=
  maxn '| up (aep_bound P (epsilon / 3)) |
 (maxn '| up (aep_bound (`O(P , W)) (epsilon / 3)) |
       '| up (aep_bound ((P `X W)) (epsilon / 3)) |).

Variable n : nat.
Hypothesis He : 0 < epsilon.

Lemma JTS_1 : (JTS_1_bound <= n)%nat ->
  1 - epsilon <= Pr ((P `X W) `^ n) (`JTS P W n epsilon).
Proof.
have : (JTS_1_bound <= n)%nat ->
  Pr ( (P `^ n `X (W ``^ n)) )
    [set x | x.1 \notin `TS P n epsilon] +
  Pr ( (P `^ n `X (W ``^ n)) )
    [set x | x.2 \notin `TS (`O(P , W)) n epsilon] +
  Pr ( (P `^ n `X  (W ``^ n)))
    [set x | prod_rV x \notin `TS ( (P `X W) ) n epsilon] <= epsilon.
  have H1 : forall n, Pr ((P `X W) `^ n) [set x | (rV_prod x).1 \notin `TS P n epsilon ] <=
    Pr (P `^ n) [set x | x \notin `TS P n (epsilon / 3)].
    move=> m.
    have : 1 <= 3 by lra.
    move/(set_typ_seq_incl P m (ltRW He)) => Hincl.
    rewrite (Pr_DMC_fst P W (fun x => x \notin `TS P m epsilon)).
    apply/Pr_incl/subsetP => i /=; rewrite !inE.
    apply contra.
    by move/subsetP : Hincl => /(_ i); rewrite !inE.
  have {H1}HnP : forall n, ('| up (aep_bound P (epsilon / 3)) | <= n)%nat ->
    Pr ((P `X W) `^ n) [set x | (rV_prod x).1 \notin `TS P n epsilon ] <= epsilon /3.
    move=> m Hm.
    apply: leR_trans; first exact: (H1 m).
    have m_prednK : m.-1.+1 = m.
      rewrite prednK // (leq_trans _ Hm) // (_ : O = '| 0 |) //.
      by apply/ltP/Zabs_nat_lt; split; [by [] | apply/up_pos/aep_bound_ge0; lra].
    have : 1 - (epsilon / 3) <= Pr (P `^ m) (`TS P m (epsilon/3)).
      rewrite -m_prednK.
      apply Pr_TS_1.
      - by apply divR_gt0 => //; lra.
      - rewrite m_prednK.
        move/leP/le_INR : Hm; apply leR_trans.
        rewrite INR_Zabs_nat; last first.
          apply/ltZW/up_pos/aep_bound_ge0 => //.
          apply divR_gt0 => //; lra.
        exact/ltRW/(proj1 (archimed _ )).
    rewrite leR_subl_addr addRC -leR_subl_addr; apply: leR_trans.
    by rewrite Pr_to_cplt setCK; exact/leRR.
  have H1 m :
    Pr ((P `X W) `^ m) [set x | (rV_prod x).2 \notin `TS ( `O(P , W) ) m epsilon ] <=
    Pr ( (`O( P , W) ) `^ m) (~: `TS ( `O( P , W) ) m (epsilon / 3)).
    have : 1 <= 3 by lra.
    move/(set_typ_seq_incl (`O(P , W)) m (ltRW He)) => Hincl.
    rewrite Pr_DMC_out.
    apply/Pr_incl/subsetP => i /=; rewrite !inE.
    apply contra.
    move/subsetP : Hincl => /(_ i).
    by rewrite !inE.
  have {H1}HnPW m : ('| up (aep_bound (`O(P , W)) (epsilon / 3)) | <= m)%nat ->
    Pr ((P `X W) `^ m) [set x | (rV_prod x).2 \notin `TS (`O(P , W)) m epsilon] <= epsilon /3.
    move=> Hm.
    apply: leR_trans; first exact: (H1 m).
    have m_prednK : m.-1.+1 = m.
      rewrite prednK // (leq_trans _ Hm) // (_ : O = '| 0 |) //.
      apply/ltP/Zabs_nat_lt (* TODO: ssrZ? *); split; [by []|apply/up_pos/aep_bound_ge0; lra].
    have : 1 - epsilon / 3 <= Pr ((`O(P , W)) `^ m) (`TS (`O(P , W)) m (epsilon / 3)).
      rewrite -m_prednK.
      apply Pr_TS_1.
      - apply divR_gt0 => //; lra.
      - move/leP/le_INR : Hm.
        rewrite m_prednK.
        apply leR_trans.
        rewrite INR_Zabs_nat; last first.
          apply/ltZW/up_pos/aep_bound_ge0; lra.
        exact/ltRW/(proj1 (archimed _ )).
    rewrite leR_subl_addr addRC -leR_subl_addr; apply: leR_trans.
    by rewrite Pr_to_cplt setCK; exact/leRR.
  have H1 m : Pr ((P `X W) `^ m) (~: `TS ((P `X W)) m epsilon) <=
    Pr (((P `X W) ) `^ m) (~: `TS ((P `X W)) m (epsilon / 3)).
    have : 1 <= 3 by lra.
    move/(set_typ_seq_incl ((P `X W)) m (ltRW He)) => Hincl.
    apply/Pr_incl/subsetP => /= v; rewrite !inE.
    apply contra.
    by move/subsetP : Hincl => /(_ v); by rewrite !inE.
  have {H1}HnP_W m : ('| up (aep_bound ((P `X W)) (epsilon / 3)) | <= m)%nat ->
    Pr ((P `X W) `^ m) (~: `TS ((P `X W)) m epsilon) <= epsilon /3.
    move=> Hm.
    apply: leR_trans; first exact: (H1 m).
    have m_prednK : m.-1.+1 = m.
      rewrite prednK // (leq_trans _ Hm) // (_ : O = '| 0 |) //.
      apply/ltP/Zabs_nat_lt; split; [by []|apply/up_pos/aep_bound_ge0; lra].
    have : 1 - epsilon / 3 <= Pr (((P `X W)) `^ m) (`TS ((P `X W)) m (epsilon / 3)).
      rewrite -m_prednK; apply Pr_TS_1.
      - apply divR_gt0 => //; lra.
      - rewrite m_prednK.
        move/leP/le_INR : Hm; apply leR_trans.
        rewrite INR_Zabs_nat; last first.
          apply/ltZW/up_pos/aep_bound_ge0; lra.
        exact/Rlt_le/(proj1 (archimed _ )).
    rewrite leR_subl_addr addRC -leR_subl_addr; apply: leR_trans.
    by rewrite Pr_to_cplt setCK; exact/leRR.
  move=> Hn.
  rewrite [in X in _ <= X](_ : epsilon = epsilon / 3 + epsilon / 3 + epsilon / 3)%R; last by field.
  move: Hn; rewrite 2!geq_max => /andP[Hn1 /andP[Hn2 Hn3]].
  rewrite !Pr_DMC_rV_prod.
  apply leR_add; first by apply leR_add; [exact: HnP | exact: HnPW].
  apply: leR_trans; last exact/HnP_W/Hn3.
  by apply/Req_le; congr Pr; apply/setP => /= tab; by rewrite !inE rV_prodK.
move=> Hn_Pr Hn.
suff H : Pr ((P `X W) `^ n ) (~: `JTS P W n epsilon) <= epsilon.
  rewrite -(Pr_cplt ((P `X W) `^ n) (`JTS P W n epsilon)).
  by rewrite leR_subl_addr leR_add2l.
apply (@leR_trans (Pr ((P `X W) `^ n)
                      ([set x | ((rV_prod x).1 \notin `TS P n epsilon)] :|:
                       ([set x | ((rV_prod x).2 \notin `TS (`O( P , W)) n epsilon)] :|:
                        (~: `TS ((P `X W)) n epsilon))))).
  by apply Req_le; congr Pr; apply/setP => xy;  rewrite !inE 2!negb_and orbA.
apply: leR_trans; last exact: Hn_Pr.
apply (@leR_trans (
 Pr ((P `X W) `^ n) [set x | (rV_prod x).1 \notin `TS P n epsilon] +
 Pr ((P `X W) `^ n) ([set x | ((rV_prod x).2 \notin `TS (`O( P , W)) n epsilon)] :|:
                      (~: `TS ((P `X W)) n epsilon)))).
  exact: Pr_union.
rewrite -addRA !Pr_DMC_rV_prod; apply/leR_add2l; apply: leR_trans (Pr_union _ _ _).
by apply/Req_le; congr Pr; apply/setP => t; rewrite !inE rV_prodK.
Qed.

End jtyp_seq_transmitted.

Section non_typicality.
Variables (A B : finType) (P : fdist A) (W : `Ch(A, B)) (n : nat) (epsilon : R).

Lemma non_typical_sequences : Pr ((P `^ n) `x ((`O(P , W)) `^ n))
  [set x | prod_rV x \in `JTS P W n epsilon] <= exp2 (- n%:R * (`I(P, W) - 3 * epsilon)).
Proof.
rewrite /Pr /=.
apply (@leR_trans (\sum_(i | i \in `JTS P W n epsilon)
    (exp2 (- INR n * (`H P - epsilon)) * exp2 (- n%:R * (`H( P `o W ) - epsilon))))) => /=.
  rewrite (reindex_onto (fun y => prod_rV y) (fun x => rV_prod x)) /=; last first.
    by move=> ? ?; rewrite rV_prodK.
  apply: leR_sumRl => i; rewrite inE => iJTS.
  - rewrite fdist_prodE; apply leR_pmul => //.
    exact: proj2 (typical_sequence1_JTS iJTS).
    exact: proj2 (typical_sequence1_JTS' iJTS).
  - exact/mulR_ge0.
  - by rewrite prod_rVK eqxx andbC.
rewrite (_ : \sum_(_ | _) _ =
  INR #| `JTS P W n epsilon| *
  exp2 (- n%:R * (`H P - epsilon)) * exp2 (- INR n * (`H( P `o W) - epsilon))); last first.
  by rewrite big_const iter_addR mulRA.
apply (@leR_trans (exp2 (INR n * (`H( P , W ) + epsilon)) *
  exp2 (- n%:R * (`H P - epsilon)) * exp2 (- INR n * (`H( P `o W ) - epsilon)))).
  do 2 apply leR_wpmul2r => //.
  exact/JTS_sup.
apply Req_le; rewrite -2!ExpD; congr (exp2 _).
rewrite /mutual_info_chan !mulRDr 2!Rmult_opp_opp.
by rewrite (_ : 3 * epsilon = epsilon + epsilon + epsilon); field.
Qed.

End non_typicality.


From mathcomp Require Import all_ssreflect all_fingroup all_algebra.
From mathcomp Require Import all_solvable all_field.
From Abel Require Import char0 various.

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

Import GRing.Theory.

Local Open Scope ring_scope.

Lemma Cyclotomic1 : 'Phi_1 = 'X - 1.
Proof.
by have := @prod_Cyclotomic 1%N isT; rewrite big_cons big_nil mulr1.
Qed.

Lemma Cyclotomic2 : 'Phi_2 = 'X + 1.
Proof.
have := @prod_Cyclotomic 2%N isT; rewrite !big_cons big_nil mulr1/=.
rewrite Cyclotomic1 -(@expr1n [ringType of {poly int}] 2%N).
by rewrite subr_sqr expr1n => /mulfI->//; rewrite polyXsubC_eq0.
Qed.

Lemma prim_root1 (F : fieldType) n : (n.-primitive_root (1 : F)) = (n == 1)%N.
Proof.
case: n => [|[|n]]//.
  by apply/'forall_eqP => i; rewrite ord1//= eqxx; apply/unity_rootP.
apply/'forall_eqP => /= /(_ (@Ordinal _ n _))/=/(_ _)/unity_rootP.
by rewrite !ltnS leqnSn ltn_eqF//; apply => //; rewrite expr1n.
Qed.

Lemma prim2_rootN1 (F : fieldType) : 2%:R != 0 :> F ->
   2.-primitive_root (- 1 : F).
Proof.
move=> tow_neq0; apply/'forall_eqP => -[[|[|]]]//= _; last first.
  by apply/unity_rootP; rewrite -signr_odd.
by apply/unity_rootP/eqP; rewrite expr1 eq_sym -addr_eq0 -mulr2n.
Qed.

Section PhiCyclotomic.

Variable (F : fieldType).

Local Notation ZtoF := (intr : int -> F).
Local Notation pZtoF := (map_poly ZtoF).

Lemma Phi_cyclotomic (n : nat) (w : F) : n.-primitive_root w ->
   pZtoF 'Phi_n = cyclotomic w n.
Proof.
elim/ltn_ind: n w => n ihn w prim_w.
have n_gt0 := prim_order_gt0 prim_w.
pose P k := pZtoF 'Phi_k.
pose Q k := cyclotomic (w ^+ (n %/ k)) k.
have eP : \prod_(d <- divisors n) P d = 'X^n - 1.
  by rewrite -rmorph_prod /= prod_Cyclotomic // rmorphB /= map_polyC map_polyXn.
have eQ : \prod_(d <- divisors n) Q d = 'X^n - 1 by rewrite -prod_cyclotomic.
have fact (u : nat -> {poly F}) : \prod_(d <- divisors n) u d =
              u n * \prod_(d <- rem n (divisors n)) u d.
  by rewrite [LHS](big_rem n) ?divisors_id.
pose p := \prod_(d <- rem n (divisors n)) P d.
pose q := \prod_(d <- rem n (divisors n)) Q d.
have ePp : P n * p = 'X^n - 1 by rewrite -eP fact.
have eQq : Q n * q = 'X^n - 1 by rewrite -eQ fact.
have Xnsub1N0 : 'X^n - 1 != 0 :> {poly F}.
  by rewrite -size_poly_gt0 size_Xn_sub_1.
have pN0 : p != 0 by apply: dvdpN0 Xnsub1N0; rewrite -ePp dvdp_mulIr.
have epq : p = q.
  case: (divisors_correct n_gt0) => uniqd sortedd dP.
  apply: eq_big_seq=> i; rewrite mem_rem_uniq ?divisors_uniq // inE.
  case/andP=> NiSn di; apply: ihn; last by apply: dvdn_prim_root; rewrite -?dP.
  suff: (i <= n)%N by rewrite leq_eqVlt (negPf NiSn).
  by apply: dvdn_leq => //; rewrite -dP.
have {epq} : P n * p = Q n * p by rewrite [in RHS]epq ePp eQq.
by move/(mulIf pN0); rewrite /Q divnn n_gt0.
Qed.

End PhiCyclotomic.

Section CyclotomicExt.

Variables (F0 : fieldType) (L : fieldExtType F0).
Variables (E : {subfield L}) (w : L) (n : nat).
Hypothesis w_is_nth_root : n.-primitive_root w.

Lemma splitting_Fadjoin_cyclotomic :
  splittingFieldFor E (cyclotomic w n) <<E; w>>.
Proof.
exists [seq w ^+ val k | k <- enum 'I_n & coprime (val k) n].
  by rewrite /cyclotomic big_map big_filter big_enum_cond/= eqpxx.
rewrite map_comp -(filter_map _ (fun i => coprime i n)) val_enum_ord.
have [n_gt1|] := ltnP 1 n; last first.
  case: n w_is_nth_root (prim_order_gt0 w_is_nth_root) => [|[|]]//= wnth _ _.
  by rewrite adjoin_seq1 expr0 -[w]expr1 prim_expr_order.
set s := (X in <<_ & X>>%VS); suff /eq_adjoin-> : s =i w :: s.
  rewrite adjoin_cons (Fadjoin_seq_idP _)//.
  by apply/allP => _/mapP[i _ ->]/=; rewrite rpredX// memv_adjoin.
move=> x; rewrite in_cons orbC; symmetry; have []//= := boolP (_ \in _).
apply: contraNF => /eqP ->; rewrite -[w]expr1 map_f//.
by rewrite mem_filter mem_iota// coprime1n.
Qed.

Lemma cyclotomic_over : cyclotomic w n \is a polyOver E.
Proof.
by apply/polyOverP=> i; rewrite -Phi_cyclotomic // coef_map /= rpred_int.
Qed.

Hint Resolve cyclotomic_over : core.

End CyclotomicExt.

Section Cyclotomic.

(* MISSING *)
Lemma primitive_root_pow (F : fieldType) (m : nat) (w w' : F) :
    m.-primitive_root w' -> m.-primitive_root w ->
  exists2 k, coprime k m & w = w' ^+ k.
Proof.
move/root_cyclotomic<-.
rewrite /cyclotomic -big_filter; have [t et [uniqs tP /= perms]] := big_enumP.
pose rs := [seq w' ^+ (val i) | i <- t]; set p := (X in root X).
have {p} -> :  p = \prod_(w <- rs) ('X - w%:P) by rewrite /p big_map.
rewrite root_prod_XsubC; case/mapP=> [[i ltim]]; rewrite tP /= => coprim ew.
by exists i.
Qed.

Variables (F0 : fieldType) (L : splittingFieldType F0).
Variables (E : {subfield L}) (w : L) (n : nat).
Hypothesis w_is_nth_root : n.-primitive_root w.

(** Easy **)
(*     - E(x) is Galois                                                       *)
Lemma galois_Fadjoin_cyclotomic : galois E <<E; w>>.
Proof.
apply/splitting_galoisField; exists (cyclotomic w n).
split; rewrite ?cyclotomic_over//; last exact: splitting_Fadjoin_cyclotomic.
rewrite /cyclotomic -(big_image _ _ _ (fun x => 'X - x%:P))/=.
rewrite separable_prod_XsubC map_inj_uniq ?enum_uniq// => i j /eqP.
by rewrite (eq_prim_root_expr w_is_nth_root) !modn_small// => /eqP/val_inj.
Qed.

Lemma abelian_cyclotomic : abelian 'Gal(<<E; w>> / E)%g.
Proof.
case: (boolP (w \in E)) => [w_in_E |w_notin_E].
  suff -> : ('Gal(<<E; w>> / E) = 1)%g by apply: abelian1.
  apply/eqP; rewrite -subG1; apply/subsetP => x x_in.
  rewrite inE gal_adjoin_eq ?group1 // (fixed_gal _ x_in w_in_E) ?gal_id //.
  by have /Fadjoin_idP H := w_in_E; rewrite -{1}H subvv.
rewrite card_classes_abelian /classes.
apply/eqP; apply: card_in_imset => f g f_in g_in; rewrite -!orbitJ.
move/orbit_eqP/orbitP => [] h h_in <- {f f_in}; apply/eqP.
rewrite gal_adjoin_eq //= /conjg /= ?groupM ?groupV //.
rewrite ?galM ?memv_gal ?memv_adjoin //.
have hg_gal f : f \in 'Gal(<<E; w>> / E)%g -> f w ^+ n = 1.
  by move=> f_in; apply/prim_expr_order; rewrite fmorph_primitive_root.
have := svalP (prim_rootP w_is_nth_root (hg_gal _ g_in)).
have h1_in : (h ^-1)%g \in 'Gal(<<E; w>> / E)%g by rewrite ?groupV.
have := svalP (prim_rootP w_is_nth_root (hg_gal _ h1_in)).
set ih1 := sval _ => hh1; set ig := sval _ => hg.
rewrite hh1 rmorphX /= hg exprAC -hh1 rmorphX /=.
by rewrite -galM ?memv_adjoin // mulVg gal_id.
Qed.

(*     - Gal(E(x) / E) is then solvable                                       *)
Lemma solvable_Fadjoin_cyclotomic : solvable 'Gal(<<E; w>> / E).
Proof. exact/abelian_sol/abelian_cyclotomic. Qed.

End Cyclotomic.


(* week-05_consec_even.v *)
(* YSC3236 2017-2018, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 05 Sep 2017 *)

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

(* Paraphernalia: *)
Ltac unfold_tactic name := intros; unfold name; (* fold name; *) reflexivity.

Require Import Arith Bool.

Notation "A =n= B" :=
  (beq_nat A B) (at level 70, right associativity).

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

Definition test_evenp (candidate : nat -> bool) : bool :=
  (eqb (candidate 0) true)
  &&
  (eqb (candidate 1) false)
  &&
  (eqb (candidate 7) false)
  &&
  (eqb (candidate 8) true)
  &&
  (eqb (candidate 17) false)
  .

Fixpoint evenp (n : nat) : bool :=
  match n with
  | 0 => true
  | S n' => negb (evenp n')
  end.

  Compute (test_evenp evenp).

  Lemma sum_even_even_is_even (a b : nat) :
    evenp(a) = true -> evenp(b) = true -> evenp(a + b) = true.
    Admitted.

Theorem consec_is_even :
  forall n: nat,
   evenp(n * S n) = true.

  intro n.
  induction n as [ | n' IHn'].
  Search (0 * _ = _).
  rewrite (Nat.mul_0_l 1).
  unfold evenp.
  reflexivity.

  Check Nat.add_1_l n'.
  rewrite <- (Nat.add_1_l n').
  rewrite <- (Nat.add_1_l (1 + n')).

  Search (_ + (_ + _) = _).
  Check (Nat.add_assoc 1 1 n').
  rewrite -> (Nat.add_assoc 1 1 n').

  Search (_ * _ = _ + _).
  Check (Nat.mul_add_distr_l (1 + n') (1 + 1) (n')).
  rewrite -> (Nat.mul_add_distr_l (1 + n') (1 + 1) (n')).

  Check (sum_even_even_is_even ((1 + n') * (1 + 1)) ((1 + n') * n')).
  apply sum_even_even_is_even.
  Check (Nat.add_1_l 1).
  rewrite -> (Nat.add_1_l 1).

  Restart.

  Fixpoint evenp (n : nat) : bool :=
  match n with
  | 0 => true
  | S n' => negb (evenp n')
  end.

  Compute (test_evenp evenp).

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

(* end of week-05_consec_even.v *)


Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.orders
  HoTT.Classes.orders.maps
  HoTT.Classes.theory.lattices.

Generalizable Variables K L f.

(*
We prove that the algebraic definition of a lattice corresponds to the
order theoretic one. Note that we do not make any of these instances global,
because that would cause loops.
*)
Section join_semilattice_order.
  Context `{JoinSemiLatticeOrder L}.

  Lemma join_ub_3_r x y z : z ≤ x ⊔ y ⊔ z.
  Proof.
  apply join_ub_r.
  Qed.

  Lemma join_ub_3_m x y z : y ≤ x ⊔ y ⊔ z.
  Proof.
  transitivity (x ⊔ y).
  - apply join_ub_r.
  - apply join_ub_l.
  Qed.

  Lemma join_ub_3_l x y z : x ≤ x ⊔ y ⊔ z.
  Proof.
  transitivity (x ⊔ y); apply join_ub_l.
  Qed.

  Lemma join_ub_3_assoc_l x y z : x ≤ x ⊔ (y ⊔ z).
  Proof.
  apply join_ub_l.
  Qed.

  Lemma join_ub_3_assoc_m x y z : y ≤ x ⊔ (y ⊔ z).
  Proof.
  transitivity (y ⊔ z).
  - apply join_ub_l.
  - apply join_ub_r.
  Qed.

  Lemma join_ub_3_assoc_r x y z : z ≤ x ⊔ (y ⊔ z).
  Proof.
  transitivity (y ⊔ z); apply join_ub_r.
  Qed.

  Instance join_sl_order_join_sl: IsJoinSemiLattice L.
  Proof.
  repeat split.
  - apply _.
  - intros x y z. apply (antisymmetry (≤)).
    + apply join_lub.
      * apply join_ub_3_l.
      * apply join_lub.
        ** apply join_ub_3_m.
        ** apply join_ub_3_r.
    + apply join_lub.
      * apply join_lub.
        ** apply join_ub_3_assoc_l.
        ** apply join_ub_3_assoc_m.
      * apply join_ub_3_assoc_r.
  - intros x y. apply (antisymmetry (≤)); apply join_lub;
    first [apply join_ub_l | apply join_ub_r].
  - intros x. red. apply (antisymmetry (≤)).
    + apply join_lub; apply reflexivity.
    + apply join_ub_l.
  Qed.

  Lemma join_le_compat_r x y z : z ≤ x -> z ≤ x ⊔ y.
  Proof.
  intros E. transitivity x.
  - trivial.
  - apply join_ub_l.
  Qed.

  Lemma join_le_compat_l x y z : z ≤ y -> z ≤ x ⊔ y.
  Proof.
  intros E. rewrite (commutativity (f:=join)).
  apply join_le_compat_r.
  trivial.
  Qed.

  Lemma join_l x y : y ≤ x -> x ⊔ y = x.
  Proof.
  intros E. apply (antisymmetry (≤)).
  - apply join_lub;trivial. apply reflexivity.
  - apply join_ub_l.
  Qed.

  Lemma join_r x y : x ≤ y -> x ⊔ y = y.
  Proof.
  intros E. rewrite (commutativity (f:=join)).
  apply join_l.
  trivial.
  Qed.

  Lemma join_sl_le_spec x y : x ≤ y <-> x ⊔ y = y.
  Proof.
  split; intros E.
  - apply join_r. trivial.
  - rewrite <-E. apply join_ub_l.
  Qed.

  Global Instance join_le_preserving_l : forall z, OrderPreserving (z ⊔).
  Proof.
  red;intros.
  apply join_lub.
  - apply join_ub_l.
  - apply join_le_compat_l. trivial.
  Qed.

  Global Instance join_le_preserving_r : forall z, OrderPreserving (⊔ z).
  Proof.
  intros. apply maps.order_preserving_flip.
  Qed.

  Lemma join_le_compat x₁ x₂ y₁ y₂ : x₁ ≤ x₂ -> y₁ ≤ y₂ -> x₁ ⊔ y₁ ≤ x₂ ⊔ y₂.
  Proof.
  intros E1 E2. transitivity (x₁ ⊔ y₂).
  - apply (order_preserving (x₁ ⊔)). trivial.
  - apply (order_preserving (⊔ y₂));trivial.
  Qed.

  Lemma join_le x y z : x ≤ z -> y ≤ z -> x ⊔ y ≤ z.
  Proof.
  intros. rewrite <-(idempotency (⊔) z).
  apply join_le_compat;trivial.
  Qed.

  Section total_join.
  Context `{!TotalRelation le}.

  Lemma total_join_either `{!TotalRelation le} x y : join x y = x |_| join x y = y.
  Proof.
  destruct (total le x y) as [E|E].
  - right. apply join_r,E.
  - left. apply join_l,E.
  Qed.

  Definition max x y :=
    match total le x y with
    | inl _ => y
    | inr _ => x
    end.

  Lemma total_join_max x y : join x y = max x y.
  Proof.
  unfold max;destruct (total le x y) as [E|E].
  - apply join_r,E.
  - apply join_l,E.
  Qed.
  End total_join.

End join_semilattice_order.

Section bounded_join_semilattice.
  Context `{JoinSemiLatticeOrder L} `{Bottom L} `{!IsBoundedJoinSemiLattice L}.

  Lemma above_bottom x : ⊥ ≤ x.
  Proof.
  apply join_sl_le_spec.
  rewrite left_identity.
  reflexivity.
  Qed.

  Lemma below_bottom x : x ≤ ⊥ -> x = ⊥.
  Proof.
  intros E.
  apply join_sl_le_spec in E. rewrite right_identity in E.
  trivial.
  Qed.
End bounded_join_semilattice.

Section meet_semilattice_order.
  Context `{MeetSemiLatticeOrder L}.

  Lemma meet_lb_3_r x y z : x ⊓ y ⊓ z ≤ z.
  Proof.
  apply meet_lb_r.
  Qed.

  Lemma meet_lb_3_m x y z : x ⊓ y ⊓ z ≤ y.
  Proof.
  transitivity (x ⊓ y).
  - apply meet_lb_l.
  - apply meet_lb_r.
  Qed.

  Lemma meet_lb_3_l x y z : x ⊓ y ⊓ z ≤ x.
  Proof.
  transitivity (x ⊓ y); apply meet_lb_l.
  Qed.

  Lemma meet_lb_3_assoc_l x y z : x ⊓ (y ⊓ z) ≤ x.
  Proof.
  apply meet_lb_l.
  Qed.

  Lemma meet_lb_3_assoc_m x y z : x ⊓ (y ⊓ z) ≤ y.
  Proof.
  transitivity (y ⊓ z).
  - apply meet_lb_r.
  - apply meet_lb_l.
  Qed.

  Lemma meet_lb_3_assoc_r x y z : x ⊓ (y ⊓ z) ≤ z.
  Proof.
  transitivity (y ⊓ z); apply meet_lb_r.
  Qed.

  Instance meet_sl_order_meet_sl: IsMeetSemiLattice L.
  Proof.
  repeat split.
  - apply _.
  - intros x y z. apply (antisymmetry (≤)).
    + apply meet_glb.
      * apply meet_glb.
        ** apply meet_lb_3_assoc_l.
        ** apply meet_lb_3_assoc_m.
      * apply meet_lb_3_assoc_r.
    + apply meet_glb.
      ** apply meet_lb_3_l.
      ** apply meet_glb.
         *** apply meet_lb_3_m.
         *** apply meet_lb_3_r.
  - intros x y. apply (antisymmetry (≤)); apply meet_glb;
    first [apply meet_lb_l | try apply meet_lb_r].
  - intros x. red. apply (antisymmetry (≤)).
    + apply meet_lb_l.
    + apply meet_glb;apply reflexivity.
  Qed.

  Lemma meet_le_compat_r x y z : x ≤ z -> x ⊓ y ≤ z.
  Proof.
  intros E. transitivity x.
  - apply meet_lb_l.
  - trivial.
  Qed.

  Lemma meet_le_compat_l x y z : y ≤ z -> x ⊓ y ≤ z.
  Proof.
  intros E. rewrite (commutativity (f:=meet)).
  apply meet_le_compat_r.
  trivial.
  Qed.

  Lemma meet_l x y : x ≤ y -> x ⊓ y = x.
  Proof.
  intros E. apply (antisymmetry (≤)).
  - apply meet_lb_l.
  - apply meet_glb; trivial. apply reflexivity.
  Qed.

  Lemma meet_r x y : y ≤ x -> x ⊓ y = y.
  Proof.
  intros E. rewrite (commutativity (f:=meet)). apply meet_l.
  trivial.
  Qed.

  Lemma meet_sl_le_spec x y : x ≤ y <-> x ⊓ y = x.
  Proof.
  split; intros E.
  - apply meet_l;trivial.
  - rewrite <-E. apply meet_lb_r.
  Qed.

  Global Instance: forall z, OrderPreserving (z ⊓).
  Proof.
  red;intros.
  apply meet_glb.
  - apply meet_lb_l.
  - apply  meet_le_compat_l. trivial.
  Qed.

  Global Instance: forall z, OrderPreserving (⊓ z).
  Proof.
  intros. apply maps.order_preserving_flip.
  Qed.

  Lemma meet_le_compat x₁ x₂ y₁ y₂ : x₁ ≤ x₂ -> y₁ ≤ y₂ -> x₁ ⊓ y₁ ≤ x₂ ⊓ y₂.
  Proof.
  intros E1 E2. transitivity (x₁ ⊓ y₂).
  - apply (order_preserving (x₁ ⊓)). trivial.
  - apply (order_preserving (⊓ y₂)). trivial.
  Qed.

  Lemma meet_le x y z : z ≤ x -> z ≤ y -> z ≤ x ⊓ y.
  Proof.
  intros. rewrite <-(idempotency (⊓) z). apply meet_le_compat;trivial.
  Qed.

  Section total_meet.
  Context `{!TotalRelation le}.

  Lemma total_meet_either x y : meet x y = x |_| meet x y = y.
  Proof.
  destruct (total le x y) as [E|E].
  - left. apply meet_l,E.
  - right. apply meet_r,E.
  Qed.

  Definition min x y :=
    match total le x y with
    | inr _ => y
    | inl _ => x
    end.

  Lemma total_meet_min x y : meet x y = min x y.
  Proof.
  unfold min. destruct (total le x y) as [E|E].
  - apply meet_l,E.
  - apply meet_r,E.
  Qed.
  End total_meet.

End meet_semilattice_order.

Section lattice_order.
  Context `{LatticeOrder L}.

  Instance: IsJoinSemiLattice L := join_sl_order_join_sl.
  Instance: IsMeetSemiLattice L := meet_sl_order_meet_sl.

  Instance: Absorption (⊓) (⊔).
  Proof.
  intros x y. apply (antisymmetry (≤)).
  - apply meet_lb_l.
  - apply meet_le.
   + apply reflexivity.
   + apply join_ub_l.
  Qed.

  Instance: Absorption (⊔) (⊓).
  Proof.
  intros x y. apply (antisymmetry (≤)).
  - apply join_le.
    + apply reflexivity.
    + apply meet_lb_l.
  - apply join_ub_l.
  Qed.

  Instance lattice_order_lattice: IsLattice L := {}.

  Lemma meet_join_distr_l_le x y z : (x ⊓ y) ⊔ (x ⊓ z) ≤ x ⊓ (y ⊔ z).
  Proof.
  apply meet_le.
  - apply join_le; apply meet_lb_l.
  - apply join_le.
    + transitivity y.
      * apply meet_lb_r.
      * apply join_ub_l.
    + transitivity z.
      * apply meet_lb_r.
      * apply join_ub_r.
  Qed.

  Lemma join_meet_distr_l_le x y z : x ⊔ (y ⊓ z) ≤ (x ⊔ y) ⊓ (x ⊔ z).
  Proof.
  apply meet_le.
  - apply join_le.
    + apply join_ub_l.
    + transitivity y.
      * apply meet_lb_l.
      * apply join_ub_r.
  - apply join_le.
    + apply join_ub_l.
    + transitivity z.
      * apply meet_lb_r.
      * apply join_ub_r.
  Qed.
End lattice_order.

Definition default_join_sl_le `{IsJoinSemiLattice L} : Le L :=  fun x y => x ⊔ y = y.

Section join_sl_order_alt.
  Context `{IsJoinSemiLattice L} `{Le L} `{is_mere_relation L le}
    (le_correct : forall x y, x ≤ y <-> x ⊔ y = y).

  Lemma alt_Build_JoinSemiLatticeOrder : JoinSemiLatticeOrder (≤).
  Proof.
  repeat split.
  - apply _.
  - apply _.
  - intros x.
    apply le_correct. apply binary_idempotent.
  - intros x y z E1 E2.
    apply le_correct in E1;apply le_correct in E2;apply le_correct.
    rewrite <-E2, simple_associativity, E1. reflexivity.
  - intros x y E1 E2.
    apply le_correct in E1;apply le_correct in E2.
    rewrite <-E1, (commutativity (f:=join)).
    apply symmetry;trivial.
  - intros. apply le_correct.
    rewrite simple_associativity,binary_idempotent.
    reflexivity.
  - intros;apply le_correct.
    rewrite (commutativity (f:=join)).
    rewrite <-simple_associativity.
    rewrite (idempotency _ _).
    reflexivity.
  - intros x y z E1 E2.
    apply le_correct in E1;apply le_correct in E2;apply le_correct.
    rewrite <-simple_associativity, E2. trivial.
  Qed.
End join_sl_order_alt.

Definition default_meet_sl_le `{IsMeetSemiLattice L} : Le L :=  fun x y => x ⊓ y = x.

Section meet_sl_order_alt.
  Context `{IsMeetSemiLattice L} `{Le L} `{is_mere_relation L le}
    (le_correct : forall x y, x ≤ y <-> x ⊓ y = x).

  Lemma alt_Build_MeetSemiLatticeOrder : MeetSemiLatticeOrder (≤).
  Proof.
  repeat split.
  - apply _.
  - apply _.
  - intros ?. apply le_correct. apply (idempotency _ _).
  - intros ? ? ? E1 E2.
    apply le_correct in E1;apply le_correct in E2;apply le_correct.
    rewrite <-E1, <-simple_associativity, E2.
    reflexivity.
  - intros ? ? E1 E2.
    apply le_correct in E1;apply le_correct in E2.
    rewrite <-E2, (commutativity (f:=meet)).
    apply symmetry,E1.
  - intros ? ?. apply le_correct.
    rewrite (commutativity (f:=meet)), simple_associativity, (idempotency _ _).
    reflexivity.
  - intros ? ?. apply le_correct.
    rewrite <-simple_associativity, (idempotency _ _).
    reflexivity.
  - intros ? ? ? E1 E2.
    apply le_correct in E1;apply le_correct in E2;apply le_correct.
    rewrite associativity, E1.
    trivial.
  Qed.
End meet_sl_order_alt.

Section join_order_preserving.
  Context `{JoinSemiLatticeOrder L} `{JoinSemiLatticeOrder K} (f : L -> K)
    `{!IsJoinPreserving f}.

  Lemma join_sl_mor_preserving: OrderPreserving f.
  Proof.
  intros x y E.
  apply join_sl_le_spec in E. apply join_sl_le_spec.
  rewrite <-preserves_join.
  apply ap, E.
  Qed.

  Lemma join_sl_mor_reflecting `{!IsInjective f}: OrderReflecting f.
  Proof.
  intros x y E.
  apply join_sl_le_spec in E. apply join_sl_le_spec.
  rewrite <-preserves_join in E.
  apply (injective f). assumption.
  Qed.
End join_order_preserving.

Section meet_order_preserving.
  Context `{MeetSemiLatticeOrder L} `{MeetSemiLatticeOrder K} (f : L -> K)
    `{!IsMeetPreserving f}.

  Lemma meet_sl_mor_preserving: OrderPreserving f.
  Proof.
  intros x y E.
  apply meet_sl_le_spec in E. apply meet_sl_le_spec.
  rewrite <-preserves_meet.
  apply ap, E.
  Qed.

  Lemma meet_sl_mor_reflecting `{!IsInjective f}: OrderReflecting f.
  Proof.
  intros x y E.
  apply meet_sl_le_spec in E. apply meet_sl_le_spec.
  rewrite <-preserves_meet in E.
  apply (injective f). assumption.
  Qed.
End meet_order_preserving.

Section order_preserving_join_sl_mor.
  Context `{JoinSemiLatticeOrder L} `{JoinSemiLatticeOrder K}
    `{!TotalOrder (_ : Le L)} `{!TotalOrder (_ : Le K)}
    `{!OrderPreserving (f : L -> K)}.

  Lemma order_preserving_join_sl_mor: IsJoinPreserving f.
  Proof.
  intros x y. case (total (≤) x y); intros E.
  - change (f (join x y) = join (f x) (f y)).
    rewrite (join_r _ _ E),join_r;trivial.
    apply (order_preserving _). trivial.
  - change (f (join x y) = join (f x) (f y)).
    rewrite 2!join_l; trivial. apply (order_preserving _). trivial.
  Qed.
End order_preserving_join_sl_mor.

Section order_preserving_meet_sl_mor.
  Context `{MeetSemiLatticeOrder L} `{MeetSemiLatticeOrder K}
    `{!TotalOrder (_ : Le L)} `{!TotalOrder (_ : Le K)}
    `{!OrderPreserving (f : L -> K)}.

  Lemma order_preserving_meet_sl_mor: IsSemiGroupPreserving f.
  Proof.
  intros x y. case (total (≤) x y); intros E.
  - change (f (meet x y) = meet (f x) (f y)).
    rewrite 2!meet_l;trivial.
    apply (order_preserving _). trivial.
  - change (f (meet x y) = meet (f x) (f y)).
    rewrite 2!meet_r; trivial.
    apply (order_preserving _). trivial.
  Qed.
End order_preserving_meet_sl_mor.