Set Implicit Arguments.

Hint Extern 1 (_ = _) => congruence.

(* syntax *)

Inductive exp : Set :=
| Zero   : exp
| Succ   : exp -> exp
| T      : exp
| F      : exp
| Pred   : exp -> exp
| If     : exp -> exp -> exp -> exp
| IsZero : exp -> exp.

(* values *)

Inductive bvalue : exp -> Prop :=
| btrue  : bvalue T
| bfalse : bvalue F.

Inductive nvalue : exp -> Prop :=
| nzero  : nvalue Zero
| nsucc  : forall n, nvalue n -> nvalue (Succ n).

Inductive value : exp -> Prop :=
| Bvalue : forall e, bvalue e -> value e
| Nvalue : forall e, nvalue e -> value e.

Hint Constructors bvalue nvalue value.

Reserved Notation "e '==>' e1" (at level 40).

Inductive step : exp -> exp -> Prop :=
| ST_If_T
  : forall e e', (If T e e') ==> e
| ST_If_F
  : forall e e', If F e e' ==> e'
| ST_If
  : forall e e' e1 e2,
    e ==> e'                ->
    If e e1 e2 ==> If e' e1 e2
| ST_Succ
  : forall e e',
    e ==> e'                ->
    (Succ e) ==> (Succ e')
| ST_Pred_Zero
  : Pred Zero ==> Zero
| ST_Pred_Succ
  : forall e,
    nvalue e         ->
    Pred (Succ e) ==> e
| ST_Pred
  : forall e e',
    e ==> e'           ->
    (Pred e) ==> (Pred e')
| ST_IsZeroZero
  : IsZero Zero ==> T
| ST_IsZeroSucc
  : forall e,
    nvalue e           ->
    IsZero (Succ e) ==> F
| ST_IsZero
  : forall e e',
    e ==> e'               ->
    (IsZero e) ==> (IsZero e')
where "e '==>' e1" := (step e e1).

Hint Constructors step.

Definition normal_form e :=
  ~ exists e', step e e'.

Definition stuck e :=
  normal_form e /\ ~ value e.

Hint Unfold normal_form stuck.

(* first lemma *)

Ltac inverts H := inversion H ; clear H ; subst.

Lemma value_is_nf' : forall e, value e -> normal_form e.
Proof.
  intros e Hv.
  unfold normal_form.
  intro contra.
  induction e.
  +
    inverts contra.
    inverts H.
  +
    inverts contra.
    inverts Hv.
    inverts H0.
    inverts H0.
    apply IHe.
    auto.
    inverts H.
    exists e'.
    auto.
  +
    inverts contra.
    inverts H.
  +
    inverts contra.
    inverts H.
  +
    inverts Hv.
    inverts H.
    inverts H.
  +
    inverts Hv.
    inverts H.
    inverts H.
  +
    inverts Hv.
    inverts H.
    inverts H.
Qed.

Ltac s :=
      match goal with
      | [ H : ex _ |- _ ] => destruct H
      | [ H : Zero ==> _ |- _] => inverts H
      | [ H : T ==> _ |- _] => inverts H
      | [ H : F ==> _ |- _] => inverts H
      | [ H : value (Pred _) |- _] => inverts H
      | [ H : bvalue (Pred _) |- _] => inverts H
      | [ H : nvalue (Pred _) |- _] => inverts H
      | [ H : value (If _ _ _) |- _] => inverts H
      | [ H : bvalue (If _ _ _) |- _] => inverts H
      | [ H : nvalue (If _ _ _) |- _] => inverts H
      | [ H : value (IsZero _) |- _] => inverts H
      | [ H : bvalue (IsZero _) |- _] => inverts H
      | [ H : nvalue (IsZero _) |- _] => inverts H
      | [ H : value (Succ _) |- _] => inverts H
      | [ H : bvalue (Succ _) |- _] => inverts H
      | [ H : nvalue (Succ _) |- _] => inverts H
      | [ H : (Succ _) ==> _ |- _ ] => inverts H
      end.

Lemma value_is_nf : forall e, value e -> normal_form e.
Proof.
  unfold normal_form ; intros e H contra ; induction e ;
    try (repeat s) ; eauto.
Qed.

Hint Resolve value_is_nf.

Ltac s1 :=
  match goal with
  | [ H : (nvalue ?e) , H1 : ?e ==> _ |- _] =>
    apply Nvalue in H ; apply value_is_nf in H ;
    unfold normal_form in H ; apply ex_intro in H1 ; contradiction
  end.

Lemma step_deterministic
  : forall e e', e ==> e' -> forall e'', e ==> e'' -> e' = e''.
Proof.
  intros e e' H ; induction H ; intros e'' H' ;
    inverts H' ; f_equal ; try repeat s ; auto ; try repeat s1.
Qed.

Reserved Notation "e '==>*' e1" (at level 40).

Inductive multi_step : exp -> exp -> Prop :=
| mstep_refl
  : forall e, e ==>* e
| mstep_step
  : forall e e1 e',
    e ==> e1   ->
    e1 ==>* e' ->
    e ==>* e'
where "e '==>*' e1" := (multi_step e e1).

Hint Constructors multi_step.

Lemma succ_multi_step : forall e e', e ==>* e' -> Succ e ==>* Succ e'.
Proof.
  induction 1 ;
     try match goal with
         | [H : ?e ==> ?e1, IH : Succ ?e1 ==>* Succ ?e' |- _] =>
           apply ST_Succ in H ; eapply mstep_step with (e1 := Succ e1)
         end ; auto.
Qed.

Hint Resolve succ_multi_step.

Reserved Notation "e '==>>' e1" (at level 40).

Inductive big_step : exp -> exp -> Prop :=
| B_Value
  : forall v, value v -> v ==>> v
| B_If_True
  : forall e e1 e11 e2,
    e ==>> T ->
    e1 ==>> e11 ->
    (If e e1 e2) ==>> e11
| B_If_False
  : forall e e1 e2 e22,
    e ==>> F ->
    e2 ==>> e22 ->
    (If e e1 e2) ==>> e22
| B_Succ
  : forall e nv,
    nvalue nv ->
    e ==>> nv ->
    (Succ e) ==>> (Succ nv)
| B_PredZero
  : forall e,
    e ==>> Zero ->
    (Pred e) ==>> Zero
| B_PredSucc
  : forall e nv,
    nvalue nv ->
    e ==>> (Succ nv) ->
    Pred e ==>> nv
| B_IsZeroZero
  : forall e,
    e ==>> Zero ->
    (IsZero e) ==>> T
| B_IsZeroSucc
  : forall e nv,
    nvalue nv ->
    e ==>> (Succ nv) ->
    (IsZero e) ==>> F
where "e '==>>' e1" := (big_step e e1).

Hint Constructors big_step.

Ltac bs := match goal with
            | [H : T ==>> _ |- _] => inverts H
            | [H : F ==>> _ |- _] => inverts H
            | [H : Zero ==>> _ |- _] => inverts H
            | [H : (Succ _) ==>> _ |- _] => inverts H
            | [H : value _ |- _] => inverts H
            | [H : bvalue (Succ _) |- _] => inverts H
            | [H : nvalue (Succ _) |- _] => inverts H
            | [H : (Pred _) ==>> _ |- _] => inverts H
            | [H : bvalue (Pred _) |- _] => inverts H
            | [H : nvalue (Pred _) |- _] => inverts H
            | [H : (If _ _ _) ==>> _ |- _] => inverts H
            | [H : bvalue (If _ _ _) |- _] => inverts H
            | [H : nvalue (If _ _ _) |- _] => inverts H
            | [H : (IsZero _) ==>> _ |- _] => inverts H
            | [H : bvalue (IsZero _) |- _] => inverts H
            | [H : nvalue (IsZero _) |- _] => inverts H
            | [ IH : forall v, ?e ==>> v -> forall v', ?e ==>> v' -> _
                , H : ?e ==>> _, H1 : ?e ==>> _ |- _] =>
              apply (IH _ H) in H1
            end ; subst ; try f_equal ; auto.

Lemma big_step_deterministic : forall e v, e ==>> v -> forall v', e ==>> v' -> v = v'.
Proof.
  induction e ; intros ; repeat bs.
Qed.

(* typing *)

Inductive type : Set :=
| TBool : type
| TNat  : type.

Reserved Notation "e '<<-' t" (at level 40).

Inductive has_type : exp -> type -> Prop :=
| T_True
  : T <<- TBool
| T_False
  : F <<- TBool
| T_Zero
  : Zero <<- TNat
| T_Succ
  : forall e,
    e <<- TNat ->
    (Succ e) <<- TNat
| T_Pred
  : forall e,
    e <<- TNat  ->
    (Pred e) <<- TNat
| T_If
  : forall e e' e'' t,
    e <<- TBool ->
    e' <<- t    ->
    e'' <<- t   ->
    (If e e' e'') <<- t
| T_IsZero
  : forall e,
    e <<- TNat ->
    (IsZero e) <<- TBool
where "e '<<-' t" := (has_type e t).

Hint Constructors has_type.

Lemma bool_canonical : forall e, e <<- TBool -> value e -> bvalue e.
Proof.
  intros e H Hv ; inverts Hv ; inverts H ; repeat s ; auto.
Qed.

Lemma nat_canonical : forall e, e <<- TNat -> value e -> nvalue e.
Proof.
  intros e H Hv ; inverts H ; inverts Hv ; repeat s ; auto.
Qed.

Hint Resolve bool_canonical nat_canonical.

Theorem progress : forall e t, e <<- t -> value e \/ exists e', e ==> e'.
Proof.
  induction 1 ; try solve [left ; auto] ;
    try repeat (match goal with
                | [H : _ \/ _ |- _] => destruct H
                | [H : ex _ |- _] => destruct H
                | [H : value _ |- _] => inverts H
                | [H : bvalue _ |- _] => inverts H
                | [H : T <<- _ |- _] => inverts H
                | [H : F <<- _ |- _] => inverts H
                | [H : nvalue _ |- context[(Pred _)]] => inverts H
                | [H : nvalue _ |- context[(IsZero _)]] => inverts H
                | [H : ?e <<- TBool , H1 : nvalue ?e |- _] =>
                  inverts H1 ; inverts H
                end ; try solve [ right ; eexists ; eauto ] ; auto).
Qed.

Theorem preservation : forall e t, e <<- t -> forall e', e ==> e' -> e' <<- t.
Proof.
  induction 1 ; intros ; repeat (s ; eauto) ;
    try repeat (match goal with
                | [H : _ ==> _ |- _] => inverts H ; eauto
                | [H : (Succ _) <<- _ |- _] => inverts H ; eauto
                end).
Qed.

(* notations for subset types -- sig types *)

Notation "!" := (False_rec _ _).
Notation "[ e ]" := (exist _ e _).

(* notations for sumbool types *)

Notation "'Yes'" := (left _ _).
Notation "'No'" := (right _ _).
Notation "'Reduce' x" := (if x then Yes else No) (at level 50).
Notation "x || y" := (if x then Yes else Reduce y).

(* notations for sumor *)

Notation "!!" := (inright _ _).
Notation "[|| x ||]" := (inleft _ [x]).

Notation "x <-- e1 ; e2" := (match e1 with
                               | inright _ => !!
                               | inleft (exist _ x _) => e2
                             end)
                              (right associativity, at level 60).

Notation "e1 ;;; e2" := (if e1 then e2 else !!)
                          (right associativity, at level 60).

Definition eq_ty_dec : forall (t t' : type), {t = t'} + {t <> t'}.
  decide equality.
Defined.

Theorem has_type_det : forall e t, e <<- t -> forall t', e <<- t' -> t = t'.
Proof.
  induction 1 ; intros t' Hc ; inverts Hc ; eauto.
Qed.

Hint Resolve has_type_det.

Definition typecheck : forall e, {t | e <<- t} + {forall t, ~ (e <<- t)}.
  refine (fix tc (e : exp) : {t | e <<- t} + {forall t, ~ (e <<- t)} :=
            match e as e' return e = e' -> {t | e' <<- t} + {forall t, ~ (e' <<- t)} with
            | T  => fun _ => [|| TBool ||]
            | F  => fun _ => [|| TBool ||]
            | Zero  => fun _ => [|| TNat ||]
            | Succ e => fun _ =>
                          ty <-- tc e ;
                          eq_ty_dec ty TNat ;;;
                          [|| TNat ||]
            | Pred e => fun _ =>
                          ty <-- tc e ;
                          eq_ty_dec ty TNat ;;;
                          [|| TNat ||]
            | IsZero e => fun _ =>
                          ty <-- tc e ;
                          eq_ty_dec ty TNat ;;;
                          [|| TBool ||]
            | If e e1 e2 => fun _ =>
                          ty <-- tc e ;
                          ty1 <-- tc e1 ;
                          ty2 <-- tc e2 ;
                          eq_ty_dec ty TBool ;;;
                          eq_ty_dec ty1 ty2  ;;;
                          [|| ty1 ||]
            end eq_refl) ; clear tc ;
           simpl in * ; subst ;
             try (intro ; intro) ;
             try (match goal with
                  | [ H : _ <<- _ |- _] => inverts H
                  end) ;
                 try (match goal with
                      | [ H : forall x, ~ (_ <<- _) |- False ] => eapply H ; eauto
                    | [H : ?e <<- ?t , H1 : ?e <<- ?t' |- _] =>
                      eapply (has_type_det H) in H1 ; subst
                      end) ; eauto.
Defined.


(***************************************************************)
(* Coq code for OCAP                                           *)
(*                                                             *)
(* Utilities for manipulating natural numbers                  *)
(*                                                             *)
(*                                                             *)
(***************************************************************)

(* $Id: IntBool.v 21 2012-08-16 14:14:35Z guoyu $ *)

Require Import ZArith.
Require Export Bool.

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

Definition int := Z.

Open Scope Z_scope.

Theorem int_eq_dec : forall a b : int, {a = b} + {a <> b}.
Proof.
  apply Z_eq_dec.
Qed.

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

Fixpoint blt_pos (p q : positive) {struct p} : bool :=
  match (Pcompare p q Eq) with
    | Lt => true
    | _  => false
  end.

Fixpoint blt_int (n m : int) {struct n} : bool :=
  match n, m with
    | Z0, Zpos p => true
    | Zneg p, Z0 => true
    | Zneg p, Zpos q => true
    | Zneg p, Zneg q => blt_pos q p
    | Zpos p, Zpos q => blt_pos p q
    | _, _ => false
  end.

Lemma blt_pos_irrefl :
  forall p : positive, blt_pos p p = false.
Proof.
  induction p; simpl; auto with arith.
  rewrite Pcompare_refl; trivial.
  rewrite Pcompare_refl; trivial.
Qed.

Lemma blt_irrefl :
  forall a : int, blt_int a a = false.
Proof.
  destruct a; simpl; auto with arith.
  apply blt_pos_irrefl; trivial.
  apply blt_pos_irrefl; trivial.
Qed.

Lemma blt_irrefl_Prop :
  forall a : int, ~ (blt_int a a = true).
Proof.
  induction a; simpl; auto with arith.
  intro H. rewrite blt_pos_irrefl in H.
  discriminate.
  intro H; rewrite blt_pos_irrefl in H; discriminate.
Qed.

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

Fixpoint beq_pos (p p' : positive) {struct p} : bool :=
  match p, p' with
    | x~0, x'~0 => andb true (beq_pos x x')
    | p~1, p'~1 => andb true (beq_pos p p')
    | 1, 1 => true
    | _, _ => false
  end %positive.

Fixpoint beq_int (z z' : int) {struct z} : bool :=
  match z, z' with
    | Z0, Z0 => true
    | Zpos p, Zpos p' => beq_pos p p'
    | Zneg p, Zneg p' => beq_pos p p'
    | _, _ => false
  end.

Lemma beq_int_true_eq : forall z z' : int,
  beq_int z z' = true -> z = z'.
Proof.
  intros.
  induction z;destruct z';try inversion H;trivial.
  clear -H1.
  generalize dependent p0.
  induction p.
  intros.
  destruct p0.
  simpl in H1.
  apply IHp in H1.
  rewrite Zpos_xI.
  rewrite Zpos_xI.
  rewrite H1.
  trivial.
  inversion H1.
  inversion H1.
  intros.
  destruct p0.
  inversion H1.
  simpl in H1.
  apply IHp in H1.
  rewrite Zpos_xO.
  symmetry.
  rewrite Zpos_xO.
  rewrite H1.
  trivial.
  inversion H1.
  intros.
  destruct p0;try inversion H1;trivial.
  generalize dependent p0.
  induction p.
  intros.
  destruct p0.
  simpl in H1.
  apply IHp in H1.
  rewrite Zneg_xI.
  rewrite Zneg_xI.
  rewrite H1;trivial.
  simpl in H.
  simpl.
  assumption.
  inversion H1.
  inversion H1.
  intros.
  destruct p0.
  inversion H1.
  simpl in H1.
  apply IHp in H1.
  rewrite Zneg_xO.
  rewrite Zneg_xO.
  rewrite H1.
  trivial.
  simpl in H.
  simpl.
  assumption.
  inversion H1.
  intros.
  destruct p0;inversion H1;trivial.
Qed.

Lemma beq_int_false_neq : forall z z' : int,
  beq_int z z' = false -> z <> z'.
Proof.
  intros z z' Hbeq Hz.
  subst z'.
  induction z;try inversion Hbeq;induction p;try apply IHp;try assumption;try inversion Hbeq.
Qed.

Lemma eq_beq_int_true : forall z z' : int,
  z = z' -> beq_int z z' = true.
Proof.
  intros.
  subst z'.
  induction z;trivial;induction p;try assumption;trivial.
Qed.

Lemma neq_beq_int_false : forall z z' : int,
  z <> z' -> beq_int z z' = false.
Proof.
  intros.
  induction z.
  destruct z'.
  case H.
  trivial.
  trivial.
  trivial.
  destruct z'.
  trivial.
  simpl.
  generalize dependent p0.
  induction p.
  intros.
  destruct p0.
  simpl.
  apply IHp.
  rewrite Zpos_xI in H.
  rewrite Zpos_xI in H.
  intro.
  rewrite H0 in H.
  case H;trivial.
  trivial.
  trivial.
  intros.
  destruct p0.
  trivial.
  trivial.
  apply IHp.
  intro.
  apply H.
  rewrite Zpos_xO.
  symmetry.
  rewrite Zpos_xO.
  rewrite H0.
  trivial.
  trivial.
  intros.
  destruct p0;trivial;try case H;trivial.
  trivial.
  destruct z'.
  trivial.
  trivial.
  simpl.
  generalize dependent p0.
  induction p.
  intros.
  destruct p0.
  simpl.
  apply IHp.
  intro.
  rewrite Zneg_xI in H.
  rewrite Zneg_xI in H.
  rewrite H0 in H.
  case H;trivial.
  trivial.
  trivial.
  intros.
  destruct p0.
  trivial.
  simpl.
  apply IHp.
  intro.
  rewrite Zneg_xO in H.
  rewrite Zneg_xO in H.
  rewrite H0 in H.
  case H;trivial.
  trivial.
  intros.
  destruct p0;trivial;try case H;trivial.
Qed.

Lemma beq_int_dec : forall a b,
  {beq_int a b = true} + {beq_int a b = false}.
Proof.
  intros; destruct (beq_int a b); [left |  right];  trivial.
Qed.

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

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

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

(* for beq int *)

Ltac beq_case_tac x y :=
  let Hb := fresh "Hb" in
    (destruct (beq_int_dec x y) as [Hb | Hb]; trivial).

Tactic Notation "bint" "case" constr(i) constr (i') := beq_case_tac i i'.
(*
Ltac simpl_int_tac :=
  match goal with

    (* beq rewrite directly *)
    | [H : beq_int ?x ?y = ?f
      |- context [(beq_int ?x ?y)]] =>
       rewrite H; simpl_int_tac
    | [H : beq_int ?x ?y = ?f,
       H0 : context [(beq_int ?x ?y)] |- _ ] =>
       rewrite H in H0; simpl_int_tac

    (* beq_refl *)
    | [ |- context [(beq_int ?x ?x)] ] =>
      rewrite (beq_int_refl x); simpl_int_tac
    | [H : context [(beq_int ?x ?x)] |- _ ] =>
      rewrite (beq_int_refl x) in H; simpl_int_tac

    (* beq_sym *)
    | [ H : beq_int ?x ?y = ?b
        |- context [(beq_int ?y ?x)] ] =>
      rewrite (beq_int_sym x y b H); simpl_int_tac
    | [H : beq_int ?x ?y = ?b,
       H0 : context [(beq_int ?y ?x)] |- _ ] =>
      rewrite (beq_int_sym x y b H) in H0; simpl_int_tac

    (* (* neq -> beq *) *)
    (* | [ H : ?x <> ?y |- context [(beq_int ?x ?y)] ] =>  *)
    (*   rewrite (neq_beq_int_false x y H); simpl_int_tac *)
    (* | [ H : ?x <> ?y,  *)
    (*     H0 : context [(beq_int ?x ?y)] |- _ ] =>  *)
    (*   rewrite (neq_beq_false x y H) in H0; simplbnat *)

    (* | [ H : ?y <> ?x |- context [(beq_int ?x ?y)] ] =>  *)
    (*   rewrite (neq_beq_false x y (sym_not_eq H)); simplbnat *)
    (* | [ H : ?y <> ?x,  *)
    (*     H0 : context [(beq_int ?x ?y)] |- _ ] =>  *)
    (*   rewrite (neq_beq_false x y (sym_not_eq H)) in H0; simplbnat *)

    | [H : ?x = ?x |- _ ] => clear H; simpl_int_tac
    | [H : true = false |- _ ] => discriminate H
    | [H : false = true |- _ ] => discriminate H
    | _ => idtac
  end.

Tactic Notation "bint" "simpl" := simpl_int_tac.

Ltac rew_beq_tac H :=
  match type of H with
    | beq_int ?a ?b = true =>
      match goal with
        | [ |- context [(?a)]] =>
          rewrite (beq_int_true_eq a b H)
        | [ |- context [(?b)]] =>
          rewrite <- (beq_int_true_eq a b H)
      end
    | _ => fail
  end.

Tactic Notation "bint" "rewrite" constr(t) := rew_beq_tac t.

Ltac rewH_beq_tac H H' :=
  match type of H with
    | beq_int ?a ?b = true =>
      match goal with
        | [ H' : context [(?a)] |- _ ] =>
          rewrite (beq_int_true_eq a b H) in H'
        | [ H' : context [(?b)] |- _ ] =>
          rewrite <- (beq_int_true_eq a b H) in H'
      end
    | _ => fail
  end.

Tactic Notation "bint" "rewrite" constr(t) "in" hyp(H) := rewH_beq_tac t H.

*)


Require Export List. Export ListNotations.
Require Import ZArith Lia.
Local Open Scope Z_scope.
Require Import VST.zlist.sublist.

Fixpoint repeat_op_nat{T: Type}(n: nat)(start: T)(op: T -> T): T := match n with
| O => start
| S m => op (repeat_op_nat m start op)
end.

Definition repeat_op{T: Type}(n: Z)(start: T)(op: T -> T): T := repeat_op_nat (Z.to_nat n) start op.

Lemma repeat_op_step: forall {T: Type} (i: Z) (start: T) (op: T -> T),
  0 <= i ->
  repeat_op (i + 1) start op = op (repeat_op i start op).
Proof.
  intros. unfold repeat_op. rewrite Z2Nat.inj_add by lia.
  rewrite Nat.add_1_r. simpl. reflexivity.
Qed.

Fixpoint repeat_op_table_nat{T: Type}(n: nat)(start: T)(op: T -> T): list T := match n with
| O => []
| S m => (repeat_op_table_nat m start op) ++ [repeat_op_nat m start op]
end.

Definition repeat_op_table{T: Type}(n: Z)(start: T)(op: T -> T): list T :=
  repeat_op_table_nat (Z.to_nat n) start op.

Lemma repeat_op_table_step: forall {T: Type} (i: Z) (start: T) (op: T -> T),
  0 <= i ->
  repeat_op_table (i + 1) start op = (repeat_op_table i start op) ++ [repeat_op i start op].
Proof.
  intros. unfold repeat_op_table. rewrite Z2Nat.inj_add by lia.
  rewrite Nat.add_1_r. simpl. reflexivity.
Qed.

Lemma repeat_op_table_nat_length: forall {T: Type} (i: nat) (x: T) (f: T -> T),
  length (repeat_op_table_nat i x f) = i.
Proof.
  intros. induction i. reflexivity. simpl. rewrite app_length. simpl.
  rewrite IHi. lia.
Qed.

Lemma repeat_op_table_length: forall {T: Type} (i: Z) (x: T) (f: T -> T),
  0 <= i ->
  Zlength (repeat_op_table i x f) = i.
Proof.
  intros. unfold repeat_op_table.
  rewrite Zlength_correct. rewrite repeat_op_table_nat_length.
  apply Z2Nat.id. assumption.
Qed.

Lemma repeat_op_nat_id: forall {T: Type} (n: nat) (v: T),
  repeat_op_nat n v id = v.
Proof.
  intros. induction n.
  - reflexivity.
  - simpl. apply IHn.
Qed.

Lemma repeat_op_table_nat_id_app: forall {T: Type} (len1 len2: nat) (v: T),
  repeat_op_table_nat (len1 + len2) v id
  = repeat_op_table_nat len1 v id ++ repeat_op_table_nat len2 v id.
Proof.
  intros. induction len2.
  - simpl. replace (len1 + 0)%nat with len1 by lia. rewrite app_nil_r. reflexivity.
  - replace (len1 + S len2)%nat with (S (len1 + len2)) by lia. simpl.
    rewrite IHlen2. rewrite <- app_assoc. f_equal. f_equal. do 2 rewrite repeat_op_nat_id.
    reflexivity.
Qed.

Lemma sublist_repeat_op_table_id: forall {T: Type} (lo n: Z) (v: T),
  0 <= lo ->
  0 <= n ->
  sublist lo (lo + n) (repeat_op_table (lo + n) v id) = repeat_op_table n v id.
Proof.
  intros.
  replace (lo + n) with (Zlength (repeat_op_table (lo + n) v id)) at 1
    by (apply repeat_op_table_length; lia).
  rewrite sublist_skip by lia.
  unfold repeat_op_table at 1. rewrite Z2Nat.inj_add by lia.
  rewrite repeat_op_table_nat_id_app.
  rewrite Zskipn_app1 by (
    rewrite Zlength_correct;
    rewrite repeat_op_table_nat_length;
    rewrite Z2Nat.id; lia
  ).
  rewrite skipn_short; [ reflexivity | ].
  rewrite repeat_op_table_nat_length. lia.
Qed.

Fixpoint fill_list_nat{T: Type}(n: nat)(f: nat -> T): list T := match n with
| O => []
| S m => (fill_list_nat m f) ++ [f m]
end.

Definition fill_list{T: Type}(n: Z)(f: Z -> T): list T :=
  fill_list_nat (Z.to_nat n) (fun i => f (Z.of_nat i)).

Lemma fill_list_step: forall {T: Type} (n: Z) (f: Z -> T),
  0 <= n ->
  fill_list (n + 1) f = fill_list n f ++ [f n].
Proof.
  intros. unfold fill_list. rewrite Z2Nat.inj_add by lia.
  rewrite Nat.add_1_r. simpl. rewrite Z2Nat.id by lia. reflexivity.
Qed.

Ltac eval_list l :=
  let l' := eval hnf in l in lazymatch l' with
  | ?h :: ?tl => let tl' := eval_list tl in constr:(h :: tl')
  | (@nil ?T) => constr:(@nil T)
  end.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


Require Import List PeanoNat.
Import ListNotations.

Fixpoint list_in (l: list nat) (n: nat) :=
  match l with
  | [] => false
  | h :: t =>
    match Nat.eqb n h with
    | true => true
    | false => list_in t n
    end
  end.

Fixpoint unique (l: list nat) :=
  match l with
  | [] => []
  | h :: t =>
    match list_in t h with
    | true => unique t
    | false => h :: unique t
    end
  end.

Definition task := forall l n, list_in l n = true -> count_occ Nat.eq_dec (unique l) n = 1.


From LF Require Export Poly.

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

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

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

(*Exercise 1*)
(** Complete the following proof without using [simpl]. *)
Theorem silly_ex :
     (forall n, evenb n = true -> oddb (S n) = true) ->
     evenb 3 = true ->
     oddb 4 = true.
Proof.
  intros. apply H. apply H0. Qed.

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

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

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

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

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

(*Exercise 3*)
Example trans_eq_exercise : forall (n m o p : nat),
     m = (minustwo o) ->
     (n + p) = m ->
     (n + p) = (minustwo o).
Proof.
  intros. rewrite <- H. apply H0. Qed.

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

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

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

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

Theorem beq_nat_0_l : forall n,
   eqb 0 n = true -> n = 0.
Proof.
  intros n.
  destruct n as [| n'].
  - (* n = 0 *)
    intros H. reflexivity.
  - (* n = S n' *)
    simpl.
    intros H. inversion H. Qed.

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

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

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

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

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

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

(*Exercise 6*)
Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
   - simpl. intros m eq. destruct m as [| m'].
    + reflexivity.
    +  inversion eq.
  - simpl. intros m eq.
    destruct m as [| m'].
    + simpl. inversion eq.
    + apply f_equal.
      apply IHn'. inversion eq. rewrite plus_comm in H0. symmetry in H0.
    rewrite plus_comm in H0. simpl in H0.
    inversion H0. reflexivity. Qed.

(*Exercise 7: Use backward reasoning*)
Theorem example1:
  forall p q r,
  (p -> q -> r) -> p -> q -> r.

Proof.
  intros p q r H. apply H. Qed.

(*Exercise 8: Use forward reasoning*)
Theorem example2:
  forall p q r,
  (p -> q -> r) -> p -> q -> r.

Proof.
  intros. apply X in X0. apply X0. apply X1. Qed.

(*Exercise 9: Don't use rewrite!*)
Theorem length_nil:
  forall (X: Type) (l: list X),
  l = [] -> length l = 0.

Proof.
  intros. inversion H. simpl. reflexivity. Qed.

(*Exercise 10: *)
Theorem xxx :
  forall (X: Type) (l t: list X) (h: X),
  l = h :: t -> leb 1 (length l) = true.

Proof.
  intros. inversion H. simpl. reflexivity. Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Omega Permutation.

Set Implicit Arguments.

Infix "~p" := (@Permutation _) (at level 80, no associativity).

Section map.

  Variables (X Y : Type) (f g : X -> Y).

  Fact map_ext_dep l : (forall x, In x l -> f x = g x) -> map f l = map g l.
  Proof. rewrite <- Forall_forall; induction 1; simpl; f_equal; auto. Qed.

  Fact map_ext : (forall x, f x = g x) -> (forall l, map f l = map g l).
  Proof. intros; apply map_ext_dep; auto. Qed.

End map.

Definition list_length_split X n (ll : list X) :
    { l : _ & { r | ll = l++r /\ length l = n } } + { length ll < n }.
Proof.
  revert ll; induction n as [ | n IHn ].
  + left; exists nil, ll; auto.
  + intros [ | x ll ].
    * right; simpl; omega.
    * destruct (IHn ll) as [ (l & r & H1 & H2) | H1 ].
      - left; exists (x::l), r; split; subst; auto.
      - right; simpl; omega.
Qed.

Definition list_length_prefix X n (ll : list X) :
    n <= length ll -> { l : _ & { r | ll = l++r /\ length l = n } }.
Proof. intro; destruct (list_length_split n ll); trivial; omega. Qed.

Section list_length_eq_ind.

  Variable (X : Type) (P : list X -> list X -> Prop)
           (HP0 : P nil nil)
           (HP1 : forall x y l m, length l = length m -> P l m -> P (x::l) (y::m)).

  Theorem list_length_eq_ind l m : length l = length m -> P l m.
  Proof.
    intros H; cut (Forall2 (fun _ _ => True) l m).
    + induction 1; auto.
    + revert m H; induction l; intros [|]; auto; discriminate.
  Qed.

End list_length_eq_ind.

Section app.

  Variable X : Type.

  Fact split_In ll l (x : X) r : ll = l++x::r -> In x ll.
  Proof. intros; subst; apply in_or_app; simpl; auto. Qed.

  Fact in_concat_iff ll (x : X) : In x (concat ll) <-> exists l, In x l /\ In l ll.
  Proof.
    split.
    * induction ll as [ | l ll IH ]; simpl.
      - intros [].
      - intros H; apply in_app_or in H.
        destruct H as [ H | H ].
        + exists l; split; auto.
        + destruct IH as (l1 & ? & ?); auto; exists l1; auto.
   * intros (l & H1 & H2).
     apply in_split in H2.
     destruct H2 as (ll1 & ll2 & ?); subst.
     rewrite concat_app; apply in_or_app; simpl; right.
     apply in_or_app; simpl; auto.
  Qed.

End app.

Section incl.

  Variable X : Type.

  Implicit Type l : list X.

  Fact incl_cons_linv l m x : incl (x::m) l -> In x l /\ incl m l.
  Proof.
    intros H; split.
    + apply H; left; auto.
    + intros ? ?; apply H; right; auto.
  Qed.

  Fact incl_app_rinv l m p : incl m (l++p) -> exists m1 m2, m ~p m1++m2 /\ incl m1 l /\ incl m2 p.
  Proof.
    induction m as [ | x m IHm ].
    + exists nil, nil; simpl; repeat split; auto; intros ? [].
    + intros H.
      apply incl_cons_linv in H.
      destruct H as (H1 & H2).
      destruct (IHm H2) as (m1 & m2 & H3 & H4 & H5).
      apply in_app_or in H1; destruct H1.
      * exists (x::m1), m2; repeat split; auto.
        - constructor 2; auto.
        - intros ? [|]; subst; auto.
      * exists m1, (x::m2); repeat split; auto.
        - apply Permutation_cons_app; auto.
        - intros ? [|]; subst; auto.
  Qed.

  Fact incl_cons_rinv x l m : incl m (x::l) -> exists m1 m2, m ~p m1 ++ m2 /\ Forall (eq x) m1 /\ incl m2 l.
  Proof.
    intros H.
    apply (@incl_app_rinv (x::nil) _ l) in H.
    destruct H as (m1 & m2 & H1 & H2 & H3).
    exists m1, m2; repeat split; auto.
    rewrite Forall_forall.
    intros a Ha; apply H2 in Ha; destruct Ha as [ | [] ]; auto.
  Qed.

  Fact incl_right_cons_choose x l m : incl m (x::l) -> In x m \/ incl m l.
  Proof.
    intros H.
    apply incl_cons_rinv in H.
    destruct H as ( m1 & m2 & H1 & H2 & H3 ); simpl in H1.
    destruct m1 as [ | y m1 ].
    + right.
      intros u H; apply H3; revert H.
      apply Permutation_in; auto.
    + left.
      apply Permutation_in with (1 := Permutation_sym H1).
      rewrite Forall_forall in H2.
      rewrite (H2 y); left; auto.
  Qed.

  Fact incl_left_right_cons x l y m : incl (x::l) (y::m) -> y = x  /\ In y l
                                                         \/ y = x  /\ incl l m
                                                         \/ In x m /\ incl l (y::m).
  Proof.
    intros H; apply incl_cons_linv in H.
    destruct H as [ [|] H2 ]; auto.
    apply incl_right_cons_choose in H2; tauto.
  Qed.

  Fact perm_incl_left m1 m2 l: m1 ~p m2 -> incl m2 l -> incl m1 l.
  Proof. intros H1 H2 ? H. apply H2; revert H; apply Permutation_in; auto. Qed.

  Fact perm_incl_right m l1 l2: l1 ~p l2 -> incl m l1 -> incl m l2.
  Proof.
    intros H1 H2 ? ?; apply Permutation_in with (1 := H1), H2; auto.
  Qed.

End incl.

Section Permutation_tools.

  Variable X : Type.

  Implicit Types (l : list X).

  Theorem Permutation_In_inv l1 l2: l1 ~p l2 -> forall x, In x l1 -> exists l, exists r, l2 = l++x::r.
  Proof. intros H ? ?; apply in_split, Permutation_in with (1 := H); auto. Qed.

  Fact perm_in_head x l : In x l -> exists m, l ~p x::m.
  Proof.
    induction l as [ | y l IHl ].
    + destruct 1.
    + intros [ ? | H ]; subst.
      * exists l; apply Permutation_refl.
      * destruct (IHl H) as (m & Hm).
        exists (y::m).
        apply Permutation_trans with (2 := perm_swap _ _ _).
        constructor 2; auto.
  Qed.

End Permutation_tools.

Section Forall.

  Variable (X : Type) (R : X -> Prop).

  Fact Forall_app l m : Forall R l -> Forall R m -> Forall R (l++m).
  Proof. induction 1; simpl; auto. Qed.

  Fact Forall_map Y f l : Forall (fun y : Y => R (f y)) l -> Forall R (map f l).
  Proof. induction 1; constructor; auto. Qed.

End Forall.

Section Forall2.

  Variables (X Y : Type) (R : X -> Y -> Prop).

  Fact Forall2_length l m : Forall2 R l m -> length l = length m.
  Proof. induction 1; simpl; f_equal; auto. Qed.

  Fact Forall2_nil_inv_right l : Forall2 R nil l -> l = nil.
  Proof. inversion 1; auto. Qed.

  Fact Forall2_cons_inv x l y m : Forall2 R (x::l) (y::m) -> R x y /\ Forall2 R l m.
  Proof. inversion 1; auto. Qed.

  Fact Forall2_rev l m : Forall2 R l m -> Forall2 R (rev l) (rev m).
  Proof. induction 1; simpl; auto; apply Forall2_app; simpl; auto. Qed.

  Fact Forall2_app_inv l1 l2 m1 m2 : length l1 = length m1
                                  -> Forall2 R (l1++l2) (m1++m2)
                                  -> Forall2 R l1 m1 /\ Forall2 R l2 m2.
  Proof.
    revert m1; induction l1 as [ | x l1 IH ]; intros [ | y m1 ];
      try discriminate; simpl; intros H1 H2; auto.
    apply Forall2_cons_inv in H2.
    destruct H2; destruct (IH m1); auto.
  Qed.

  Fact Forall2_snoc_inv l x m y : Forall2 R (l++x::nil) (m++y::nil) -> R x y /\ Forall2 R l m.
  Proof.
    intros H.
    apply Forall2_rev in H.
    rewrite rev_app_distr, rev_app_distr in H; simpl in H.
    apply Forall2_cons_inv in H; destruct H as [ H1 H ]; split; auto.
    rewrite <- (rev_involutive l), <- (rev_involutive m); apply Forall2_rev; auto.
  Qed.

  Fact Forall2_2snoc_inv l a b m u v : Forall2 R (l++a::b::nil) (m++u::v::nil)
                                    -> R a u /\ R b v /\ Forall2 R l m.
  Proof.
    replace (l++a::b::nil) with ((l++a::nil)++b::nil) by (rewrite app_ass; auto).
    replace (m++u::v::nil) with ((m++u::nil)++v::nil) by (rewrite app_ass; auto).
    intros H.
    apply Forall2_snoc_inv in H; destruct H as (H1 & H).
    apply Forall2_snoc_inv in H; tauto.
  Qed.

  Hint Resolve Forall2_app.

  Fact Forall2_concat l m : Forall2 (Forall2 R) l m -> Forall2 R (concat l) (concat m).
  Proof. induction 1; simpl; auto. Qed.

  Fact Forall2_sym l m : Forall2 R l m -> Forall2 (fun y x => R x y) m l.
  Proof. induction 1; constructor; auto. Qed.

  Fact Forall2_In_inv_left l m x : Forall2 R l m -> In x l -> exists y, In y m /\ R x y.
  Proof. induction 1; intros []; subst; firstorder. Qed.

End Forall2.

Hint Resolve Forall2_app.

Tactic Notation "Forall2" "inv" hyp(H) "as" ident(E) :=
  match type of H with
    | Forall2 _ nil _ => apply Forall2_nil_inv_right in H; rename H into E
    | Forall2 _ (_::_) (_::_) => apply Forall2_cons_inv in H; destruct H as [ E H ]
    | Forall2 _ (_++_::nil) (_++_::nil) => apply Forall2_snoc_inv in H; destruct H as [ E H ]
    | Forall2 _ (_++_) (_++_) => apply Forall2_app_inv in H; [ destruct H as [ E H ] | ]
  end.

Fact Forall2_map_left X Y Z (f : X -> Y) (R : Y -> Z -> Prop) l m :
     Forall2 (fun x z => R (f x) z) l m -> Forall2 R (map f l) m.
Proof. induction 1; simpl; auto. Qed.

Fact Forall2_mono X Y (R S : X -> Y -> Prop) l m :
        (forall x y, R x y -> S x y)
     -> Forall2 R l m -> Forall2 S l m.
Proof. induction 2; auto. Qed.

Section seq_an.

  (* seq_an a n = [a;a+1;...;a+(n-1)] *)

  Fixpoint seq_an a n: list nat :=
    match n with
      | 0    => nil
      | S n  => a::seq_an (S a) n
    end.

  Fact seq_an_length a n : length (seq_an a n) = n.
  Proof. revert a; induction n; simpl; intros; f_equal; auto. Qed.

  Fact seq_an_spec a n x : In x (seq_an a n) <-> a <= x < a+n.
  Proof.
    revert x a; induction n as [ | n IHn ]; intros x a; simpl;
      [ | rewrite IHn ]; omega.
  Qed.

  Fixpoint is_seq_from n (l : list nat) { struct l }: Prop :=
    match l with
      | nil  => True
      | x::l => n=x /\ is_seq_from (S n) l
    end.

  Theorem is_seq_from_spec a l : is_seq_from a l <-> exists n, l = seq_an a n.
  Proof.
    revert a; induction l as [ | x l IH ]; intros a; simpl.
    + split; auto; exists 0; auto.
    + rewrite IH; split.
      * intros (? & n & Hn); subst x; exists (S n); subst; auto.
      * intros ([ | n ] & ?); subst; try discriminate.
        simpl in H; inversion H; subst; split; auto.
        exists n; auto.
  Qed.

End seq_an.


Require Export FunctionProperties.
Require Export Ensembles.
Require Import EnsemblesImplicit.
Require Export EnsemblesSpec.

Definition inverse_image {X Y:Type} (f:X->Y) (T:Ensemble Y) : Ensemble X :=
  [ x:X | In T (f x) ].
Hint Unfold inverse_image : sets.

Lemma inverse_image_increasing: forall {X Y:Type} (f:X->Y)
  (T1 T2:Ensemble Y), Included T1 T2 ->
  Included (inverse_image f T1) (inverse_image f T2).
Proof.
intros.
red; intros.
destruct H0.
constructor.
auto.
Qed.

Lemma inverse_image_empty: forall {X Y:Type} (f:X->Y),
  inverse_image f Empty_set = Empty_set.
Proof.
intros.
apply Extensionality_Ensembles; split; red; intros.
destruct H as [[]].
destruct H.
Qed.

Lemma inverse_image_full: forall {X Y:Type} (f:X->Y),
  inverse_image f Full_set = Full_set.
Proof.
intros.
apply Extensionality_Ensembles; split; red; intros;
  constructor; constructor.
Qed.

Lemma inverse_image_intersection: forall {X Y:Type} (f:X->Y)
  (T1 T2:Ensemble Y), inverse_image f (Intersection T1 T2) =
  Intersection (inverse_image f T1) (inverse_image f T2).
Proof.
intros.
apply Extensionality_Ensembles; split; red; intros.
destruct H.
inversion H.
constructor; constructor; trivial.

destruct H as [? [] []].
constructor; constructor; trivial.
Qed.

Lemma inverse_image_union: forall {X Y:Type} (f:X->Y)
  (T1 T2:Ensemble Y), inverse_image f (Union T1 T2) =
  Union (inverse_image f T1) (inverse_image f T2).
Proof.
intros.
apply Extensionality_Ensembles; split; red; intros.
destruct H.
inversion H.
left; constructor; trivial.
right; constructor; trivial.

constructor.
destruct H as [? []|? []].
left; trivial.
right; trivial.
Qed.

Lemma inverse_image_complement: forall {X Y:Type} (f:X->Y)
  (T:Ensemble Y), inverse_image f (Complement T) =
  Complement (inverse_image f T).
Proof.
intros.
apply Extensionality_Ensembles; split; red; intros.
red; intro.
destruct H.
destruct H0.
contradiction H.

constructor.
intro.
contradiction H.
constructor; trivial.
Qed.

Lemma inverse_image_composition: forall {X Y Z:Type} (f:Y->Z) (g:X->Y)
  (U:Ensemble Z), inverse_image (fun x:X => f (g x)) U =
  inverse_image g (inverse_image f U).
Proof.
intros.
apply Extensionality_Ensembles; split; red; intros.
constructor; constructor.
destruct H.
assumption.

destruct H; inversion H.
constructor; trivial.
Qed.

Hint Resolve @inverse_image_increasing : sets.
Hint Rewrite @inverse_image_empty @inverse_image_full
  @inverse_image_intersection @inverse_image_union
  @inverse_image_complement @inverse_image_composition : sets.

Require Import IndexedFamilies.

Lemma inverse_image_indexed_intersection :
  forall {A X Y:Type} (f:X->Y) (F:IndexedFamily A Y),
    inverse_image f (IndexedIntersection F) =
    IndexedIntersection (fun a:A => inverse_image f (F a)).
Proof.
intros.
apply Extensionality_Ensembles; split; red; intros.
- destruct H.
  inversion_clear H.
  constructor. intros.
  constructor.
  apply H0.
- destruct H.
  constructor.
  constructor. intros.
  destruct (H a).
  exact H0.
Qed.

Lemma inverse_image_indexed_union :
  forall {A X Y:Type} (f:X->Y) (F:IndexedFamily A Y),
    inverse_image f (IndexedUnion F) =
    IndexedUnion (fun a:A => inverse_image f (F a)).
Proof.
intros.
apply Extensionality_Ensembles; split; red; intros.
- destruct H.
  inversion_clear H.
  exists a.
  constructor.
  exact H0.
- destruct H.
  inversion_clear H.
  constructor.
  exists a.
  exact H0.
Qed.

Lemma inverse_image_fun
  {X Y : Type}
  (f : X -> Y)
  (T : Ensemble Y) :
  inverse_image f T = fun x => T (f x).
Proof.
  apply Extensionality_Ensembles.
  split;
    red;
    intros;
    constructor + destruct H;
    assumption.
Qed.

Lemma in_inverse_image
  {X Y : Type}
  (f : X -> Y)
  (T : Ensemble Y)
  (x : X) :
  In T (f x) <-> In (inverse_image f T) x.
Proof.
  rewrite inverse_image_fun.
  split; auto.
Qed.

Lemma inverse_image_id
  {X Y : Type}
  {f : X -> Y}
  {g : Y -> X} :
  (forall y, f (g y) = y) ->
  forall S,
    inverse_image g (inverse_image f S) = S.
Proof.
  intros Hfg S.
  rewrite <- inverse_image_composition.
  apply Extensionality_Ensembles.
  split; red; intros.
  - destruct H.
    rewrite <- Hfg.
    assumption.
  - constructor.
    rewrite Hfg.
    assumption.
Qed.

Lemma inverse_image_empty_set {X Y : Type} (f : X -> Y) :
  inverse_image f Empty_set = Empty_set.
Proof.
apply Extensionality_Ensembles.
split; red; intros;
  repeat destruct H.
Qed.

Lemma inverse_image_full_set {X Y : Type} (f : X -> Y) :
  inverse_image f Full_set = Full_set.
Proof.
apply Extensionality_Ensembles.
split; red; intros;
  repeat constructor.
Qed.

Lemma inverse_image_union2 {X Y : Type} (f : X -> Y) (U V : Ensemble Y) :
  inverse_image f (Union U V) = Union (inverse_image f U) (inverse_image f V).
Proof.
apply Extensionality_Ensembles.
split; red; intros.
- destruct H.
  inversion H;
    subst;
  [ left | right ];
    now constructor.
- now inversion H;
    destruct H0;
    subst;
    constructor;
  [ left | right ].
Qed.

Lemma inverse_image_family_union
  {X Y : Type}
  {f : X -> Y}
  {g : Y -> X}
  (F : Family Y) :
  (forall x, g (f x) = x) ->
  (forall y, f (g y) = y) ->
  inverse_image f (FamilyUnion F) = FamilyUnion (inverse_image (inverse_image g) F).
Proof.
  intros Hgf Hfg.
  apply Extensionality_Ensembles.
  split; red; intros.
  - apply in_inverse_image in H.
    inversion H.
    subst.
    rewrite <- Hgf.
    econstructor.
    + constructor.
      erewrite inverse_image_id.
      * exact H0.
      * exact Hfg.
    + rewrite Hgf.
      constructor.
      assumption.
  - destruct H.
    apply in_inverse_image in H.
    constructor.
    econstructor.
    + exact H.
    + constructor.
      rewrite Hgf.
      assumption.
Qed.

Lemma inverse_image_family_union_image
  {X Y : Type}
  (f : X -> Y)
  (F : Family Y) :
  inverse_image f (FamilyUnion F) = FamilyUnion (Im F (inverse_image f)).
Proof.
apply Extensionality_Ensembles.
split; red; intros;
  inversion H;
  inversion H0;
  subst;
  repeat econstructor;
  eassumption + now destruct H1.
Qed.

Lemma inverse_image_singleton
  {X Y : Type}
  (f : X -> Y)
  (g : Y -> X)
  (T : Ensemble Y) :
  (forall x, g (f x) = x) ->
  (forall y, f (g y) = y) ->
  inverse_image (inverse_image g) (Singleton T) = Singleton (inverse_image f T).
Proof.
  intros Hgf Hfg.
  rewrite inverse_image_fun.
  apply Extensionality_Ensembles.
  split;
    red;
    intros;
    inversion H;
    subst;
    red;
    rewrite inverse_image_id;
    constructor + assumption.
Qed.

Lemma inverse_image_add
  {X Y : Type}
  (f : X -> Y)
  (g : Y -> X)
  (F : Family Y)
  (T : Ensemble Y) :
  (forall x, g (f x) = x) ->
  (forall y, f (g y) = y) ->
  inverse_image (inverse_image g) (Add F T) = Add (inverse_image (inverse_image g) F) (inverse_image f T).
Proof.
  intros Hgf Hfg.
  apply Extensionality_Ensembles.
  rewrite inverse_image_fun, inverse_image_fun.
  split;
    red;
    intros;
    inversion H;
    subst;
    (left;
     assumption) +
    (right;
     inversion H0;
     rewrite inverse_image_id;
     constructor + assumption).
Qed.

Lemma inverse_image_image_surjective
  {X Y : Type}
  (f : X -> Y)
  (T : Ensemble Y) :
  surjective f ->
  Im (inverse_image f T) f = T.
Proof.
intro.
apply Extensionality_Ensembles.
split;
  red;
  intros.
- inversion H0.
  subst.
  now destruct H1.
- destruct (H x).
  subst.
  now repeat econstructor.
Qed.

Lemma inverse_image_surjective_singleton
  {X Y : Type}
  (f : X -> Y)
  (T : Ensemble X) :
  surjective f ->
  Included (inverse_image (inverse_image f) (Singleton T)) (Singleton (Im T f)).
Proof.
intros H U HU.
destruct HU.
inversion H0.
subst.
now rewrite inverse_image_image_surjective.
Qed.

Lemma inverse_image_finite {X Y : Type} (f : X -> Y) (F : Family X) :
  surjective f ->
  Finite _ F ->
  Finite _ (inverse_image (inverse_image f) F).
Proof.
intros Hf H.
induction H.
- rewrite inverse_image_empty_set.
  constructor.
- unfold Add.
  rewrite inverse_image_union2.
  pose proof (Singleton_is_finite _ (Im x f)).
  now eapply Union_preserves_Finite,
             Finite_downward_closed,
             inverse_image_surjective_singleton.
Qed.

Lemma inverse_image_surjective_injective
  {X Y : Type}
  (f : X -> Y) :
  surjective f ->
  injective (inverse_image f).
Proof.
intros H U V eq.
apply Extensionality_Ensembles.
split; red; intros;
  destruct (H x);
  subst;
  apply (in_inverse_image f);
[ rewrite <- eq | rewrite eq ];
  now constructor.
Qed.


From Ssreflect Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype.
From MathComp Require Import div bigop ssralg finset fingroup zmodp poly ssrnum.

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

Local Open Scope ring_scope.
Import GRing.Theory.

Import Num.Theory.

Variable R : realFieldType.

Record dist (A : finType) := mkDist {
  pmf :> A -> R ;
  pmf0 : forall a, 0 <= pmf a ;
  pmf1 : \sum_(a in A) pmf a = 1 }.

Definition dist_of {A : finType} := fun phT : phant (Finite.sort A) => dist A.

Notation "{ 'dist' T }" := (dist_of (Phant T))
  (at level 0, format "{ 'dist'  T }") : proba_scope.

Local Open Scope proba_scope.

Section probability.

Variable A : finType.
Variable P : dist A.

Definition Pr (E : {set A}) := \sum_(a in E) P a.

End probability.

Module ProdDist.

Section local.

Variables A B : finType.
Variable P1 : dist A.
Variable P2 : dist B.

Definition f := fun ab => P1 ab.1 * P2 ab.2.

Lemma f0 a : 0 <= f a.
Proof.
rewrite /f.
apply mulr_ge0.
apply pmf0.
apply pmf0.
Qed.

Lemma f1 : \sum_ab f ab = 1.
Proof.
rewrite /f.
rewrite -(pair_big xpredT xpredT (fun a b => P1 a * P2 b)) /=.
rewrite -(pmf1 P1).
apply eq_bigr => a _.
rewrite -big_distrr /=.
rewrite pmf1.
rewrite mulr1.
done.
Qed.

Definition d : {dist A * B} := mkDist f0 f1.

End local.

End ProdDist.

Local Notation "P1 `x P2" := (ProdDist.d P1 P2) (at level 9).

From MathComp Require Import tuple finfun.

Local Notation "t \_ i" := (tnth t i) (at level 9).

Module TupleDist.

Section local.

Variable A : finType.
Variable P : dist A.
Variable n : nat.

Definition f (t : n.-tuple A) := \prod_(i < n) P t \_ i.

Lemma f0 t : 0 <= f t.
Proof.
rewrite /f.
apply prodr_ge0.
move=> i _.
apply pmf0.
Qed.

Lemma f1 : \sum_t f t = 1.
Proof.
rewrite /f.
transitivity (\sum_(f : {ffun 'I_n -> A}) \prod_(i < n) P (f i)).
  rewrite (reindex_onto (fun f : {ffun 'I_n -> A} => [tuple f i | i < n])
                        (fun t => [ffun i : 'I_n => t \_ i])) /=; last first.
    move=> t _.
    apply eq_from_tnth => i.
    rewrite tnth_mktuple.
    rewrite ffunE.
    done.
   apply eq_big.
     move=> f.
     apply/eqP/ffunP => /= i.
     rewrite ffunE.
     by rewrite tnth_mktuple.
   move=> f /eqP Hf.
   apply eq_bigr => i _.
   by rewrite tnth_mktuple.
rewrite -(@bigA_distr_bigA _ _ _ _ _ _ _ (fun (i : 'I_n) (a : A) => P a)) /=.
rewrite big_const_ord.
rewrite pmf1.
elim: n => // m.
by rewrite iterSr mulr1.
Qed.

Definition d : {dist n.-tuple A} := mkDist f0 f1.

End local.

End TupleDist.

Notation "P `^ n" := (TupleDist.d P n) (at level 9).


Coq < Section Disjunction.

Coq < Variables A B : Prop.
A is assumed
B is assumed

Coq < Goal A \/ B -> B \/ A.
1 subgoal

  A : Prop
  B : Prop
  ============================
   A \/ B -> B \/ A

Unnamed_thm < intro.
1 subgoal

  A : Prop
  B : Prop
  H : A \/ B
  ============================
   B \/ A

Unnamed_thm < elim H.
2 subgoals

  A : Prop
  B : Prop
  H : A \/ B
  ============================
   A -> B \/ A

subgoal 2 is:
 B -> B \/ A

Unnamed_thm < intro H1.
2 subgoals

  A : Prop
  B : Prop
  H : A \/ B
  H1 : A
  ============================
   B \/ A

subgoal 2 is:
 B -> B \/ A

Unnamed_thm < right.
2 subgoals

  A : Prop
  B : Prop
  H : A \/ B
  H1 : A
  ============================
   A

subgoal 2 is:
 B -> B \/ A

Unnamed_thm < exact H1.
1 subgoal

  A : Prop
  B : Prop
  H : A \/ B
  ============================
   B -> B \/ A

Unnamed_thm < auto.
Proof completed.

Unnamed_thm < Qed.
intro.
elim H.
 intro H1.
 right.
 exact H1.

 auto.

Unnamed_thm is defined


From Coq Require Import Reals ssreflect.
Require Import Coq.micromega.Lia.

Lemma ineq2: forall(k0 M: nat),
k0 <= 2 ^ M - 1 -> k0 < 2^M.
Proof.
  intros.
  assert (2 ^ M - 1 < 2 ^ M).
  2: {
  pose proof Nat.le_lt_trans _ _ _ H H0.
  exact H1.
  }
  eapply Nat.sub_lt.
  {
  pose proof Nat.eq_0_gt_0_cases M.
  apply Nat.lt_eq_cases.
  destruct H0.
  {
  right.
  rewrite H0.
  simpl.
  reflexivity.
  }
  pose proof Nat.pow_gt_1 2 M.
  left.
  apply H1.
  auto.
  apply Nat.neq_0_lt_0.
  exact H0.
  }
  auto.
Qed.

Lemma ineq3: forall(k0 M: nat),
 2 ^ M - 1 < k0 ->  2^M <= k0.
Proof.
  intros.
  lia.
Qed.

Lemma ineq4:  forall(k M: nat),
 k <= 2 ^ S M - 1 -> k - 2 ^ M <= 2 ^ M - 1.
Proof.
  intros.
  assert (2 ^ S M - 1 - 2 ^ M = 2 ^ M - 1)%nat.
  {
  simpl.
  lia.
  }
  rewrite <- H0.
  lia.
Qed.

Lemma ineq5: forall (k : nat),
  2 ^ k <> 0.
Proof.
  intros.
  apply Nat.pow_nonzero.
  congruence.
Qed.

Lemma ineq6: forall (k0 M : nat),
  2 ^ M <= 2 ^ M + k0.
Proof.
  intros.
  lia.
Qed.

Lemma ineq: forall(k0: nat) (M: nat),
2^(S M - 1) - 1 < (k0 + 2 ^ (S M - 1)).
Proof.
  intros.
  eapply Nat.lt_le_trans.
  {
  eapply Nat.sub_lt.
  {
  pose proof Nat.eq_0_gt_0_cases M.
  apply Nat.lt_eq_cases.
  destruct H.
  {
  right.
  rewrite H.
  simpl.
  reflexivity.
  }
  pose proof Nat.pow_gt_1 2 (S M - 1).
  left.
  apply H0.
  auto.
  apply Nat.neq_0_lt_0.
  simpl.
  lia.
  }
  auto.
  }
  apply le_plus_r.
Qed.

Lemma eq0: forall M,
(2 * INR (2 ^ M))%R = (INR (2 * 2 ^ M)).
Proof.
  intros.
  pose proof mult_INR 2 (2 ^ M).
  assert (INR 2 = 2)%R.
  constructor.
  rewrite H0 in H.
  rewrite H.
  reflexivity.
Qed.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div fintype tuple.
From mathcomp Require Import finfun bigop fingroup perm ssralg zmodp matrix mxalgebra.
From mathcomp Require Import poly mxpoly.
Require Import num_occ.

Import GRing.Theory.

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

Section AboutF2.

(** * Finite Field with Two Elements

   Prime finite fields are directly available in SSReflect.

*)

Local Open Scope ring_scope.

Coercion F2_of_bool (b : bool) : 'F_2 := if b then 1 else 0.

Definition bool_of_F2 (x : 'F_2) : bool := x != 0.

Definition negF2 (x : 'F_2) : 'F_2 := (*F2_of_bool*) (x == 0%R).

Lemma F2_0_1 : forall x : 'F_2, x = (x != 0).
Proof. move=> x; rewrite -{1}[x]natr_Zp; case: x; case=> //; by case. Qed.

Lemma F2_0_1' : forall x : 'F_2, ((x == 1)%R = (x != 0)%R).
Proof. move=> x; rewrite -{1}[x]natr_Zp; case: x; case=> //; by case. Qed.

Lemma F2_0_1'' : forall x : 'F_2, ((x == 0)%R = (x != 1)%R).
Proof. move=> x; rewrite -{1}[x]natr_Zp; case: x; case=> //; by case. Qed.

(* TODO: rename *)
Lemma F2_0_1''' : forall x : 'F_2, (bool_of_F2 x) = (x != 0)%R.
Proof. move=> x; rewrite -{1}[x]natr_Zp; case: x; case=> //; by case. Qed.
Lemma F2_0_1'''' : forall x : 'F_2, ~~ (bool_of_F2 x) = (x == 0)%R.
Proof. move=> x; rewrite -{1}[x]natr_Zp; case: x; case=> //; by case. Qed.

CoInductive F2_spec : 'F_2 -> bool -> bool -> Prop :=
| F2_0 : F2_spec 0 true false
| F2_1 : F2_spec 1 false true.

Lemma F2P a : F2_spec a (a == 0) (a == 1).
Proof.
case/boolP : (a == 0).
  move/eqP => ?; subst a.
  rewrite (_ : 0 == 1 = false) //; by constructor.
rewrite F2_0_1'' negbK => /eqP ?; subst a.
rewrite eqxx; by constructor.
Qed.

Lemma F2_opp (x : 'F_2) : - x = x.
Proof.
rewrite (F2_0_1 x) -[x]natr_Zp; case: x.
case; first by rewrite /= oppr0.
by case.
Qed.

Lemma F2_add (x : 'F_2) : x + x = 0.
Proof. by rewrite -{2}(F2_opp x) addrN. Qed.

Lemma F2_of_bool_addr (x  y : 'F_2) :
  (x + F2_of_bool (y == 0) = F2_of_bool ((x + y) == 0))%R.
Proof.
  destruct (F2P x), (F2P y); simpl; try done.
    by rewrite GRing.add0r.
  by rewrite F2_add.
Qed.

Lemma F2_of_bool_0_inv : forall x, F2_of_bool x = 0 -> x = false.
Proof. by case. Qed.

Lemma F2_of_boolK : forall x, bool_of_F2 (F2_of_bool x) = x.
Proof. by case. Qed.

Lemma bool_of_F2K x : F2_of_bool (bool_of_F2 x) = x.
Proof. rewrite (F2_0_1 x); by case Heq : ( _ == _ ). Qed.

Lemma bool_of_F2_add_xor a b :
  bool_of_F2 (a + b) = bool_of_F2 a (+) bool_of_F2 b.
Proof.
rewrite (F2_0_1 a) (F2_0_1 b).
by case Ha : ( a == _ ); case Hb : ( b == _ ).
Qed.

Lemma morph_F2_of_bool : {morph F2_of_bool : x y / x (+) y >-> (x + y) : 'F_2}.
Proof.
move=> x y /=.
rewrite /F2_of_bool.
move: x y; case; case => //=; by rewrite F2_add.
Qed.

Lemma morph_bool_of_F2 : {morph bool_of_F2 : x y / (x + y) : 'F_2 >-> x (+) y}.
Proof. move=> x y /=; by rewrite bool_of_F2_add_xor. Qed.

Local Open Scope nat_scope.

Lemma num_occ_sum : forall (t : seq 'F_2),
  num_occ 1%R t = \sum_(i <- t) i.
Proof.
elim => [ /= | /= h t ->].
  by rewrite big_nil.
rewrite big_cons.
by case/F2P: h.
Qed.

Local Close Scope nat_scope.

(** Properties of %$\mathbb{F}_2$%#F_2# generalize to matrices over
   %$\mathbb{F}_2$%#F_2#: *)

Lemma F2_addmx m n (v : 'M['F_2]_(m, n)) : v + v = 0.
Proof. apply/matrixP => i j; by rewrite !mxE F2_add. Qed.

Lemma F2_mx_opp m n (v : 'M['F_2]_(m, n)) : - v = v.
Proof. apply/matrixP => i j; by rewrite mxE F2_opp. Qed.

Lemma F2_addmx0 m n (a b : 'M['F_2]_(m, n)) : a + b = 0 -> a = b.
Proof.
move/eqP.
rewrite addr_eq0 F2_mx_opp.
by move/eqP.
Qed.

(** Properties of %$\mathbb{F}_2$%#F_2# generalize to polynomials over
   %$\mathbb{F}_2$%#F_2#: *)

Lemma F2_poly_add (p : {poly 'F_2}) : p + p = 0.
Proof.
apply/polyP => i.
by rewrite coef0 coef_add_poly F2_add.
Qed.

(*Lemma poly_rV_scale n (a : 'F_2) (p : { poly 'F_2 }) :
 poly_rV (a%:P * p) = a%:M *m (@poly_rV _ n p).
Proof. by rewrite mul_polyC linearZ /= mul_scalar_mx. Qed.*)

(* TODO: move *)
From mathcomp Require Import polydiv.

(*Lemma scale_modp (p d : {poly 'F_2}) (c : 'F_2) :
  (c%:P * p) %% d = c%:P * (p %% d).
Proof.
rewrite (F2_0_1 c); case: (_ =P _) => /= _.
- by rewrite polyC0 2!mul0r mod0p.
- by rewrite polyC1 2!mul1r.
Qed.*)

(** Furthermore, polynomials over %$\mathbb{F}_2$%#F_2# enjoy special properties
    w.r.t. their coefficients, e.g.: *)

Lemma size_lead_coef_F2 (p : {poly 'F_2}) : size p <> O -> lead_coef p = 1.
Proof.
move=> sz_p.
suff goal : lead_coef p <> 0.
  apply/eqP; rewrite F2_0_1'; by apply/eqP.
rewrite lead_coefE.
contradict sz_p.
case: p sz_p => p /= last_p sz_p.
rewrite (nth_last 0 p) in sz_p.
case: p last_p sz_p => //= last_p sz_p.
by move/negbTE; move/eqP.
Qed.

Lemma size1_polyC_F2 (p : {poly 'F_2}) : size p = 1%nat -> p = 1%:P.
Proof.
move=> sz_1.
have sz_1' : (size p <= 1)%nat by rewrite sz_1.
rewrite (size1_polyC sz_1').
transitivity (lead_coef p)%:P.
by rewrite /lead_coef sz_1.
by rewrite size_lead_coef_F2 // sz_1.
Qed.

Lemma lead_coef_F2 (p q : {poly 'F_2}) : size p = size q -> lead_coef p = lead_coef q.
Proof.
move=> X.
case/orP : (orbN (size p == O)) => [ | Y].
- move/eqP => Y; rewrite Y in X.
  symmetry in X; move/eqP: X; rewrite size_poly_eq0; move/eqP => ->.
  by move/eqP: Y; rewrite size_poly_eq0; move/eqP => ->.
- rewrite size_lead_coef_F2; last by apply/eqP.
  rewrite size_lead_coef_F2 //; by rewrite -X; apply/eqP.
Qed.

Lemma monic_F_2 (p : { poly 'F_2 }) : p != 0 -> p \is monic.
Proof.
move=> Hp; apply negbNE; apply/negP => H.
have {H} : lead_coef p == 0.
  move/monicP/eqP : H; by rewrite F2_0_1' negbK.
rewrite lead_coef_eq0.
by apply/negP.
Qed.

Lemma row_nth n (i j : bitseq) : (size i <= n)%nat -> size j = size i ->
  \row_(i0 < n) F2_of_bool (nth false i i0) =
  \row_(i0 < n) F2_of_bool (nth false j i0) -> i = j.
Proof.
move=> Hi Hj /matrixP Heq.
apply/esym.
apply (@eq_from_nth _ false _ _ Hj) => i0 Hi0.
rewrite Hj in Hi0.
have {Hi0}Hi0 : (i0 < n)%nat.
  apply leq_ltn_trans with ((size i).-1)%nat;
    rewrite -ltnS prednK //; by apply leq_ltn_trans with i0.
move: (Heq 0 (Ordinal Hi0)).
rewrite !mxE /=; by do 2 case: nth.
Qed.

(*Lemma col_nth n (i j : bitseq) : (size i <= n)%nat -> size j = size i ->
  \col_(i0 < n) F2_of_bool (nth false i i0) =
  \col_(i0 < n) F2_of_bool (nth false j i0) -> i = j.
Proof.
move=> Hi Hj /matrixP Heq.
apply/esym.
apply (@eq_from_nth _ false _ _ Hj) => i0 Hi0.
rewrite Hj in Hi0.
have {Hi0}Hi0 : (i0 < n)%nat.
  apply leq_ltn_trans with ((size i).-1)%nat;
    rewrite -ltnS prednK //; by apply leq_ltn_trans with i0.
move: (Heq (Ordinal Hi0) 0).
rewrite !mxE /=; by do 2 case: nth.
Qed.*)

End AboutF2.


(** Supplement to Coq's axiomatized Reals *)

Require Export Reals.
Require Import Psatz.
Require Export Program.
Require Export Summation.

(** * Basic lemmas *)

(** Relevant lemmas from Coquelicot's Rcomplements.v **)

Open Scope R_scope.
Local Coercion INR : nat >-> R.

Lemma Rle_minus_l : forall a b c,(a - c <= b <-> a <= b + c). Proof. intros. lra. Qed.
Lemma Rlt_minus_r : forall a b c,(a < b - c <-> a + c < b). Proof. intros. lra. Qed.
Lemma Rlt_minus_l : forall a b c,(a - c < b <-> a < b + c). Proof. intros. lra. Qed.
Lemma Rle_minus_r : forall a b c,(a <= b - c <-> a + c <= b). Proof. intros. lra. Qed.
Lemma Rminus_le_0 : forall a b, a <= b <-> 0 <= b - a. Proof. intros. lra. Qed.
Lemma Rminus_lt_0 : forall a b, a < b <-> 0 < b - a. Proof. intros. lra. Qed.

(* Automation *)

Lemma Rminus_unfold : forall r1 r2, (r1 - r2 = r1 + -r2). Proof. reflexivity. Qed.
Lemma Rdiv_unfold : forall r1 r2, (r1 / r2 = r1 */ r2). Proof. reflexivity. Qed.

Hint Rewrite Rminus_unfold Rdiv_unfold Ropp_0 Ropp_involutive Rplus_0_l
             Rplus_0_r Rmult_0_l Rmult_0_r Rmult_1_l Rmult_1_r : R_db.
Hint Rewrite <- Ropp_mult_distr_l Ropp_mult_distr_r : R_db.
Hint Rewrite Rinv_l Rinv_r sqrt_sqrt using lra : R_db.

Notation "√ n" := (sqrt n) (at level 20) : R_scope.

(** Other useful facts *)

Lemma Rmult_div_assoc : forall (x y z : R), x * (y / z) = x * y / z.
Proof. intros. unfold Rdiv. rewrite Rmult_assoc. reflexivity. Qed.

Lemma Rmult_div : forall r1 r2 r3 r4 : R, r2 <> 0 -> r4 <> 0 ->
  r1 / r2 * (r3 / r4) = r1 * r3 / (r2 * r4).
Proof. intros. unfold Rdiv. rewrite Rinv_mult_distr; trivial. lra. Qed.

Lemma Rdiv_cancel :  forall r r1 r2 : R, r1 = r2 -> r / r1 = r / r2.
Proof. intros. rewrite H. reflexivity. Qed.

Lemma Rsum_nonzero : forall r1 r2 : R, r1 <> 0 \/ r2 <> 0 -> r1 * r1 + r2 * r2 <> 0.
Proof.
  intros.
  replace (r1 * r1)%R with (r1 ^ 2)%R by lra.
  replace (r2 * r2)%R with (r2 ^ 2)%R by lra.
  specialize (pow2_ge_0 (r1)). intros GZ1.
  specialize (pow2_ge_0 (r2)). intros GZ2.
  destruct H.
  - specialize (pow_nonzero r1 2 H). intros NZ. lra.
  - specialize (pow_nonzero r2 2 H). intros NZ. lra.
Qed.

Lemma Rpow_le1: forall (x : R) (n : nat), 0 <= x <= 1 -> x ^ n <= 1.
Proof.
  intros; induction n.
  - simpl; lra.
  - simpl.
    rewrite <- Rmult_1_r.
    apply Rmult_le_compat; try lra.
    apply pow_le; lra.
Qed.

(* The other side of Rle_pow, needed below *)
Lemma Rle_pow_le1: forall (x : R) (m n : nat),
  0 <= x <= 1 -> (m <= n)%nat -> x ^ n <= x ^ m.
Proof.
  intros x m n [G0 L1] L.
  remember (n - m)%nat as p.
  replace n with (m+p)%nat in * by lia.
  clear -G0 L1.
  rewrite pow_add.
  rewrite <- Rmult_1_r.
  apply Rmult_le_compat; try lra.
  apply pow_le; trivial.
  apply pow_le; trivial.
  apply Rpow_le1; lra.
Qed.

(** * Square roots *)

Lemma pow2_sqrt : forall x:R, 0 <= x -> (√ x) ^ 2 = x.
Proof. intros; simpl; rewrite Rmult_1_r, sqrt_def; auto. Qed.

Lemma sqrt_pow : forall (r : R) (n : nat), (0 <= r)%R -> (√ (r ^ n) = √ r ^ n)%R.
Proof.
  intros r n Hr.
  induction n.
  simpl. apply sqrt_1.
  rewrite <- 2 tech_pow_Rmult.
  rewrite sqrt_mult_alt by assumption.
  rewrite IHn. reflexivity.
Qed.

Lemma pow2_sqrt2 : (√ 2) ^ 2 = 2.
Proof. apply pow2_sqrt; lra. Qed.

Lemma pown_sqrt : forall (x : R) (n : nat),
  0 <= x -> √ x ^ (S (S n)) = x * √ x ^ n.
Proof.
  intros. simpl. rewrite <- Rmult_assoc. rewrite sqrt_sqrt; auto.
Qed.

Lemma sqrt_neq_0_compat : forall r : R, 0 < r -> √ r <> 0.
Proof. intros. specialize (sqrt_lt_R0 r). lra. Qed.

Lemma sqrt_inv : forall (r : R), 0 < r -> √ (/ r) = (/ √ r)%R.
Proof.
  intros.
  replace (/r)%R with (1/r)%R by lra.
  rewrite sqrt_div_alt, sqrt_1 by lra.
  lra.
Qed.

Lemma sqrt2_div2 : (√ 2 / 2)%R = (1 / √ 2)%R.
Proof.
   field_simplify_eq; try (apply sqrt_neq_0_compat; lra).
   rewrite pow2_sqrt2; easy.
Qed.

Lemma sqrt2_inv : √ (/ 2) = (/ √ 2)%R.
Proof. apply sqrt_inv; lra. Qed.

Lemma sqrt_sqrt_inv : forall (r : R), 0 < r -> (√ r * √ / r)%R = 1.
Proof.
  intros.
  rewrite sqrt_inv; trivial.
  rewrite Rinv_r; trivial.
  apply sqrt_neq_0_compat; easy.
Qed.

Lemma sqrt2_sqrt2_inv : (√ 2 * √ / 2)%R = 1.
Proof. apply sqrt_sqrt_inv. lra. Qed.

Lemma sqrt2_inv_sqrt2 : ((√ / 2) * √ 2)%R = 1.
Proof. rewrite Rmult_comm. apply sqrt2_sqrt2_inv. Qed.

Lemma sqrt2_inv_sqrt2_inv : ((√ / 2) * (√ / 2) = /2)%R.
Proof.
  rewrite sqrt2_inv. field_simplify.
  rewrite pow2_sqrt2. easy.
  apply sqrt_neq_0_compat; lra.
Qed.

Lemma sqrt_1_unique : forall x, 1 = √ x -> x = 1.
Proof. intros. assert (H' := H). unfold sqrt in H. destruct (Rcase_abs x).
       - apply R1_neq_R0 in H; easy.
       - rewrite <- (sqrt_def x); try rewrite <- H'; lra.
Qed.

Lemma lt_ep_helper : forall (ϵ : R),
  ϵ > 0 <-> ϵ / √ 2 > 0.
Proof. intros; split; intros.
       - unfold Rdiv.
         apply Rmult_gt_0_compat; auto;
           apply Rinv_0_lt_compat; apply Rlt_sqrt2_0.
       - rewrite <- (Rmult_1_r ϵ).
         rewrite <- (Rinv_l (√ 2)), <- Rmult_assoc.
         apply Rmult_gt_0_compat; auto.
         apply Rlt_sqrt2_0.
         apply sqrt2_neq_0.
Qed.

(** Defining 2-adic valuation of an integer and properties *)

Open Scope Z_scope.

(* could return nat, but int seem better *)
Fixpoint two_val_pos (p : positive) : Z :=
  match p with
  | xO p' => 1 + (two_val_pos p')
  | _ => 0
  end.

Fixpoint odd_part_pos (p : positive) : positive :=
  match p with
  | xO p' => odd_part_pos p'
  | _ => p
  end.

Lemma two_val_pos_mult : forall (p1 p2 : positive),
  two_val_pos (p1 * p2) = two_val_pos p1 + two_val_pos p2.
Proof. induction p1; try easy; intros.
       - replace (two_val_pos p1~1) with 0 by easy.
         induction p2; try easy.
         replace ((xI p1) * (xO p2))%positive with (xO ((xI p1) * p2))%positive by lia.
         replace (two_val_pos (xO ((xI p1) * p2))%positive) with
           (1 + (two_val_pos ((xI p1) * p2)%positive)) by easy.
         rewrite IHp2; easy.
       - replace (two_val_pos (xO p1)) with (1 + two_val_pos p1) by easy.
         rewrite <- Z.add_assoc, <- IHp1.
         replace ((xO p1) * p2)%positive with (xO (p1 * p2))%positive by lia.
         easy.
Qed.

(* TODO: prove at some point, don't actually need this now though. *)
(*
Lemma two_val_pos_plus : forall (p1 p2 : positive),
  two_val_pos (p1 + p2) >= Z.min (two_val_pos p1) (two_val_pos p2).
Proof. induction p1; try easy; intros.
       - replace (two_val_pos p1~1) with 0 by easy.
         induction p2; try easy.
         replace ((xI p1) * (xO p2))%positive with (xO ((xI p1) * p2))%positive by lia.
         replace (two_val_pos (xO ((xI p1) * p2))%positive) with
           (1 + (two_val_pos ((xI p1) * p2)%positive)) by easy.
         rewrite IHp2; easy.
       - replace (two_val_pos (xO p1)) with (1 + two_val_pos p1) by easy.
         rewrite <- Z.add_assoc, <- IHp1.
         replace ((xO p1) * p2)%positive with (xO (p1 * p2))%positive by lia.
         easy.
Qed. *)

(* CHECK: maybe only need these for positives since we split on 0, pos, neg, anyways *)

Definition two_val (z : Z) : Z :=
  match z with
  | Z0 => 0 (* poorly defined on 0 *)
  | Zpos p => two_val_pos p
  | Zneg p => two_val_pos p
  end.

Definition odd_part (z : Z) : Z :=
  match z with
  | Z0 => 0  (* poorly defined on 0 *)
  | Zpos p => Zpos (odd_part_pos p)
  | Zneg p => Zneg (odd_part_pos p)
  end.

(* useful for below since its easier to induct on nats rather than ints *)
Coercion Z.of_nat : nat >-> Z.

(* helper for the next section to go from nats to ints *)
Lemma Z_plusminus_nat : forall z : Z,
  (exists n : nat, z = n \/ z = - n)%Z.
Proof. intros.
       destruct z.
       - exists O; left; easy.
       - exists (Pos.to_nat p); left; lia.
       - exists (Pos.to_nat p); right; lia.
Qed.

Lemma two_val_mult : forall (z1 z2 : Z),
  z1 <> 0 -> z2 <> 0 ->
  two_val (z1 * z2) = two_val z1 + two_val z2.
Proof. intros.
       destruct z1; destruct z2; simpl; try easy.
       all : rewrite two_val_pos_mult; easy.
Qed.

(* TODO: should prove this, but don't actually need it.
Lemma two_val_plus : forall (z1 z2 : Z),
  z1 <> 0 -> z2 <> 0 ->
  z1 + z2 <> 0 ->
  two_val (z1 + z2) >= Z.min (two_val z1) (two_val z2).
Proof. intros.
       destruct z1; destruct z2; try easy.
*)

Lemma two_val_odd_part : forall (z : Z),
  two_val (2 * z + 1) = 0.
Proof. intros.
       destruct z; auto.
       destruct p; auto.
Qed.

Lemma two_val_even_part : forall (a : Z),
  a >= 0 -> two_val (2 ^ a) = a.
Proof. intros.
       destruct (Z_plusminus_nat a) as [x [H0 | H0]]; subst.
       induction x; auto.
       replace (S x) with (1 + x)%nat by lia.
       rewrite Nat2Z.inj_add, Z.pow_add_r, two_val_mult; try lia.
       rewrite IHx; auto; try lia.
       try (apply (Z.pow_nonzero 2 x); lia).
       induction x; auto.
       replace (S x) with (1 + x)%nat by lia.
       rewrite Nat2Z.inj_add, Z.opp_add_distr, Z.pow_add_r, two_val_mult; try lia.
Qed.

Lemma twoadic_nonzero : forall (a b : Z),
  a >= 0 -> 2^a * (2 * b + 1) <> 0.
Proof. intros.
       apply Z.neq_mul_0; split; try lia;
       try (apply Z.pow_nonzero; lia).
Qed.

Lemma get_two_val : forall (a b : Z),
  a >= 0 ->
  two_val (2^a * (2 * b + 1)) = a.
Proof. intros.
       rewrite two_val_mult; auto.
       rewrite two_val_odd_part, two_val_even_part; try lia.
       apply Z.pow_nonzero; try lia.
       lia.
Qed.

Lemma odd_part_reduce : forall (a : Z),
  odd_part (2 * a) = odd_part a.
Proof. intros.
       induction a; try easy.
Qed.

Lemma get_odd_part : forall (a b : Z),
  a >= 0 ->
  odd_part (2^a * (2 * b + 1)) = 2 * b + 1.
Proof. intros.
       destruct (Z_plusminus_nat a) as [x [H0 | H0]]; subst.
       induction x; try easy.
       - replace (2 ^ 0%nat * (2 * b + 1)) with (2 * b + 1) by lia.
         destruct b; simpl; auto.
         induction p; simpl; easy.
       - replace (2 ^ S x * (2 * b + 1)) with (2 * (2 ^ x * (2 * b + 1))).
         rewrite odd_part_reduce, IHx; try lia.
         replace (S x) with (1 + x)%nat by lia.
         rewrite Nat2Z.inj_add, Z.pow_add_r; try lia.
       - destruct x; try easy.
         replace (2 ^ (- 0%nat) * (2 * b + 1)) with (2 * b + 1) by lia.
         destruct b; simpl; auto.
         induction p; simpl; easy.
Qed.

Lemma break_into_parts : forall (z : Z),
  z <> 0 -> exists a b, a >= 0 /\ z = (2^a * (2 * b + 1)).
Proof. intros.
       destruct z; try easy.
       - induction p.
         + exists 0, (Z.pos p); try easy.
         + destruct IHp as [a [b [H0 H1]]]; try easy.
           exists (1 + a), b.
           replace (Z.pos (xO p)) with (2 * Z.pos p) by easy.
           split; try lia.
           rewrite H1, Z.pow_add_r; try lia.
         + exists 0, 0; split; try lia.
       - induction p.
         + exists 0, (Z.neg p - 1); try easy; try lia.
         + destruct IHp as [a [b [H0 H1]]]; try easy.
           exists (1 + a), b.
           replace (Z.neg (xO p)) with (2 * Z.neg p) by easy.
           split; try lia.
           rewrite H1, Z.pow_add_r; try lia.
         + exists 0, (-1); split; try lia.
Qed.

Lemma twoadic_breakdown : forall (z : Z),
  z <> 0 -> z = (2^(two_val z)) * (odd_part z).
Proof. intros.
       destruct (break_into_parts z) as [a [b [H0 H1]]]; auto.
       rewrite H1, get_two_val, get_odd_part; easy.
Qed.

Lemma odd_part_pos_odd : forall (p : positive),
  (exists p', odd_part_pos p = xI p') \/ (odd_part_pos p = xH).
Proof. intros.
       induction p.
       - left; exists p; easy.
       - destruct IHp.
         + left.
           destruct H.
           exists x; simpl; easy.
         + right; simpl; easy.
       - right; easy.
Qed.

Lemma odd_part_0 : forall (z : Z),
  odd_part z = 0 -> z = 0.
Proof. intros.
       destruct z; simpl in *; easy.
Qed.

Lemma odd_part_odd : forall (z : Z),
  z <> 0 ->
  2 * ((odd_part z - 1) / 2) + 1 = odd_part z.
Proof. intros.
       rewrite <- (Zdiv.Z_div_exact_full_2 _ 2); try lia.
       destruct z; try easy; simpl;
         destruct (odd_part_pos_odd p).
       - destruct H0; rewrite H0; simpl.
         rewrite Pos2Z.pos_xO, Zmult_comm, Zdiv.Z_mod_mult.
         easy.
       - rewrite H0; easy.
       - destruct H0; rewrite H0; simpl.
         rewrite (Pos2Z.neg_xO (Pos.succ x)), Zmult_comm, Zdiv.Z_mod_mult.
         easy.
       - rewrite H0; easy.
Qed.

Lemma two_val_ge_0 : forall (z : Z),
  two_val z >= 0.
Proof. intros.
       destruct z; simpl; try lia.
       - induction p; try (simpl; lia).
         replace (two_val_pos p~0) with (1 + two_val_pos p) by easy.
         lia.
       - induction p; try (simpl; lia).
         replace (two_val_pos p~0) with (1 + two_val_pos p) by easy.
         lia.
Qed.

(*
 *
 *
 *)

Close Scope Z_scope.

(** proving that sqrt2 is irrational! *)

(* note that the machinery developed in the previous section makes this super easy,
   although does not generalize for other primes *)
Lemma two_not_square : forall (a b : Z),
  (b <> 0)%Z ->
  ~ (a*a = b*b*2)%Z.
Proof. intros.
       unfold not; intros.
       destruct (Z.eq_dec a 0); try lia.
       apply (f_equal_gen two_val two_val) in H0; auto.
       do 3 (rewrite two_val_mult in H0; auto); try lia.
       replace (two_val 2) with 1%Z in H0 by easy.
       lia.
Qed.

Theorem sqrt2_irrational : forall (a b : Z),
  (b <> 0)%Z -> ~ (IZR a = (IZR b) * √ 2).
Proof. intros.
       apply (two_not_square a b) in H.
       unfold not; intros; apply H.
       apply (f_equal_gen (fun x => x * x) (fun x => x * x)) in H0; auto.
       rewrite Rmult_assoc, (Rmult_comm (√ 2)), Rmult_assoc,
         sqrt_def, <- Rmult_assoc in H0; try lra.
       repeat rewrite <- mult_IZR in H0.
       apply eq_IZR in H0.
       easy.
Qed.

Corollary one_sqrt2_Rbasis : forall (a b : Z),
  (IZR a) + (IZR b) * √2 = 0 ->
  (a = 0 /\ b = 0)%Z.
Proof. intros.
       destruct (Req_dec (IZR b) 0); subst.
       split.
       rewrite H0, Rmult_0_l, Rplus_0_r in H.
       all : try apply eq_IZR; auto.
       apply Rplus_opp_r_uniq in H; symmetry in H.
       assert (H' : b <> 0%Z).
       unfold not; intros; apply H0.
       rewrite H1; auto.
       apply (sqrt2_irrational (-a) b) in H'.
       rewrite Ropp_Ropp_IZR in H'.
       easy.
Qed.

(* Automation *)
Ltac R_field_simplify := repeat field_simplify_eq [pow2_sqrt2 sqrt2_inv].
Ltac R_field := R_field_simplify; easy.

(** * Trigonometry *)

Lemma sin_upper_bound_aux : forall x : R, 0 < x < 1 -> sin x <= x.
Proof.
  intros x H.
  specialize (SIN_bound x) as B.
    destruct (SIN x) as [_ B2]; try lra.
    specialize PI2_1 as PI1. lra.
    unfold sin_ub, sin_approx in *.
    simpl in B2.
    unfold sin_term at 1 in B2.
    simpl in B2.
    unfold Rdiv in B2.
    rewrite Rinv_1, Rmult_1_l, !Rmult_1_r in B2.
    (* Now just need to show that the other terms are negative... *)
    assert (sin_term x 1 + sin_term x 2 + sin_term x 3 + sin_term x 4 <= 0); try lra.
    unfold sin_term.
    remember (INR (fact (2 * 1 + 1))) as d1.
    remember (INR (fact (2 * 2 + 1))) as d2.
    remember (INR (fact (2 * 3 + 1))) as d3.
    remember (INR (fact (2 * 4 + 1))) as d4.
    assert (0 < d1) as L0.
    { subst. apply lt_0_INR. apply lt_O_fact. }
    assert (d1 <= d2) as L1.
    { subst. apply le_INR. apply fact_le. simpl; lia. }
    assert (d2 <= d3) as L2.
    { subst. apply le_INR. apply fact_le. simpl; lia. }
    assert (d3 <= d4) as L3.
    { subst. apply le_INR. apply fact_le. simpl; lia. }
    simpl.
    ring_simplify.
    assert ( - (x * (x * (x * 1)) / d1) + x * (x * (x * (x * (x * 1)))) / d2 <= 0).
    rewrite Rplus_comm.
    apply Rle_minus.
    field_simplify; try lra.
    assert (x ^ 5 <= x ^ 3).
    { apply Rle_pow_le1; try lra; try lia. }
    apply Rmult_le_compat; try lra.
    apply pow_le; lra.
    left. apply Rinv_0_lt_compat. lra.
    apply Rinv_le_contravar; lra.
    unfold Rminus.
    assert (- (x * (x * (x * (x * (x * (x * (x * 1)))))) / d3) +
            x * (x * (x * (x * (x * (x * (x * (x * (x * 1)))))))) / d4 <= 0).
    rewrite Rplus_comm.
    apply Rle_minus.
    field_simplify; try lra.
    assert (x ^ 9 <= x ^ 7).
    { apply Rle_pow_le1; try lra; try lia. }
    apply Rmult_le_compat; try lra.
    apply pow_le; lra.
    left. apply Rinv_0_lt_compat. lra.
    apply Rinv_le_contravar; lra.
    lra.
Qed.

Lemma sin_upper_bound : forall x : R, Rabs (sin x) <= Rabs x.
Proof.
  intros x.
  specialize (SIN_bound x) as B.
  destruct (Rlt_or_le (Rabs x) 1).
  (* abs(x) > 1 *)
  2:{ apply Rabs_le in B. lra. }
  destruct (Rtotal_order x 0) as [G | [E| L]].
  - (* x < 0 *)
    rewrite (Rabs_left x) in * by lra.
    rewrite (Rabs_left (sin x)).
    2:{ apply sin_lt_0_var; try lra.
        specialize PI2_1 as PI1.
        lra. }
    rewrite <- sin_neg.
    apply sin_upper_bound_aux.
    lra.
  - (* x = 0 *)
    subst. rewrite sin_0. lra.
  - rewrite (Rabs_right x) in * by lra.
    rewrite (Rabs_right (sin x)).
    2:{ apply Rle_ge.
        apply sin_ge_0; try lra.
        specialize PI2_1 as PI1. lra. }
    apply sin_upper_bound_aux; lra.
Qed.

Hint Rewrite sin_0 sin_PI4 sin_PI2 sin_PI cos_0 cos_PI4 cos_PI2
             cos_PI sin_neg cos_neg : trig_db.

(** * glb support *)

Definition is_lower_bound (E:R -> Prop) (m:R) := forall x:R, E x -> m <= x.

Definition bounded_below (E:R -> Prop) := exists m : R, is_lower_bound E m.

Definition is_glb (E:R -> Prop) (m:R) :=
  is_lower_bound E m /\ (forall b:R, is_lower_bound E b -> b <= m).

Definition neg_Rset (E : R -> Prop) :=
  fun r => E (-r).

Lemma lb_negset_ub : forall (E : R -> Prop) (b : R),
  is_lower_bound E b <-> is_upper_bound (neg_Rset E) (-b).
Proof. unfold is_lower_bound, is_upper_bound, neg_Rset; split; intros.
       - apply H in H0; lra.
       - rewrite <- Ropp_involutive in H0.
         apply H in H0; lra.
Qed.

Lemma ub_negset_lb : forall (E : R -> Prop) (b : R),
  is_upper_bound E b <-> is_lower_bound (neg_Rset E) (-b).
Proof. unfold is_lower_bound, is_upper_bound, neg_Rset; split; intros.
       - apply H in H0; lra.
       - rewrite <- Ropp_involutive in H0.
         apply H in H0; lra.
Qed.

Lemma negset_bounded_above : forall (E : R -> Prop),
  bounded_below E -> (bound (neg_Rset E)).
Proof. intros.
       destruct H.
       exists (-x).
       apply lb_negset_ub; easy.
Qed.

Lemma negset_glb : forall (E : R -> Prop) (m : R),
  is_lub (neg_Rset E) m -> is_glb E (-m).
Proof. intros.
       destruct H; split.
       - apply lb_negset_ub.
         rewrite Ropp_involutive; easy.
       - intros.
         apply lb_negset_ub in H1.
           apply H0 in H1; lra.
Qed.

Lemma glb_completeness :
  forall E:R -> Prop,
    bounded_below E -> (exists x : R, E x) -> { m:R | is_glb E m }.
Proof. intros.
       apply negset_bounded_above in H.
       assert (H' : exists x : R, (neg_Rset E) x).
       { destruct H0; exists (-x).
         unfold neg_Rset; rewrite Ropp_involutive; easy. }
       apply completeness in H'; auto.
       destruct H' as [m [H1 H2] ].
       exists (-m).
       apply negset_glb; easy.
Qed.

(** * Showing that R is a field, and a vector space over itself *)

Global Program Instance R_is_monoid : Monoid R :=
  { Gzero := 0
  ; Gplus := Rplus
  }.
Solve All Obligations with program_simpl; try lra.

Global Program Instance R_is_group : Group R :=
  { Gopp := Ropp }.
Solve All Obligations with program_simpl; try lra.

Global Program Instance R_is_comm_group : Comm_Group R.
Solve All Obligations with program_simpl; lra.

Global Program Instance R_is_ring : Ring R :=
  { Gone := 1
  ; Gmult := Rmult
  }.
Solve All Obligations with program_simpl; try lra.
Next Obligation. try apply Req_EM_T. Qed.

Global Program Instance R_is_comm_ring : Comm_Ring R.
Solve All Obligations with program_simpl; lra.

Global Program Instance R_is_field : Field R :=
  { Ginv := Rinv }.
Next Obligation.
  rewrite Rinv_r; easy.
Qed.

Global Program Instance R_is_module_space : Module_Space R R :=
  { Vscale := Rmult }.
Solve All Obligations with program_simpl; lra.

Global Program Instance R_is_vector_space : Vector_Space R R.

(** * some big_sum lemmas specific to R *)

Lemma Rsum_le : forall (f g : nat -> R) (n : nat),
  (forall i, (i < n)%nat -> f i <= g i) ->
  (big_sum f n) <= (big_sum g n).
Proof. induction n as [| n']; simpl; try lra.
       intros.
       apply Rplus_le_compat.
       apply IHn'; intros.
       all : apply H; try lia.
Qed.

Lemma Rsum_ge_0 : forall (f : nat -> R) (n : nat),
  (forall i, (i < n)%nat -> 0 <= f i) ->
  0 <= big_sum f n.
Proof. induction n as [| n'].
       - intros; simpl; lra.
       - intros. simpl; apply Rplus_le_le_0_compat.
         apply IHn'; intros; apply H; lia.
         apply H; lia.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Basic_Cons.Product.
Require Import Coq_Cats.Type_Cat.Type_Cat.

Local Notation "A + B" := (@Sum Type_Cat A B) : object_scope.

(** The sum of types in coq is the categorical notion of sum in category of
    types. *)
Program Definition sum_Sum (A B : Type) : (A + B)%object :=
{|
  product := (A + B)%type;
  Prod_morph_ex :=
    fun (p' : Type)
        (r1 : A → p')
        (r2 : B → p')
        (X : A + B) =>
      match X return p' with
      | inl a => r1 a
      | inr b => r2 b
      end
|}.

Local Obligation Tactic := idtac.

Next Obligation. (* Sum_morph_unique *)
Proof.
  intros A B p' r1 r2 f g H1 H2 H3 H4.
  rewrite <- H3 in H1.
  rewrite <- H4 in H2.
  clear H3 H4.
  extensionality x.
  destruct x;
    match goal with
        [|- f (?m ?y) = g (?m ?y)] =>
        apply (@equal_f _ _ (fun x => f (m x)) (fun x => g (m x)))
    end; auto.
Qed.

(* sum_Sum defined *)

Program Instance Type_Cat_Has_Sums : Has_Sums Type_Cat := sum_Sum.