(**
This file is part of the Coq.Interval library for proving bounds of
real-valued expressions in Coq: http://coq-interval.gforge.inria.fr/

Copyright (C) 2007-2016, Inria

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import Reals Bool.
From Flocq Require Import Raux.
From mathcomp.ssreflect Require Import ssreflect.

Require Import Stdlib.

Definition is_zero x := Req_bool x 0.
Definition is_positive x := Rlt_bool 0 x.
Definition is_negative x := Rlt_bool x 0.

Lemma is_zero_spec :
  forall x, Req_bool_prop x 0 (is_zero x).
Proof.
intros x.
exact (Req_bool_spec x 0).
Qed.

Lemma is_zero_0 :
  is_zero 0 = true.
Proof.
now apply Req_bool_true.
Qed.

Lemma is_zero_true :
  forall x, x = 0%R -> is_zero x = true.
Proof.
intros x ->.
exact is_zero_0.
Qed.

Lemma is_zero_false :
  forall x, x <> 0%R -> is_zero x = false.
Proof.
intros x Hx.
now apply Req_bool_false.
Qed.

Lemma is_positive_spec :
  forall x, Rlt_bool_prop 0 x (is_positive x).
Proof.
exact (Rlt_bool_spec 0).
Qed.

Lemma is_positive_true :
  forall x, (0 < x)%R -> is_positive x = true.
Proof.
intros x Hx.
now apply Rlt_bool_true.
Qed.

Lemma is_positive_false :
  forall x, (x <= 0)%R -> is_positive x = false.
Proof.
intros x Hx.
now apply Rlt_bool_false.
Qed.

Lemma is_negative_spec :
  forall x, Rlt_bool_prop x 0 (is_negative x).
Proof.
intros x.
exact (Rlt_bool_spec x 0).
Qed.

Lemma is_negative_true :
  forall x, (x < 0)%R -> is_negative x = true.
Proof.
intros x Hx.
now apply Rlt_bool_true.
Qed.

Lemma is_negative_false :
  forall x, (0 <= x)%R -> is_negative x = false.
Proof.
intros x Hx.
now apply Rlt_bool_false.
Qed.

(*
 * Extended reals
 *)

Inductive ExtendedR : Set :=
  | Xnan : ExtendedR
  | Xreal : R -> ExtendedR.

Definition proj_val x :=
  match x with Xreal y => y | Xnan => R0 end.

Definition proj_fun v f x :=
  match f (Xreal x) with Xreal y => y | Xnan => v end.

(* useful to discriminate over an ExtendedR *)
Definition notXnan (xR : ExtendedR) : Prop :=
  match xR with
    | Xnan => false
    | Xreal _ => true end = true.

Inductive Xcomparison : Set :=
  Xeq | Xlt | Xgt | Xund.

Definition Xcmp x y :=
  match x, y with
  | Xreal u, Xreal v =>
    match Rcompare u v with
    | Lt => Xlt
    | Eq => Xeq
    | Gt => Xgt
    end
  | _, _ => Xund
  end.

Definition extension f fx := forall x,
  match fx x, x with
  | Xnan, _ => True
  | Xreal v, Xreal u => f u = v
  | _, _ => False
  end.

Definition Xbind f x :=
  match x with
  | Xreal x => f x
  | Xnan => Xnan
  end.

Definition Xbind2 f x y :=
  match x, y with
  | Xreal x, Xreal y => f x y
  | _, _ => Xnan
  end.

Notation Xlift f := (Xbind (fun x => Xreal (f x))).
Notation Xlift2 f := (Xbind2 (fun x y => Xreal (f x y))).

Lemma Xlift2_nan_r :
  forall f x, Xlift2 f x Xnan = Xnan.
Proof.
now intros f [|x].
Qed.

Notation Xneg := (Xlift Ropp).

Lemma Xneg_involutive :
  forall x, Xneg (Xneg x) = x.
Proof.
intros [|x].
easy.
apply (f_equal Xreal), Ropp_involutive.
Qed.

Definition Xinv' x := if is_zero x then Xnan else Xreal (/ x).
Definition Xsqrt' x := Xreal (sqrt x).
Definition Xsqrt_nan' x := if is_negative x then Xnan else Xreal (sqrt x).
Definition Xdiv' x y := if is_zero y then Xnan else Xreal (x / y).

Notation Xinv := (Xbind Xinv').
Notation Xsqrt := (Xbind Xsqrt').
Notation Xsqrt_nan := (Xbind Xsqrt_nan').
Notation Xabs := (Xlift Rabs).
Notation Xadd := (Xlift2 Rplus).
Notation Xsub := (Xlift2 Rminus).
Notation Xmul := (Xlift2 Rmult).
Notation Xdiv := (Xbind2 Xdiv').
Notation Xmin := (Xlift2 Rmin).
Notation Xmax := (Xlift2 Rmax).

Delimit Scope XR_scope with XR.

Notation "x + y" := (Xadd x y) : XR_scope.
Notation "x - y" := (Xsub x y) : XR_scope.
Notation " - y" := (Xneg y) : XR_scope.
Notation "x * y" := (Xmul x y) : XR_scope.
Notation "x / y" := (Xdiv x y) : XR_scope.

Lemma Xsub_split :
  forall x y, Xsub x y = Xadd x (Xneg y).
Proof.
now intros [|x] [|y].
Qed.

Lemma Xdiv_split :
  forall x y, Xdiv x y = Xmul x (Xinv y).
Proof.
intros [|x] [|y] ; try split.
unfold Xbind2, Xbind, Xdiv', Xinv'.
now case (is_zero y).
Qed.

Definition Xtan' x := if is_zero (cos x) then Xnan else Xreal (tan x).
Definition Xln' x := if is_positive x then Xreal (ln x) else Xnan.
Definition Xpower_int' x n :=
  match n with
  | 0%Z => Xreal 1%R
  | Zpos p => Xreal (pow x (nat_of_P p))
  | Zneg p => if is_zero x then Xnan else Xreal (Rinv (pow x (nat_of_P p)))
  end.

Notation Xsqr := (Xlift Rsqr).
Notation Xcos := (Xlift cos).
Notation Xsin := (Xlift sin).
Notation Xtan := (Xbind Xtan').
Notation Xatan := (Xlift atan).
Notation Xexp := (Xlift exp).
Notation Xln := (Xbind Xln').
Definition Xpower_int x n := Xbind (fun x => Xpower_int' x n) x.

Lemma Xpower_int_correct :
  forall n, extension (fun x => powerRZ x n) (fun x => Xpower_int x n).
Proof.
intros [|n|n] [|x] ; try split.
unfold Xpower_int, Xpower_int', Xbind.
now case (is_zero x).
Qed.

(*
 * "Field" structure
 *)

Lemma Xadd_comm :
  forall x y,
  Xadd x y = Xadd y x.
Proof.
intros [|x] [|y] ; try split.
simpl.
apply f_equal.
apply Rplus_comm.
Qed.

Lemma Xadd_0_l :
  forall x,
  Xadd (Xreal 0) x = x.
Proof.
intros [|x] ; try split.
simpl.
apply f_equal.
apply Rplus_0_l.
Qed.

Lemma Xadd_0_r :
  forall x,
  Xadd x (Xreal 0) = x.
Proof.
intros [|x] ; try split.
simpl.
apply f_equal.
apply Rplus_0_r.
Qed.

Lemma Xmul_comm :
  forall x y,
  Xmul x y = Xmul y x.
Proof.
intros [|x] [|y] ; try split.
simpl.
apply f_equal.
apply Rmult_comm.
Qed.

Lemma Xmul_assoc :
  forall x y z,
  Xmul (Xmul x y) z = Xmul x (Xmul y z).
Proof.
intros [|x] [|y] [|z] ; try split.
simpl.
apply f_equal.
apply Rmult_assoc.
Qed.

Lemma Xmul_1_l :
  forall x,
  Xmul (Xreal 1) x = x.
Proof.
intros [|x] ; try split.
simpl.
apply f_equal.
apply Rmult_1_l.
Qed.

Lemma Xmul_1_r :
  forall x,
  Xmul x (Xreal 1) = x.
Proof.
intros [|x] ; try split.
simpl.
apply f_equal.
apply Rmult_1_r.
Qed.

Lemma Xmul_Xadd_distr_r :
  forall x y z,
  Xmul (Xadd x y) z = Xadd (Xmul x z) (Xmul y z).
Proof.
intros [|x] [|y] [|z] ; try split.
simpl.
apply f_equal.
apply Rmult_plus_distr_r.
Qed.

Lemma Xmul_Xneg_distr_l :
  forall x y,
  Xmul (Xneg x) y = Xneg (Xmul x y).
Proof.
intros [|x] [|y] ; try split.
simpl.
apply f_equal.
apply Ropp_mult_distr_l_reverse.
Qed.

Lemma Xmul_Xneg_distr_r :
  forall x y,
  Xmul x (Xneg y) = Xneg (Xmul x y).
Proof.
intros [|x] [|y] ; try split.
simpl.
apply f_equal.
apply Ropp_mult_distr_r_reverse.
Qed.

Lemma Xinv_Xmul_distr :
  forall x y,
  Xinv (Xmul x y) = Xmul (Xinv x) (Xinv y).
Proof.
intros [|x] [|y] ; try easy ; simpl ; unfold Xinv'.
now destruct (is_zero_spec x).
destruct (is_zero_spec x).
destruct (is_zero_spec (x * y)).
apply refl_equal.
elim H0.
rewrite H.
apply Rmult_0_l.
destruct (is_zero_spec y).
destruct (is_zero_spec (x * y)).
apply refl_equal.
elim H1.
rewrite H0.
apply Rmult_0_r.
destruct (is_zero_spec (x * y)).
elim (prod_neq_R0 _ _ H H0 H1).
apply (f_equal Xreal).
now apply Rinv_mult_distr.
Qed.

Definition Xmask x y :=
  match y with
  | Xreal _ => x
  | Xnan => Xnan
  end.

Lemma Xmul_Xinv :
  forall x,
  Xmul x (Xinv x) = Xmask (Xreal 1) (Xinv x).
Proof.
intros [|x] ; try easy ; simpl ; unfold Xinv'.
destruct (is_zero_spec x).
apply refl_equal.
apply (f_equal Xreal).
now apply Rinv_r.
Qed.

Lemma Xdiv_0_r :
  forall x,
  Xdiv x (Xreal 0) = Xnan.
Proof.
intros [|x] ; try easy ; simpl ; unfold Xdiv'.
case is_zero_spec.
easy.
intros H.
now elim H.
Qed.


Require Import Coq.Init.Peano.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.PArith.BinPosDef.
Require Import Coq.ZArith.BinInt Coq.ZArith.ZArith Coq.ZArith.Zdiv Coq.ZArith.Znumtheory Coq.NArith.NArith. (* import Zdiv before Znumtheory *)
Require Import Coq.NArith.Nnat.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.

Require Import Circom.Tuple.
Require Import Crypto.Util.Decidable Crypto.Util.ZUtil Crypto.Algebra.Ring.
Require Import Crypto.Algebra.Hierarchy Crypto.Algebra.Field.
Require Import Crypto.Spec.ModularArithmetic.
Require Import Crypto.Arithmetic.ModularArithmeticTheorems Crypto.Arithmetic.PrimeFieldTheorems.
From Circom Require Import Circom ListUtil.

Module DSL.

Import ListNotations.

Local Open Scope nat_scope.

Section iter.

Variable A: Type.
Variable f: nat -> A -> A.

(* functional iteration *)

Fixpoint iter' (m n: nat) (a: A) : A :=
  match m with
  | O => a
  | S m' => iter' m' n (f (n-m) a)
  end.

Lemma iter'_S:
  forall i j a,
  iter' (S i) (S j) a = f j (iter' i j a).
Proof.
  induction i; intros.
  - simpl. replace (j - 0) with j by lia. reflexivity.
  - eauto.
Qed.

Local Hint Rewrite iter'_S : iter.
Definition iter (n: nat) := iter' n n.
Local Hint Unfold iter : iter.

Theorem iter_inv (Inv: nat -> A -> Prop):
  forall a i,
  Inv 0 a ->
  (forall j b, Inv j b -> j < i -> Inv (S j) (f j b)) ->
  Inv i (iter i a).
Proof.
  intros a.
  induction i; intros H0 Hind; eauto.
  - replace (iter (S i) a) with (f i (iter i a)) by
      (unfold iter; rewrite iter'_S; reflexivity).
    apply Hind. apply IHi; auto. lia.
Qed.

End iter.

Arguments iter' {A}.
Arguments iter {A}.

Section init.

Variable A: Type.
Variable f: nat -> A.

Fixpoint init' (i n m: nat) : list A :=
  match m with
  | O => nil
  | S m' => if dec (i >= n) then nil else f i :: init' (S i) n m'
  end.

Definition init (i n: nat) := init' i n n.

Lemma init'_length: forall m i n, length (init' i n m) = min m (n-i).
Proof.
  induction m; simpl; intros.
  reflexivity.
  destruct (dec (i>=n)).
  subst. replace (n-i) with O by lia. auto.
  destruct (n-i) eqn:E. lia.
  simpl. rewrite IHm. lia.
Qed.

Lemma init_length: forall i n, length (init i n) = n - i.
Proof.
  intros. unfold init. rewrite init'_length. lia.
Qed.

Lemma init0_length: forall n, length (init O n) = n.
Proof. intros. rewrite init_length. lia. Qed.

Definition initT (i n: nat) := from_list (n-i) (init i n) (init_length _ _).
Definition initT0 (n: nat) := from_list (n) (init O n) (init0_length _).

End init.

Arguments init {A}.
Arguments initT {A}.
Arguments initT0 {A}.

Section opsT.

Local Open Scope F_scope.
Definition opT {n} (op: F -> F -> F) (xs ys: tuple F n) := map2 op xs ys.
Definition addT {n} := @opT n (fun x y => x + y : F).
Definition mulT {n} := @opT n (fun x y => x * y : F).
Definition scaleT {n} (k: F) (xs: tuple F n) := map (fun x => k * x) xs.
Definition eqT {A n} (xs ys: tuple A n) := xs = ys.

Definition sumT_F {n} := fold_right n (fun x y => x + y) (0:F).
Definition sum_nat {n} := fold_right n (fun x y => x + y)%nat (0)%nat.
End opsT.

End DSL.

(* Remember the iterating function *)
Ltac rem_iter :=
  repeat match goal with
  | [ _: context[DSL.iter ?f _ _] |- _] =>
    match f with
    | fun _ => _ => let fn := fresh "f" in remember f as fn
    | _ => fail
    end
  end.

(* prove invariant Inv about simple connection circuits *)
Ltac connection Inv :=
  apply DSL.iter_inv; unfold Inv; easy ||
  ( intros i _cons IH Hi Hstep;
    subst; lift_to_list; intuition;
    eapply firstn_congruence; fold_default; (lia || eauto)).

Module DSLL.

Import ListNotations.

Local Open Scope nat_scope.

Section iter.

Variable A: Type.
Variable f: nat -> A -> A.

(* functional iteration *)

Fixpoint iter' (m n: nat) (a: A) : A :=
  match m with
  | O => a
  | S m' => iter' m' n (f (n-m) a)
  end.

Lemma iter'_S:
  forall i j a,
  iter' (S i) (S j) a = f j (iter' i j a).
Proof.
  induction i; intros.
  - simpl. replace (j - 0) with j by lia. reflexivity.
  - eauto.
Qed.

Local Hint Rewrite iter'_S : iter.
Definition iter (n: nat) := iter' n n.
Local Hint Unfold iter : iter.

Theorem iter_inv (Inv: nat -> A -> Prop):
  forall a i,
  Inv 0 a ->
  (forall j b, Inv j b -> j < i -> Inv (S j) (f j b)) ->
  Inv i (iter i a).
Proof.
  intros a.
  induction i; intros H0 Hind; eauto.
  - replace (iter (S i) a) with (f i (iter i a)) by
      (unfold iter; rewrite iter'_S; reflexivity).
    apply Hind. apply IHi; auto. lia.
Qed.

End iter.

Arguments iter' {A}.
Arguments iter {A}.

Section init.
Variable A: Type.
Variable f: nat -> A.

Fixpoint init' (i n m: nat) : list A :=
  match m with
  | O => nil
  | S m' => if dec (i >= n) then nil else f i :: init' (S i) n m'
  end.

Definition init (i n: nat) := init' i n n.

Lemma init'_length: forall m i n, length (init' i n m) = min m (n-i).
Proof.
  induction m; simpl; intros.
  reflexivity.
  destruct (dec (i>=n)).
  subst. replace (n-i) with O by lia. auto.
  destruct (n-i) eqn:E. lia.
  simpl. rewrite IHm. lia.
Qed.

Lemma init_length: forall i n, length (init i n) = n - i.
Proof.
  intros. unfold init. rewrite init'_length. lia.
Qed.

Lemma init0_length: forall n, length (init O n) = n.
Proof. intros. rewrite init_length. lia. Qed.

Definition init0 (n: nat) := init O n.

End init.

Arguments init {A}.
Arguments init0 {A}.

Section opsL.

Local Open Scope F_scope.
Fixpoint map2 {A B C} (f: A -> B -> C) (xs: list A) (ys: list B) : list C :=
  match xs, ys with
  | nil, _ => nil
  | _, nil => nil
  | x::xs', y::ys' => f x y :: map2 f xs' ys'
  end.
Definition opL (op: F -> F -> F) (xs ys: list F) := map2 op xs ys.
Definition addL := opL (fun x y => x + y : F).
Definition mulL := opL (fun x y => x * y : F).
Definition scaleL (k: F) (xs: list F) := List.map (fun x => k * x) xs.
Definition eqL {A} (xs ys: list A) := xs = ys.
Definition sumL_F := List.fold_right (fun x y => x + y) (0:F).
Definition sumL_nat := List.fold_right (fun x y => x + y)%nat (0)%nat.

End opsL.

End DSLL.


Require Import Rsequence_def Rsequence_base_facts.
Require Import Reals Rfunction_def Rfunction_facts Rextensionality.

Require Import Nth_derivative_def Nth_derivative_facts.
Require Import Rpser.
Require Import Rfunction_classes.

Require Import Dequa_def Dequa_facts Dequa_quote.
Require Import List.

(* Require Import LegacyField_Theory. *)

Local Open Scope R_scope.

Lemma constant_is_cst : forall (c : R) (rc: infinite_cv_radius (constant_seq c)),
  forall x, sum _ rc x = c.
Proof.
intros c rc ; solve_diff_equa ; reflexivity.
Qed.

Lemma identity_is_id : forall (ri : infinite_cv_radius identity_seq)
 (di : derivable (sum _ ri)), forall x, derive (sum _ ri) di x = 1.
Proof.
intros ri di ; solve_diff_equa ; unfold An_deriv, identity_seq,
 constant_seq, Rseq_shift, Rseq_mult ; intros [ | n] ; simpl ; ring.
Qed.

Lemma diff_equa_cos : forall (rc : infinite_cv_radius cos_seq),
  forall x, nth_derive (sum _ rc) (D_infty_Rpser _ rc 2%nat) x
  = - nth_derive (sum _ rc) (D_infty_Rpser _ rc O) x.
Proof.
intro rc ; solve_diff_equa ; intro n ; rewrite An_nth_deriv_S',
 An_nth_deriv_1, (An_deriv_ext _ (- sin_seq)).
 rewrite An_deriv_opp_compat ; unfold Rseq_opp ;
  apply Ropp_eq_compat ; apply Deriv_sin_seq_simpl.
 apply Deriv_cos_seq_simpl.
Qed.

Lemma diff_equa_sin : forall (rc : infinite_cv_radius sin_seq),
  forall x, nth_derive (sum _ rc) (D_infty_Rpser _ rc 2%nat) x
  = - nth_derive (sum _ rc) (D_infty_Rpser _ rc O) x.
Proof.
intro rc ; solve_diff_equa ; intro n ; rewrite An_nth_deriv_S',
 An_nth_deriv_1, (An_deriv_ext _ cos_seq) ;
 [apply Deriv_cos_seq_simpl | apply Deriv_sin_seq_simpl].
Qed.

Lemma diff_equa_exp : forall n (re : infinite_cv_radius exp_seq) x,
  nth_derive (sum _ re) (D_infty_Rpser _ re (S n)) x
  = nth_derive (sum _ re) (D_infty_Rpser _ re n) x.
Proof.
intros n re ; solve_diff_equa ; rewrite An_nth_deriv_S',
 (An_nth_deriv_ext _ exp_seq) ; [reflexivity | apply Deriv_exp_seq_simpl].
Qed.

Require Import Commutative_ring_binomial.

Lemma Rexp_mult_simpl : forall a b x,
  Rexp (a * x) * Rexp (b * x) = Rexp ((a + b) * x).
Proof.
intros a b ; unfold Rexp ; solve_diff_equa.
Abort.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

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

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (x : lst) : natural := Succ (double (len x)).


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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


Require Import Vector.
Require Import Strings.String.
Require Import Strings.Ascii.
Require Import Coq.Setoids.Setoid.
Require Import Program.
Require Import alphabet.
Require Import utils.
Require Import Omega.

Inductive NoDupVec {A : Type} : forall {n : nat}, Vec A n -> Prop :=
| NoDupVec_nil : NoDupVec (nil A)
| NoDupVec_cons : forall x m (v : Vec A m), ~ In x v -> NoDupVec v -> NoDupVec (cons _ x m v).

Definition summary := Vec nat 26.

Definition empty_summary : summary :=
  Vector.const 0 26.

Definition increment_summary (a : Alpha) (s : summary) : summary :=
  let v := S (nth s a) in replace s a v.

Fixpoint summarize_vec {n : nat} (v : Vec Alpha n) : summary :=
  match v with
  | nil _ => empty_summary
  | cons _ a n' t => increment_summary a (summarize_vec t)
  end.

Theorem summarize_nil :
  summarize_vec (nil _) = empty_summary.
Proof.
  reflexivity.
Qed.

Theorem nth_cons :
  forall {A n k e x} (v : Vec A n),
    nth v k = e ->
    nth (cons A x n v) (Fin.FS k) = e.
Proof.
  auto.
Qed.

Theorem nth_cons' :
  forall {A n k x} (v : Vec A n),
    nth (cons A x n v) (Fin.FS k) = nth v k.
Proof.
  auto.
Qed.

Theorem replace_replaces :
  forall {A n k e} (v : Vec A n),
    nth (replace v k e) k = e.
Proof.
  intros A n k e v. induction v.
  - inversion k.
  - dependent destruction k.
    + reflexivity.
    + simpl. auto.
Qed.

Theorem nth_replace :
  forall {A n j k e} (v : Vec A n),
    j <> k ->
    nth (replace v j e) k = nth v k.
Proof.
  intros A n j k. induction v.
  - inversion j.
  - dependent destruction k.
    + dependent destruction j.
      * contradiction.
      * reflexivity.
    + dependent destruction j.
      * reflexivity.
      * intros. simpl. apply IHv.
        unfold not in *. intros Hjk.
        apply H. rewrite Hjk. reflexivity.
Qed.

Theorem increment_summary_increments :
  forall {k j} (s : summary),
    nth s k = j ->
    nth (increment_summary k s) k = S j.
Proof.
  intros k j s H.
  unfold increment_summary.
  rewrite replace_replaces.
  auto.
Qed.

Theorem increment_summary_increments' :
  forall {k} (s : summary),
    nth (increment_summary k s) k = S (nth s k).
Proof.
  intros k s.
  erewrite increment_summary_increments; reflexivity.
Qed.

Theorem summarize_empty :
  forall k,
    nth empty_summary k = 0.
Proof.
  intros k.
  unfold empty_summary.
  apply const_nth.
Qed.

Theorem increment_summary_greater :
  forall {x k j} (s : summary),
    nth s k = j ->
    nth (increment_summary x s) k >= j.
Proof.
  intros x k j s.
  unfold increment_summary.
  intros Hnth.
  destruct (Fin.eq_dec x k).
  - rewrite e. rewrite replace_replaces.
    subst. auto.
  - rewrite nth_replace. rewrite Hnth.
    + auto.
    + assumption.
Qed.

Theorem increment_summary_greater_greater :
  forall {x k j} (s : summary),
    nth s k >= j ->
    nth (increment_summary x s) k >= j.
Proof.
  intros x k j s.
  unfold increment_summary.
  intros Hnth.
  destruct (Fin.eq_dec x k).
  - rewrite e. rewrite replace_replaces.
    subst. auto.
  - rewrite nth_replace; auto.
Qed.

Theorem increment_summary_neq :
  forall {x k} (s : summary),
    x <> k ->
    nth (increment_summary x s) k = nth s k.
Proof.
  intros x k s H.
  unfold increment_summary.
  apply nth_replace.
  assumption.
Qed.

Theorem summarize_cons :
  forall {k n j} x (v : Vec Alpha n),
    nth (summarize_vec v) k = j ->
    nth (summarize_vec (cons _ x n v)) k >= j.
Proof.
  intros k n j x v H.
  simpl. apply increment_summary_greater.
  assumption.
Qed.

Theorem in_summarize :
  forall {k n} (v : Vec Alpha n),
    nth (summarize_vec v) k > 0 ->
    In k v.
Proof.
  intros k n v H.
  generalize dependent k.
  induction v.
  - intros k H.
    pose proof summarize_nil. rewrite H0 in H.
    pose proof summarize_empty. rewrite H1 in H. inversion H.
  - simpl. intros k H.
    destruct (Fin.eq_dec h k); subst; constructor.
    rewrite increment_summary_neq in H; auto.
Qed.

Theorem summarize_in :
  forall {k n} (v : Vec Alpha n),
    In k v ->
    nth (summarize_vec v) k > 0.
Proof.
  intros k n v H.
  generalize dependent k.
  induction v.
  - intros k H. inversion H.
  - simpl. intros k H.
    destruct (Fin.eq_dec h k); subst.
    + rewrite increment_summary_increments'. apply Gt.gt_Sn_O.
    + invert_existT H; try contradiction.
      apply IHv in H2.
      inversion H2; apply increment_summary_greater_greater; auto.
Qed.

Theorem summarize_alphabet :
  summarize_vec alphabet = Vector.const 1 26.
Proof.
  reflexivity.
Qed.

Theorem all_in_alphabet :
   forall (a : Alpha),
    In a alphabet.
Proof.
  intros a.
  apply in_summarize.
  rewrite summarize_alphabet.
  rewrite const_nth. auto.
Qed.

Theorem Forall_nth :
  forall {A n} (P : A -> Prop) (v : Vec A n),
    Forall P v <->
    forall k, P (nth v k).
Proof.
  intros A n P v.
  split; intros H.
  - intros k. induction H.
    + inversion k.
    + dependent induction k; simpl; auto.
  - induction v; constructor.
    + apply (H Fin.F1).
    + apply IHv. intros k.
      pose proof (H (Fin.FS k)) as Hnth.
      rewrite nth_cons' in Hnth.
      apply Hnth.
Qed.

Theorem no_dup_summary :
  forall h (s : summary),
    Forall (fun n : nat => n < 2) (increment_summary h s) ->
    Forall (fun n : nat => n < 2) s.
Proof.
  intros h s H. unfold summary in *. unfold Vec in *.
  unfold Alpha in *. unfold Fin in *.
  rewrite Forall_nth in H.
  rewrite Forall_nth.
  intros k.
  pose proof (H k) as Hk.
  destruct (Fin.eq_dec h k).
  - subst.
    rewrite increment_summary_increments' in Hk.
    apply PeanoNat.Nat.lt_succ_l in Hk. auto.
  - pose proof(increment_summary_neq s n) as Hnth.
    rewrite <- Hnth. auto.
Qed.

Theorem no_dup_summary_nth :
  forall {n h} (v : Vec Alpha n),
    Forall (fun n : nat => n < 2) (increment_summary h (summarize_vec v)) ->
    nth (summarize_vec (cons _ h _ v)) h < 2.
Proof.
  intros n h v H.
  simpl.
  rewrite Forall_nth in H.
  apply H.
Qed.

Theorem no_dup_summarize :
  forall {n} (v : Vec Alpha n),
    Forall (fun n => n < 2) (summarize_vec v) ->
    NoDupVec v.
Proof.
  intros n v H.
  induction v; simpl in *; constructor.
  - unfold not. intros Hin.
    apply summarize_in in Hin.

    pose proof H as Hnth.
    apply no_dup_summary_nth in Hnth.
    simpl in Hnth.
    rewrite increment_summary_increments' in Hnth.
    apply Lt.lt_S_n in Hnth.
    apply NPeano.Nat.lt_1_r in Hnth.
    rewrite Hnth in Hin.
    inversion Hin.
  - apply IHv. eauto using no_dup_summary.
Qed.

Theorem no_dup_alphabet' :
  NoDupVec alphabet.
Proof.
  apply no_dup_summarize.
  apply Forall_nth.
  intros k.

  rewrite summarize_alphabet.
  rewrite const_nth.

  auto.
Qed.

Fixpoint in_vector {A : Type} {n : nat} (decA : forall x y : A, {x = y} + {x <> y}) (a : A) (v : Vec A n) : bool :=
  match v with
  | nil _ => false
  | cons _ x n t =>
    if decA a x
    then true
    else in_vector decA a t
  end.

Theorem In_in_vector :
  forall {n : nat} {A : Type} (decA : forall x y : A, {x = y} + {x <> y}) (a : A) (v : Vec A n),
    In a v -> in_vector decA a v = true.
Proof.
  intros n A decA a v H.
  induction H; simpl; destruct decA; try reflexivity; auto.
Qed.

Theorem in_vector_In :
  forall {n : nat} {A : Type} (decA : forall x y : A, {x = y} + {x <> y}) (a : A) (v : Vec A n),
    in_vector decA a v = true -> In a v.
Proof.
  intros n A decA a v H.
  induction v.
  - simpl in H. inversion H.
  - simpl in *. destruct (decA a h) eqn:HdecA.
    + destruct HdecA. subst. apply In_cons_hd.
    + apply In_cons_tl. auto.
Qed.

Inductive IsPermutation {A} : forall {n}, Vec A n -> Vec A n -> Prop :=
| permNil : IsPermutation (nil _) (nil _)
| permSkip : forall {x m} (v1 : Vec A m) (v2 : Vec A m),
    IsPermutation v1 v2 -> IsPermutation (cons _ x m v1) (cons _ x m v2)
| permSwap : forall {x y m} (v : Vec A m),
    IsPermutation (cons _ x (S m) (cons _ y _ v))
                  (cons _ y (S m) (cons _ x _ v))
| permTrans : forall {m} (v1 : Vec A m) (v2 : Vec A m) (v3 : Vec A m),
    IsPermutation v1 v2 -> IsPermutation v2 v3 -> IsPermutation v1 v3
.

Lemma incremented_summary_not_empty :
  forall h (s : summary),
    increment_summary h s <> empty_summary.
Proof.
  unfold not.
  intros h s H.
  pose proof eq_nth_iff nat 26.
  rewrite <- H0 in H.
  pose proof (H h h). rewrite increment_summary_increments' in H1. unfold empty_summary in H1.
  rewrite const_nth in H1.
  assert (h=h) by reflexivity.
  apply H1 in H2.
  inversion H2.
Qed.

Lemma summarize_empty_is_nil :
  forall {n} (v : Vec Alpha n),
    summarize_vec v = empty_summary ->
    n = 0.
Proof.
  intros n v H. induction v; trivial.
  simpl in *.
  pose proof (incremented_summary_not_empty h (summarize_vec v)).
  contradiction.
Qed.

Lemma increment_same :
  forall h s1 s2,
    increment_summary h s1 = increment_summary h s2 ->
    s1 = s2.
Proof.
  intros h s1 s2 H.

  apply eq_nth_iff.
  intros x' x Hpp. subst.

  pose proof H as Hnth.
  apply (f_equal (fun s => nth s x)) in Hnth.

  destruct (Fin.eq_dec h x).
  - subst.
    repeat rewrite increment_summary_increments' in Hnth.
    inversion Hnth.
    reflexivity.
  - repeat (rewrite increment_summary_neq in Hnth; try assumption).
Qed.

Lemma increment_empty :
  forall a b,
    increment_summary a empty_summary = increment_summary b empty_summary ->
    a = b.
Proof.
  intros a b H.
  unfold increment_summary in H. unfold empty_summary in H. repeat rewrite const_nth in H.

  unfold Alpha in *.
  repeat (try dependent destruction a; try dependent destruction b).
  all: try reflexivity.
  all: invert_existT H.
Qed.

Fixpoint summary_total {n} (s : Vec nat n) : nat :=
  match s with
  | nil _ => 0
  | cons _ h _ s' => h + summary_total s'
  end.

Fixpoint cons_rep {A n} (a : A) (k : nat) (v : Vec A n) : Vec A (k + n) :=
  match k with
  | 0 => v
  | S k' => cons _ a (k' + n) (cons_rep a k' v)
  end.

Fixpoint summary_to_vector_helper {n} (a : Alpha) (s : Vec nat n) : Vec Alpha (summary_total s) :=
  match s as s' return (Vec Alpha (summary_total s')) with
  | nil _ => nil _
  | cons _ h _ t => cons_rep a h (summary_to_vector_helper (step_fin a) t)
  end.

Definition summary_to_vector {n} (s : Vec nat n) : Vec Alpha (summary_total s) := summary_to_vector_helper Fin.F1 s.

Lemma summary_total_replace :
  forall {n h} (v : Vec nat n),
    summary_total (replace v h (S (nth v h))) = S (summary_total v).
Proof.
  intros n h v.
  induction v as [| x n' v].
  - inversion h.
  - refine (match h as h' in Fin.t n
                  return forall pf : n = S n',
                         eq_rect n Fin h' (S n') pf = h ->
                         summary_total (replace (VectorDef.cons nat x n' v) h (S (nth (VectorDef.cons nat x n' v) h))) = S (summary_total (VectorDef.cons nat x n' v)) with
            | Fin.F1 => _
            | Fin.FS h' => _
            end eq_refl eq_refl); intros pf H; inversion pf; subst; repeat rewrite <- Eqdep_dec.eq_rect_eq_dec by apply eq_nat_dec; simpl.
    + reflexivity.
    + rewrite IHv. rewrite plus_n_Sm.
      reflexivity.
Qed.

Lemma increment_summary_total :
  forall {h} (s : summary),
    summary_total (increment_summary h s) = S (summary_total s).
Proof.
  intros h s.
  apply summary_total_replace.
Qed.

Lemma summarize_same_length :
  forall {n} (v : Vec Alpha n),
    summary_total (summarize_vec v) = n.
Proof.
  intros n v.
  induction v.
  - reflexivity.
  - simpl. rewrite increment_summary_total. rewrite IHv.
    reflexivity.
Qed.

Definition summarize_and_back {n} (v : Vec Alpha n) : Vec Alpha n.
  pose proof summary_to_vector (summarize_vec v).
  rewrite summarize_same_length in H.
  apply H.
Defined.

Lemma summarize_and_back_nil :
  summarize_and_back (nil _) = nil _.
Proof.
  unfold summarize_and_back. simpl.
  unfold eq_rec.
  rewrite <- Eqdep_dec.eq_rect_eq_dec by apply eq_nat_dec.
  reflexivity.
Qed.

(*
I have:

H: summary_total (increment_summary h empty_summary) = 1

Goal:

eq_rect (summary_total (increment_summary h empty_summary)) (fun n : nat => Vec Alpha n)
    (summary_to_vector (increment_summary h empty_summary)) 1
    (summarize_same_length (cons (Fin 26) h 0 (nil (Fin 26))))

Why can't I rewrite using H in the goal?

eq_rect : forall {A : Type} (x : A) (P : A -> Type) (f : P x) (y : A) (e : x = y)

In this case.... eq_rect x P f y e

x = (summary_total (increment_summary h empty_summary))
P = (fun n : nat => Vec Alpha n)
f = (summary_to_vector (increment_summary h empty_summary))
y = 1
e = (summarize_same_length (cons (Fin 26) h 0 (nil (Fin 26))))

summarize_same_length : forall {n : nat} (v : Vec (Fin.t 26) n), summary_total (summarize_vec v) = n
 *)
Lemma summarize_and_back_one :
  forall h,
    summarize_and_back (cons _ h _ (nil _)) = cons _ h _ (nil _).
Proof.
  intros h.
  unfold Alpha in *.

  dependent destruction h. compute. admit. dependent destruction h. compute.

  summarize_same_length. reflexivity.

  unfold summarize_and_back. simpl.
  pose proof @increment_summary_total h empty_summary.
  rewrite EqdepFacts.eq_sig_snd.

  unfold summarize_same_length.
  unfold eq_rect. simpl.

Qed.

Print summarize_and_back_one.

Lemma bleh :
  forall h n v,
    IsPermutation (cons Alpha h n (summarize_and_back v)) (summarize_and_back (VectorDef.cons Alpha h n v)).
Proof.
  intros h n v.
  induction v.
  - rewrite summarize_and_back_nil.
    unfold summarize_and_back. simpl.

Qed.

Lemma summary_is_perm :
  forall {n} (v : Vec Alpha n),
    IsPermutation v (summarize_and_back v).
Proof.
  intros n v.
  induction v.
  - unfold summarize_and_back. simpl. rewrite <- eq_rec_eq. constructor.
  - econstructor.
    + constructor. apply IHv.
    +

Qed.
*)

(*
Lemma permutation_extract :
  forall {n} h (v : Vec Alpha (S n)),
    In h v ->
    exists v', IsPermutation (cons _ h n v') v.
Proof.
  dependent destruction v.
  intros H.
  destruct (Fin.eq_dec h h0).
  - subst.

Qed.
*)

(*
  by induction on v1...

  If v1 is nil, then v2 must also be nil, since the have the same length. Thus
  the condition holds, since IsPermutation nil nil is true.

  Then we assume it works for some v1, and we want to show that it works for some
  (h :: v1).

  Thus we have summarize_vec (h :: v1) = summarize_vec v2, and
  forall v2, summarize_vec v1 = summarize_vec v2 -> IsPermutation v1 v2

  We want to show that:

  IsPermutation (h :: v1) v2.

  If we destruct v2, then we can have

  IsPermutation (h :: v1) (h :: v2') which is just

  IsPermutation v1 v2', so we can apply the induction hypothesis, and
  then see that if we incremented h for the summary of v1 and v2 you
  would get the same thing.

  However, when you have x <> h...

  IsPermutation (h :: v1) (x :: v2')

  is much more difficult to show, since there isn't a constructor for
  IsPermutation which immediately applies.

  We want to show that h is in v2 (which is clear because v2's summary
  equals h::v1's summary, which means h is in v2). And then knowing that we want to say that...

  IsPermutation (h :: v2') v2

  for some v2'
 *)

Theorem permutation_refl :
  forall {A n} (v : Vec A n),
    IsPermutation v v.
Proof.
  intros A n v.
  induction v; constructor; auto.
Qed.

Theorem summarize_permutation :
  forall {n} (v1 v2 : Vec Alpha n),
    summarize_vec v1 = summarize_vec v2 ->
    IsPermutation v1 v2.
Proof.
  intros n v1 v2 H.
  induction v1.
  - nilify. constructor.
  - dependent destruction v2. simpl in *. destruct (Fin.eq_dec h h0).
    + subst. constructor. eauto using increment_same.
    +
      Lemma blah :
        forall {n} h h0 (v1 v2 : Vec Alpha n),
          h <> h0 ->
          increment_summary h (summarize_vec v1) = increment_summary h0 (summarize_vec v2) ->
          In h v2.
      Proof.
        intros n h h0 v1 v2 Hne Hinc.
        induction v1.
        - nilify. apply increment_empty in Hinc. contradiction.
        - simpl in *. dependent destruction v2.
          destruct (Fin.eq_dec h h2).
          + subst. constructor.
          + constructor. apply IHv1.
            unfold increment_summary in *.
            simpl in *.
            apply eq_nth_iff. intros p1 p2 H. subst.
            apply replace_replaces.

          constructor
          + simpl in *.
      Qed.

      econstructor.
      * (* Want to show h :: v1 is a permutation of h :: h0 :: (v2 - h)

           Which means we need to show that v1 is a permutation of h0 :: (v2 - h)
         *)

      (*
        summarize_vec v1 <> summarize_vec v2, but we know...

        nth h (summarize_vec v2) = nth h (increment_summary h (summarize_vec v1))
        nth h0 (summarize_vec v1) = nth h0 (increment_summary h0 (summarize_vec v2))

        Which means that v1 has the same amount of h0 in it, and v2
        has the same amount of h in it...

        So, we know that v1 - h0 is a permutation of v2 - h which
        means that v1 is a permutation of h0 :: (v2 - h), which means that
        h :: v1 is a permutation of h :: h0 :: (v2 - h).

        h :: h0 :: (v2 - h) is a permutation of h0 :: v2
       *)

    +
  - simpl in H. rewrite (vec_0_is_nil v2). pose proof vec_0_is_nil v2. subst.
    constructor.
  - simpl in H. dependent destruction v2. simpl in *.
    apply permutation_refl.
  -
Qed.

Definition wf_permutation (perm : Vec Alpha 26) : Prop :=
  IsPermutation perm alphabet.

Theorem Forall_hd :
  forall {A n h} (f : A -> Prop) (v : Vec A n),
    Forall f (cons _ h n v) ->
    f h.
Proof.
  intros A n h f v H.
  inversion H. assumption.
Qed.

Theorem In_not_in_tl :
  forall {A n x h} (v : Vec A n),
    In x (cons _ h n v) ->
    not (In x v) ->
    x = h.
Proof.
  intros A n x h v Hin Hnin.
  invert_existT Hin.
  - reflexivity.
  - contradiction.
Qed.

Theorem Forall_In :
  forall {A n} (f : A -> Prop) (v : Vec A n),
    Forall f v ->
    (forall x, In x v -> f x).
Proof.
  intros A n f v Hall x Hin.
  induction Hall.
  - inversion Hin.
  - invert_existT Hin; auto.
Qed.

Theorem In_Forall :
  forall {A n} (f : A -> Prop) (v : Vec A n),
    (forall x, In x v -> f x) ->
    Forall f v.
Proof.
  intros A n f v.
  induction v.
  - intros x. constructor.
  - intros H. constructor.
    + apply H. constructor.
    + apply IHv. intros x Hin.
      apply H. constructor.
      assumption.
Qed.

Theorem Forall_tl :
  forall {A n x} (f : A -> Prop) (v : Vec A n),
    Forall f (cons A x n v) ->
    Forall f v.
Proof.
  intros A n x f v H.
  apply In_Forall.
  pose proof Forall_In f (cons A x n v).
  intros x0 H1.
  apply H0.
  assumption.
  constructor.
  assumption.
Qed.

Theorem forall_perm :
  forall {A n} (f : A -> Prop) (v1 v2 : Vec A n),
    Forall f v1 ->
    IsPermutation v1 v2 ->
    Forall f v2.
Proof.
  intros A n f v1 v2 Hall Hperm.
  induction Hperm.
  - constructor.
  - constructor.
    + inversion Hall; assumption.
    + apply IHHperm. apply Forall_tl in Hall. assumption.
  - constructor.
    + apply Forall_tl in Hall. inversion Hall; assumption.
    + constructor.
      * inversion Hall; assumption.
      * repeat apply Forall_tl in Hall. assumption.
  - auto.
Qed.

Theorem in_cons_swap :
  forall {A n x y1 y2} (v : Vec A n),
    In x (cons A y1 (S n) (cons A y2 n v)) ->
    In x (cons A y2 (S n) (cons A y1 n v)).
Proof.
  intros A n x y1 y2 v H.
  invert_existT H.
  - repeat constructor.
  - invert_existT H2; repeat constructor; auto.
Qed.

Theorem not_in_swap :
  forall {A n x y} (v : Vec A n),
    NoDupVec (cons A y n v) ->
    ~ In x (cons A y n v) ->
    ~ In y (cons A x n v).
Proof.
  unfold not.
  intros A n x y v Hdup Hxy Hyx.
  invert_existT Hyx.
  - contradiction.
  - invert_existT Hdup. contradiction.
Qed.

v
Theorem in_perm :
  forall {A n x} (v1 v2 : Vec A n),
    In x v1 ->
    IsPermutation v1 v2 ->
    In x v2.
Proof.
  intros A n x v1 v2 Hin Hperm.
  induction Hperm.
  - assumption.
  - invert_existT Hin; constructor; auto.
  - invert_existT Hin.
    + repeat constructor.
    + apply in_cons_swap. assumption.
  - auto.
Qed.

Theorem not_in_perm :
  forall {A n x} (v1 v2 : Vec A n),
    ~ In x v1 ->
    IsPermutation v1 v2 ->
    ~ In x v2.
Proof.
  unfold not.
  intros A n x v1 v2 Hnin Hperm Hin.
  induction Hperm; auto.
  - invert_existT Hin.
    + apply Hnin. constructor.
    + apply IHHperm; auto.
      intros. apply Hnin.
      constructor. apply H.
  - invert_existT Hin; apply Hnin; apply in_cons_swap; auto.
Qed.

Theorem NoDupVec_weaken :
  forall {A n x} (v : Vec A n),
    NoDupVec (cons A x n v) ->
    NoDupVec v.
Proof.
  intros A n x v H; invert_existT H; assumption.
Qed.

Theorem no_dup_perm :
  forall {A n} (v1 v2 : Vec A n),
    NoDupVec v1 ->
    IsPermutation v1 v2 ->
    NoDupVec v2.
Proof.
  intros A n v1 v2 Hdup Hperm.
  induction Hperm.
  - constructor.
  - invert_existT Hdup.
    constructor; pose proof not_in_perm v1 v2 H2; auto.
  - invert_existT Hdup.
    constructor.
    + apply not_in_swap; assumption.
    + apply NoDupVec_weaken in H3.
      constructor.
      * unfold not in *. intros. apply H2.
        constructor. assumption.
      * assumption.
  - auto.
Qed.


Require Import SfLib.
Require Import partial_map.

Module STLC.

Hint Resolve beq_id_eq beq_id_false_not_eq.

(* types *)
Inductive type : Type :=
| TBool : type
| TNat : type
| TArrow : type -> type -> type.

Hint Constructors type.

(* terms *)
Inductive term : Type :=
| TVar : id -> term
| TApp : term -> term -> term
| TLambda : id -> type -> term -> term
| TTrue : term
| TFalse : term
| TIf : term -> term -> term -> term
| TNum : nat -> term
| TPlus : term -> term -> term
| TEqNat : term -> term -> term.

Notation "\ x : t1 . y" := (TLambda x t1 y) (at level 50).

Tactic Notation "term_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "TVar"    | Case_aux c "TApp"
  | Case_aux c "TLambda" | Case_aux c "TTrue"
  | Case_aux c "TFalse"  | Case_aux c "TIf"
  | Case_aux c "TNum"    | Case_aux c "TPlus"
  | Case_aux c "TEqNat" ].

Hint Constructors term.

Inductive value : term -> Prop :=
| v_abs : forall x T t, value (TLambda x T t)
| v_true : value TTrue
| v_false : value TFalse
| v_nat : forall n, value (TNum n).

Hint Constructors value.

Fixpoint subst (x : id) (s : term) (t : term) : term :=
  match t with
    | TVar x' =>
      if beq_id x x' then s else t
    | TLambda x' T t1 =>
      TLambda x' T (if beq_id x x' then t1 else (subst x s t1))
    | TApp lambda arg =>
      TApp (subst x s lambda) (subst x s arg)
    | TTrue => TTrue
    | TFalse => TFalse
    | TIf c t e => TIf (subst x s c) (subst x s t) (subst x s e)
    | TNum n => TNum n
    | TPlus l r => TPlus (subst x s l) (subst x s r)
    | TEqNat l r => TEqNat (subst x s l) (subst x s r)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

Reserved Notation "t1 '=>' t2" (at level 40).
Inductive step : term -> term -> Prop :=
| ST_AppLambda : forall x T t12 v2,
                   value v2 -> (TApp (TLambda x T t12) v2) => [x := v2]t12
| ST_App1 : forall t1 t1' t2, t1 => t1' -> TApp t1 t2 => TApp t1' t2
| ST_App2 : forall v1 t2 t2', value v1 -> t2 => t2' -> TApp v1 t2 => TApp v1 t2'
| ST_IfTrue : forall t1 t2, TIf TTrue t1 t2 => t1
| ST_IfFalse : forall t1 t2, TIf TFalse t1 t2 => t2
| ST_If : forall t1 t1' t2 t3, t1 => t1' -> TIf t1 t2 t3 => TIf t1' t2 t3
| ST_Plus : forall n m, TPlus (TNum n) (TNum m) => TNum (n + m)
| ST_PlusL : forall l l' r, l => l' -> TPlus l r => TPlus l' r
| ST_PlusR : forall l r r', value l -> r => r' -> TPlus l r => TPlus l r'
| ST_EqNatT : forall n m, beq_nat n m = true ->
                          TEqNat (TNum n) (TNum m) => TTrue
| ST_EqNatF : forall n m, beq_nat n m = false ->
                          TEqNat (TNum n) (TNum m) => TFalse
| ST_EqNatL : forall l l' r, l => l' -> TEqNat l r => TEqNat l' r
| ST_EqNatR : forall l r r', value l -> r => r' -> TEqNat l r => TEqNat l r'
    where "t1 '=>' t2" := (step t1 t2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppLambda" | Case_aux c "ST_App1"
  | Case_aux c "ST_App2"      | Case_aux c "ST_IfTrue"
  | Case_aux c "ST_IfFalse"   | Case_aux c "ST_If"
  | Case_aux c "ST_Plus"      | Case_aux c "ST_PlusL"
  | Case_aux c "ST_PlusR"     | Case_aux c "ST_EqNatT"
  | Case_aux c "ST_EqNatF"    | Case_aux c "ST_EqNatL"
  | Case_aux c "ST_EqNatR" ].

Hint Constructors step.

Notation multistep := (multi step).
Notation "t1 '=>*' t2" := (multistep t1 t2) (at level 40).

Definition context := partial_map type.

Inductive has_type : context -> term -> type -> Prop :=
| T_Var : forall G x T,
            G x = Some T -> has_type G (TVar x) T
| T_Lambda : forall G x T11 T12 t12,
               has_type (extend G x T11) t12 T12 ->
               has_type G (TLambda x T11 t12) (TArrow T11 T12)
| T_App : forall T11 T12 G t1 t2,
            has_type G t1 (TArrow T11 T12) ->
            has_type G t2 T11 ->
            has_type G (TApp t1 t2) T12
| T_True : forall G, has_type G TTrue TBool
| T_False : forall G, has_type G TFalse TBool
| T_If : forall t1 t2 t3 T G,
           has_type G t1 TBool ->
           has_type G t2 T ->
           has_type G t3 T ->
           has_type G (TIf t1 t2 t3) T
| T_Nat : forall G n, has_type G (TNum n) TNat
| T_Plus : forall G l r, has_type G l TNat -> has_type G r TNat -> has_type G (TPlus l r) TNat
| T_EqNat : forall G l r, has_type G l TNat -> has_type G r TNat -> has_type G (TEqNat l r) TBool.

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var"   | Case_aux c "T_Lambda"
  | Case_aux c "T_App"   | Case_aux c "T_True"
  | Case_aux c "T_False" | Case_aux c "T_If"
  | Case_aux c "T_Nat"   | Case_aux c "T_Plus"
  | Case_aux c "T_EqNat" ].

Hint Constructors has_type.
Hint Unfold beq_nat beq_id extend.

Theorem progress : forall t T,
     has_type empty t T ->
     value t \/ exists t', t => t'.
Proof with eauto.
  intros t T Ht.
  remember empty as gamma.
  has_type_cases (induction Ht) Case; subst...
  Case "T_Var". inversion H.
  Case "T_App". right. destruct IHHt1...
    SCase "t1 is a value". destruct IHHt2...
      SSCase "t2 is a value".
        inversion H; subst; try solve by inversion.
        exists ([x := t2] t). constructor...
      SSCase "t2 steps". inversion H0. exists (TApp t1 x). constructor...
    SCase "t1 steps". inversion H. exists (TApp x t2). constructor...
  Case "T_If". right. destruct IHHt1...
    SCase "t1 is a value". inversion H; subst; try solve by inversion.
      SSCase "if true". exists t2. constructor.
      SSCase "if false". exists t3. constructor.
    inversion H. exists (TIf x t2 t3). constructor...
  Case "T_Plus". right. destruct IHHt1... destruct IHHt2...
    inversion H; subst; try solve by inversion.
    inversion H0; subst; try solve by inversion.
    exists (TNum (n+n0))...
    inversion H0. exists (TPlus l x)...
    inversion H. exists (TPlus x r)...
  Case "T_EqNat". right. destruct IHHt1... destruct IHHt2...
    inversion H; subst; try solve by inversion.
    inversion H0; subst; try solve by inversion.
    remember (beq_nat n n0). destruct b. exists TTrue...
    exists TFalse...
    inversion H0. exists (TEqNat l x)...
    inversion H. exists (TEqNat x r)...
Qed.

Inductive appears_free_in : id -> term -> Prop :=
| AFI_Var : forall x,
              appears_free_in x (TVar x)
| AFI_App1 : forall x t1 t2,
               appears_free_in x t1 -> appears_free_in x (TApp t1 t2)
| AFI_App2 : forall x t1 t2,
               appears_free_in x t2 -> appears_free_in x (TApp t1 t2)
| AFI_Lambda : forall x y T11 t12,
                 y <> x ->
                 appears_free_in x t12 ->
                 appears_free_in x (TLambda y T11 t12)
| AFI_If1 : forall x t1 t2 t3,
              appears_free_in x t1 ->
              appears_free_in x (TIf t1 t2 t3)
| AFI_If2 : forall x t1 t2 t3,
              appears_free_in x t2 ->
              appears_free_in x (TIf t1 t2 t3)
| AFI_If3 : forall x t1 t2 t3,
              appears_free_in x t3 ->
              appears_free_in x (TIf t1 t2 t3)
| AFI_Plus1 : forall x l r,
                appears_free_in x l ->
                appears_free_in x (TPlus l r)
| AFI_Plus2 : forall x l r,
                appears_free_in x r ->
                appears_free_in x (TPlus l r)
| AFI_EqNat1 : forall x l r,
                appears_free_in x l ->
                appears_free_in x (TEqNat l r)
| AFI_EqNat2 : forall x l r,
                appears_free_in x r ->
                appears_free_in x (TEqNat l r).

Tactic Notation "afi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "AFI_Var"  | Case_aux c "AFI_App1"
  | Case_aux c "AFI_App2" | Case_aux c "AFI_Lambda"
  | Case_aux c "AFI_If1"  | Case_aux c "AFI_If2"
  | Case_aux c "AFI_If3"  | Case_aux c "AFI_Plus1"
  | Case_aux c "AFI_Plus2" | Case_aux c "AFI_EqNat1"
  | Case_aux c "AFI_EqNat2" ].

Hint Constructors appears_free_in.

Definition closed (t:term) := forall x, ~ appears_free_in x t.

Lemma free_in_context : forall x t T gamma,
                          appears_free_in x t ->
                          has_type gamma t T ->
                          exists T', gamma x = Some T'.
Proof.
  intros x t T gamma H H0. generalize dependent gamma.
  generalize dependent T.
  afi_cases (induction H) Case; intros; try solve [inversion H0; eauto].
    Case "AFI_Lambda". inversion H1. subst. apply IHappears_free_in in H7.
      apply not_eq_beq_id_false in H. rewrite extend_neq in H7; assumption.
Qed.

Lemma context_invariance : forall gamma gamma' t T,
                             has_type gamma t T ->
                             (forall x, appears_free_in x t -> gamma x = gamma' x) ->
                             has_type gamma' t T.
Proof with eauto.
  intros.
  generalize dependent gamma'.
  has_type_cases (induction H) Case; intros; auto.
  Case "T_Var". apply T_Var. rewrite <- H0...
  Case "T_Lambda". apply T_Lambda. apply IHhas_type. intros x0 Hafi.
    unfold extend. remember (beq_id x x0). destruct b...
  Case "T_App".
    eapply T_App...
Qed.

Lemma substitution_preserves_typing : forall gamma x U t t' T,
                                        has_type (extend gamma x U) t T ->
                                        has_type empty t' U ->
                                        has_type gamma ([x:=t']t) T.
Proof with eauto.
  intros gamma x U t t' T Ht Ht'.
  generalize dependent gamma. generalize dependent T.
  term_cases (induction t) Case; intros T gamma H; inversion H; subst; simpl...
  Case "TVar". rename i into y. remember (beq_id x y) as e. destruct e.
    SCase "x=y". apply beq_id_eq in Heqe. subst. rewrite extend_eq in H2.
      inversion H2. subst. eapply context_invariance... intros x Hcontra.
      destruct (free_in_context _ _ T empty Hcontra)... inversion H0.
    SCase "x<>y". constructor. rewrite extend_neq in H2...
  Case "TLambda". rename i into y. apply T_Lambda.
    remember (beq_id x y) as e. destruct e.
    SCase "x=y". eapply context_invariance... apply beq_id_eq in Heqe. subst.
      intros x Hafi. unfold extend. remember (beq_id y x) as e. destruct e...
    SCase "x<>y".
      apply IHt. eapply context_invariance... intros z Hafi. unfold extend.
      remember (beq_id y z) as e0. destruct e0...
      apply beq_id_eq in Heqe0. subst.
      rewrite <- Heqe...
Qed.

Theorem preservation : forall t t' T,
                         has_type empty t T ->
                         t => t' ->
                         has_type empty t' T.
Proof with eauto.
  remember empty as gamma.
  intros t t' T HT. generalize dependent t'.
  has_type_cases (induction HT) Case;
    intros t' HE; subst;
       try solve [inversion HE; subst; auto].
  Case "T_App".
    inversion HE; subst...
    (* Most of the cases are immediate by induction,
       and eauto takes care of them *)
    SCase "ST_AppAbs".
      apply substitution_preserves_typing with T11...
      inversion HT1...
Qed.

Definition normal_form {X:Type} (R:relation X) (t:X) : Prop :=
  ~ exists t', R t t'.

Definition stuck (t : term) : Prop :=
  (normal_form step) t /\ ~ value t.

Corollary soundness : forall t t' T,
  has_type empty t T ->
  t =>* t' ->
  ~(stuck t').
Proof with auto.
  intros t t' T Hhas_type Hmulti. unfold stuck.
  intros [Hnf Hnot_val]. unfold normal_form in Hnf.
  multi_cases (induction Hmulti) Case.
  Case "multi_refl".
    apply progress in Hhas_type. inversion Hhas_type...
  Case "multi_step".
    apply preservation with (t' := y) in Hhas_type...
Qed.


(**
This file is part of the CoqApprox formalization of rigorous
polynomial approximation in Coq:
http://tamadi.gforge.inria.fr/CoqApprox/

Copyright (c) 2010-2013, ENS de Lyon and Inria.

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

Require Import Rdefinitions Raxioms RIneq Rbasic_fun.
Require Import Epsilon FunctionalExtensionality.
Require Import mathcomp.ssreflect.ssreflect mathcomp.ssreflect.ssrfun mathcomp.ssreflect.ssrbool mathcomp.ssreflect.eqtype mathcomp.ssreflect.ssrnat.
Require Import mathcomp.ssreflect.choice mathcomp.ssreflect.bigop mathcomp.algebra.ssralg.

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

Local Open Scope R_scope.

Definition eqr (r1 r2 : R) : bool :=
  if Req_EM_T r1 r2 is left _ then true else false.

Lemma eqrP : Equality.axiom eqr.
Proof.
by move=> r1 r2; rewrite /eqr; case: Req_EM_T=> H; apply: (iffP idP).
Qed.

Canonical Structure real_eqMixin := EqMixin eqrP.
Canonical Structure real_eqType := Eval hnf in EqType R real_eqMixin.

Fact inhR : inhabited R.
Proof. exact: (inhabits 0). Qed.

Definition pickR (P : pred R) (n : nat) :=
  let x := epsilon inhR P in if P x then Some x else None.

Fact pickR_some P n x : pickR P n = Some x -> P x.
Proof. by rewrite /pickR; case: (boolP (P _)) => // Px [<-]. Qed.

Fact pickR_ex (P : pred R) :
  (exists x : R, P x) -> exists n, pickR P n.
Proof. by rewrite /pickR; move=> /(epsilon_spec inhR)->; exists 0%N. Qed.

Fact pickR_ext (P Q : pred R) : P =1 Q -> pickR P =1 pickR Q.
Proof.
move=> PEQ n; rewrite /pickR; set u := epsilon _ _; set v := epsilon _ _.
suff->: u = v by rewrite PEQ.
by congr epsilon; apply: functional_extensionality=> x; rewrite PEQ.
Qed.

Definition R_choiceMixin : choiceMixin R :=
  Choice.Mixin pickR_some pickR_ex pickR_ext.

Canonical R_choiceType := Eval hnf in ChoiceType R R_choiceMixin.

Fact RplusA : associative (Rplus).
Proof. by move=> *; rewrite Rplus_assoc. Qed.

Definition real_zmodMixin := ZmodMixin RplusA Rplus_comm Rplus_0_l Rplus_opp_l.

Canonical Structure real_zmodType := Eval hnf in ZmodType R real_zmodMixin.

Fact RmultA : associative (Rmult).
Proof. by move=> *; rewrite Rmult_assoc. Qed.

Fact R1_neq_0 : R1 != R0.
Proof. by apply/eqP/R1_neq_R0. Qed.

Definition real_ringMixin := RingMixin RmultA Rmult_1_l Rmult_1_r
  Rmult_plus_distr_r Rmult_plus_distr_l R1_neq_0.

Canonical Structure real_ringType := Eval hnf in RingType R real_ringMixin.
Canonical Structure real_comringType := Eval hnf in ComRingType R Rmult_comm.

Import Monoid.

Canonical Radd_monoid := Law RplusA Rplus_0_l Rplus_0_r.
Canonical Radd_comoid := ComLaw Rplus_comm.

Canonical Rmul_monoid := Law RmultA Rmult_1_l Rmult_1_r.
Canonical Rmul_comoid := ComLaw Rmult_comm.

Canonical Rmul_mul_law := MulLaw Rmult_0_l Rmult_0_r.
Canonical Radd_add_law := AddLaw Rmult_plus_distr_r Rmult_plus_distr_l.


Require Import List.      (* sequence *)
Require Import Multiset.  (* bag *)
Require Import ListSet.   (* set *)
Require Import Bool.
Require Import String.
Open Scope string.

(* Option 1 *)

Inductive Table1:=
  BuildTable1: list string -> string -> list nat -> Table1.

Definition t1: Table1:=
  BuildTable1
    ("a"::"b"::nil) "c"
    (0::0::1::
     0::1::0::nil).

(* Option 2 *)

Inductive Table2:=
  BuildTable2 :
     list string -> string -> list (prod (list nat) nat) -> Table2.

Definition t2: Table2:=
  BuildTable2
    ("a"::"b"::nil) "c"
    (((0::0::nil),1)::
     ((0::1::nil),0)::nil).

(* Option 3 *)

Inductive Cell3 {rtype ctype vtype: Type}:=
  BuildCell3:
    (* row *) rtype ->
    (* column *) ctype ->
    (* value *) vtype -> Cell3.

Definition Table3 (rtype ctype vtype: Type) :=
  list (@Cell3 rtype ctype vtype).

Inductive TT3 :=
  BuildTT3 :
    (* input ports *) list string ->
    (* output port *) string ->
    (* values *) Table3 nat string bool -> TT3.

Definition t3: TT3 :=
  BuildTT3
    ("a"::"b"::nil) "c"
    ((BuildCell3 0 "a" false)::(BuildCell3 0 "b" false)::(BuildCell3 0 "c" true)::
     (BuildCell3 1 "a" false)::(BuildCell3 1 "b" true)::(BuildCell3 1 "c" false)::nil).

(* Option 4 *)

Inductive Cell4 {vtype: Type}:=
  BuildCell4:
    (* row *) nat ->
    (* column *) nat ->
    (* value *) vtype -> Cell4.

Definition Table4 (vtype: Type):=
  list (@Cell4 vtype).

Inductive TT4:=
  BuildTT4:
    (* input ports *) list string ->
    (* output ports *) list string ->
    (* values *) Table4 bool -> TT4.

Definition t4: TT4:=
  BuildTT4
    ("a"::"b"::nil) ("c"::nil)
    ((BuildCell4 0 0 false)::(BuildCell4 0 1 false)::(BuildCell4 0 2 true )::
     (BuildCell4 1 0 false)::(BuildCell4 1 1 true )::(BuildCell4 1 2 false)::nil).

(* Option 5 *)

Inductive Table:=
  BuildTable :
    (* input ports *) list string ->
    (* output ports *) list string ->
    (* values *) list (list (prod string bool)) -> Table.

Definition t: Table:=
  BuildTable
    ("a"::"b"::nil) ("c"::nil)
    ((("a", false)::("b", false)::("c", true )::nil)::
     (("a", false)::("b", true )::("c", false)::nil)::nil).

Require Import core.Model.

Definition tmodel: Model (list (prod string bool)) unit:=
  Build_Model
  ((("a", false)::("b", false)::("c", true )::nil)::
   (("a", false)::("b", true )::("c", false)::nil)::nil)
   nil.


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

(******************************************************************************)
(*                   Maximum Subset Satisfying some Property                  *)
(******************************************************************************)

(* OUTLINE:
- Module maxsubset.
- Section max_subset_satisfying_P.
*)

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

Module Maxsubset.
Section maxsubset.
Variable A : finType.

Definition maxset P (E : {set A}) := (P E) &&
  [forall F : {set A}, (P F && (E \subset F)) == (E == F)].

Lemma maxset_eq P1 P2 E : P1 =1 P2 -> maxset P1 E = maxset P2 E.
Proof.
move=> P1P2.
rewrite /maxset.
rewrite P1P2.
congr (_ && _).
apply/forallP/forallP => /= H x.
by rewrite -P1P2 H.
by rewrite P1P2 H.
Qed.

Lemma maxsetP (P : {set A} -> bool) E :
  reflect ((P E) /\ (forall F, P F -> E \subset F -> E = F)) (maxset P E).
Proof.
case H : (maxset P E); [apply ReflectT | apply ReflectF].
  case/andP : H => -> /forallP H.
  split => // F H1 H2.
  move: (H F).
  by rewrite H1 H2 /= eq_sym eqb_id => /eqP.
case => H1 H2.
move/negP : H; apply.
rewrite /maxset H1 /=.
apply/forallP => F.
case H : (_ && _).
  case/andP : H.
  move/H2 => H3; move/H3 => ->.
  by rewrite eqxx.
rewrite eq_sym.
rewrite eqbF_neg.
apply/eqP => ?; subst F.
rewrite H1 /= in H.
move/negP : H; by apply.
Qed.

Lemma maxsetp E P : maxset P E -> P E.
Proof. by case/maxsetP. Qed.

Lemma maxsetinf P E F : maxset P E -> P F -> E \subset F -> E = F.
Proof.
case/maxsetP => H1 H2 PF.
by apply H2.
Qed.

Lemma ex_maxset (P : pred {set A}): (exists E, P E) -> {E | maxset P E}.
Proof.
move=> exQ.
pose pS n := [pred F | P F & #|F| == n].
pose p n := ~~ pred0b (pS n).
have {exQ} : exists n, p n.
  case: exQ => E QE.
  exists #| E  |.
  rewrite /p.
  apply/existsP.
  exists E.
  by rewrite eqxx andbT.
case/(@ex_maxnP _ #|A|).
  move=> o pi.
  case/existsP : pi => B /andP [] QB /eqP <-.
  by apply max_card.
move=> i.
move/pred0P.
case: (pickP (pS i)) => // F.
move=> pSF H Hi.
exists F.
apply/(@maxsetP P).
split.
  rewrite /pS inE in pSF.
  by case/andP : pSF.
move=> G QG FG.
apply/eqP.
rewrite eqEcard FG /=.
move: (Hi #|G|).
rewrite /pS inE in pSF.
case/andP : pSF => H1 H2.
rewrite (eqP H2).
apply.
apply/existsP.
exists G.
by rewrite QG eqxx.
Qed.

Lemma maxset_exists (P : pred {set A}) C : P C -> {F | maxset P F & C \subset F}.
Proof.
move=> PC.
have{PC}: exists A, P A && (C \subset A).
  by exists C; rewrite PC /=.
case/ex_maxset => B.
move/maxsetP => [].
case/andP => BP CB maxB.
exists B => //.
apply/maxsetP.
split=> // D PD BD.
rewrite (maxB D) // PD.
by rewrite (subset_trans CB).
Qed.
End maxsubset.
End Maxsubset.

Section max_subset_satisfying_P.

Variable A : finType.
Variable P : pred {set A}.

Definition Psets (E : {set A}) : {set {set A}} :=
  [set s : {set A} | s \subset E & P s].

Definition maxset E := \bigcup_(s in Psets E) s.

Lemma maxset_is_subset E : maxset E \subset E.
Proof. apply/bigcupsP => /= s; rewrite inE; by case/andP. Qed.

Definition covered_by (E K : {set A}):=
  [forall s, (s \in Psets E) ==> (s \subset K)].

Lemma covered_by_maxset E : covered_by E (maxset E).
Proof.
apply/forallP => s.
apply/implyP => Hs.
rewrite /maxset.
exact: subset_trans (bigcup_sup _ Hs).
Qed.

Hypothesis P0 : P set0.

Lemma card_Psets (E : {set A}) : #| Psets E | != 0.
Proof.
rewrite cards_eq0.
apply/set0Pn => /=.
exists set0; by rewrite inE P0 andbT sub0set.
Qed.

Hypothesis PU : forall s1 s2, P s1 -> P s2 -> P (s1 :|: s2).

Lemma PsetsU s1 s2 E : s1 \in Psets E -> s2 \in Psets E ->
  s1 :|: s2 \in Psets E.
Proof.
rewrite /Psets.
rewrite inE; case/andP => s1E Ps1.
rewrite inE; case/andP => s2E Ps2.
rewrite inE.
apply/andP; split.
  by apply/subUsetP.
by rewrite PU.
Qed.

Lemma maxset_in_Psets E : maxset E \in Psets E.
Proof.
rewrite /Psets inE maxset_is_subset /= /maxset.
suff Hgen : forall F : {set {set A}} , (forall s', s' \in F -> P s') -> P (\bigcup_(s in F) s).
  apply Hgen => s'.
  rewrite inE.
  by case/andP.
move=> F /= HF.
move Hk : (#| F |) => k.
elim: k => [ | k IH ] in F Hk HF *.
  rewrite big_pred0.
    by rewrite P0.
  move=> s /=.
  apply/negbTE.
  move/eqP : Hk.
  rewrite cards_eq0 => /negPn.
  apply: contra => sF.
  apply/set0Pn; by exists s.
have : #|F| != O by rewrite Hk.
rewrite cards_eq0.
case/set0Pn => f0 Hf0.
rewrite -(@setD1K _ f0 F) // bigcup_setU PU //.
  rewrite (big_pred1 f0).
    by apply HF.
  move=> /= s; by rewrite inE.
apply IH.
  rewrite (cardsD1 f0) in Hk.
  rewrite Hf0 in Hk.
  rewrite add1n in Hk.
  by case: Hk.
move=> s' Hs'.
apply HF.
rewrite inE in Hs'.
by case/andP : Hs'.
Qed.

Lemma maxset_is_Ppred E : P (maxset E).
Proof.
have : maxset E \in Psets E by apply maxset_in_Psets.
rewrite inE.
by case/andP.
Qed.

Definition is_unique E (P : {set A} -> Prop)  : Prop :=
  forall E', P E' -> E' = E.

Lemma maxset_is_unique E : is_unique (maxset E)
  (fun E' => E' \subset E /\ covered_by E E' /\ P E').
Proof.
rewrite /is_unique => E'.
case=> EsubE'.
case=> EE' HE'.
apply/setP => /= n0.
case/boolP : (n0 \in maxset E) => Hn0.
  move/forallP : EE'.
  move=> /(_ (maxset E)).
  move /implyP.
  move/(_ (maxset_in_Psets E)).
  move /subsetP.
  by apply.
apply: contraTF Hn0.
rewrite negbK => n0E'.
apply/bigcupP => /=.
exists E' => //.
by rewrite inE HE' andbT.
Qed.

End max_subset_satisfying_P.


Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Example test_orb1: (orb true false) = true.
Proof. reflexivity. Qed.
Example test_orb2: (orb true true) = true.
Proof. reflexivity. Qed.
Example test_orb3: (orb false false) = false.
Proof. reflexivity. Qed.
Example test_orb4: (orb false true) = true.
Proof. reflexivity. Qed.

Definition nandb (b1:bool) (b2:bool) : bool :=
   (negb (andb b1 b2)).

Example test_nandb1: (nandb true false) = true.
Proof. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. reflexivity. Qed.

Definition andb3 (b1:bool) (b2:bool)
                 (b3:bool) : bool :=
   (andb b1 (andb b2 b3)).
Example test_andb31: (andb3 true true true) = true.
Proof. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. reflexivity. Qed.


Require Import Omega.

Definition task := forall m n, m + n = 1 -> m = 0 \/ n = 0.

Theorem solution: task.
Proof.
  unfold task.
  intros.
  omega.
Qed.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.
Require int.ComputerDivision.
Require number.Parity.
Require number.Divisibility.

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.
Require int.ComputerDivision.
Require number.Parity.
Require number.Divisibility.

Import Znumtheory.

(* Why3 goal *)
Notation gcd := Zgcd (only parsing).

(* Why3 goal *)
Lemma gcd_nonneg : forall (a:Z) (b:Z), (0%Z <= (gcd a b))%Z.
Proof.
exact Zgcd_is_pos.
Qed.

(* Why3 goal *)
Lemma gcd_def1 : forall (a:Z) (b:Z), (number.Divisibility.divides (gcd a b)
  a).
Proof.
intros a b.
apply Zgcd_is_gcd.
Qed.

(* Why3 goal *)
Lemma gcd_def2 : forall (a:Z) (b:Z), (number.Divisibility.divides (gcd a b)
  b).
Proof.
intros a b.
apply Zgcd_is_gcd.
Qed.

(* Why3 goal *)
Lemma gcd_def3 : forall (a:Z) (b:Z) (x:Z), (number.Divisibility.divides x
  a) -> ((number.Divisibility.divides x b) -> (number.Divisibility.divides x
  (gcd a b))).
Proof.
intros a b x.
apply Zgcd_is_gcd.
Qed.

(* Why3 goal *)
Lemma gcd_unique : forall (a:Z) (b:Z) (d:Z), (0%Z <= d)%Z ->
  ((number.Divisibility.divides d a) -> ((number.Divisibility.divides d b) ->
  ((forall (x:Z), (number.Divisibility.divides x a) ->
  ((number.Divisibility.divides x b) -> (number.Divisibility.divides x
  d))) -> (d = (gcd a b))))).
Proof.
intros.
apply sym_eq.
apply Zis_gcd_gcd.
exact H.
now constructor.
Qed.

(* Why3 goal *)
Lemma Assoc : forall (x:Z) (y:Z) (z:Z), ((gcd (gcd x y) z) = (gcd x (gcd y
  z))).
Proof.
exact Zgcd_ass.
Qed.

(* Why3 goal *)
Lemma Comm : forall (x:Z) (y:Z), ((gcd x y) = (gcd y x)).
Proof.
exact Zgcd_comm.
Qed.

(* Why3 goal *)
Lemma gcd_0_pos : forall (a:Z), (0%Z <= a)%Z -> ((gcd a 0%Z) = a).
Proof.
intros a H.
rewrite <- (Zabs_eq a H) at 2.
apply Zgcd_0.
Qed.

(* Why3 goal *)
Lemma gcd_0_neg : forall (a:Z), (a < 0%Z)%Z -> ((gcd a 0%Z) = (-a)%Z).
Proof.
intros a H.
rewrite <- Zabs_non_eq.
apply Zgcd_0.
now apply Zlt_le_weak.
Qed.

(* Why3 goal *)
Lemma gcd_opp : forall (a:Z) (b:Z), ((gcd a b) = (gcd (-a)%Z b)).
Proof.
intros a b.
apply Zis_gcd_gcd.
apply Zgcd_is_pos.
apply Zis_gcd_minus.
apply Zis_gcd_sym.
apply Zgcd_is_gcd.
Qed.

(* Why3 goal *)
Lemma gcd_euclid : forall (a:Z) (b:Z) (q:Z), ((gcd a b) = (gcd a
  (b - (q * a)%Z)%Z)).
Proof.
intros a b c.
apply Zis_gcd_gcd.
apply Zgcd_is_pos.
apply Zis_gcd_sym.
apply Zis_gcd_for_euclid with c.
apply Zgcd_is_gcd.
Qed.

(* Why3 goal *)
Lemma Gcd_computer_mod : forall (a:Z) (b:Z), (~ (b = 0%Z)) -> ((gcd b
  (ZArith.BinInt.Z.rem a b)) = (gcd a b)).
Proof.
intros a b _.
rewrite (Zgcd_comm a b).
rewrite (gcd_euclid b a (Z.quot a b)).
apply f_equal.
rewrite (Z.quot_rem' a b) at 2.
ring.
Qed.

(* Why3 goal *)
Lemma Gcd_euclidean_mod : forall (a:Z) (b:Z), (~ (b = 0%Z)) -> ((gcd b
  (int.EuclideanDivision.mod1 a b)) = (gcd a b)).
Proof.
intros a b Zb.
rewrite (Zgcd_comm a b).
rewrite (gcd_euclid b a (EuclideanDivision.div a b)).
apply f_equal.
rewrite (EuclideanDivision.Div_mod a b Zb) at 2.
ring.
Qed.

(* Why3 goal *)
Lemma gcd_mult : forall (a:Z) (b:Z) (c:Z), (0%Z <= c)%Z -> ((gcd (c * a)%Z
  (c * b)%Z) = (c * (gcd a b))%Z).
Proof.
intros a b c H.
apply Zis_gcd_gcd.
apply Zmult_le_0_compat with (1 := H).
apply Zgcd_is_pos.
apply Zis_gcd_mult.
apply Zgcd_is_gcd.
Qed.


From Coq Require Import ZArith Reals Psatz.
From Coq Require Import Arith.Arith.
From Coquelicot Require Import Coquelicot.
From Flocq Require Import Core.

Require Import vcfloat.RAux.

Require Import Interval.Tactic.

Import Coq.Logic.FunctionalExtensionality.

Set Bullet Behavior "Strict Subproofs".

Lemma Rabs_triang_aux :
  forall a b c : R,
  Rabs a + Rabs b <= c ->
  Rabs( a + b ) <= c.
Proof.
intros.
pose proof Rabs_triang a b.
pose proof Rle_trans _ _ _ H0 H; assumption.
Qed.

Lemma Rabs_triang_aux2 :
  forall a b c d : R,
  Rabs a + Rabs b + Rabs c <= d ->
  Rabs (a + b) + Rabs c <= d.
Proof.
intros.
assert (Rabs (a + b) + Rabs c <= Rabs a + Rabs b + Rabs c).
pose proof Rcomplements.Rle_minus_r
  (Rabs (a + b)) (Rabs a + Rabs b + Rabs c) (Rabs c); destruct H0.
try apply H0; field_simplify; apply Rabs_triang.
try pose proof Rle_trans _ _ d H0 H; assumption.
Qed.

Lemma Rabs_triang_aux3 :
  forall a b c x y z : R,
  Rabs a <= x ->
  Rabs b <= y ->
  Rabs c <= z ->
  Rabs a + Rabs b + Rabs c <= x + y +z.
Proof. intros; nra. Qed.

Lemma Rabs_triang_aux4 :
  forall x xp v vp : R,
  Rabs ( x^2 + v^2 - (xp^2 + vp^2)) <=
  Rabs ( x + xp) * Rabs ( x - xp) +
  Rabs ( v + vp) * Rabs ( v - vp).
Proof.
intros.
replace (x ^ 2 + v ^ 2 - (xp ^ 2 + vp ^ 2))
with ( (x ^ 2 - xp ^ 2) + (v ^ 2 - vp^2)) by nra.
eapply Rle_trans.
+
match goal with |- context[ Rabs (?a + ?b)<= _] =>
apply Rabs_triang
end.
+
repeat match goal with |- context[ (?a^2 - ?b^2) ] =>
replace (a^2 - b^2) with ((a+b)*(a-b)) by nra
end.
repeat rewrite Rabs_mult. nra.
Qed.

Lemma Rabs_le_aux:
  forall w x y z a b c d : R,
  Rabs w <= a ->
  Rabs x <= b ->
  Rabs y <= c ->
  Rabs z <= d ->
  Rabs w * Rabs x + Rabs y * Rabs z <= a * b + c * d.
Proof.
intros.
eapply Rle_trans.
eapply Rplus_le_compat_r.
eapply Rmult_le_compat_r. apply Rabs_pos. apply H.
eapply Rle_trans.
eapply Rplus_le_compat_r.
eapply Rmult_le_compat_l.
eapply Rle_trans. apply Rabs_pos. apply H. apply H0.
eapply Rplus_le_compat_l.
eapply Rle_trans.
eapply Rmult_le_compat_l.
apply Rabs_pos. apply H2.
eapply Rmult_le_compat_r.
eapply Rle_trans.
apply Rabs_pos. apply H2. assumption.
Qed.

Lemma powerRZ_pos_sub2:
forall (x : R) (n m : positive),
     x <> 0 ->
     x ^ Pos.to_nat n * / x ^ Pos.to_nat m = powerRZ x (Z.pos_sub n m).
Proof.
intros; symmetry; apply powerRZ_pos_sub; auto. Qed.

Lemma mul_powerRZ (a:R) (n:Z) :
 a / powerRZ 2 n = a * powerRZ 2 (-n).
Proof.
replace (powerRZ 2 (- n)) with
(1 / powerRZ 2 n).
nra.
(apply neg_powerRZ); nra.
Qed.

Lemma Rminus_dist:
  forall x y z : R,
  x - (y +z) = x - y - z.
Proof.
intros;nra.
Qed.

Lemma abs_lt:
 forall a b d: R,
 Rabs b <= d ->
 Rabs a - d <= Rabs a - Rabs b.
Proof.
intros; nra.
Qed.

Lemma abs_mul:
 forall a b: R,
 0 <= a ->
 Rabs (a * b) = a * Rabs b.
Proof.
intros; pose proof Rabs_mult a b. rewrite -> H0.
pose proof Rabs_pos_eq a H; auto; nra.
Qed.

Lemma abs_mul2:
 forall a b: R,
 0 <= b ->
 Rabs (a * b) =  b * Rabs a.
Proof.
intros; pose proof Rabs_mult a b. rewrite -> H0.
pose proof Rabs_pos_eq b H. auto; nra.
Qed.

Lemma rabs_mul_t:
forall u a b c d: R ,
u <= a * Rabs(b) + c -> Rabs(b) <= d -> 0 <a -> u <= a * d + c.
Proof.
intros. nra.
Qed.

Lemma del_eps_reduce1 :
forall a del eps: R,
a - (a*(1+del)+eps) = -a*del - eps.
Proof.
intros; field_simplify; reflexivity.
Qed.

Lemma del_eps_reduce2 :
forall a c d d' del eps: R,
a*(c + d) - a*((c + d')*(1+del)+eps) = a*(d - d') - a*(c + d')*del - a* eps.
Proof.
intros; field_simplify; reflexivity.
Qed.

Lemma Rabs_le_inv2 (x y :  R):
0 <= Rabs x <= y -> - y <= x <= y.
Proof.
intros.
assert (Rabs x <= y) by nra;
pose proof Rabs_le_inv x y H0; assumption.
Qed.

Lemma error_reduce a b c d :
a - (b * (1 + c) + d) =
(a - b )  - b * c - d.
Proof.
intros.
nra.
Qed.

Lemma Rabs_mult_le_l a b c :
 0<= a ->
  Rabs b <= c ->
  Rabs(a*b) <= a * c.
Proof.
intros.
assert (a * Rabs b <= a* c) by nra.
assert (Rabs (a * b) <= a * Rabs b).
rewrite Rabs_mult. rewrite Rabs_pos_eq; nra.
eapply Rle_trans. apply H2. auto.
Qed.

Lemma Rle_minus_l_2 :
  forall a b c : R, a - b <= c <-> a <= b + c .
Proof.
intros. split. nra. nra. Qed.

Lemma Rle_plus :
  forall a b  : R, 0<= a -> 0 <=b -> 0 <= a + b.
Proof.
intros. nra. Qed.

Lemma Rle_mult :
  forall a b  : R, 0<= a -> 0 <=b -> 0 <= a * b.
Proof.
intros. nra. Qed.

Lemma Rabs_le_minus_mul :
forall a b x y : R,
0 <= a -> 0 <= b ->
Rabs x <= 1 -> Rabs y <= 1 ->
Rabs(a * x - b * y) <= a + b.
Proof.
intros.
eapply Rle_trans.
eapply Rabs_triang.
rewrite Rabs_Ropp.
repeat (rewrite abs_mul; try auto).
eapply Rplus_le_compat; nra.
Qed.

Lemma sqr_plus_pos a b:
0 <= a ^ 2 + b ^ 2.
Proof.
nra.
Qed.

Lemma sqrt_plus_pos a b:
0 <= sqrt a  + sqrt b .
Proof.
apply Rle_plus; apply sqrt_pos.
Qed.

Lemma sqrt_triang_ineq a b:
0 <= a ->
0 <= b ->
sqrt ( a + b ) <= sqrt(a) + sqrt(b).
Proof.
intros.
assert (a + b  <= (sqrt a + sqrt b)^2).
simpl. field_simplify.
repeat rewrite pow2_sqrt; auto.
rewrite Rplus_assoc.
apply Rplus_le_compat_l.
rewrite Rplus_comm.
apply Rle_minus_l_2. field_simplify.
eapply Rle_trans.
2: apply Rmult_le_compat_l.
2: eapply Rle_trans.
3: apply Rmult_le_compat_l; try nra; try auto.
3: apply sqrt_pos; try nra.
3: apply sqrt_pos; try nra.
nra. nra.
apply sqrt_le_1 in H1; try nra.
rewrite sqrt_pow2 in H1; try nra.
apply sqrt_plus_pos.
Qed.

Lemma square_pos x:
0 <= x^2.
Proof.
pose proof Rle_0_sqr x.
unfold Rsqr in H.
unfold pow. rewrite Rmult_1_r.
apply H.
Qed.

Lemma Rmax_pos a b :
0 <=a ->
0<= b ->
0<= Rmax a b.
Proof.
intros.
eapply Rle_trans.
apply H.
apply Rmax_l.
Qed.

Lemma Rmax_sqr a b :
0 <=a ->
0<= b ->
a^2 + b^2<= 2 * Rmax a b ^2.
Proof.
intros.
cbv [Rmax]. destruct Rle_dec.
+ eapply Rle_trans.
eapply Rplus_le_compat_r.
assert ( a ^2 <= b ^2) by nra.
apply H1. nra.
+ eapply Rle_trans.
eapply Rplus_le_compat_l.
assert ( b ^2 <= a ^2) by nra.
apply H1. nra.
Qed.

Lemma Rabs_pos_le a b:
0 <= a ->
0 <= b ->
a <= b -> Rabs(a) <= Rabs(b).
Proof.
intros.
apply Rabs_pos_eq in H0.
apply Rabs_pos_eq in H.
rewrite H, H0.
auto.
Qed.

Lemma Rabs_sqr_le a :
Rabs(a ^ 2) = Rabs(a) ^2.
Proof.
intros.
replace (a ^ 2) with ( a * a) by nra.
rewrite Rabs_mult.
nra.
Qed.

Definition Rprod : Type := R * R.
Declare Scope Rprod.
Delimit Scope Rprod with Rprod.
Bind Scope Rprod with Rprod.

Definition Rprod_minus (x y : Rprod) : Rprod :=
  (Rminus (fst x) (fst y), Rminus (snd x) (snd y)).

Definition Rprod_plus (x y : Rprod) : Rprod :=
  (Rplus (fst x) (fst y), Rplus (snd x) (snd y)).

Definition Rprod_norm (x : Rprod) : R  :=
  sqrt ( fst x ^ 2 +  snd x ^ 2).

Notation " L1 - L2 " := (Rprod_minus L1 L2) (at level 50, left associativity) : Rprod.

Notation " L1 + L2 " := (Rprod_plus L1 L2) (at level 50,  left associativity) : Rprod.

Notation "∥ L ∥" := (Rprod_norm L%Rprod) (at level 10, L at level 90) : R_scope.
Notation "∥·∥" := Rprod_norm (only parsing) : R_scope.

Lemma Rprod_triang_ineq x y: ∥ x + y ∥ <=  ∥ x ∥ + ∥ y ∥.
Proof.
destruct x, y.
unfold Rprod_plus, Rprod_norm, fst, snd.
assert ((r + r1) ^ 2 + (r0 + r2) ^ 2 <=
  (sqrt (r ^ 2 + r0 ^ 2) + sqrt (r1 ^ 2 + r2 ^ 2))^2).
replace ((sqrt (r ^ 2 + r0 ^ 2) + sqrt (r1 ^ 2 + r2 ^ 2)) ^ 2)
with (r^2 + r0^2 + r1^2 + r2^2 + 2 * sqrt (r ^ 2 + r0 ^ 2)* sqrt (r1 ^ 2 + r2 ^ 2))
by
(simpl; field_simplify;
repeat rewrite pow2_sqrt; repeat nra).
simpl. field_simplify.
repeat rewrite Rplus_assoc.
apply Rplus_le_compat_l.
rewrite Rplus_comm.
repeat rewrite Rplus_assoc.
apply Rplus_le_compat_l.
apply Rplus_le_compat_l.
rewrite Rplus_comm.
repeat rewrite Rplus_assoc.
apply Rplus_le_compat_l.
repeat rewrite Rmult_assoc.
replace (2 * (r * r1) + 2 * (r0 * r2)) with
(2 * ((r * r1) + (r0 * r2))) by nra.
apply Rmult_le_compat_l; try nra.
repeat rewrite Rmult_1_r.
apply sqrt_cauchy.
apply sqrt_le_1 in H.
rewrite sqrt_pow2 in H; auto.
apply sqrt_plus_pos.
apply sqr_plus_pos.
rewrite <- Rsqr_pow2.
apply Rle_0_sqr.
Qed.

Lemma Rprod_norm_plus_minus_eq x y z:  ∥ x - y ∥ = ∥ (x - z) + (z - y) ∥.
Proof.
intros.
destruct x, y, z.
unfold Rprod_plus, Rprod_minus, Rprod_norm, fst, snd.
f_equal.
nra.
Qed.

Lemma Rnorm_pos x: 0 <= ∥ x ∥.
Proof.
unfold Rprod_norm.
apply sqrt_pos.
Qed.

Lemma Rprod_plus_assoc :
forall a b c : Rprod,  ( (a+b)+c = a+(b+c) )%Rprod.
Proof.
intros.
unfold Rprod_plus.
simpl. f_equal; nra.
Qed.

Lemma Rprod_plus_sym :
forall a b : Rprod,  ( a + b = b + a )%Rprod.
Proof.
intros.
unfold Rprod_plus.
f_equal; nra.
Qed.

Lemma sum_pow_mult_l:
  forall a : R,
  forall n : nat,
  a * sum_f 0 n (fun m => a ^ m ) =
  sum_f 1 (S n) (fun m => a ^ m ).
Proof.
intros.
replace (a * sum_f 0 n (fun m => a ^ m ) )
with
( sum_f 0 n (fun m => a ^ m * a )).
+ replace (fun m : nat => a ^ m * a) with
(fun m : nat => a ^ (m+1)).
induction n.
++ unfold sum_f. simpl. nra.
++ set (yy:=sum_f 0 (S n) (fun m : nat => a ^ (m + 1))).
rewrite sum_f_n_Sm. rewrite <- IHn. subst yy.
rewrite sum_f_n_Sm. repeat f_equal. ring.
apply Nat.le_0_l.
rewrite <- Nat.succ_le_mono.
apply Nat.le_0_l.
++ apply functional_extensionality.
intros. replace (x+1)%nat
  with (S x) by ring.
simpl; nra.
+  induction n.
++ unfold sum_f. simpl. nra.
++  rewrite sum_f_n_Sm. rewrite IHn.
rewrite sum_f_n_Sm. field_simplify. nra.
apply Nat.le_0_l. apply Nat.le_0_l.
Qed.

Lemma sum_pow_mult_r :
  forall a : R,
  forall n : nat,
  sum_f 0 n (fun m => a ^ m ) * a =
  sum_f 1 (S n) (fun m => a ^ m ).
Proof.
intros.
rewrite Rmult_comm.
apply sum_pow_mult_l.
Qed.

Lemma sum_pow_first :
  forall a : R,
  forall n : nat,
  sum_f 0 (S n) (fun m => a ^ m ) =
  sum_f 1 (S n) (fun m => a ^ m ) + 1.
Proof.
intros.
induction n.
+ unfold sum_f. simpl. nra.
+
match goal with |-context[?a = ?b]=>
set (yy:= a)
end.
rewrite sum_f_n_Sm.
rewrite Rplus_assoc.
rewrite Rplus_comm.
rewrite Rplus_comm in IHn.
rewrite Rplus_assoc.
rewrite <- IHn.
subst yy.
rewrite sum_f_n_Sm.
rewrite IHn.
field_simplify. nra.
apply Nat.le_0_l.
rewrite <- Nat.succ_le_mono.
apply Nat.le_0_l.
Qed.

Definition error_sum error n: R:=
 match n with
  | 0 => 0
  | S n' => sum_f 0 n' (fun m => error ^ m )
end.

Lemma error_sum_aux n (er: R):
  error_sum er n + er ^ n = error_sum er (S n).
Proof.
intros.
induction n.
+  simpl. unfold sum_f. simpl. nra.
+ unfold error_sum.
rewrite sum_f_n_Sm; auto.
apply Nat.le_0_l.
Qed.

Lemma error_sum_aux2 er n:
  er * error_sum er n + 1  = error_sum er (S n).
Proof.
intros.
induction n.
+  simpl. unfold sum_f. rewrite Rmult_0_r. simpl. nra.
+ unfold error_sum.
rewrite Rmult_comm.
rewrite sum_pow_mult_r.
rewrite sum_pow_first.
nra.
Qed.

Lemma Rmax_mult_le_pos a b:
0 <=a ->
0 <= b ->
a * b <= Rmax a b ^2.
Proof.
intros.
cbv [Rmax]. destruct Rle_dec.
eapply Rle_trans.
apply Rmult_le_compat_r; auto.
apply r. nra.
apply Rnot_le_lt in n.
eapply Rle_trans.
apply Rmult_le_compat_l; auto.
apply Rlt_le in n.
apply n. nra.
Qed.

Lemma Rmax_mult_le_neg  a b:
a <= 0 ->
b <= 0 ->
a * b <= Rmin a b ^2.
Proof.
intros.
cbv [Rmin]. destruct Rle_dec.
eapply Rle_trans.
assert (a * b <= a * a) by nra.
apply H1. nra.
apply Rnot_le_lt in n.
eapply Rle_trans.
assert (a * b <= b * b) by nra.
apply H1. nra.
Qed.

Lemma bounded_one_plus_pow:
forall x n,
0 <= x ->
(1 + x)^n <= exp ( INR n * x).
Proof.
intros.
induction n.
+ simpl. rewrite Rmult_0_l.
rewrite exp_0; nra.
+
rewrite <- tech_pow_Rmult.
eapply Rle_trans.
eapply Rmult_le_compat_l; try nra.
apply IHn.
eapply Rle_trans.
pose proof exp_ineq1_le x.
eapply Rmult_le_compat_r; try nra.
pose proof exp_pos (INR n * x).
apply Rlt_le in H1; auto.
apply H0.
rewrite <- exp_plus.
rewrite S_INR.
apply Req_le.
f_equal.
nra.
Qed.

(* apparently this is already covered by Constant Coq.Reals.PartSum.tech3*)
Theorem geo_series_closed_form:
forall r k ,
r <> 1 ->
sum_f 0 k (fun m => r ^ m ) = (1-(r^(S k)))/(1-r).
Proof.
intros.
induction k.
+ unfold sum_f. simpl. field_simplify. nra. lra.
+ rewrite sum_f_n_Sm .
++ rewrite IHk.
match goal with|- context [?a/?aa + ?b = _] =>
replace  b with
((r ^ S k)*(1-r)/(1-r))
end.
field_simplify; try nra.
replace  (- r ^ S k * r) with
(- r ^ S (S k) ).
nra.
simpl. nra.
field_simplify; try nra.
++ apply Nat.le_0_l.
Qed.

Lemma mult_pos :
forall a b, 0 < a * b -> 0 <= a -> 0 < b.
Proof.
intros; nra.
Qed.

Lemma is_lim_exp_pow:
forall n ,
is_lim (fun y : R => exp (INR n * y)) 0 1.
Proof.
intros.
induction n.
+ simpl.
apply (is_lim_ext (fun y : R => exp 0)  (fun y : R => exp (0 * y))).
intros. rewrite Rmult_0_l; auto.
replace (exp 0) with 1.
apply is_lim_const.
field_simplify. symmetry; (apply exp_0).
+ rewrite S_INR.
apply (is_lim_ext (fun y : R => exp ((INR n * y + y) ))
    (fun y : R => exp ((INR n + 1) * y))).
intros. f_equal. nra.
apply ( is_lim_ext (fun y : R => exp (INR n * y) * exp y)
    (fun y : R => exp ((INR n * y + y) ))).
intros. rewrite <- exp_plus; nra.
pose proof (is_lim_mult (fun x => exp (INR n * x)) (fun x => exp x) 0 1 1 IHn) .
assert (is_lim (fun x : R => exp x) 0 1).
pose proof Lim_exp 0. simpl in H0.
pose proof (Lim_correct) (fun y : R => exp y) 0 (ex_lim_exp 0).
rewrite exp_0 in H0.
rewrite H0 in H1; auto.
assert (ex_Rbar_mult 1 1).
unfold ex_Rbar_mult; nra.
specialize (H H0 H1).
apply (is_lim_ext (fun y : R => (fun x : R => exp (INR n * x)) y * (fun x : R => exp x) y)
    (fun y : R => exp (INR n * y) * exp y)) in H.
simpl in H. rewrite Rmult_1_l in H. apply H.
intros. f_equal.
Qed.

Lemma square_abs :
forall x : R, x ^ 2 = (Rabs x) ^ 2.
Proof.
intros.
pose proof Rsqr_abs x.
assert (x  ^ 2 = Rsqr x).
unfold Rsqr; nra.
rewrite pow2_abs.
rewrite H0; nra.
Qed.

Lemma sqrt_le :
forall a b,
a ^ 2 <= b ->
Rabs a <= sqrt b.
Proof.
intros.
replace b with (sqrt b ^2) in H.
replace (a ^ 2) with (Rsqr a) in H by (unfold Rsqr; nra).
replace (sqrt b ^ 2) with (Rsqr (sqrt b)) in H by (unfold Rsqr; nra).
apply Rsqr_le_abs_0 in H.
pose proof Rabs_pos_eq (sqrt b) (sqrt_pos b). rewrite <- H0.
auto.
apply pow2_sqrt.
eapply Rle_trans.
2 : apply H.
apply square_pos.
Qed.

Lemma Rprod_minus_comm : forall a b, ∥ a - b ∥ = ∥ b - a ∥.
Proof.
intros.
unfold Rprod_norm, Rprod_minus.
destruct a; destruct b; unfold fst, snd.
f_equal. simpl. nra.
Qed.

Lemma Rprod_triang_inv : forall a b, ∥a∥ - ∥b∥ <= ∥ a - b ∥.
Proof.
intros.
assert ( ∥ a ∥ = ∥ (a-b)+b ∥ ).
  - unfold Rprod_norm, Rprod_plus, Rprod_minus.
  destruct a; destruct b. f_equal. unfold fst, snd. nra.
-
rewrite H.
eapply Rle_trans.
apply Rplus_le_compat_r.
apply Rprod_triang_ineq.
apply Req_le. rewrite Rprod_minus_comm.
nra.
Qed.

Lemma error_sum_le_Sn :
  forall a n,
  0 <= a ->
  error_sum a n <=
  error_sum a (S n).
Proof.
intros.
pose proof error_sum_aux n a.
rewrite <- H0.
rewrite Rplus_comm.
apply Rle_minus_l.
field_simplify.
apply pow_le; nra.
Qed.

Lemma error_sum_pos:
forall a n ,
0 <= a ->
0 <=   error_sum a n.
Proof.
intros.
induction n.
+ simpl; nra.
+ pose proof (error_sum_aux n a).
rewrite <- H0.
rewrite Rplus_comm.
apply Rle_plus.
apply pow_le; auto.
apply IHn.
Qed.

Lemma error_sum_le_trans_aux :
  forall a,
  forall m n,
  (n <= m)%nat ->
  ( 1 <= a) ->
  error_sum a (S n) <=
  error_sum a (S m).
Proof.
intros.
pose proof (error_sum_aux m a).
rewrite <- H1.
pose proof (error_sum_aux n a).
rewrite <- H2.
clear H1 H2.
induction m.
- assert (n = 0)%nat by lia. subst; simpl; nra.
- assert ((n = S m)%nat \/ ((n < S m)%nat)) by lia.
destruct H1.
+ subst ; apply Req_le; auto.
+ assert  (n <= m)%nat by lia.
specialize (IHm H2).
eapply Rle_trans.
apply IHm.
eapply Rle_trans.
apply Rplus_le_compat_l.
assert (m <= S m)%nat by lia.
pose proof Rle_pow a m (S m) H0 H3.
apply H4.
eapply Rle_trans.
apply Rplus_le_compat_r.
apply error_sum_le_Sn; nra.
apply Req_le.
auto.
Qed.

Lemma error_sum_le_trans :
  forall a,
  forall m n,
  (n <= m)%nat ->
  ( 1 <= a) ->
  error_sum a n <=
  error_sum a m.
Proof.
intros.
destruct n.
- simpl. apply error_sum_pos; nra.
- destruct m.
+ lia.
+ apply error_sum_le_trans_aux; try lia; lra.
Qed.

Lemma error_sum_GS :
forall n,
forall h,
0 < h ->
error_sum (1 + h) n = ((1 + h) ^ n - 1) / h.
Proof.
intros.
induction n.
- simpl. nra.
- unfold error_sum.
assert (1 + h <> 1) by nra.
pose proof geo_series_closed_form (1 + h) n H0.
rewrite H1.
replace (((1 - (1 + h) ^ S n) / (1 - (1 + h))))
with (( (1 + h) ^ S n - 1) / h).
field_simplify;
repeat nra.
set (aa:=(1 + h) ^ S n).
apply Stdlib.Rdiv_eq_reg.
nra.
all : nra.
Qed.

Lemma sep_0_div (a b : R) :
  a <> 0 /\ b <> 0 -> a/b <> 0.
Proof.
intros.
replace (a / b) with (a * / b) by nra.
destruct H as (HA & HB).
generalize (Rinv_neq_0_compat b HB).
pose proof Req_dec (a / b) 0 as Hy; destruct Hy; try auto.
Qed.

Lemma h_sqrt2_lemma (h : R) :
0 < h < sqrt 2 ->
0 < h^2  < 2.
Proof.
intros.
destruct H; split; auto.
apply pow2_gt_0; try nra.
assert ( h * h < sqrt 2  * sqrt 2) by nra.
rewrite sqrt_def in H1; try nra.
Qed.

Lemma fst_eq (a b c d: R *  R):
 a = b -> fst (a,c) = fst (b,d).
Proof.
intros.
simpl.
auto.
Qed.

Lemma sqrt_norm :
  forall x : R, sqrt (x^2) = (@norm R_AbsRing _ x).
Proof.
intros.
unfold norm.
etransitivity.
replace (x ^ 2) with (x²) .
apply sqrt_Rsqr_abs.
unfold Rsqr; simpl; nra.
simpl; 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 finset fingroup finalg perm.
From mathcomp Require Import zmodp matrix.
From mathcomp Require Import Rstruct classical_sets.
Require Import Reals Lra.
Require Import ssrR Reals_ext logb ssr_ext ssralg_ext bigop_ext Rbigop fdist.
Require Import entropy binary_entropy_function channel hamming channel_code.

(******************************************************************************)
(*                Capacity of the binary symmetric channel                    *)
(*                                                                            *)
(* BSC.c == Definition of the binary symmetric channel (BSC)                  *)
(*                                                                            *)
(* Lemma:                                                                     *)
(*   BSC_capacity == the capacity of a BSC is 1 - H p                         *)
(******************************************************************************)

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

Local Open Scope fdist_scope.
Local Open Scope channel_scope.
Local Open Scope R_scope.

Module BSC.
Section BSC_sect.
Variable A : finType.
Hypothesis card_A : #|A| = 2%nat.
Variable p : prob.

Definition c : `Ch(A, A) := fdist_binary card_A p.

End BSC_sect.
End BSC.

Local Open Scope entropy_scope.

Section bsc_capacity_proof.
Variable A : finType.
Hypothesis card_A : #|A| = 2%nat.
Variables (P : fdist A) (p : R).
Hypothesis p_01' : (0 < p < 1)%R.

Let p_01 : prob := Eval hnf in Prob.mk_ (ltR2W p_01').

Lemma HP_HPW : `H P - `H(P, BSC.c card_A p_01) = - H2 p.
Proof.
rewrite {2}/entropy /=.
rewrite (eq_bigr (fun a => ((P `X (BSC.c card_A p_01))) (a.1, a.2) *
  log (((P `X (BSC.c card_A p_01))) (a.1, a.2)))); last by case.
rewrite -(pair_big xpredT xpredT (fun a b => (P `X (BSC.c card_A p_01))
  (a, b) * log ((P `X (BSC.c card_A p_01)) (a, b)))) /=.
rewrite {1}/entropy .
set a := \sum_(_ in _) _. set b := \sum_(_ <- _) _.
apply trans_eq with (- (a + (-1) * b)); first by field.
rewrite /b {b} big_distrr /= /a {a} -big_split /=.
rewrite !Set2sumE /= !fdist_prodE /BSC.c !fdist_binaryxx !fdist_binaryE/=.
rewrite eq_sym !(negbTE (Set2.a_neq_b card_A)) /H2 (* TODO *).
set a := Set2.a _. set b := Set2.b _.
case: (Req_EM_T (P a) 0) => H1.
  rewrite H1 !(mul0R, mulR0, addR0, add0R).
  move: (FDist.f1 P); rewrite Set2sumE /= -/a -/b.
  rewrite H1 add0R => ->.
  rewrite /log Log_1 !(mul0R, mulR0, addR0, add0R, mul1R, mulR1); field.
rewrite /log LogM; last 2 first.
  rewrite -fdist_gt0; exact/eqP.
  case: p_01' => ? ?; lra.
rewrite /log LogM; last 2 first.
  rewrite -fdist_gt0; exact/eqP.
  by case: p_01'.
case: (Req_EM_T (P b) 0) => H2.
  rewrite H2 !(mul0R, mulR0, addR0, add0R).
  move: (FDist.f1 P); rewrite Set2sumE /= -/a -/b.
  rewrite H2 addR0 => ->.
  rewrite /log Log_1 !(mul0R, mulR0, addR0, add0R, mul1R, mulR1); field.
rewrite /log LogM; last 2 first.
  rewrite -fdist_gt0; exact/eqP.
  by case: p_01'.
rewrite /log LogM; last 2 first.
  rewrite -fdist_gt0; exact/eqP.
  rewrite subR_gt0; by case: p_01'.
transitivity (p * (P a + P b) * log p + (1 - p) * (P a + P b) * log (1 - p) ).
  rewrite /log; by field.
by move: (FDist.f1 P); rewrite Set2sumE /= -/a -/b => ->; rewrite /log; field.
Qed.

Lemma IPW : `I(P, BSC.c card_A p_01) = `H(P `o BSC.c card_A p_01) - H2 p.
Proof.
rewrite /mutual_info_chan addRC.
set a := `H(_ `o _).
transitivity (a + (`H P - `H(P , BSC.c card_A p_01))); first by field.
by rewrite HP_HPW.
Qed.

Lemma H_out_max : `H(P `o BSC.c card_A p_01) <= 1.
Proof.
rewrite {1}/entropy /= Set2sumE /= !fdist_outE 2!Set2sumE /=.
set a := Set2.a _. set b := Set2.b _.
rewrite /BSC.c !fdist_binaryxx !fdist_binaryE /= !(eq_sym _ a).
rewrite (negbTE (Set2.a_neq_b card_A)).
move: (FDist.f1 P); rewrite Set2sumE /= -/a -/b => P1.
have -> : p * P a + (1 - p) * P b = 1 - ((1 - p) * P a + p * P b).
  rewrite -{2}P1; by field.
have H01 : 0 < ((1 - p) * P a + p * P b) < 1.
  move: (FDist.ge0 P a) => H1.
  move: (FDist.le1 P b) => H4.
  move: (FDist.le1 P a) => H3.
  case: p_01' => Hp1 Hp2.
  split.
    case/Rle_lt_or_eq_dec : H1 => H1.
    - apply addR_gt0wl; by [apply mulR_gt0; lra | apply mulR_ge0; lra].
    - by rewrite -H1 mulR0 add0R (_ : P b = 1) ?mulR1 // -P1 -H1 add0R.
  rewrite -{2}P1.
  case: (Req_EM_T (P a) 0) => Hi.
    rewrite Hi mulR0 !add0R.
    rewrite Hi add0R in P1.
    by rewrite P1 mulR1.
  case: (Req_EM_T (P b) 0) => Hj.
    rewrite Hj addR0 in P1.
    rewrite Hj mulR0 !addR0 P1 mulR1.
    lra.
  case/Rle_lt_or_eq_dec : H1 => H1.
  - apply leR_lt_add.
    + rewrite -{2}(mul1R (P a)); apply leR_wpmul2r; lra.
    + rewrite -{2}(mul1R (P b)); apply ltR_pmul2r => //.
      apply/ltRP; rewrite lt0R; apply/andP; split; [exact/eqP|exact/leRP].
  - rewrite -H1 mulR0 2!add0R.
    have -> : P b = 1 by rewrite -P1 -H1 add0R.
    by rewrite mulR1.
rewrite (_ : forall a b, - (a + b) = - a - b); last by move=> *; field.
rewrite -mulNR.
set q := (1 - p) * P a + p * P b.
apply: (@leR_trans (H2 q)); last exact: H2_max.
by rewrite /H2 !mulNR; apply Req_le; field.
Qed.

Lemma bsc_out_H_half' : 0 < 1%:R / 2%:R < 1.
Proof. by rewrite /= (_ : 1%:R = 1) // (_ : 2%:R = 2) //; lra. Qed.

Lemma H_out_binary_uniform : `H(fdist_uniform card_A `o BSC.c card_A p_01) = 1.
Proof.
rewrite {1}/entropy !Set2sumE /= !fdist_outE !Set2sumE /=.
rewrite /BSC.c !fdist_binaryxx !fdist_binaryE (eq_sym _ (Set2.a _)) !fdist_uniformE.
rewrite (negbTE (Set2.a_neq_b card_A)).
rewrite -!mulRDl (_ : 1 - p + p = 1); last by field.
rewrite mul1R (_ : p + (1 - p) = 1); last by field.
rewrite mul1R -!mulRDl card_A /= (_ : INR 2 = 2) // /log LogV; last lra.
by rewrite Log_n //=; field.
Qed.

End bsc_capacity_proof.

Section bsc_capacity_theorem.
Variable A : finType.
Hypothesis card_A : #|A| = 2%nat.
Variable p : R.
Hypothesis p_01' : 0 < p < 1.
Let p_01 := Eval hnf in Prob.mk_ (ltR2W p_01').

Theorem BSC_capacity : capacity (BSC.c card_A p_01) = 1 - H2 p.
Proof.
rewrite /capacity /image.
set E := (fun y : R => _).
set p' := Prob.mk_ (ltR2W p_01').
have has_sup_E : has_sup E.
  split.
    set d := fdist_binary card_A p' (Set2.a card_A).
    by exists (`I(d, BSC.c card_A p')), d.
  exists 1 => y [P _ <-{y}].
  rewrite IPW; apply/RleP/leR_subl_addr/(leR_trans (H_out_max card_A P p_01')).
  rewrite addRC -leR_subl_addr subRR.
  by rewrite (entropy_H2 card_A (Prob.mk_ (ltR2W p_01'))); exact/entropy_ge0.
apply eqR_le; split.
  apply/RleP.
  have [_ /(_ (1 - H2 p))] := Rsup_isLub (0 : R) has_sup_E.
  apply => x [d _ dx]; apply/RleP.
  suff : `H(d `o BSC.c card_A p_01) <= 1.
    move: (@IPW _ card_A d _ p_01') => ?.
    by unfold p_01 in *; lra.
  exact: H_out_max.
move: (@IPW _ card_A (fdist_uniform card_A) _ p_01').
rewrite H_out_binary_uniform => <-.
by apply/RleP/Rsup_ub => //=; exists (fdist_uniform card_A).
Qed.

End bsc_capacity_theorem.

Section dH_BSC.

Variable p : prob.
Let card_F2 : #| 'F_2 | = 2%nat. by rewrite card_Fp. Qed.
Let W := BSC.c card_F2 p.
Variables (M : finType) (n : nat) (f : encT [finType of 'F_2] M n).

Local Open Scope vec_ext_scope.

Lemma DMC_BSC_prop m y : let d := dH y (f m) in
  W ``(y | f m) = ((1 - p) ^ (n - d) * p ^ d)%R.
Proof.
move=> d; rewrite DMCE.
transitivity ((\prod_(i < n | (f m) ``_ i == y ``_ i) (1 - p)) *
              (\prod_(i < n | (f m) ``_ i != y ``_ i) p))%R.
  rewrite (bigID [pred i | (f m) ``_ i == y ``_ i]) /=; congr (_ * _).
    by apply eq_bigr => // i /eqP ->; rewrite /BSC.c fdist_binaryxx.
  apply eq_bigr => //= i /negbTE Hyi; by rewrite /BSC.c fdist_binaryE eq_sym Hyi.
congr (_ * _).
  by rewrite big_const /= iter_mulR /= card_dHC.
by rewrite big_const /= iter_mulR /= card_dH_vec.
Qed.

End dH_BSC.