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

Set Printing Depth 1000.
Definition lfind_eval  l n:=
Cons n l.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).


Require Import ssreflect ssrfun ssrbool.
Require Import Setoid.

(** some simple lemmas about bool *)

Lemma degen_bool : forall P, is_true false -> P.
Proof.
  intros; discriminate.
Qed.

(* AND *)
Lemma foo : forall a b:bool, a -> b -> a && b.
Proof.
  intros a b; case a; case b; solve [reflexivity | discriminate].
Qed.

Lemma and_bool_lr : forall a b, a && b -> a /\ b.
Proof.
  intros a b; case a; case b; intros H; inversion H; split; assumption.
Qed.

Lemma and_bool : forall a b, a && b <-> a /\ b.
Proof.
  intros a b; split.
  apply and_bool_lr.
  case a;case b; intros (ha,hb); solve [inversion ha | inversion hb | reflexivity].
Qed.

Lemma ab5_bool : forall a b c d e, a && b && c && d && e <-> a /\ b /\ c /\ d /\ e.
  intros a b c d e; split.
  repeat rewrite -> and_bool; intros; tauto.
  case a; case b; case c; case d; case e; intros ; solve [reflexivity | decompose [and] H; discriminate].
Qed.

Lemma circ2 : forall a b, a&&b -> b&&a.
Proof.
  intros a b; destruct a; destruct b; intros H;inversion H; assumption.
Qed.

Lemma circ3: forall A B C: bool, B && C && A -> A && B &&C.
Proof.
  intros a b c; case a; case b; case c; intros; assumption.
Qed.

Lemma circ6: forall A B C D E F : bool,
       B && C && D && E &&F && A -> A && B && C && D && E && F.
Proof.
  intros a b c d e f; case a; case b; case c; case d; case e; case f; intros; assumption.
Qed.

Lemma bool6 : forall a b c d e f, a && b && c && d && e && f -> a && e && d && c && b && f.
Proof.
  intros a b c d e f; case a; case b; case c; case d; case e; case f; intros; assumption.
Qed.

Lemma comm12L: forall A B C:bool, B && A && C -> A && B && C.
   Proof.
     intros a b c; case a; case b; case c; intros; assumption.
   Qed.

Lemma comm12P: forall A B C D E F :bool,
       B && A && C && D &&E && F -> A && B && C && D && E && F.
Proof.
  intros a b c d e f; case a; case b; case c; case d; case e; case f; intros; assumption.
Qed.

(* OR *)
Lemma or_bool : forall a b : bool, a || b <-> a \/ b.
Proof.
  intros a b; destruct a; destruct b; split; intuition.
Qed.


(***************************************************************************
* Safety for Simply Typed Lambda Calculus (CBV) - Definitions              *
* Extented from "Type Safety for STLC" by                                  *
* Brian Aydemir & Arthur Charguéraud & Stephanie Weirich,                  *
* July 2007, Coq v8.1                                                      *
***************************************************************************)

Set Implicit Arguments.
Require Import Metatheory.

(** Grammar of types. *)

Inductive typ : Set :=
  | typ_var   : var -> typ
  | typ_arrow : typ -> typ -> typ.

(** Grammar of pre-terms. *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_app  : typ -> trm -> trm -> trm.

(** Opening up abstractions *)

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i      => if k === i then u else (trm_bvar i)
  | trm_fvar x      => trm_fvar x
  | trm_abs t1      => trm_abs (open_rec (S k) u t1)
  | trm_app U t1 t2 => trm_app U (open_rec k u t1) (open_rec k u t2)
  end.

Definition open t u := open_rec 0 u t.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).
Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (trm_fvar x)).

(** Terms are locally-closed pre-terms *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs t1)
  | term_app : forall t1 t2 T,
      term t1 ->
      term t2 ->
      term (trm_app T t1 t2).

(** Environment is an associative list mapping variables to types. *)

Definition env := Env.env typ.

(** Typing relation *)

Reserved Notation "E |= t ~: T" (at level 69).

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      ok E ->
      binds x T E ->
      E |= (trm_fvar x) ~: T
  | typing_abs : forall L E U T t1,
      (forall x, x \notin L ->
        (E & x ~ U) |= t1 ^ x ~: T) ->
      E |= (trm_abs t1) ~: (typ_arrow U T)
  | typing_app : forall S T E t1 t2,
      E |= t1 ~: (typ_arrow S T) ->
      E |= t2 ~: S ->
      E |= (trm_app S t1 t2) ~: T

where "E |= t ~: T" := (typing E t T).

(** Definition of values (only abstractions are values) *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1,
      term (trm_abs t1) -> value (trm_abs t1).

(** Reduction relation - one step in call-by-value *)

Inductive red : trm -> trm -> Prop :=
  | red_beta : forall t1 t2 T,
      term (trm_abs t1) ->
      value t2 ->
      red (trm_app T (trm_abs t1) t2) (t1 ^^ t2)
  | red_app_1 : forall t1 t1' t2 T,
      term t2 ->
      red t1 t1' ->
      red (trm_app T t1 t2) (trm_app T t1' t2)
  | red_app_2 : forall t1 t2 t2' T,
      value t1 ->
      red t2 t2' ->
      red (trm_app T t1 t2) (trm_app T t1 t2').

Notation "t --> t'" := (red t t') (at level 68).

(** Goal is to prove preservation and progress *)

Definition preservation := forall E t t' T,
  E |= t ~: T ->
  t --> t' ->
  E |= t' ~: T.

Definition progress := forall t T,
  empty |= t ~: T ->
     value t
  \/ exists t', t --> t'.


(***********************************************************************************)
(*  Poly Logique et demonstration automatique                                      *)
(*  P140,Exercice 97.6                                                             *)
(*                                                                                *)
(*  (forall x, P x -> Q x) /\ (exists x, P x) -> (exists x, Q x)                   *)
(*                                                                                *)
(*  contexte | no  | ligne                                        | regle          *)
(*  1        | 1   | Sup (forall x, P x => Q x)/\(exists x, P x)  | hyp            *)
(*  1        | 2   | forall x, P x => Q x                         | /\E1,1         *)
(*  1        | 3   | exists x, P x                                | /\E2,1         *)
(*  1,4      | 4   | P x /\ Q x                                   | forallE,2      *)
(*  1,4,6    | 5   | Sup P x                                      | hyp            *)
(*  1,4,6    | 6   | Q x                                          | =>E,4 5        *)
(*  1,4,6    | 7   | exists x, Q x                                | existsI,6      *)
(*  1,4      | 8   | Donc P x => exists x, Q x                    | =>I,5 7        *)
(*  1,4      | 9   | exists x, Q x                                | existsE,8 3    *)
(*  1,4      | 10  | Donc cqfd                                    | =>I,1 9        *)
(*                                                                                *)
(***********************************************************************************)

Require Import Classical.

Section Declaration.

Variable D : Set.
Variable P : D -> Prop.
Variable Q : D -> Prop.

Section Preuve.

Lemma ex976 : (forall x : D, P x -> Q x) /\ (exists x : D, P x) -> (exists x : D, Q x).

intro H0.
elim H0.
intros H0_decomp_G H0_decomp_D.
elim H0_decomp_D.
intros x0 P_x0.
exists x0.
apply H0_decomp_G.
exact P_x0.

Qed.

End Preuve.
End Declaration.

Check ex976.

Quit.


Require Import String ZArith Lia.
Require Import lang.
Require Import logic.
Require Import pretty.

Fixpoint fib (n : nat) :=
  (match n with
  | 0 => 0
  | S k =>
    match k with
    | 0 => 1
    | S l => fib k + fib l
    end
  end)%nat.

Definition fib_imp : insn :=
  ("x" :== 0;
  "y" :== 1;
  While (1 <= "input") Do
        ("sum" :== "x" + "y";
        "x" :== "y";
        "y" :== "sum";
        "input" :== "input" - 1)
        Done;
  "output" :== "sum").

Search (nat -> Z).

(* Idea: automatically prove a correspondance between tail-recursive
   function and while loops. *)
Theorem fib_imp_correct : forall n : nat,
    hoare (fun f => f "input" = Z.of_nat n)
          fib_imp
          (fun g => g "output" = Z.of_nat (fib n)).
Proof.
  intros.
Abort.


From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.
From mathcomp Require Import all_real_closed.
From CoqEAL Require Import ssrcomplements.

(******************************************************************************)
(*                                                                            *)
(*  This file contains theory about polynomials with coefficients             *)
(*  in a closed field.                                                        *)
(*                                                                            *)
(*  In follow we pose p = (X - r1)^+a1 * (X - r2)^+a2 * ... * (X - rn)^+an    *)
(*                                                                            *)
(*            root_seq p == the sequence of all roots of polynomial p.        *)
(*       root_seq_uniq p == the sequence of all distinct roots of             *)
(*                          polynomial p (i.e the sequence [:: r1; ...; rn])  *)
(*         root_mu_seq p == the sequence of pair off the roots and            *)
(*                          its multiplicity of polynomial p.                 *)
(*                          (i.e the sequence [:: (r1,a1); ... ; (rn,an)])    *)
(*       root_seq_poly s == the concatenation of the sequences root_mu_seq p  *)
(*                          for all polynomials p in the sequence s.          *)
(*   linear_factor_seq p == the sequence of linear factor tha appear of the   *)
(*                          decompositionof polynomial p. (i.e the sequence   *)
(*                          [:: (X - r1)^+a1; ... ; (X - rn)^+an])            *)
(*                                                                            *)
(******************************************************************************)

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

Section poly_closedFieldType.

Variable F : closedFieldType.
Import GRing.Theory.

Local Open Scope ring_scope.

Definition root_seq : {poly F} -> seq F :=
  let fix loop (p : {poly F}) (n : nat) :=
    if n is n.+1 then
      if (size p != 1%N) =P true is ReflectT p_neq0
        then let x := projT1 (sigW (closed_rootP p p_neq0)) in
          x :: loop (p %/ ('X - x%:P)) n
        else [::]
      else [::]
  in fun p => loop p (size p).

Lemma root_root_seq (p : {poly F}) x : p != 0 -> x \in root_seq p = root p x.
Proof.
rewrite /root_seq; set loop := fix loop p n := if n is _.+1 then _ else _.
elim: size {-2 5}p (erefl (size p))=> /= {p} [|n ihn] p /=.
  by move/eqP; rewrite size_poly_eq0 => /eqP->; rewrite eqxx.
case: eqP=> /= [sp_neq1 sp_eqn|/negP]; last first.
  rewrite negbK=> /size_poly1P [c c_neq0 ->] _ _.
  by rewrite rootC (negPf c_neq0).
case: sigW => z /= rpz p_neq0.
rewrite in_cons; have [->|neq_xz] //= := altP eqP.
move: rpz sp_eqn => /factor_theorem [q ->].
rewrite mulpK ?polyXsubC_eq0 // rootM root_XsubC (negPf neq_xz) orbF.
have [->|q_neq0] := eqVneq q 0; first by rewrite mul0r size_poly0.
rewrite size_mul ?polyXsubC_eq0 // size_XsubC addn2.
by case=> /ihn /(_ q_neq0).
Qed.

Lemma root_seq_cons (p : {poly F}) x s : root_seq p = x :: s ->
  s = root_seq (p %/ ('X - x%:P)).
Proof.
rewrite /root_seq; set loop := fix loop p n := if n is _.+1 then _ else _.
case H: (size p)=> [|n] //=; case: eqP=> // Hp.
move/eqP; rewrite eqseq_cons; case/andP=> /eqP {1}<- /eqP <-.
suff ->: n = size (p %/ ('X - x%:P))=> //.
by rewrite size_divp ?polyXsubC_eq0 // size_XsubC subn1 H.
Qed.

Lemma root_seq_eq (p : {poly F}) :
  p = lead_coef p *: \prod_(x <- root_seq p) ('X - x%:P).
Proof.
move: {2}(root_seq p) (erefl (root_seq p))=> s.
elim: s p=> [p | x s IHp p H].
  rewrite /root_seq; set loop := fix loop p n := if n is _.+1 then _ else _.
  case H: (size p)=> [|n].
    move/eqP: H; rewrite size_poly_eq0=> /eqP ->.
    by rewrite lead_coef0 scale0r.
  case: n H => [H | n H] /=; case: eqP => //.
    move=> _ _; rewrite big_nil.
    move/eqP: H => /size_poly1P [c H] ->.
    by rewrite lead_coefC alg_polyC.
  by move/negP; rewrite negbK H.
rewrite H big_cons (root_seq_cons H) mulrC scalerAl.
have Hfp : p = p %/ ('X - x%:P) * ('X - x%:P).
  apply/eqP; rewrite -dvdp_eq dvdp_XsubCl -root_root_seq.
    by rewrite H mem_head.
  move: H; rewrite /root_seq.
  set loop := fix loop p n := if n is _.+1 then _ else _.
  by apply: contraPneq => ->; rewrite size_poly0.
suff -> : lead_coef p = lead_coef (p %/ ('X - x%:P)).
  by rewrite -IHp ?(root_seq_cons H).
by rewrite {1}Hfp lead_coef_Mmonic // monicXsubC.
Qed.

Lemma root_seq0 : root_seq 0 = [::].
Proof. by rewrite /root_seq size_poly0. Qed.

Lemma size_root_seq p : size (root_seq p) = (size p).-1.
Proof.
have [-> | p0] := eqVneq p 0; first by rewrite root_seq0 size_poly0.
rewrite {2}[p]root_seq_eq size_scale ?lead_coef_eq0 //.
rewrite (big_nth 0) big_mkord size_prod.
  rewrite (eq_bigr (fun=> (1 + 1)%N)).
    by rewrite big_split sum1_card /= subSKn addnK card_ord.
  by move=> i _; rewrite size_XsubC.
by move=> i _; rewrite polyXsubC_eq0.
Qed.

Lemma root_seq_nil (p : {poly F}) :
  (size p <= 1)%N = ((root_seq p) == [::]).
Proof. by rewrite -subn_eq0 subn1 -size_root_seq size_eq0. Qed.

Lemma sub_root_div (p q : {poly F}) (Hq : q != 0) :
  p %| q -> {subset (root_seq p) <= (root_seq q)} .
Proof.
case: (eqVneq p 0) => [->|p0]; first by rewrite root_seq0.
by case/dvdpP => x Hx y; rewrite !root_root_seq // Hx rootM orbC=> ->.
Qed.

Definition root_seq_uniq p := undup (root_seq p).

Lemma prod_XsubC_count (p : {poly F}):
   p = (lead_coef p) *:
   \prod_(x <- root_seq_uniq p) ('X - x%:P)^+ (count_mem x (root_seq p)).
Proof.
by rewrite {1}[p]root_seq_eq (prod_seq_count (root_seq p)).
Qed.

Lemma count_root_seq p x : count_mem x (root_seq p) = \mu_x p.
Proof.
have [-> | Hp] := eqVneq p 0; first by rewrite root_seq0 mu0.
apply/eqP; rewrite -muP //.
case/boolP: (x \in root_seq p) => [|H].
  rewrite -mem_undup => H.
  move: (prod_XsubC_count p).
  rewrite (bigD1_seq x) //= ?undup_uniq //.
  set b:= \big[_/_]_(_ <- _ | _) _ => Hpq.
  apply/andP; split; apply/dvdpP.
    by exists (lead_coef p *: b); rewrite -scalerAl mulrC.
  case=> q Hq.
  have H1: ~~ (('X - x%:P) %| b).
    rewrite dvdp_XsubCl; apply/rootP.
    rewrite horner_prod; apply/eqP.
    rewrite (big_nth 0) big_mkord.
    apply/prodf_neq0=> i Hix.
    by rewrite horner_exp hornerXsubC expf_neq0 // subr_eq0 eq_sym.
  have H2: (('X - x%:P) %| b).
    apply/dvdpP; exists ((lead_coef p)^-1 *: q).
    apply: (@scalerI _ _ (lead_coef p)); first by rewrite lead_coef_eq0.
    rewrite -scalerAl scalerA mulrV ?unitfE ?lead_coef_eq0 // scale1r.
    have HX: (('X - x%:P)^+ (count_mem x (root_seq p))) != 0.
      by apply: expf_neq0; rewrite -size_poly_eq0 size_XsubC.
    rewrite -(mulpK (_ *: b) HX) -(mulpK (q * _) HX).
    by rewrite -scalerAl mulrC -Hpq -mulrA -exprS -Hq.
  by rewrite H2 in H1.
have->: count_mem x (root_seq p) = 0%N by apply/count_memPn.
by rewrite dvd1p /= dvdp_XsubCl -root_root_seq.
Qed.

Definition root_mu_seq p := [seq (x,(\mu_x p)) | x <- (root_seq_uniq p)].

Lemma root_mu_seq_pos x p : p != 0 -> x \in root_mu_seq p -> (0 < x.2)%N.
Proof.
move=> Hp H.
have Hr: size (root_seq_uniq p) = size (root_mu_seq p) by rewrite size_map.
have Hs: (index x (root_mu_seq p) < size (root_seq_uniq p))%N.
  by rewrite Hr index_mem.
rewrite -(nth_index (0,0%N) H) // (nth_map 0) // mu_gt0 //.
by rewrite -root_root_seq // -mem_undup mem_nth.
Qed.

Definition root_seq_poly (s : seq {poly F}) := flatten (map root_mu_seq s).

Lemma root_seq_poly_pos x s : (forall p , p \in s -> p !=0) ->
  x \in root_seq_poly s -> (0 < x.2)%N.
Proof.
elim : s=> [|p l IHl H]; first by rewrite in_nil.
rewrite mem_cat.
case/orP; first by apply: root_mu_seq_pos; apply: H; rewrite mem_head.
by apply: IHl=> q Hq; apply: H; rewrite in_cons Hq orbT.
Qed.

Definition linear_factor_seq p :=
   [seq ('X - x.1%:P)^+x.2 | x <- (root_mu_seq p)].

Lemma monic_linear_factor_seq p : forall q, q \in linear_factor_seq p ->
  q \is monic.
Proof.
move=> q Hq; rewrite -(nth_index 0 Hq) (nth_map (0,0%N)).
apply: monic_exp; first by apply: monicXsubC.
by rewrite -index_mem size_map in Hq.
Qed.

Lemma size_linear_factor_leq1 p : forall q, q \in linear_factor_seq p ->
  (1 < size q)%N.
Proof.
move=> q; have [-> | Hp Hq] := eqVneq p 0.
  rewrite /linear_factor_seq /root_mu_seq.
  by rewrite /root_seq_uniq /root_seq size_poly0.
rewrite -(nth_index 0 Hq) (nth_map (0,0%N)); last first.
  by rewrite -index_mem size_map in Hq.
rewrite size_exp_XsubC (nth_map 0); last first.
  by rewrite -index_mem !size_map in Hq.
rewrite -(@prednK (\mu_ _ _)) // mu_gt0 // -root_root_seq //.
rewrite -mem_undup mem_nth //.
by rewrite -index_mem !size_map in Hq.
Qed.

Lemma coprimep_linear_factor_seq p :
  forall (i j : 'I_(size (linear_factor_seq p))),
  i != j ->
  coprimep (linear_factor_seq p)`_i (linear_factor_seq p)`_j.
Proof.
move=> [i +] [j +]; rewrite !size_map=> Hi Hj Hij.
rewrite !(nth_map (0,0%N)) ?size_map //.
apply/coprimep_expl/coprimep_expr/coprimep_factor.
by rewrite unitfE subr_eq0 !(nth_map 0) //= nth_uniq // ?undup_uniq // eq_sym.
Qed.

Lemma prod_XsubC_mu (p : {poly F}):
   p = (lead_coef p) *: \prod_(x <- root_seq_uniq p) ('X - x%:P)^+(\mu_x p).
Proof.
rewrite {1}[p]prod_XsubC_count.
by congr GRing.scale; apply: eq_bigr => i _; rewrite count_root_seq.
Qed.

Lemma monic_prod_XsubC p :
   p \is monic -> p = \prod_(x <- root_seq_uniq p) ('X - x%:P)^+(\mu_x p).
Proof.
by move/monicP=> H; rewrite {1}[p]prod_XsubC_mu H scale1r.
Qed.

Lemma prod_factor (p : {poly F}):
   p = (lead_coef p) *: \prod_(x <- linear_factor_seq p) x.
Proof.
by rewrite !big_map {1}[p]prod_XsubC_mu.
Qed.

Lemma monic_prod_factor p :
   p \is monic -> p = \prod_(x <- linear_factor_seq p) x.
Proof.
by move/monicP=> H; rewrite {1}[p]prod_factor H scale1r.
Qed.

Lemma uniq_root_mu_seq (p : {poly F}) : uniq (root_seq p) ->
  forall x, x \in root_mu_seq p -> x.2 = 1%N.
Proof.
move=> H x /(nthP (0,0%N)) [] i; rewrite size_map=> Hi.
rewrite (nth_map 0) // => <- /=; move: Hi.
rewrite /root_seq_uniq undup_id // -count_root_seq => Hi.
by rewrite count_uniq_mem // (mem_nth 0 Hi).
Qed.

Lemma uniq_root_dvdp p q : q != 0 ->
  (uniq (root_seq q)) -> p %| q -> (uniq (root_seq p)).
Proof.
move=> Hq Hq2 Hpq.
apply: count_mem_uniq=> x.
have Hc:= count_uniq_mem x Hq2.
have Hle: (count_mem x (root_seq p) <= count_mem x (root_seq q))%N.
  rewrite !count_root_seq; case/dvdpP: Hpq => r Hr.
  by rewrite Hr mu_mul -?Hr // leq_addl.
have: (count_mem x (root_seq p) <= 1)%N.
  by rewrite (leq_trans Hle) // Hc; case: (x \in root_seq q).
rewrite leq_eqVlt ltnS leqn0.
case Hp: (x \in root_seq p).
  rewrite -has_pred1 has_count in Hp.
  by rewrite (eqn_leq _ 0%N) leqNgt Hp orbF => /eqP ->.
by rewrite eqn_leq -has_count has_pred1 Hp andbF orFb => /eqP ->.
Qed.

Lemma root_root_mu_seq p : [seq x.1 | x <- root_mu_seq p] = root_seq_uniq p.
Proof.
apply: (@eq_from_nth _ 0)=>[|i]; rewrite !size_map //.
by move=> Hi; rewrite (nth_map (0,0%N)) ?size_map // (nth_map 0) //.
Qed.

End poly_closedFieldType.


From mathcomp Require Import ssreflect.

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

Require Import class_set.

Section Class_Set_Theories.

  Variable U:Type.

  Theorem union_comm:
    forall (X Y:Ensemble U), X ∪ Y = Y ∪ X.
  Proof.
    move => X Y.
    apply /Extensionality_Ensembles.
    +split => x; case => x0 H.
     ++right.
       apply H.
       left.
       apply H.
     ++right.
       apply H.
       left.
       apply H.
  Qed.

  Theorem union_assoc:
    forall (X Y Z:Ensemble U), (X ∪ Y) ∪ Z = X ∪ Y ∪ Z.
  Proof.
    move => X Y Z.
    apply /Extensionality_Ensembles.
    +split => x.
     apply.
     apply.
  Qed.

  Lemma noone_in_complement: forall (x:U) (X:Ensemble U), x ∈ X <-> (x ∈ (X^c) -> False).
  Proof.
    move => x X.
    rewrite /iff.
    split => H.
    +move => H0.
     move: H.
     apply H0.
    +rewrite -(Complement_Complement U X).
     move => H0.
     move: H0.
     apply H.
  Qed.

  Lemma include_contrapositive:
    forall (X Y:Ensemble U), X ⊂ Y <-> (Y^c) ⊂ (X^c).
  Proof.
    move => X Y.
    rewrite /iff.
    split.
    +apply contrapositive.
     apply classic.
     move => H.
     unfold Included.
     move => H0.
     apply H.
     unfold Included.
     move => x.
     apply contrapositive.
     apply classic.
     rewrite -noone_in_complement.
     rewrite -noone_in_complement.
     apply H0.
    +unfold Included.
     move => H x.
     apply contrapositive.
     apply classic.
     rewrite noone_in_complement.
     rewrite (noone_in_complement x X).
     rewrite not_not_iff.
     rewrite not_not_iff.
     apply H.
     apply classic.
     apply classic.
  Qed.

  Proposition double_setminus:
    forall (X Y:Ensemble U), X ⊂ Y -> Y \ (Y \ X) = X.
  Proof.
    move => X Y H.
    apply /Extensionality_Ensembles.
    split => a H'.
    inversion H'.
    apply NNPP.
    move => HF.
    apply H1.
    split.
    apply H0.
    done.
    split.
    apply H.
    apply H'.
    move => H0.
    inversion H0.
    apply H2.
    done.
  Qed.

  Proposition complement_set_is_eq:
    forall (A B:Ensemble U), A ^c = B ^c <-> A = B.
  Proof.
    move => A B.
    rewrite /iff.
    split => H.
    apply Extension in H.
    inversion H.
    apply include_contrapositive in H0.
    apply include_contrapositive in H1.
    apply /Extensionality_Ensembles.
    split.
    apply H1.
    apply H0.
    rewrite H.
    reflexivity.
  Qed.

  Lemma de_morgen_union_intersection_in_set:
    forall (A B:Ensemble U),
      (A ∪ B) ^c = A ^c ∩ B ^c.
  Proof.
    move => A B.
    apply Extensionality_Ensembles.
    split => x H.
    have L1: (~ x ∈ A) /\ (~ x ∈ B).
    split; move => H'; apply H;[left|right];done.
    inversion L1.
    split; done.
    inversion H.
    move => HF.
    inversion HF; [apply H0|apply H1]; done.
  Qed.

  Lemma de_morgen_intersection_union_in_set:
    forall (A B:Ensemble U),
      (A ∩ B) ^c = A ^c ∪ B ^c.
  Proof.
    move => A B.
    have L1: ((A ^c ∪ B ^c) ^c) ^c = (A ^c ∪ B ^c).
    apply Complement_Complement.
    rewrite -L1.
    rewrite de_morgen_union_intersection_in_set.
    rewrite Complement_Complement.
    rewrite Complement_Complement.
    reflexivity.
  Qed.

  Lemma de_morgen_union_intersection_in_setminus:
    forall (A B X:Ensemble U),
      X \ (A ∪ B) = (X \ A) ∩ (X \ B).
  Proof.
    move => A B X.
    apply Extensionality_Ensembles.
    split => x H.
    inversion H.
    have L1: (~ x ∈ A) /\ (~ x ∈ B).
    split; move => H2;apply H1;[left|right];done.
    inversion L1.
    split;split;done.
    inversion H.
    inversion H0.
    inversion H1.
    split.
    apply H3.
    move => HF.
    inversion HF.
    apply H4.
    apply H7.
    apply H6.
    done.
  Qed.

  Lemma de_morgen_and_intersection_union_setminus:
    forall (A B X:Ensemble U),
      A ⊂ X /\ B ⊂ X -> X \ (A ∩ B) = (X \ A) ∪ (X \ B).
  Proof.
    move => A B X [HA HB].
    have L1: ((X \ A) ∪ (X \ B)) ⊂ X.
    move => x.
    case => x';case => H HF;done.
    have L2: X \ (X \ ((X \ A) ∪ (X \ B))) = (X \ A) ∪ (X \ B).
    rewrite (double_setminus L1).
    reflexivity.
    rewrite -L2.
    rewrite de_morgen_union_intersection_in_setminus.
    rewrite (double_setminus HA).
    rewrite (double_setminus HB).
    reflexivity.
  Qed.

End Class_Set_Theories.

Export class_set.


Require Import HoTT.

(** A few lemmas and definitions regarding path types we didn't find in the HoTT library. *)

(** A couple auxiliary lemmas we need  *)
Definition ap011_pp_pp {A B C : Type} (f : A -> B -> C) {x x' x'' : A} {y y' y'' : B}
           (p : x = x') (p' : x' = x'') (q : y = y') (q' : y' = y'') :
  ap011 f (p @ p') (q @ q') = ap011 f p q @ ap011 f p' q'.
Proof.
    by path_induction.
Qed.

Lemma ap011_VV
  : forall {A B C: Type} (f : A -> B -> C)
           {a0 a1 : A} {b0 b1 : B}
           (p : a0 = a1) (q : b0 = b1),
    (ap011 f p q)^ = ap011 f p^ q^.
Proof.
  intros. destruct p. destruct q. reflexivity.
Defined.

Definition double_pathover {A B : Type} (P : A -> B -> Type)
           {a a' : A} (p : a = a')
           {b b' : B} (q : b = b')
           (c : P a b) (c' : P a' b') : Type.
Proof.
  destruct p,q. exact (c = c').
Defined.

Definition double_pathover_to_path {A B : Type} (P : A -> B -> Type)
           {a a' : A} (p : a = a')
           {b b' : B} (q : b = b')
           (c : P a b) (c' : P a' b')
  : double_pathover P p q c c' ->
    transport (uncurry P) (path_prod (a,b) (a',b') p q) c = c'.
Proof.
  destruct p, q. exact idmap.
Defined.

Definition path_to_double_pathover {A B : Type} (P : A -> B -> Type)
           {a a' : A} (p : a = a')
           {b b' : B} (q : b = b') (c : P a b) (c' : P a' b')
  : transport (uncurry P) (path_prod (a, b) (a', b') p q) c = c' ->
    double_pathover P p q c c'.
Proof.
  destruct p. destruct q. exact idmap.
Defined.

Lemma path_arrow_V {A B : Type} {f g : A -> B} (H : f == g) :
  path_arrow g f (fun a => (H a)^) = (path_arrow f g H)^.
Proof.
  transitivity (path_arrow f g (ap10 (path_forall _ _ H)))^.
  - transitivity (path_arrow g f (fun a => (ap10 (path_forall _ _ H) a)^)).
    + apply (ap (path_arrow g f)). apply path_forall.
      intro a. apply (ap inverse). apply inverse. apply (ap10_path_arrow).
    +  destruct (path_forall f g H). simpl.
       destruct (path_forall _ _ (ap10_1 (f:= f)))^.
       destruct (path_arrow_1 f)^. reflexivity.
  - apply (ap inverse). apply (ap (path_arrow f g)). apply (path_forall _ _ (ap10_path_arrow f g H)).
Defined.

Definition path_prod_VV {A B : Type} (z z' : A*B) (p1 : fst z = fst z') (p2 : snd z = snd z') :
  path_prod z' z p1^ p2^ = (path_prod z z' p1 p2)^.
Proof.
  destruct z as [z1 z2]. destruct z' as [z1' z2']. simpl in *. destruct p1, p2. reflexivity.
Defined.

Definition path_triple_prod {A B C : Type} (a1 a2 : A * (B * C)) :
  (fst a1 = fst a2) * ((fst (snd a1) = fst (snd a2)) * (snd (snd a1) = snd (snd a2))) -> a1 = a2.
Proof.
  intros [p [q r]].
  apply (path_prod a1 a2 p (path_prod (_,_) (_,_) q r)).
Defined.

Definition equiv_path_triple_prod {A B C : Type} (a1 a2 : A * (B * C)) :
  (fst a1 = fst a2) * ((fst (snd a1) = fst (snd a2)) * (snd (snd a1) = snd (snd a2))) <~> a1 = a2.
Proof.
  srapply (@equiv_adjointify _ _ (path_triple_prod a1 a2)).
  - intro p.
    exact (ap fst p, (ap fst (ap snd p), (ap snd (ap snd p)))).
  - intros []. reflexivity.
  - intros [p [q r]].
    destruct a2 as [a2 [b2 c2]]. simpl in *.
    destruct p,q,r. reflexivity.
Defined.


(* http://www.cse.chalmers.se/research/group/logic/TypesSS05/resources/coq/CoqArt/contents.html *)

(* Chapter 3 *)
(* Section 3.1 *)

Require Import Arith.
Require Import ZArith.
Require Import Bool.

Section Minimal_propositional_logic.

  Variables P Q R T : Prop.

  Theorem imp_trans_auto : (P -> Q) -> (Q -> R) -> P -> R.
  Proof.
    auto.
  Qed.

  Theorem imp_trans : (P -> Q) -> (Q -> R) -> P -> R.
  Proof.
    intros H H' p.
    apply H'.
    apply H.
    exact p.
  Qed.

  Print imp_trans_auto.
  Print imp_trans.

(* Section 3.2 *)

  Section example_of_assumption.
    Hypothesis H : P -> Q -> R.

    Lemma L1 : P -> Q -> R.
    Proof.
      assumption.
    Qed.
  End example_of_assumption.

  Theorem delta : (P -> P -> Q) -> P -> Q.
  Proof.
    exact (fun (H : P -> P -> Q) (p:P) => H p p).
  Qed.

  Theorem delta2 : (P -> P -> Q) -> P -> Q.
  Proof (fun (H : P -> P -> Q) (p:P) => H p p).

  Theorem apply_example : (Q -> R -> T) -> (P -> Q) -> P -> R -> T.
  Proof.
    intros H H0 p.
    apply H.
    exact (H0 p).
  Qed.

  Theorem imp_dist_auto : (P -> Q -> R) -> (P -> Q) -> (P -> R).
  Proof.
    auto.
  Qed.
  Print imp_dist_auto.

  Theorem imp_dist : (P -> Q -> R) -> (P -> Q) -> (P -> R).
  Proof.
    intros H H' p.
    apply H.
    - exact p.
    - exact (H' p).
  Qed.

  Theorem K : P -> Q -> P.
  Proof.
    intros p q.
    exact p.
  Qed.

(* Section 3.3 *)

(* Exercise 3.2 *)

  Lemma id_P : P -> P.
  Proof.
    intro p.
    exact p.
  Qed.

  Lemma id_PP : (P -> P) -> (P -> P).
  Proof.
    intro p.
    exact p.
  Qed.

  Lemma imp_trans' : (P -> Q) -> (Q -> R) -> P -> R.
  Proof.
    intros Hpq Hqr p.
    apply Hqr.
    apply Hpq.
    exact p.
  Qed.

  Lemma imp_perm : (P -> Q -> R) -> (Q -> P -> R).
  Proof.
    intros Hpqr q p.
    apply Hpqr.
    - exact p.
    - exact q.
  Qed.

  Lemma ignore_Q : (P -> R) -> P -> Q -> R.
  Proof.
    intros Hpr p q.
    apply Hpr.
    exact p.
  Qed.

  Lemma delta_imp : (P -> P -> Q) -> P -> Q.
  Proof.
    intros Hppq p.
    apply Hppq.
    - exact p.
    - exact p.
  Qed.

  Lemma delta_impR : (P -> Q) -> (P -> P -> Q).
  Proof.
    intros Hpq p1 p2.
    apply Hpq.
    exact p1.
  Qed.

  Lemma diamond : (P -> Q) -> (P -> R) -> (Q -> R -> T) -> P -> T.
  Proof.
    intros Hpq Hpr Hqrt p.
    apply Hqrt.
    - apply Hpq.
      exact p.
    - apply Hpr.
      exact p.
  Qed.

  Lemma weak_peirce : ((((P -> Q) -> P) -> P) -> Q) -> Q.
  Proof.
    intro H0.
    apply H0.
    intro H1.
    apply H1.
    intro p.
    apply H0.
    intro H2.
    exact p.
  Qed.

(* Section 3.4*)

  Definition unreliable : (nat -> bool) -> (nat -> bool) -> nat -> bool.
    intros f1 f2.
    assumption.
  Defined.
  Print unreliable.
  Eval compute in (unreliable (fun n => true) (fun n => false) 45).
  Opaque unreliable.
  Eval compute in (unreliable (fun n => true) (fun n => false) 45).

(* Section 3.5 *)

  Section proof_of_triple_impl.
    Hypothesis H : ((P -> Q) -> Q) -> Q.
    Hypothesis p : P.

    Lemma Rem : (P -> Q) -> Q.
    Proof (fun H0 : P -> Q => H0 p).

    Theorem triple_impl : Q.
    Proof (H Rem).
  End proof_of_triple_impl.
  Print Rem.
  Print triple_impl.

(* Section 3.6 *)

  Theorem then_example : P -> Q -> (P -> Q -> R) -> R.
  Proof.
    intros p q Hpq.
    apply Hpq; assumption.
  Qed.

  Theorem triple_impl_one_go : (((P -> Q) -> Q) -> Q) -> P -> Q.
  Proof.
    intros H p; apply H; intro H0; apply H0; assumption.
  Qed.

  Theorem compose_example : (P -> Q -> R) -> (P -> Q) -> P -> R.
  Proof.
    intros Hpqr Hpq p.
    apply Hpqr; [assumption | apply Hpq; assumption].
  Qed.

  Theorem orelse_example : (P -> Q) -> R -> ((P -> Q) -> R -> (T -> Q) -> T) -> T.
  Proof.
    intros Hpq r H.
    apply H;(assumption || intro H1).
  Abort.

(* Exercise 3.3 - TODO *)

Lemma id_P_1 : P -> P.
Proof.
  intros p; assumption.
Qed.

Lemma id_PP_1 : (P -> P) -> (P -> P).
Proof.
  intros Hpp p; assumption.
Qed.

Lemma imp_trans_1 : (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros Hpq Hqr p; apply Hqr; apply Hpq; assumption.
Qed.

Lemma imp_perm_1 : (P -> Q -> R) -> (Q -> P -> R).
Proof.
  intros Hpqr q p; apply Hpqr; assumption.
Qed.

Lemma ignore_Q_1 : (P -> R) -> P -> Q -> R.
Proof.
  intros Hpr p q; apply Hpr; assumption.
Abort.

Lemma delta_imp_1 : (P -> P -> Q) -> P -> Q.
Proof.
  intros Hppq p; apply Hppq; assumption.
Qed.

Lemma delta_impR_1 : (P -> Q) -> (P -> P -> Q).
Proof.
  intros Hpq p0 p1; apply Hpq; assumption.
Qed.

Lemma diamond_1 : (P -> Q) -> (P -> R) -> (Q -> R -> T) -> P -> T.
Proof.
  intros Hpq Hpr Hqrt p; apply Hqrt; (apply Hpr || apply Hpq); assumption.
Qed.

Lemma weak_peirce_1 : ((((P -> Q) -> P) -> P) -> Q) -> Q.
Proof.
  auto. (*TODO*)
Qed.

(* Section 3.7 *)

  Section section_for_cut_example.
    Hypotheses
      (H : P -> Q)
      (H0 : Q -> R)
      (H1 : (P -> R) -> T -> Q)
      (H2 : (P -> R) -> T).
    Theorem cut_example : Q.
    Proof.
      cut (P -> R).
      intro H3.
      - apply H1; [assumption | apply H2; assumption ].
      - intro p.
        apply H0.
        apply H.
        exact p.
    Qed.
    Print cut_example.
  End section_for_cut_example.

(* Exercise 3.5 *)

End Minimal_propositional_logic.

(* Section 3.9 *)

Print imp_dist.

Section using_imp_dict.
  Variables (P1 P2 P3 : Prop).
  Check (imp_dist P1 P2 P3).
End using_imp_dict.


Require Import Coq.Strings.String.

Inductive exp : Type :=
  | num : nat -> exp
  | var : string -> exp
  | plus : exp -> exp -> exp
  | minus : exp -> exp -> exp.

Definition state : Type := string -> nat.

Fixpoint eval (s : state) (e : exp) : nat :=
  match e with
  | num n => n
  | var v => s v
  | plus lhs rhs => eval s lhs + eval s rhs
  | minus lhs rhs => eval s lhs - eval s rhs
  end.

Definition empty : state := fun v => 0.

Definition update (v : string) (n : nat) (s : state) : state :=
  fun v' => if eqb v v' then n else s v.

Theorem putGet (v : string) (n : nat) (s : state) : (update v n s) v = n.
Proof.
  unfold update. rewrite eqb_refl. trivial.
Qed.

Theorem getPut (v : string) (s : state) : (update v (s v) s) v = (s v).
Proof.
  unfold update. rewrite eqb_refl. trivial.
Qed.

Theorem putPut (v : string) (n1 : nat) (n2 : nat) (s : state)
  : (update v n2 (update v n1 s)) v = n2.
Proof.
  unfold update. rewrite eqb_refl. trivial.
Qed.

Inductive even : nat -> Prop :=
  | ev0 : even 0
  | evS (n : nat) (H : even n) : even (S (S n)).

Example even4 :
  even 4.
Proof.
  apply evS.
  apply evS.
  apply ev0.
Qed.


Require Import Arith List.
Require Import CpdtTactics.
Require Import MoreSpecif.

Local Open Scope specif.

Module P1.
  Definition compare : forall n m : nat, {n <= m} + {n > m}.
  Proof.
    refine (fix cmp (n m : nat) : {n <= m} + {n > m} :=
              match n with
              | O => Yes
              | S n' => match m with
                        | O => No
                        | S m' => Reduce (cmp n' m')
                        end
              end); omega.
  Defined.
End P1.

Module P2.
  Definition var := nat.

  Inductive prop : Set :=
  | Var : var -> prop
  | Not : prop -> prop
  | Conj : prop -> prop -> prop
  | Disj : prop -> prop -> prop.

  Fixpoint denote (U : var -> bool) (e : prop) : Prop :=
    match e with
    | Var x => if U x then True else False
    | Not p => ~ denote U p
    | Conj p1 p2 => denote U p1 /\ denote U p2
    | Disj p1 p2 => denote U p1 \/ denote U p2
    end.

  Definition bool_true_dec : forall b, {b = true} + {b = true -> False}.
  Proof.
    refine (fun b => match b with
                     | true => Yes
                     | false => No
                     end); crush.
  Defined.

  Definition decide : forall (U : var -> bool) (p : prop), {denote U p} + {~ denote U p}.
  Proof.
    induction p; crush.
    destruct (U v); crush.
  Defined.

  Definition negate : forall p, {p' | forall U, denote U p <-> ~ denote U p'}.
  Proof.
    refine (fix neg p : {p' | forall U, denote U p <-> ~ denote U p'} :=
              match p with
              | Var x => [Not (Var x)]
              | Not p' => [p']
              | Conj p1 p2 => (p1' <== neg p1;
                               p2' <== neg p2;
                               [Disj p1' p2'])
              | Disj p1 p2 => (p1' <== neg p1;
                               p2' <== neg p2;
                               [Conj p1' p2'])
              end); intros; simpl.
    destruct (U x); crush.
    crush.
    rewrite _H. rewrite _H0.
    intuition.
    rewrite _H. rewrite _H0.
    intuition.
    destruct (decide U p1'); intuition.
  Defined.
End P2.


Require Import Vector.
Require Import Arith.
Require Import Bool.Bvector.
(* Try to represent bool function as list of result,
for example conj will represent like {0, 0, 0, 1} *)

Definition BoolFunN (n: nat) := t Prop (2^n).

Inductive closClass (n: nat): Type :=
| PreservesFalse (x: BoolFunN n)
| PreservesTrue (x: BoolFunN n)
| SelfDual (x: BoolFunN n)
| Monotonous (x: BoolFunN n)
| Linear (x: BoolFunN n) .

Definition сompose {BoolFun} (f : BoolFun -> BoolFun) (g: BoolFun -> BoolFun) :=
  fun x: BoolFun => g (f x).

Definition BoolFun2 (x: t Prop 4) := BoolFunN 2.

Check BoolFun2.

Check t Prop.

Definition conj := BoolFun2 ([False ; False ; False ; True ]).

Check [False ; False ; False ; True ].

Check conj.

Definition IsPreservesFalseFunc (n: nat) (f : (BoolFunN n)): Prop :=
  match f with
    | True :: t => False
    | _ => True
    (*| False :: t => True*)
end.

Eval compute in (IsPreservesFalseFunc 2 [False ; False ; False ; True ]).

Definition IsPreservesTrueFunc (n: nat) (f : (BoolFunN n)): Prop :=
  match f with
    | [] => False (* Strange case*)
    | h::t => if List.last (to_list t) false then True else False
end.

Import Lists.List.

Fixpoint IsListSelfDual(v p : list bool): Prop :=
  match v, p with
  | Lists.List.nil, Lists.List.nil => True
  | h::t, f::g => if eqb h f then False else  IsListSelfDual t g
  | _, _ => False
end.

Definition IsSelfDualFunc (n: nat) (f : (BoolFunN n)) : Prop := let x := to_list f in IsListSelfDual x (rev x).

Definition getComparableSet (n: nat) : list (nat * nat) :=
  match n with
  | 1 => (cons (0 , 1) nil)
  | 2 => (cons (0 , 1) (cons (1 , 2)  (cons (2 , 3) nil) ))
  | 3 => (cons (0 , 1) (cons (0 , 2)  (cons (0 , 4) ( cons (1 ,3) ( cons (1,5)
( cons (2, 3) ( cons (2, 6) ( cons (3, 7)( cons (4 ,5)( cons (4, 6)
(cons (5,7) ( cons (6, 7) nil))))))) )))))
  | _ => nil
  end.

Definition leBool (a b : bool) : bool :=
  match a, b with
  | true, false => false
  | _, _ => true
  end.

Fixpoint isMonotoniusFuncHelp {n: nat} (f : (BoolFunN n)) ( comparation: list (nat * nat)) : Prop :=
  let fl := to_list f in match comparation with
  | List.nil => True
  | h::t => if  leBool (nth (fst h) fl false) (nth (snd h) fl false)  then isMonotoniusFuncHelp f t  else False
  end.

Definition isMonotoniusFunc (n: nat) (f : (BoolFunN n)) : Prop := isMonotoniusFuncHelp f (getComparableSet n).

Eval compute in (IsPreservesFalseFunc 2 conj).
(*
Как применять эти функции????
Check isMonotoniusFunc 2 conj - не работает.
Определит линейность, ввести понятие системы функций,
написать проверки на на не принадлежность к классам для системы функций,
тогда теорема о полноте: T0 -> T1 -> S -> M -> L -> Full.
А проверка конкретной системы будет ??????*)


(** * Encoding terms, formulas and proofs *)

Require Import Arith.
Require Import fol.
Require Import folProof.
Require Import cPair.

Section Code_Term_Formula_Proof.

Variable L : Language.
Variable codeF : Functions L -> nat.
Variable codeR : Relations L -> nat.
Hypothesis codeFInj :
  forall f g : Functions L, codeF f = codeF g -> f = g.
Hypothesis codeRInj :
  forall R S : Relations L, codeR R = codeR S -> R = S.

Let Formula := Formula L.
Let Formulas := Formulas L.
Let System := System L.
Let Term := Term L.
Let Terms := Terms L.
Let Prf := Prf L.
Let SysPrf := SysPrf L.

Fixpoint codeTerm (t : Term) : nat :=
  match t with
  | var n => cPair 0 n
  | apply f ts => cPair (S (codeF f)) (codeTerms _ ts)
  end

 with codeTerms (n : nat) (ts : Terms n) {struct ts} : nat :=
  match ts with
  | Tnil => 0
  | Tcons n t ss => S (cPair (codeTerm t) (codeTerms n ss))
  end.

Lemma codeTermInj :
  forall t s : Term, codeTerm t = codeTerm s -> t = s.
Proof.
  intro t; elim t using Term_Terms_ind
    with (P0 := fun (n : nat) (ts : fol.Terms L n) =>
                  forall ss : Terms n,
                    codeTerms n ts = codeTerms n ss -> ts = ss).
  - (* variables *) intros n s H; destruct s.
    + simpl in H; apply cPairInj2 in H; now subst.
    + simpl in H.
      assert (H0: 0 = S (codeF f)) by (eapply cPairInj1; apply H).
      discriminate H0.
  - (* applications *) intros f t0 H s H0; destruct s.
    + simpl in H0.
      assert (H1: S (codeF f) = 0) by (eapply cPairInj1; apply H0).
      discriminate H1.
    + simpl in H0; assert (H1: f = f0).
       { apply codeFInj, eq_add_S; eapply cPairInj1; apply H0. }
       cut
         (cPair (S (codeF f)) (codeTerms (arityF L f) t0) =
            cPair (S (codeF f0))
              (codeTerms (arityF L f0) t1)).
       * generalize t1; rewrite <- H1; clear H1 H0 t1.
         intros t1 H0; rewrite (H t1).
         -- reflexivity.
         -- eapply cPairInj2.
            apply H0.
       * apply H0.
  - (* empty sequence *)  intros ss H; rewrite <- nilTerms; reflexivity.
  - (* non-empty sequence *)
    intros n t0 H t1 H0 ss H1; induction (consTerms L n ss).
    destruct x as (a, b); simpl in p; rewrite <- p.
    rewrite <- p in H1; simpl in H1; rewrite (H a).
    + rewrite (H0 b).
      * reflexivity.
      * eapply cPairInj2; apply eq_add_S, H1.
    + eapply cPairInj1.
      apply eq_add_S, H1.
Qed.

Lemma codeTermsInj :
 forall (n : nat) (ts ss : Terms n),
 codeTerms n ts = codeTerms n ss -> ts = ss.
Proof.
  intros n ts; induction ts as [| n t ts Hrects].
  - intros ss H; now rewrite <- (nilTerms L ss).
  - intros ss H.
    destruct (consTerms L n ss) as [(a,b) p].
    simpl in p; rewrite <- p in H |- *.
    rewrite (Hrects b).
    + rewrite (codeTermInj t a).
      * reflexivity.
      * eapply cPairInj1.
        apply eq_add_S, H.
    + eapply cPairInj2.
      apply eq_add_S, H.
Qed.

Fixpoint codeFormula (f : Formula) : nat :=
  match f with
  | equal t1 t2 => cPair 0 (cPair (codeTerm t1) (codeTerm t2))
  | impH f1 f2 => cPair 1 (cPair (codeFormula f1) (codeFormula f2))
  | notH f1 => cPair 2 (codeFormula f1)
  | forallH n f1 => cPair 3 (cPair n (codeFormula f1))
  | atomic R ts => cPair (4+(codeR R)) (codeTerms _ ts)
  end.

Lemma codeFormulaInj :
  forall f g : Formula, codeFormula f = codeFormula g -> f = g.
Proof.
  intro f;
    induction f as [t t0| r t| f1 Hrecf1 f0 Hrecf0| f Hrecf| n f Hrecf]; intros;
    [ destruct g as [t1 t2| r t1| f f0| f| n f]
    | destruct g as [t0 t1| r0 t0| f f0| f| n f]
    | destruct g as [t t0| r t| f f2| f| n f]
    | destruct g as [t t0| r t| f0 f1| f0| n f0]
    | destruct g as [t t0| r t| f0 f1| f0| n0 f0] ];
    (simpl in H;
     try
       match goal with
       | h:(cPair ?X1 ?X2 = cPair ?X3 ?X4) |- _ =>
           assert  False by ( cut (X1 = X3);
           [ discriminate | eapply cPairInj1; apply h ]);
           contradiction
       end).
  - (* equality between terms *)
    rewrite (codeTermInj t t1).
    + rewrite (codeTermInj t0 t2).
      * reflexivity.
      * eapply cPairInj2.
        eapply cPairInj2.
        apply H.
    + eapply cPairInj1.
      eapply cPairInj2.
      apply H.
  - (* atomic formulas *) assert (r = r0).
    { apply codeRInj.
      do 4 apply eq_add_S.
      eapply cPairInj1.
      apply H.
    }
    cut  (cPair (S (S (S (S (codeR r)))))
            (codeTerms (arityR L r) t) =
            cPair (S (S (S (S (codeR r0)))))
              (codeTerms (arityR L r0) t0)).
    + generalize t0; rewrite <- H0; clear H0 H t0.
      intros t0 H; rewrite (codeTermsInj _ t t0).
      * reflexivity.
      * eapply cPairInj2; apply H.
    + apply H.
  - (* implication *)
    rewrite (Hrecf1 f).
    + rewrite (Hrecf0 f2).
      * reflexivity.
      * eapply cPairInj2.
        eapply cPairInj2.
        apply H.
    + eapply cPairInj1.
      eapply cPairInj2; apply H.
  - (* negation *) rewrite (Hrecf f0).
    reflexivity.
    eapply cPairInj2.
    apply H.
  - (* universal quantification *)
    rewrite (Hrecf f0).
    + replace n0 with n.
      * reflexivity.
      * eapply cPairInj1.
        eapply cPairInj2.
        apply H.
    + eapply cPairInj2.
      eapply cPairInj2.
      apply H.
Qed.

Fixpoint codePrf (Z : Formulas) (f : Formula) (prf : Prf Z f) {struct prf} :
 nat :=
  match prf with
  | AXM A => cPair 0 (codeFormula A)
  | MP Axm1 Axm2 A B rec1 rec2 =>
      cPair 1
        (cPair
           (cPair (cPair 1 (cPair (codeFormula A) (codeFormula B)))
              (codePrf _ _ rec1)) (cPair (codeFormula A) (codePrf _ _ rec2)))
  | GEN Axm A v _ rec =>
      cPair 2 (cPair v (cPair (codeFormula A) (codePrf _ _ rec)))
  | IMP1 A B => cPair 3 (cPair (codeFormula A) (codeFormula B))
  | IMP2 A B C =>
      cPair 4 (cPair (codeFormula A) (cPair (codeFormula B) (codeFormula C)))
  | CP A B => cPair 5 (cPair (codeFormula A) (codeFormula B))
  | FA1 A v t => cPair 6 (cPair (codeFormula A) (cPair v (codeTerm t)))
  | FA2 A v _ => cPair 7 (cPair (codeFormula A) v)
  | FA3 A B v => cPair 8 (cPair (codeFormula A) (cPair (codeFormula B) v))
  | EQ1 => cPair 9 0
  | EQ2 => cPair 10 0
  | EQ3 => cPair 11 0
  | EQ4 r => cPair 12 (codeR r)
  | EQ5 f => cPair 13 (codeF f)
  end.

Lemma codePrfInjAxm :
 forall (a b : Formula) (A B : Formulas) (p : Prf A a) (q : Prf B b),
 codePrf A a p = codePrf B b q -> A = B.
Proof.
  intros a b A B p; generalize B b; clear B b.
  induction p
    as
    [A|
      Axm1 Axm2 A B p1 Hrecp1 p0 Hrecp0|
      Axm A v n p Hrecp|
      A B|
      A B C|
      A B|
      A v t|
      A v n|
      A B v|
    |
    |
    |
      R|
      f]; intros;
    [ destruct q
      as
      [A0|
        Axm1 Axm2 A0 B p p0|
        Axm A0 v n p|
        A0 B|
        A0 B C|
        A0 B|
        A0 v t|
        A0 v n|
        A0 B v|
      |
      |
      |
        R|
        f]
    | destruct q
      as
      [A0|
        Axm0 Axm3 A0 B0 p p2|
        Axm A0 v n p|
        A0 B0|
        A0 B0 C|
        A0 B0|
        A0 v t|
        A0 v n|
        A0 B0 v|
      |
      |
      |
        R|
        f]
    | destruct q
      as
      [A0|
        Axm1 Axm2 A0 B p0 p1|
        Axm0 A0 v0 n0 p0|
        A0 B|
        A0 B C|
        A0 B|
        A0 v0 t|
        A0 v0 n0|
        A0 B v0|
      |
      |
      |
        R|
        f]
    | destruct q
      as
      [A0|
        Axm1 Axm2 A0 B0 p p0|
        Axm A0 v n p|
        A0 B0|
        A0 B0 C|
        A0 B0|
        A0 v t|
        A0 v n|
        A0 B0 v|
      |
      |
      |
        R|
        f]
    | destruct q
      as
      [A0|
        Axm1 Axm2 A0 B0 p p0|
        Axm A0 v n p|
        A0 B0|
        A0 B0 C0|
        A0 B0|
        A0 v t|
        A0 v n|
        A0 B0 v|
      |
      |
      |
        R|
        f]
    | destruct q
      as
      [A0|
        Axm1 Axm2 A0 B0 p p0|
        Axm A0 v n p|
        A0 B0|
        A0 B0 C|
        A0 B0|
        A0 v t|
        A0 v n|
        A0 B0 v|
      |
      |
      |
        R|
        f]
    | destruct q
      as
      [A0|
        Axm1 Axm2 A0 B p p0|
        Axm A0 v0 n p|
        A0 B|
        A0 B C|
        A0 B|
        A0 v0 t0|
        A0 v0 n|
        A0 B v0|
      |
      |
      |
        R|
        f]
    | destruct q
      as
      [A0|
        Axm1 Axm2 A0 B p p0|
        Axm A0 v0 n0 p|
        A0 B|
        A0 B C|
        A0 B|
        A0 v0 t|
        A0 v0 n0|
        A0 B v0|
      |
      |
      |
        R|
        f]
    | destruct q
      as
      [A0|
        Axm1 Axm2 A0 B0 p p0|
        Axm A0 v0 n p|
        A0 B0|
        A0 B0 C|
        A0 B0|
        A0 v0 t|
        A0 v0 n|
        A0 B0 v0|
      |
      |
      |
        R|
        f]
    | destruct q
      as
      [A|
        Axm1 Axm2 A B p p0|
        Axm A v n p|
        A B|
        A B C|
        A B|
        A v t|
        A v n|
        A B v|
      |
      |
      |
        R|
        f]
    | destruct q
      as
      [A|
        Axm1 Axm2 A B p p0|
        Axm A v n p|
        A B|
        A B C|
        A B|
        A v t|
        A v n|
        A B v|
      |
      |
      |
        R|
        f]
    | destruct q
      as
      [A|
        Axm1 Axm2 A B p p0|
        Axm A v n p|
        A B|
        A B C|
        A B|
        A v t|
        A v n|
        A B v|
      |
      |
      |
        R|
        f]
    | destruct q
      as
      [A|
        Axm1 Axm2 A B p p0|
        Axm A v n p|
        A B|
        A B C|
        A B|
        A v t|
        A v n|
        A B v|
      |
      |
      |
        R0|
        f]
    | destruct q
      as
      [A|
        Axm1 Axm2 A B p p0|
        Axm A v n p|
        A B|
        A B C|
        A B|
        A v t|
        A v n|
        A B v|
      |
      |
      |
        R|
        f0] ];
    (simpl in H;
     try
       match goal with
       | h:(cPair ?X1 ?X2 = cPair ?X3 ?X4) |- _ =>
           assert False by (cut (X1 = X3);
           [ discriminate | eapply cPairInj1; apply h ]); contradiction
       end); try reflexivity.
  - replace A0 with A.
    + reflexivity.
    + apply codeFormulaInj; eapply cPairInj2, H.
  - replace Axm0 with Axm1.
    + replace Axm3 with Axm2.
      * reflexivity.
      * eapply Hrecp0 with A0 p2.
        do 3 eapply cPairInj2.
        apply H.
    + eapply Hrecp1 with (impH  A0 B0) p.
      eapply cPairInj2.
      eapply cPairInj1.
      eapply cPairInj2.
      apply H.
  - eapply Hrecp with A0 p0.
    do 3 eapply cPairInj2.
    apply H.
Qed.

Definition codeImp (a b : nat) := cPair 1 (cPair a b).

Lemma codeImpCorrect :
 forall a b : Formula,
 codeImp (codeFormula a) (codeFormula b) = codeFormula (impH a b).
Proof. intros; reflexivity. Qed.

Definition codeNot (a : nat) := cPair 2 a.

Lemma codeNotCorrect :
 forall a : Formula, codeNot (codeFormula a) = codeFormula (notH a).
Proof. intros; reflexivity. Qed.

Definition codeForall (n a : nat) := cPair 3 (cPair n a).

Lemma codeForallCorrect :
 forall (n : nat) (a : Formula),
 codeForall n (codeFormula a) = codeFormula (forallH n a).
Proof.
 intros; reflexivity. Qed.

Definition codeOr (a b : nat) := codeImp (codeNot a) b.

Lemma codeOrCorrect :
 forall a b : Formula,
 codeOr (codeFormula a) (codeFormula b) = codeFormula (orH a b).
Proof. intros; reflexivity. Qed.

Definition codeAnd (a b : nat) := codeNot (codeOr (codeNot a) (codeNot b)).

Lemma codeAndCorrect :
 forall a b : Formula,
 codeAnd (codeFormula a) (codeFormula b) = codeFormula (andH a b).
Proof. intros; reflexivity. Qed.

Definition codeIff (a b : nat) := codeAnd (codeImp a b) (codeImp b a).

Lemma codeIffCorrect :
 forall a b : Formula,
 codeIff (codeFormula a) (codeFormula b) = codeFormula (iffH a b).
Proof. intros; reflexivity. Qed.

End Code_Term_Formula_Proof.


Require Import ZArith Lia Basics RelationClasses Program.
Require Import Flocq.IEEE754.Binary Flocq.Core.Defs Flocq.Core.Zaux.
Require Import ExtLib.Structures.Monads ExtLib.Data.Monads.OptionMonad.
Require Import Floats.

Open Scope Z.

(* a basic float - a pair of two integers - mantissa and exponent *)
Definition bfloat := Flocq.Core.Defs.float radix2.
Definition BFloat := Flocq.Core.Defs.Float radix2.

(** * converting between floats in the same cohort *)

(* increase a given float's exponent by [de] *)
Definition inc_e (f : bfloat) (de : positive) : option bfloat :=
  let '(m, e) := (Fnum f, Fexp f) in
  let rm := two_power_pos de in
  if (Zmod m rm =? 0)
  then Some (BFloat (m / two_power_pos de) (e + Z.pos de))
  else None.

(* decrese a given float's exponent by [de] *)
Definition dec_e (f : bfloat) (de : positive) : bfloat :=
  let '(m, e) := (Fnum f, Fexp f) in
  let rm := two_power_pos de in
  BFloat (m * two_power_pos de) (e - Z.pos de).

(* shift (up or down) the exponent by [de] *)
Definition shift_e (f : bfloat) (de : Z) : option bfloat :=
  match de with
  | Z0 => Some f
  | Z.pos pde => inc_e f pde
  | Z.neg nde => Some (dec_e f nde)
  end.

(* set exponent to a given one *)
Definition set_e (f : bfloat) (e : Z) : option bfloat :=
  shift_e f (e - Fexp f).

(* binary length of a number *)
Definition Zdigits (m : Z) := Z.log2 (Z.abs m) + 1.

(* shifting the binary length of the mantissa - *)
Definition inc_digits_m := dec_e.
Definition dec_digits_m := inc_e.
Definition shift_digits_m (f : bfloat) (ddm : Z) := shift_e f (- ddm).
Definition set_digits_m (f : bfloat) (dm : Z) := shift_digits_m f (dm - Zdigits (Fnum f)).

(** * normalization *)
Definition normalize_float (prec emax : Z) (f : bfloat)
  : option bfloat :=
  let emin := 3 - emax - prec in
  match set_e f emin with
    | None => None
    | Some f1 => if Zdigits (Fnum f1) <=? prec
                 then Some f1
                 else match set_digits_m f prec with
                     | None => None
                     | Some f2 => if andb
                                       (emin <=? Fexp f2)
                                       (Fexp f2 <=? emax - prec)
                                  then Some f2
                                  else None
                     end
  end.

(* check if a mantissa-exponent pair is represntable in a format given by prec, emax *)
Definition can_convert_exactly (prec__target emax__target : Z) (m : positive) (e : Z) : bool :=
  let f := BFloat (Z.pos m) e in
  match normalize_float prec__target emax__target f with
  | Some _ => true
  | None => false
  end.

Definition can_convert_float_to_float32 (v : float) : bool :=
  match v with
  | B754_finite _ m e _ => can_convert_exactly 24 128 m e
  | _ => true
  end.

Definition can_convert_float_to_float64 (v : float) : bool :=
  match v with
  | B754_finite _ m e _ => can_convert_exactly 53 1024 m e
  | _ => true
  end.

Section Correctness.

  (*
   * Inspired by StructTact
   * Source: github.com/uwplse/StructTact
   *
   * [break_match] looks for a [match] construct in the goal or some hypothesis,
   * and destructs the discriminee, while retaining the information about
   * the discriminee's value leading to the branch being taken.
   *)
  Ltac break_match :=
    match goal with
      | [ |- context [ match ?X with _ => _ end ] ] =>
        match type of X with
          | sumbool _ _ => destruct X
          | _ => destruct X eqn:?
        end
      | [ H : context [ match ?X with _ => _ end ] |- _] =>
        match type of X with
          | sumbool _ _ => destruct X
          | _ => destruct X eqn:?
        end
    end.

  (* binary length of a positive number *)
  Let digits := compose Z.succ log_inf.

  (* closed form for Flocq's [digits2_pos] *)
  Lemma digits2_pos_digits (m : positive) :
    Z.pos (Digits.digits2_pos m) = digits m.
  Proof.
    induction m; simpl;
      try rewrite Pos2Z.inj_succ, IHm; reflexivity.
  Qed.

  (** ** Flocq's Binary.bounded rewritten in a form close to IEEE-754 *)
  Lemma bounded_closed_form (prec emax : Z)
        (prec_gt_0 : Flocq.Core.FLX.Prec_gt_0 prec) (Hmax : (prec < emax)%Z)
        (m : positive) (e : Z) :
    bounded prec emax m e = true
    <->
    or
      (digits m < prec /\ e = 3 - emax - prec)
      (digits m = prec /\ 3 - emax - prec <= e <= emax - prec).
  Proof.
    unfold FLX.Prec_gt_0, bounded, canonical_mantissa, FLT.FLT_exp in *.
    rewrite Bool.andb_true_iff, Z.leb_le, <-Zeq_is_eq_bool, digits2_pos_digits.
    remember (3 - emax - prec) as emin.
    split; intro.
    all: destruct (Z_lt_le_dec (digits m + e - prec) emin).
    all: try rewrite Z.max_r in * by lia.
    all: try rewrite Z.max_l in * by lia.
    all: lia.
  Qed.

  Definition valid_float (prec emax : Z) (f : bfloat) :=
    match (Fnum f) with
    | Z0 => true
    | Z.pos m => bounded prec emax m (Fexp f)
    | Z.neg m => bounded prec emax m (Fexp f)
    end.

  (** ** equality on floats with no jumps to Real *)
  Definition float_eq (f1 : bfloat) (f2 : bfloat) : Prop :=
    let '(m1, e1) := (Fnum f1, Fexp f1) in
    let '(m2, e2) := (Fnum f2, Fexp f2) in
    or
      (e2 <= e1 /\ m2 = m1 * 2 ^ (e1 - e2))
      (e1 <= e2 /\ m1 = m2 * 2 ^ (e2 - e1)).

  Lemma float_eq_refl : Reflexive float_eq.
  Proof.
    unfold Reflexive; intro f.
    unfold float_eq; left.
    replace (Fexp f - Fexp f) with 0.
    all: lia.
  Qed.

  Lemma float_eq_sym : Symmetric float_eq.
  Proof.
    unfold Symmetric, float_eq.
    intros; destruct H; auto.
  Qed.

  Lemma Zpow_divide (b p1 p2 : Z) :
    0 < b ->
    0 <= p1 <= p2 ->
    (b ^ p1 | b ^ p2).
  Proof.
    intros B P.
    rewrite <-Z.mod_divide by (apply Z.pow_nonzero; lia).
    replace p2 with ((p2 - p1) + p1) by lia.
    rewrite Z.pow_add_r by lia.
    apply Z_mod_mult.
  Qed.

  Lemma float_eq_trans : Transitive float_eq.
  Proof.
    unfold Transitive.
    destruct x as [mx ex], y as [my ey], z as [mz ez].
    unfold float_eq.
    simpl.
    intros XY YZ.
    destruct XY as [XY | XY]; destruct YZ as [YZ | YZ].
    all: destruct XY as [EXY MXY]; destruct YZ as [EYZ MYZ]; subst.
    - left; split; [lia |].
      rewrite <-Z.mul_assoc.
      rewrite <-Z.pow_add_r; try lia.
      replace (ex - ey + (ey - ez)) with (ex - ez) by lia.
      reflexivity.
    - destruct (Z.eq_dec ex ez); subst.
      + (* ex = ez *)
        apply Z.mul_reg_r in MYZ.
        subst; left; split; [lia |].
        rewrite Z.sub_diag; lia.
        generalize (Z.pow_pos_nonneg 2 (ez - ey)); lia.
      + destruct (Z_lt_le_dec ex ez).
        * (* ex < ez *)
          rename MYZ into H.
          assert (H1 : ey <= ex < ez) by lia; clear EXY EYZ n l.
          right; split; [lia |].
          apply f_equal with (f := fun x => Z.div x (2 ^ (ex - ey))) in H.
          rewrite Z_div_mult in H;
            [| generalize (Z.pow_pos_nonneg 2 (ex - ey)); lia].
          subst.
          rewrite Z.divide_div_mul_exact;
            [| apply Z.pow_nonzero; lia | apply Zpow_divide; lia].
          replace (ez - ey) with ((ez - ex) + (ex - ey)) by lia.
          rewrite Z.pow_add_r by lia.
          rewrite Z.div_mul by (apply Z.pow_nonzero; lia).
          reflexivity.
        * (* ez < ex *)
          rename MYZ into H.
          assert (H1: ey <= ez < ex) by lia; clear EXY EYZ n l.
          left; split; [lia |].
          apply f_equal with (f := fun x => Z.div x (2 ^ (ez - ey))) in H.
          rewrite Z_div_mult in H;
            [| generalize (Z.pow_pos_nonneg 2 (ez - ey)); lia].
          subst.
          rewrite Z.divide_div_mul_exact;
            [| apply Z.pow_nonzero; lia | apply Zpow_divide; lia].
          replace (ex - ey) with ((ex - ez) + (ez - ey)) by lia.
          rewrite Z.pow_add_r by lia.
          rewrite Z.div_mul by (apply Z.pow_nonzero; lia).
          reflexivity.
    - destruct (Z.eq_dec ex ez); subst.
      + (* ex = ez *)
        left; split; [lia |].
        rewrite Z.sub_diag; lia.
      + destruct (Z_lt_le_dec ex ez).
        * (* ex < ez *)
          assert (H : ex < ez <= ey) by lia; clear EXY EYZ n l.
          right; split; [lia |].
          rewrite <-Z.mul_assoc.
          rewrite <-Z.pow_add_r by lia.
          replace (ey - ez + (ez - ex)) with (ey - ex) by lia.
          reflexivity.
        * (* ez < ex *)
          assert (H: ez < ex <= ey) by lia; clear EXY EYZ n l.
          left; split; [lia |].
          rewrite <-Z.mul_assoc.
          rewrite <-Z.pow_add_r by lia.
          replace (ey - ex + (ex - ez)) with (ey - ez) by lia.
          reflexivity.
    - right; split; [lia |].
      rewrite <-Z.mul_assoc.
      rewrite <-Z.pow_add_r; try lia.
      replace (ez - ey + (ey - ex)) with (ez - ex) by lia.
      reflexivity.
  Qed.

  Definition float_eq_equivalence :=
    Build_Equivalence float_eq float_eq_refl float_eq_sym float_eq_trans.

  Definition not_zero (f : bfloat) := (Fnum f) <> 0.

  Lemma not_zero_Zpos (m : positive) (e : Z) :
    not_zero (BFloat (Z.pos m) e).
  Proof. unfold not_zero. simpl. discriminate. Qed.

  Lemma not_zero_eq (f1 f2 : bfloat) :
    not_zero f1 ->
    float_eq f1 f2 ->
    not_zero f2.
  Proof.
    unfold not_zero, float_eq.
    destruct f1 as [m1 e1], f2 as [m2 e2]; simpl.
    intros NZ1 H.
    destruct H; destruct H as [H1 H2]; subst.
    - assert (0 < 2 ^ (e1 - e2)) by (apply Z.pow_pos_nonneg; lia).
      apply Z.neq_mul_0.
      lia.
    - intros H; contradict NZ1.
      subst; reflexivity.
  Qed.

  (** shifting the exponent results in a shifted exponent as expected *)
  Lemma inc_e_correct (f1 : bfloat) (de : positive) {f2 : bfloat} :
    inc_e f1 de = Some f2 ->
    Fexp f2 = Fexp f1 + Z.pos de.
  Proof.
    unfold inc_e.
    intro; break_match; inversion H; clear H.
    reflexivity.
  Qed.

  Lemma dec_e_correct (f : bfloat) (de : positive) :
    Fexp (dec_e f de) = Fexp f - Z.pos de.
  Proof. reflexivity. Qed.

  Lemma shift_e_correct (f1 : bfloat) (de : Z) {f2 : bfloat} :
    shift_e f1 de = Some f2 ->
    Fexp f2 = Fexp f1 + de.
  Proof.
    unfold shift_e; intro; break_match; inversion H; clear H.
    lia.
    apply inc_e_correct; assumption.
    apply dec_e_correct.
  Qed.

  Lemma set_e_correct (f1 : bfloat) (e : Z) {f2 : bfloat} :
    set_e f1 e = Some f2 ->
    Fexp f2 = e.
  Proof.
    unfold set_e.
    intro H.
    apply shift_e_correct in H.
    lia.
  Qed.

  (** shifting the exponent preserves the float's value *)
  Lemma inc_e_eq (f1 : bfloat) (de : positive) {f2 : bfloat} :
    inc_e f1 de = Some f2 ->
    float_eq f1 f2.
  Proof.
    intros.
    destruct f1 as [m1 e1], f2 as [m2 e2].
    unfold inc_e in H; break_match; inversion H; clear H.
    unfold float_eq.
    simpl in *.
    right.
    replace (e1 + Z.pos de - e1) with (Z.pos de) by lia.
    rewrite <-two_power_pos_equiv.
    remember (two_power_pos de) as rm.
    rewrite Z.eqb_eq in Heqb.
    rewrite Z.mul_comm.
    rewrite <-Z_div_exact_2 with (b := rm); try auto.
    rewrite two_power_pos_equiv in Heqrm.
    assert (0 < 2 ^ Z.pos de).
    apply Z.pow_pos_nonneg.
    all: try lia.
    subst rm.
    rewrite two_power_pos_equiv.
    generalize (Z.pow_pos_nonneg 2 (Z.pos de)).
    lia.
  Qed.

  Lemma dec_e_eq (f : bfloat) (de : positive) :
    float_eq f (dec_e f de).
  Proof.
    destruct f as [m e].
    unfold dec_e, float_eq.
    simpl.
    left.
    replace (e - (e - Z.pos de)) with (Z.pos de) by lia.
    rewrite two_power_pos_equiv.
    split.
    lia.
    reflexivity.
  Qed.

  Lemma shift_e_eq (f1 : bfloat) (de : Z) {f2 : bfloat} :
    shift_e f1 de = Some f2 ->
    float_eq f1 f2.
  Proof.
    destruct de; simpl.
    - intro H; inversion H; apply float_eq_refl.
    - apply inc_e_eq.
    - intro H; inversion H; apply dec_e_eq.
  Qed.

  Lemma set_e_eq (f1 : bfloat) (e : Z) {f2 : bfloat} :
    set_e f1 e = Some f2 ->
    float_eq f1 f2.
  Proof.
    unfold set_e.
    apply shift_e_eq.
  Qed.

  Lemma Zdigits_mul_pow2 (m : Z) (d : positive) :
    m <> 0 -> Zdigits (m * two_power_pos d) = Zdigits m + Z.pos d.
  Proof.
    intro.
    rewrite two_power_pos_equiv.
    unfold Zdigits.
    rewrite Z.abs_mul, Z.abs_pow.
    replace (Z.abs 2) with 2 by reflexivity.
    remember (Z.abs m) as pm; remember (Z.pos d) as pd.
    rewrite Z.log2_mul_pow2.
    all: lia.
  Qed.

  Lemma Zabs_div_exact (a b : Z) :
    b <> 0 ->
    a mod b = 0 ->
    Z.abs (a / b) = Z.abs a / Z.abs b.
  Proof.
    intros B AMB.
    apply Zmod_divides in AMB; [| assumption ].
    destruct AMB as [c AMB].
    rewrite AMB at 1.
    apply f_equal with (f := Z.abs) in AMB.
    rewrite Z.abs_mul in AMB.
    rewrite AMB.
    rewrite Z.mul_comm. rewrite Z.div_mul.
    rewrite Z.mul_comm. rewrite Z.div_mul.
    all: lia.
  Qed.

  Lemma Zdigits_div_pow2 (m : Z) (d : positive) :
    m <> 0 ->
    m mod two_power_pos d = 0 ->
    Zdigits (m / two_power_pos d) = Zdigits m - Z.pos d.
  Proof.
    intros M H.
    unfold Zdigits.
    rewrite Zabs_div_exact.
    rewrite two_power_pos_equiv in *.
    rewrite Z.abs_pow.
    remember (Z.abs m) as pm; remember (Z.pos d) as pd.
    apply Zmod_divides in H; destruct H.
    subst m.
    rewrite Z.abs_mul, Z.abs_pow in Heqpm.
    replace (Z.abs 2) with 2 in * by reflexivity.
    subst pm.
    remember (Z.abs x) as px.
    rewrite Z.mul_comm.
    rewrite Z.div_mul.
    rewrite Z.log2_mul_pow2.
    all: subst.
    all: try lia.
    destruct (Z.eq_dec x 0); subst; lia.
    destruct (Z.eq_dec (2 ^ Z.pos d) 0); [ rewrite e in M; lia | assumption ].
    assert (m mod 2 ^ Z.pos d < 2 ^ Z.pos d); try lia.
    apply Zmod_pos_bound.
    apply Z.pow_pos_nonneg; lia.
    rewrite two_power_pos_equiv; generalize (Z.pow_pos_nonneg 2 (Z.pos d)); lia.
  Qed.

  (** changing the mantissa's binary length results in an expected number of digits *)
  Lemma inc_digits_m_correct (f : bfloat) (ddm : positive) :
    not_zero f ->
    Zdigits (Fnum (inc_digits_m f ddm)) = Zdigits (Fnum f) + Z.pos ddm.
  Proof.
    unfold inc_digits_m, dec_e; simpl.
    apply Zdigits_mul_pow2.
  Qed.

  Lemma dec_digits_m_correct (f1 : bfloat) (ddm : positive) {f2 : bfloat} :
    not_zero f1 ->
    dec_digits_m f1 ddm = Some f2 ->
    Zdigits (Fnum f2) = Zdigits (Fnum f1) - Z.pos ddm.
  Proof.
    destruct f1 as [m1 e1], f2 as [m2 e2].
    unfold dec_digits_m, inc_e.
    simpl; intros M H.
    break_match; inversion H; clear H.
    rewrite Z.eqb_eq in Heqb.
    apply Zdigits_div_pow2; assumption.
  Qed.

  Lemma shift_digits_m_correct (f1 : bfloat) (ddm : Z) {f2 : bfloat} :
    Fnum f1 <> 0 ->
    shift_digits_m f1 ddm = Some f2 ->
    Zdigits (Fnum f2) = Zdigits (Fnum f1) + ddm.
  Proof.
    unfold shift_digits_m, shift_e.
    simpl; intros M H.
    break_match; inversion H; clear H; subst.
    - lia.
    - replace inc_e with dec_digits_m in H1 by reflexivity.
      replace ddm with (Z.neg p) by lia.
      apply dec_digits_m_correct; assumption.
    - replace dec_e with inc_digits_m in Heqz by reflexivity.
      replace ddm with (Z.pos p) by lia.
      apply inc_digits_m_correct; assumption.
  Qed.

  Lemma set_digits_m_correct (f1 : bfloat) (dm : Z) {f2 : bfloat} :
    not_zero f1 ->
    set_digits_m f1 dm = Some f2 ->
    Zdigits (Fnum f2) = dm.
  Proof.
    intros M H.
    unfold set_digits_m in H.
    apply shift_digits_m_correct in H; [| assumption].
    rewrite H.
    lia.
  Qed.

  (** changing the binary length of the mantissa preserves the float's value *)
  Lemma inc_digits_m_eq (f : bfloat) (ddm : positive) :
    float_eq f (inc_digits_m f ddm).
  Proof.
    unfold inc_digits_m.
    apply dec_e_eq.
  Qed.

  Lemma dec_digits_m_eq (f1 : bfloat) (ddm : positive) {f2 : bfloat} :
    dec_digits_m f1 ddm = Some f2 ->
    float_eq f1 f2.
  Proof.
    unfold dec_digits_m.
    apply inc_e_eq.
  Qed.

  Lemma shift_digits_m_eq (f1 : bfloat) (ddm : Z) {f2 : bfloat} :
    shift_digits_m f1 ddm = Some f2 ->
    float_eq f1 f2.
  Proof.
    unfold shift_digits_m.
    apply shift_e_eq.
  Qed.

  Lemma set_digits_m_eq (f1 : bfloat) (dm : Z) {f2 : bfloat} :
    set_digits_m f1 dm = Some f2 ->
    float_eq f1 f2.
  Proof.
    unfold set_digits_m.
    apply shift_digits_m_eq.
  Qed.

  (** two equal floats with the same exponent are exactly the same *)
  Lemma exponent_unique_fnum (f1 f2 : bfloat) :
    float_eq f1 f2 ->
    Fexp f1 = Fexp f2 ->
    Fnum f1 = Fnum f2.
  Proof.
    unfold float_eq.
    destruct f1 as [m1 e1], f2 as [m2 e2].
    simpl; intros H E; destruct H; destruct H as [T H]; clear T; subst.
    all: rewrite Z.sub_diag; simpl; lia.
  Qed.

  Lemma exponent_unique (f1 f2 : bfloat) :
    float_eq f1 f2 ->
    Fexp f1 = Fexp f2 ->
    f1 = f2.
  Proof.
    intros.
    pose proof exponent_unique_fnum f1 f2 H H0.
    destruct f1, f2; simpl in *.
    subst; reflexivity.
  Qed.

  (** two equal floats with the same mantissa length are exactly the same *)
  Lemma Zdigits_m_unique_fexp (f1 f2 : bfloat) :
    not_zero f1 ->
    float_eq f1 f2 ->
    Zdigits (Fnum f1) = Zdigits (Fnum f2) ->
    Fexp f1 = Fexp f2.
  Proof.
    intros NZ1 H.
    assert (NZ2 : not_zero f2) by apply (not_zero_eq f1 f2 NZ1 H).
    unfold float_eq in *.
    destruct f1 as [m1 e1], f2 as [m2 e2].
    simpl in *; intro DM; destruct H; destruct H as [H1 H2]; subst.
    all: destruct (Z.eq_dec e1 e2); try assumption.
    - assert (e2 < e1) by lia; clear H1 n.
      apply Zcompare_Gt in H.
      apply Zcompare_Gt_spec in H; destruct H as [de H].
      replace (e1 - e2) with (Z.pos de) in DM by lia.
      rewrite <-two_power_pos_equiv in DM.
      rewrite Zdigits_mul_pow2 in DM by assumption.
      contradict DM; lia.
    - assert (e1 < e2) by lia; clear H1 n.
      apply Zcompare_Gt in H.
      apply Zcompare_Gt_spec in H; destruct H as [de H].
      replace (e2 - e1) with (Z.pos de) in DM by lia.
      rewrite <-two_power_pos_equiv in DM.
      rewrite Zdigits_mul_pow2 in DM by assumption.
      contradict DM; lia.
  Qed.

  Lemma Zdigits_m_unique (f1 f2 : bfloat) :
    not_zero f1 ->
    float_eq f1 f2 ->
    Zdigits (Fnum f1) = Zdigits (Fnum f2) ->
    f1 = f2.
  Proof.
    intros.
    pose proof Zdigits_m_unique_fexp f1 f2 H H0 H1.
    apply exponent_unique; assumption.
  Qed.

  Fact Zdigits_Zpos_log_inf (p : positive) :
  Zdigits (Z.pos p) = Z.succ (log_inf p).
  Proof.
    unfold Zdigits, Z.abs.
    rewrite <-Zlog2_log_inf.
    reflexivity.
  Qed.

  Fact Zdigits_Zneg_log_inf (p : positive) :
  Zdigits (Z.neg p) = Z.succ (log_inf p).
  Proof.
    unfold Zdigits, Z.abs.
    rewrite <-Zlog2_log_inf.
    reflexivity.
  Qed.

  (* similar to [bounded_closed_form] *)
  Lemma valid_float_closed_form (prec emax : Z) (f : bfloat) (NZ : not_zero f)
        (prec_gt_0 : FLX.Prec_gt_0 prec) (Hmax : prec < emax) :
    let emin := 3 - emax - prec in
    let '(m, e) := (Fnum f, Fexp f) in
      valid_float prec emax f = true
      <->
      or
        (Zdigits m < prec /\ e = emin)
        (Zdigits m = prec /\ emin <= e <= emax - prec).
  Proof.
    destruct f as [m e].
    intro.
    unfold FLX.Prec_gt_0 in prec_gt_0.
    unfold valid_float.
    simpl.
    destruct m.
    - (* Z0 *)
      unfold not_zero in NZ; simpl in NZ.
      contradict NZ.
      reflexivity.
    - (* Zpos *)
      rewrite bounded_closed_form by assumption;
        rewrite Zdigits_Zpos_log_inf;
        unfold compose.
      split; intros H; destruct H; auto.
    - (* Zneg *)
      rewrite bounded_closed_form by assumption.
        rewrite Zdigits_Zneg_log_inf;
        unfold compose.
      split; intros H; destruct H; auto.
  Qed.

  Lemma not_None_iff_exists_Some {A : Type} {x : option A} :
    x <> None <-> exists y, x = Some y.
  Proof.
    split; intro.
    - destruct x.
      + exists a; reflexivity.
      + contradict H; reflexivity.
    - destruct H; subst; discriminate.
  Qed.

  Lemma float_eq_trans_l (f1 f2 f3 : bfloat) :
    float_eq f1 f2 ->
    float_eq f1 f3 ->
    float_eq f2 f3.
  Proof.
    intros EQ12 EQ13.
    apply float_eq_sym in EQ12.
    apply float_eq_trans with (y := f1);
      assumption.
  Qed.

  Lemma float_eq_set_e (f1 f2 : bfloat) :
    float_eq f1 f2 ->
    set_e f1 (Fexp f2) = Some f2.
  Proof.
    intro.
    destruct set_e as [f |] eqn:SE.
    - (* if successful, then equal *)
      pose proof set_e_eq f1 (Fexp f2) SE; rename H0 into H1.
      apply set_e_correct in SE.
      apply (float_eq_trans_l f1 f f2 H1) in H.
      apply (exponent_unique f f2 H) in SE.
      subst; reflexivity.
    - (* always successful *)
      exfalso.
      unfold float_eq, set_e, shift_e, inc_e, dec_e in *.
      destruct f1 as [m1 e1], f2 as [m2 e2]; simpl in *.
      repeat break_match; try discriminate.
      clear SE; rename Heqb into H1.
      apply Z.eqb_neq in H1.
      destruct H; destruct H as [E M]; [lia |]; subst.
      rewrite two_power_pos_equiv in H1.
      rewrite Z.mod_mul in H1; auto.
      generalize (Z.pow_pos_nonneg 2 (Z.pos p)); lia.
  Qed.

  Lemma float_eq_set_digits_m (f1 f2 : bfloat) :
    not_zero f1 ->
    float_eq f1 f2 ->
    set_digits_m f1 (Zdigits (Fnum f2)) = Some f2.
  Proof.
    intros NZ1 H.
    assert (NZ2 : not_zero f2) by apply (not_zero_eq f1 f2 NZ1 H).
    destruct set_digits_m as [f |] eqn:SDM.
    - (* if successful, then equal *)
      pose proof set_digits_m_eq f1 (Zdigits (Fnum f2)) SDM; rename H0 into H1.
      apply set_digits_m_correct in SDM; auto.
      apply (float_eq_trans_l f1 f f2 H1) in H.
      assert (NZ: not_zero f) by (apply not_zero_eq with (f1 := f1); assumption).
      apply (Zdigits_m_unique f f2 NZ H) in SDM.
      subst; reflexivity.
    - (* always successful *)
      exfalso.
      unfold float_eq, set_digits_m, shift_digits_m, shift_e, inc_e, dec_e in *.
      destruct f1 as [m1 e1], f2 as [m2 e2]; simpl in *.
      repeat break_match; try discriminate.
      clear SDM; rename Heqb into H1.
      apply Z.eqb_neq in H1.
      destruct H; destruct H as [E M]; subst.
      + destruct (Z.eq_dec e1 e2).
        replace (e1 - e2) with 0 in Heqz by lia;
          rewrite Z.mul_1_r in Heqz; lia.
        assert (e2 < e1) by lia; clear E n.
        apply Zcompare_Gt in H.
        apply Zcompare_Gt_spec in H; destruct H.
        replace (e1 - e2) with (Z.pos x) in *.
        rewrite <-two_power_pos_equiv in *.
        rewrite Zdigits_mul_pow2 in Heqz.
        lia.
        auto.
      + destruct (Z.eq_dec e1 e2).
        replace (e2 - e1) with 0 in Heqz by lia;
          rewrite Z.mul_1_r in Heqz; lia.
        assert (e1 < e2) by lia; clear E n.
        apply Zcompare_Gt in H.
        apply Zcompare_Gt_spec in H; destruct H.
        replace (e2 - e1) with (Z.pos x) in *.
        rewrite <-two_power_pos_equiv in *.
        rewrite Zdigits_mul_pow2 in Heqz.
        assert (x = p) by lia; subst.
        rewrite two_power_pos_equiv in H1.
        rewrite Z.mod_mul in H1; auto.
        generalize (Z.pow_pos_nonneg 2 (Z.pos p)); lia.
        auto.
  Qed.

  (** ** declarative definition of `set_e` *)
  Lemma set_e_definition (f1 : bfloat) (e : Z) {f2 : bfloat} :
    set_e f1 e = Some f2 <->
    float_eq f1 f2 /\ Fexp f2 = e.
  Proof.
    split; intro.
    - split.
      apply (set_e_eq f1 e H). apply (set_e_correct f1 e H).
    - destruct H as [EQ FEXP].
      subst.
      apply (float_eq_set_e f1 f2 EQ).
  Qed.

  (** ** declarative definition of `set_digits_m` *)
  Lemma set_digits_m_definition (f1 : bfloat) (dm : Z) {f2 : bfloat} :
    not_zero f1 ->
    set_digits_m f1 dm = Some f2 <->
    float_eq f1 f2 /\ Zdigits (Fnum f2) = dm.
  Proof.
    intros NZ1.
    split; intro.
    - split.
      apply (set_digits_m_eq f1 dm H).
      apply (set_digits_m_correct f1 dm NZ1 H).
    - destruct H as [EQ FEXP].
      subst.
      apply (float_eq_set_digits_m f1 f2 NZ1 EQ).
  Qed.

  Lemma normalize_correct' (prec emax : Z) (f : bfloat) (NZ : not_zero f)
        (prec_gt_0 : FLX.Prec_gt_0 prec) (Hmax : prec < emax) :
    match (normalize_float prec emax f) with
    | Some nf => (float_eq f nf) /\ (valid_float prec emax nf = true)
    | None => forall (xf : bfloat),
        float_eq f xf -> valid_float prec emax xf = false
    end.
  Proof.
    unfold FLX.Prec_gt_0 in prec_gt_0.
    break_match. rename b into nf.
    - (* successful normalization - equal and valid? *)
      unfold normalize_float in Heqo.
      repeat break_match; inversion Heqo; subst.
      + (* subnormal *)
        split.
        * (* same float? *)
          apply set_e_eq with (e := 3 - emax - prec).
          assumption.
        * (* valid float? *)
          apply Z.leb_le in Heqb0.
          rewrite valid_float_closed_form.
          apply set_e_correct in Heqo0.
          lia.
          apply not_zero_eq with (f1 := f). assumption.
          apply set_e_eq in Heqo0. assumption.
          unfold FLX.Prec_gt_0; lia.
          assumption.
      + (* normal *)
        split.
        * (* same float? *)
          apply set_digits_m_eq with (dm := prec).
          assumption.
        * (* valid float? *)
          apply andb_prop in Heqb1; destruct Heqb1 as [H1 H2].
          apply Z.leb_le in H1; apply Z.leb_le in H2.
          rewrite valid_float_closed_form.
          right.
          apply set_e_correct in Heqo0.
          apply set_digits_m_correct in Heqo1.
          lia.
          assumption.
          apply not_zero_eq with (f1 := f). assumption.
          apply set_digits_m_eq in Heqo1. assumption.
          unfold FLX.Prec_gt_0; lia.
          assumption.
    - (* unsuccesful normalization - impossible to normalize? *)
      intros xf H.
      apply Bool.not_true_is_false.
      intros V.
      assert (XNZ: not_zero xf) by apply (not_zero_eq f xf NZ H).
      rewrite valid_float_closed_form in V by assumption.
      destruct V as [V | V]; destruct V as [D E].
      + (* xf is subnormal *)
        unfold normalize_float in Heqo.
        repeat break_match; try discriminate; clear Heqo.
        all: rewrite <-E in Heqo0.
        all: rewrite float_eq_set_e in Heqo0 by assumption.
        all: inversion Heqo0; subst.
        all: rewrite Z.leb_gt in Heqb0; lia.
      + (* xf is normal *)
        unfold normalize_float in Heqo.
        repeat break_match; try discriminate; clear Heqo.
        * rewrite <-D in Heqo1.
          rewrite float_eq_set_digits_m in Heqo1 by assumption.
          inversion Heqo1; subst; clear Heqo1.
          apply Bool.andb_false_elim in Heqb1; destruct Heqb1.
          all: rewrite Z.leb_gt in e; lia.
        * rewrite <-D in Heqo1.
          rewrite float_eq_set_digits_m in Heqo1 by assumption.
          inversion Heqo1.
        * unfold set_e, shift_e, inc_e, dec_e in Heqo0.
          repeat break_match; try discriminate; clear Heqo0.
          remember (3 - emax - prec) as emin.
          rewrite Z.eqb_neq in Heqb.
          destruct f as [m e], xf as [xm xe].
          unfold float_eq, not_zero in *.
          simpl in *.
          destruct H; destruct H as [EXP NUM].
          -- lia.
          -- subst m.
             replace (xe - e) with ((xe - emin) + Z.pos p) in Heqb by lia.
             rewrite Z.pow_add_r in Heqb by lia.
             rewrite Z.mul_assoc in Heqb.
             rewrite two_power_pos_equiv in Heqb.
             rewrite Z.mod_mul in Heqb.
             contradict Heqb; reflexivity.
             pose proof Z.add_assoc.
             generalize (Z.pow_pos_nonneg 2 (Z.pos p)); lia.
  Qed.

  Theorem normalize_correct (prec emax : Z) (f : bfloat) (NZ : not_zero f)
        (prec_gt_0 : FLX.Prec_gt_0 prec) (Hmax : prec < emax) {nf : bfloat} :
    normalize_float prec emax f = Some nf
    <->
    (float_eq f nf) /\ (valid_float prec emax nf = true).
  Proof.
    pose proof normalize_correct' prec emax f NZ prec_gt_0 Hmax.
    split; intro.
    - rewrite H0 in H; clear H0; assumption.
    - break_match; try discriminate.
      + destruct H, H0.
        rename b into f1, nf into f2.
        pose proof float_eq_trans_l f f1 f2 H H0 as EQ.
        pose proof not_zero_eq f f1 NZ H as NZ1.
        pose proof not_zero_eq f f2 NZ H0 as NZ2.
        clear H H0 NZ f Heqo.
        apply valid_float_closed_form in H1; try assumption.
        apply valid_float_closed_form in H2; try assumption.
        f_equal.
        destruct H1 as [H1 | H1], H2 as [H2 | H2];
          destruct H1 as [M1 E1], H2 as [M2 E2].
        * apply exponent_unique; try assumption.
          rewrite E1, E2; reflexivity.
        * exfalso. unfold float_eq in EQ.
          destruct EQ as [EQ | EQ]; destruct EQ as [E M].
          -- rewrite M in M2.
             replace (Fexp f1 - Fexp f2) with 0 in M2 by lia.
             simpl in M2; rewrite Z.mul_1_r in M2.
             rewrite M2 in M1.
             lia.
          -- rewrite M in M1.
             destruct (Fexp f2 - Fexp f1) eqn:T; try lia.
             simpl in M1; rewrite Z.mul_1_r in M1.
             rewrite M2 in M1.
             lia.
             rewrite <-two_power_pos_equiv in M1.
             rewrite Zdigits_mul_pow2 in M1.
             lia.
             unfold not_zero in NZ2; assumption.
        * exfalso. unfold float_eq in EQ.
          destruct EQ as [EQ | EQ]; destruct EQ as [E M].
          -- rewrite M in M2.
             destruct (Fexp f1 - Fexp f2) eqn:T; try lia.
             simpl in M2; rewrite Z.mul_1_r in M2.
             rewrite M1 in M2.
             lia.
             rewrite <-two_power_pos_equiv in M2.
             rewrite Zdigits_mul_pow2 in M2.
             lia.
             unfold not_zero in NZ2; assumption.
          -- rewrite M in M1.
             replace (Fexp f2 - Fexp f1) with 0 in M1 by lia.
             simpl in M1; rewrite Z.mul_1_r in M1.
             rewrite M1 in M2.
             lia.
        * apply Zdigits_m_unique; try assumption.
          rewrite M1, M2; reflexivity.
      + destruct H0;
        apply H in H0.
        rewrite H0 in H1.
        inversion H1.
  Qed.

End Correctness.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : test for Vector
  author    : ZhengPu Shi
  date      : 2021.01
*)

From FCS Require Import DepPair.Vector.

(** ** Definition of vector *)

Example vec_ex0 : @vec nat 0 := tt.
Example vec_ex1 : vec 3 := [1;2;3].
Example vec_ex2 : vec 3 := [4;5;6].

(** ** Construct a vector with same element *)

Compute vrepeat 5 3.

(** ** vec0, its elements is 0 *)

Compute vec0 0 3.

(** ** Get head element *)

Compute vhd 0 vec_ex1.

(** ** Get tail vector *)

Compute vtl vec_ex1.
Compute vtl (vtl vec_ex1).

(** ** Get last element *)

Compute vlast vec_ex1.

(** Construct a vector with a function *)

Compute vmake_old 5 (fun i : nat => i).
Compute vmake 5 (fun i => 3).
Compute vmake 5 (fun i : nat => i).

(** ** Append two vectors *)

Compute vapp vec_ex1 vec_ex2.

(** Get n-th element of a vector *)

Compute vnth 99 2 vec_ex1.
Compute vnth 99 5 vec_ex1.

(** ** Get top k element of a vector *)

Compute vfirstn 99 5 vec_ex1.

(** Get remain (n-k) elements of a vector *)

Compute vskipn 1 vec_ex1.

(** ** Maping a vector to another *)

Compute vmap (S) vec_ex1.

(** Mapping two vectors to another vector *)

Compute vmap2 Nat.add vec_ex1 vec_ex2.

(** ** Vector addition *)

Compute vadd Nat.add vec_ex1 vec_ex1.

(** ** Vector substraction *)

Compute vopp Nat.succ vec_ex1.
Compute vsub Nat.sub vec_ex1 vec_ex1.

(** ** Vector constant multiplication *)

Compute vcmul Nat.mul 3 vec_ex1.
Compute vmulc Nat.mul vec_ex1 3.

(** ** Fold a vector to an element *)

Compute vfoldl Nat.add 0 vec_ex1.
Compute vfoldr Nat.add 0 vec_ex1.

(** ** Dot product of two vectors *)

Compute vdot 0 Nat.add Nat.mul vec_ex1 vec_ex1.

(** ** Concatenation a nested vector to a plain vector *)

Compute vvflat ([[1;2];[3;4];[5;6]] : @vec (vec 2) 3).


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(* This contribution was updated for Coq V5.10 by the COQ workgroup.        *)
(* January 1995                                                             *)
(****************************************************************************)
(*                                                                          *)
(*        Initial Version: Frederic Prost, July 1993                        *)
(*        Revised Version: Gilles Kahn, September 1993                      *)
(*        Revised for a tutorial on Coq:  Gilles Kahn, March 1994           *)
(*                                     INRIA Sophia-Antipolis, FRANCE       *)
(*                                                                          *)
(****************************************************************************)
(*                              Relations_1.v                               *)
(****************************************************************************)

Section Relations_1.
   Variable U : Type.

   Definition Relation := U -> U -> Prop.
   Variable R : Relation.

   Definition Reflexive : Prop := forall x : U, R x x.

   Definition Transitive : Prop := forall x y z : U, R x y -> R y z -> R x z.

   Definition Symmetric : Prop := forall x y : U, R x y -> R y x.

   Definition Antisymmetric : Prop :=
     forall x y : U, R x y -> R y x -> x = y :>U.

   Definition contains (R R' : Relation) : Prop :=
     forall x y : U, R' x y -> R x y.

   Definition same_relation (R R' : Relation) : Prop :=
     contains R R' /\ contains R' R.

   Inductive Preorder : Prop :=
       Definition_of_preorder : Reflexive -> Transitive -> Preorder.

   Inductive Order : Prop :=
       Definition_of_order :
         Reflexive -> Transitive -> Antisymmetric -> Order.

   Inductive Equivalence : Prop :=
       Definition_of_equivalence :
         Reflexive -> Transitive -> Symmetric -> Equivalence.

   Inductive PER : Prop :=
       Definition_of_PER : Symmetric -> Transitive -> PER.

End Relations_1.
Hint Unfold Reflexive.
Hint Unfold Transitive.
Hint Unfold Antisymmetric.
Hint Unfold Symmetric.
Hint Unfold contains.
Hint Unfold same_relation.
Hint Resolve Definition_of_preorder.
Hint Resolve Definition_of_order.
Hint Resolve Definition_of_equivalence.
Hint Resolve Definition_of_PER.


Require Export Wellfounded.Transitive_Closure.
Require Export Relations.
Require Export Relation_Operators.
Require Export List.
Require Import Setoid.

Ltac isda := intros; simpl in *; try discriminate; auto.

Section tcl.

Variable A : Type.
Variable R : relation A.

Notation trans_clos := (clos_trans A R).
Notation trans_clos_l := (clos_trans_1n A R).
Notation trans_clos_r := (clos_trans_n1 A R).

Lemma exl : forall x y, trans_clos x y -> R x y \/ exists z, R x z /\ trans_clos z y.
Proof with auto.
  induction 1.
  left...
  right; clear IHclos_trans2; destruct IHclos_trans1 as [H1 | [u [H1 H2]]].
  exists y...
  exists u; split; [ assumption | econstructor 2; eauto].
Qed.

Lemma exr : forall x y, trans_clos x y -> R x y \/ exists z, R z y /\ trans_clos x z.
Proof with auto.
  induction 1.
  left...
  right; clear IHclos_trans1; destruct IHclos_trans2 as [H1 | [u [H1 H2]]].
  exists y...
  exists u; split; [ assumption | econstructor 2; eauto].
Qed.

Lemma tcl_l_h : forall x y z, trans_clos x y -> trans_clos_l y z -> trans_clos_l x z.
Proof with eauto.
  induction 1; intros...
  econstructor 2...
Qed.

Lemma tcl_l : forall x y, trans_clos x y <-> trans_clos_l x y.
Proof with eauto.
  split; induction 1; intros...
  constructor...
  eapply tcl_l_h...
  constructor...
  econstructor 2...
  constructor...
Qed.

Lemma tcl_r_h : forall x y z, trans_clos y z -> trans_clos_r x y -> trans_clos_r x z.
Proof with eauto.
  induction 1; intros...
  econstructor 2...
Qed.

Lemma tcl_r : forall x y, trans_clos x y <-> trans_clos_r x y.
Proof with eauto.
  split; induction 1; intros.
  constructor...
  eapply tcl_r_h...
  constructor...
  econstructor 2...
  constructor...
Qed.

Lemma Acc_tcl_l : forall x, Acc trans_clos x -> Acc trans_clos_l x.
Proof with auto.
  induction 1.
  constructor; intros.
  apply H0; rewrite tcl_l...
Qed.

Theorem wf_clos_trans_l : well_founded R -> well_founded trans_clos_l.
Proof with auto.
  intros H a; apply Acc_tcl_l; apply wf_clos_trans...
Qed.

Lemma Acc_tcl_r : forall x, Acc trans_clos x -> Acc trans_clos_r x.
Proof with auto.
  induction 1.
  constructor; intros.
  apply H0; rewrite tcl_r...
Qed.

Theorem wf_clos_trans_r : well_founded R -> well_founded trans_clos_r.
Proof with auto.
  intros H a; apply Acc_tcl_r; apply wf_clos_trans...
Qed.

End tcl.

Definition opt_to_list {T} (o : option T) : list T :=
  match o with
  | None => nil
  | Some x => x :: nil
  end.

Section map_injective.

  Variables A B : Set.
  Variable f : A -> B.
  Hypothesis f_injective : forall a a0 : A, f a = f a0 -> a = a0.

  Lemma map_injective : forall l l0, map f l = map f l0 -> l = l0.
  Proof.
    induction l; destruct l0; intro H; inversion H; f_equal; auto.
  Qed.

End map_injective.

Section streams.

  Variable A : Set.

  CoInductive stream :=
  | s_nil : stream
  | s_cons : A -> stream -> stream.

  CoInductive bisim_stream : stream -> stream -> Prop :=
  | b_nil : bisim_stream s_nil s_nil
  | b_cons : forall (x : A) (s0 s1 : stream), bisim_stream s0 s1 -> bisim_stream (s_cons x s0) (s_cons x s1).

End streams.

Implicit Arguments s_nil [A].
Implicit Arguments s_cons [A].
Implicit Arguments bisim_stream [A].
Implicit Arguments b_nil [A].
Implicit Arguments b_cons [A x s0 s1].


Require Import List.

Require Import CpdtTactics.
(*
Definition bad : unit := tt.
*)

Set Implicit Arguments.
Set Asymmetric Patterns.

Section stream.
  Variable A : Type.

  CoInductive stream : Type :=
  | Cons : A -> stream -> stream.
End stream.

CoFixpoint zeroes : stream nat := Cons 0 zeroes.

CoFixpoint trues_falses : stream bool := Cons true falses_trues
with falses_trues : stream bool := Cons false trues_falses.

Fixpoint take A (n : nat) (s : stream A) : list A :=
  match n with
    | O => nil
    | S n' =>
      match s with
        | Cons h t => h :: take n' t
      end
  end.

Eval simpl in take 10 zeroes.
Eval simpl in take 10 trues_falses.

Section map.
  Variables A B : Type.
  Variable f : A -> B.

  CoFixpoint map (s : stream A) : stream B :=
    match s with
      | Cons h t => Cons (f h) (map t)
    end.
End map.

Section interleave.
  Variable A : Type.

  CoFixpoint interleave (s1 s2 : stream A) : stream A :=
    match s1, s2 with
      | Cons h1 t1, Cons h2 t2 => Cons h1 (Cons h2 (interleave t1 t2))
    end.
End interleave.

(*
Section map'.
  Variables A B : Type.
  Variable f : A -> B.
  CoFixpoint map' (s : stream A) : stream B :=
    match s with
      | Cons h t => interleave (Cons (f h) (map' t)) (Cons (f h) (map' t))
    end.
End map'.
*)

Definition tail A (s : stream A) : stream A :=
  match s with
    | Cons _ s' => s'
  end.

CoFixpoint ones : stream nat := Cons 1 ones.

Definition ones' := map S zeroes.

Theorem ones_eq : ones = ones'.
Abort.

Section stream_eq.
  Variable A : Type.

  CoInductive stream_eq : stream A -> stream A -> Prop :=
  | Stream_eq : forall h t1 t2, stream_eq t1 t2 -> stream_eq (Cons h t1)(Cons h t2).
End stream_eq.

Theorem ones_eq : stream_eq ones ones'.
  cofix.
  assumption.
  Undo.
  simpl.
Abort.

Definition frob A (s : stream A) : stream A :=
  match s with
    | Cons h t => Cons h t
  end.

Theorem frob_eq : forall A (s : stream A), s = frob s.
  destruct s.
  simpl.
  reflexivity.
Qed.

Theorem ones_eq : stream_eq ones ones'.
  cofix.
  rewrite (frob_eq ones).
  rewrite (frob_eq ones').
  simpl.
  constructor.
  fold (map S).
  fold ones'.
  assumption.
Qed.

Definition head A (s : stream A) : A :=
  match s with
    | Cons x _ => x
  end.

Section stream_eq_coind.
  Variable A : Type.
  Variable R : stream A -> stream A -> Prop.

  Hypothesis Cons_case_hd : forall s1 s2, R s1 s2 -> head s1 = head s2.
  Hypothesis Cons_case_tl : forall s1 s2, R s1 s2 -> R (tail s1) (tail s2).

  Theorem stream_eq_coind : forall s1 s2, R s1 s2 -> stream_eq s1 s2.
    cofix.
    destruct s1.
    destruct s2.
    intro.
    generalize (Cons_case_hd H).
    intro Heq.
    simpl in Heq.
    rewrite Heq.
    constructor.
    apply stream_eq_coind.
    apply (Cons_case_tl H).
  Qed.
End stream_eq_coind.

Print stream_eq_coind.

Theorem ones_eq'' : stream_eq ones ones'.
  apply (stream_eq_coind (fun s1 s2 => s1 = ones /\ s2 = ones')); crush.
Qed.

Section stream_eq_loop.
  Variable A : Type.
  Variables s1 s2 : stream A.

  Hypothesis Cons_case_hd : head s1 = head s2.
  Hypothesis loop1 : tail s1 = s1.
  Hypothesis loop2 : tail s2 = s2.

  Theorem stream_eq_loop : stream_eq s1 s2.
    apply (stream_eq_coind (fun s1' s2' => s1' = s1 /\ s2' = s2)); crush.
  Qed.

End stream_eq_loop.

Require Import Arith.
Print fact.

CoFixpoint fact_slow' (n : nat) := Cons (fact n) (fact_slow' (S n)).
Definition fact_slow := fact_slow' 1.

CoFixpoint fact_iter' (cur acc : nat) := Cons acc (fact_iter' (S cur) (acc * cur)).
Definition fact_iter := fact_iter' 2 1.

Eval simpl in take 5 fact_slow.
Eval simpl in take 5 fact_iter.

Lemma fact_recur : forall n,
  fact n * S n = fact (S n).
  intro n.
  induction n.
  simpl.
  reflexivity.
  unfold fact.
  ring.
Qed.

Lemma fact_def : forall x n,
  fact_iter' x (fact n * S n) = fact_iter' x (fact (S n)).
  intros.
  rewrite fact_recur.
  reflexivity.
Qed.

Hint Resolve fact_def.

Lemma fact_eq' : forall n, stream_eq (fact_iter' (S n) (fact n)) (fact_slow' n).
  intro n.
  apply(stream_eq_coind (fun s1 s2 =>
    exists n, s1 = fact_iter' (S n) (fact n) /\ s2 = fact_slow' n)); crush; eauto.
Qed.

Theorem fact_eq : stream_eq fact_iter fact_slow.
  apply fact_eq'.
Qed.

Section stream_eq_onequant.
  Variables A B : Type.

  Variables f g : A -> stream B.

  Hypothesis Cons_case_hd : forall x, head (f x) = head (g x).
  Hypothesis Cons_case_tl : forall x, exists y,tail (f x) = f y /\ tail (g x) = g y.

  Theorem stream_eq_onequant : forall x, stream_eq (f x) (g x).
    intro; apply (stream_eq_coind (fun s1 s2 =>
      exists x, s1 = f x /\ s2 = g x)); crush; eauto.
  Qed.
End stream_eq_onequant.

Lemma fact_eq'' : forall n, stream_eq (fact_iter' (S n) (fact n)) (fact_slow' n).
  apply stream_eq_onequant.
  simpl.
  reflexivity.
  simpl.
  eauto.
Qed.

Definition var := nat.

Definition environment := var -> nat.

Definition set (env : environment) (v : var) (n : nat) : environment :=
  fun v' => if beq_nat v v' then n else env v'.

Inductive exp : Set :=
| Const : nat -> exp
| Var : var -> exp
| Plus : exp -> exp -> exp.

Fixpoint evalExp (e : exp) (env : environment) : nat :=
  match e with
    | Const n => n
    | Var v => env v
    | Plus e1 e2 => evalExp e1 env + evalExp e2 env
  end.

Inductive cmd : Set :=
| Assign : var -> exp -> cmd
| Seq : cmd -> cmd -> cmd
| While : exp -> cmd -> cmd.

CoInductive evalCmd : environment -> cmd -> environment -> Prop :=
| EvalAssign : forall env v e, evalCmd env (Assign v e) (set env v (evalExp e env))
| EvalSeq : forall env1 env2 env3 c1 c2, evalCmd env1 c1 env2
  -> evalCmd env2 c2 env3 -> evalCmd env1 (Seq c1 c2) env3
| EvalWhileFalse : forall env e c, evalExp e env = 0
  -> evalCmd env (While e c) env
| EvalWhileTrue : forall env1 env2 env3 e c, evalExp e env1 <> 0
  -> evalCmd env1 c env2
  -> evalCmd env2 (While e c) env3
  -> evalCmd env1 (While e c) env3.

Section evalCmd_coind.
  Variable R : environment -> cmd -> environment -> Prop.

  Hypothesis AssignCase : forall env1 env2 v e,
    R env1 (Assign v e) env2 -> env2 = set env2 v (evalExp e env1).

  Hypothesis SeqCase : forall env1 env3 c1 c2,
    R env1 (Seq c1 c2) env3 -> exists env2, R env1 c1 env2 /\ R env2 c2 env3.

  Hypothesis WhileCase : forall env1 env3 e c,
    R env1 (While e c) env3 -> (evalExp e env1 = 0 /\ env3 = env1)
    \/ exists env2,evalExp e env1 <> 0 /\ R env1 c env2 /\ R env2 (While e c) env3.

  Theorem evalCmd_coind : forall env1 c env2, R env1 c env2 -> evalCmd env1 c env2.
  Admitted.

End evalCmd_coind.

Fixpoint optExp (e : exp) : exp :=
  match e with
    | Plus (Const 0) e => optExp e
    | Plus e1 e2 => Plus (optExp e1) (optExp e2)
    | _ => e
  end.

Fixpoint optCmd (c : cmd) : cmd :=
  match c with
    | Assign v e => Assign v (optExp e)
    | Seq c1 c2 => Seq (optCmd c1) (optCmd c2)
    | While e c => While (optExp e) (optCmd c)
  end.

Lemma optExp_correct : forall env e, evalExp (optExp e) env = evalExp e env.
  induction e.
  simpl.
  reflexivity.
  simpl.
  reflexivity.
  simpl.
  crush.
  repeat (match goal with
           | [ |- context[match ?E with Const _ => _ | _ => _ end] ] => destruct E
               | [ |- context[match ?E with O => _ | S _ => _ end] ] => destruct E
            end; crush).
Qed.

Hint Rewrite optExp_correct.

Ltac finisher := match goal with
                   | [ H : evalCmd _ _ _ |- _ ] => ((inversion H; [])
                     || (inversion H; [|])); subst
                 end; crush; eauto 10.

Lemma optCmd_correct1 : forall vs1 c vs2, evalCmd vs1 c vs2
  -> evalCmd vs1 (optCmd c) vs2.
  intros; apply (evalCmd_coind (fun vs1 c' vs2 => exists c, evalCmd vs1 c vs2
    /\ c' = optCmd c)); eauto; crush;
    match goal with
      | [ H : _ = optCmd ?E |- _ ] => destruct E; simpl in *; discriminate
        || injection H; intros; subst
    end; finisher.
Qed.

Lemma optCmd_correct2 : forall env1 c env2, evalCmd env1 (optCmd c) env2
  -> evalCmd env1 c env2.
  intros; apply (evalCmd_coind (fun vs1 c vs2 => evalCmd vs1 (optCmd c) vs2));
    crush; finisher.
Qed.

Theorem optCmd_correct : forall env1 c env2, evalCmd env1 (optCmd c) env2
  <-> evalCmd env1 c env2.
  intuition; apply optCmd_correct1 || apply optCmd_correct2; assumption.
Qed.


Welcome to Coq 8.4pl6 (January 2017)

Coq < Inductive natoption : Type := | Some : nat -> natoption | None : natoption.
natoption is defined
natoption_rect is defined
natoption_ind is defined
natoption_rec is defined

Coq < Inductive natlist : Type := | nil : natlist | cons : nat -> natlist -> natlist.
natlist is defined
natlist_rect is defined
natlist_ind is defined
natlist_rec is defined

Coq < Notation "[ ]" := nil.
Setting notation at level 0.

Coq < Notation "x ++ y" := (app x y) (right associativity, at level 60).

Coq < Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).
Setting notation at level 0.

Coq < Notation "x :: l" := (cons x l) (at level 60, right associativity).

Coq < Fixpoint beq_nat (n m : nat) : bool := match n with | O => match m with | O => true | S m' => false end | S n' => match m with | O => false | S m' => beq_nat n' m' end end.
beq_nat is recursively defined (decreasing on 1st argument)

Coq < Fixpoint nth_error (l:natlist) (n:nat) : natoption := match l with | nil => None | a :: l' => match beq_nat n O with | true => Some a | false => nth_error l' (pred n) end end.
nth_error is recursively defined (decreasing on 1st argument)

Coq < Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
1 subgoal

  ============================
   nth_error (4 :: 5 :: 6 :: 7 :: []) 0 = Some 4

test_nth_error1 < info_auto.
(* info auto : *)
 apply @eq_refl.
No more subgoals.

test_nth_error1 < Qed.
info_auto.

test_nth_error1 is defined

Coq < Example test_nth_error2 : nth_error [4;5;6;7] 3 = Some 7.
1 subgoal

  ============================
   nth_error (4 :: 5 :: 6 :: 7 :: []) 3 = Some 7

test_nth_error2 < info_auto.
(* info auto : *)
 apply @eq_refl.
No more subgoals.

test_nth_error2 < Qed.
info_auto.

test_nth_error2 is defined

Coq < Example test_nth_error3 : nth_error [4;5;6;7] 9 = None.
1 subgoal

  ============================
   nth_error (4 :: 5 :: 6 :: 7 :: []) 9 = None

test_nth_error3 < info_auto.
(* info auto : *)
 apply @eq_refl.
No more subgoals.

test_nth_error3 < Qed.
info_auto.

test_nth_error3 is defined