(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export bar_induction2.

Hint Rewrite @mkcv_inteq_substc : slow.
Hint Rewrite @mkcv_less_substc  : slow.
Hint Rewrite @mkcv_apply_substc : slow.
Hint Rewrite @mkcv_zero_substc  : slow.
Hint Rewrite @mkcv_bot_substc   : slow.
Hint Rewrite @mkcv_nat_substc   : slow.

(* !!MOVE *)
Lemma eq_kseq_trans {o} :
  forall lib (s1 s2 s3 : @CTerm o) n,
    eq_kseq lib s1 s2 n
    -> eq_kseq lib s2 s3 n
    -> eq_kseq lib s1 s3 n.
Proof.
  introv eqk1 eqk2.
  unfold eq_kseq in *.
  eapply equality_trans; eauto.
Qed.

(* !!MOVE *)
Lemma type_natk2nat_if_member_nat {o} :
  forall lib (t : @CTerm o),
    member lib t mkc_tnat
    -> type lib (natk2nat t).
Proof.
  introv mem.
  apply tequality_natk2nat.
  apply member_tnat_implies_computes in mem; exrepnd.
  exists (Z.of_nat k) (Z.of_nat k).
  rewrite <- mkc_nat_eq; dands; spcast; auto.
  introv lek.
  destruct (Z.le_gt_cases (Z.of_nat k) k0) as [d|d]; tcsp.
Qed.

(* !!MOVE *)
Lemma is_seq_implies_is_kseq {o} :
  forall lib (s : @CTerm o) n,
    is_seq lib s
    -> is_kseq lib s n.
Proof.
  introv iss.
  unfold is_seq in iss; unfold is_kseq, eq_kseq.
  apply equality_nat2nat_to_natk2nat; auto.
  apply nat_in_nat.
Qed.

(* !!MOVE *)
Lemma eq_kseq_sym {o} :
  forall lib (s1 s2 : @CTerm o) n,
    eq_kseq lib s1 s2 n
    -> eq_kseq lib s2 s1 n.
Proof.
  introv eqk.
  unfold eq_kseq in *.
  apply equality_sym; auto.
Qed.

(* !!MOVE *)
Lemma is_kseq_if_eq_kseq {o} :
  forall lib (s1 s2 : @CTerm o) n,
    eq_kseq lib s1 s2 n
    -> (is_kseq lib s1 n /\ is_kseq lib s2 n).
Proof.
  introv eqk.
  unfold is_kseq.
  unfold eq_kseq in *.
  dands.
  { apply equality_refl in eqk; auto. }
  { apply equality_sym in eqk; apply equality_refl in eqk; auto. }
Qed.

(* !!MOVE *)
Lemma seq2kseq_prop3 {o} :
  forall lib (s : @CTerm o) n v,
    is_kseq lib s n
    -> eq_kseq lib s (seq2kseq s n v) n.
Proof.
  introv isk.
  unfold is_kseq in isk.
  unfold eq_kseq in *.
  apply implies_equality_natk2nat; introv ltmn.
  apply (equality_natk2nat_implies _ m) in isk; auto; exrepnd.
  exists k; dands; auto.
  unfold seq2kseq.
  clear isk0.
  apply cequivc_nat_implies_computes_to_valc.
  apply computes_to_valc_implies_cequivc in isk1.
  eapply cequivc_trans;[apply cequivc_beta|].
  autorewrite with slow.
  allrw @mkc_zero_eq.
  eapply cequivc_trans;[apply cequivc_mkc_less_nat|].
  boolvar; try omega.
  eapply cequivc_trans;[apply cequivc_mkc_less_nat|].
  boolvar; try omega; auto.
Qed.

Definition barind_meta2_fun_bar_con {o} lib Q S (B R : @CTerm o) v :=
  forall (s : CTerm),
    is_seq lib s
    -> (forall m, meta2_fun_on_seq lib S R m s)
    -> {m : nat , meta2_fun_on_seq lib Q B m (seq2kseq s m v) }.

Definition barind_meta2_fun_imp_con {o} lib Q S P (B R X : @CTerm o) :=
  forall (n : nat) (s : CTerm),
    is_kseq lib s n
    -> meta2_fun_on_seq lib S R n s
    -> meta2_fun_on_seq lib Q B n s
    -> meta2_fun_on_seq lib P X n s.

Definition barind_meta2_fun_ind_con {o} lib S P (R X : @CTerm o) v :=
  forall (n : nat) (s : CTerm),
    is_kseq lib s n
    -> (forall (m : nat),
           meta2_fun_on_seq lib S R n s
           -> meta2_fun_on_upd_seq lib P X s n m v)
    -> meta2_fun_on_seq lib P X n s.

Definition barind_meta2_fun_ind_con_cont {o} lib S P (R X : @CTerm o) v :=
  forall (n : nat) (s : CTerm),
    is_kseq lib s n
    -> !meta2_fun_on_seq lib P X n s
    -> {m : nat
        , !meta2_fun_on_upd_seq lib P X s n m v
        /\ meta2_fun_on_seq lib S R n s}.

Lemma barind_meta2_fun_ind_con_implies_cont {o} :
  forall lib S P (R X : @CTerm o) v,
    barind_meta2_fun_ind_con lib S P R X v
    -> barind_meta2_fun_ind_con_cont lib S P R X v.
Proof.
  introv ind i ni.
  pose proof (ind n s i) as h; clear ind.
  apply contraposition in h; auto.
  (* We use Markov's principle *)
  apply not_all_ex_not in h; auto.
  exrepnd.
  exists n0.
  dands.
  { intro h; tcsp. }
  { pose proof (classic (meta2_fun_on_seq lib S R n s)) as k.
    repndors; auto.
    destruct h0; tcsp. }
Qed.

Definition barind_meta2_fun_ind_con_cont2 {o} lib S P (R X : @CTerm o) v :=
  forall (x : meta2_fun_seq_NA lib P X),
    {m : nat
     , !meta2_fun_on_upd_seq
        lib P X
        (meta2_fun_seq_NA_seq x)
        (meta2_fun_seq_NA_nat x)
        m v
     /\ meta2_fun_on_seq
          lib S R
          (meta2_fun_seq_NA_nat x)
          (meta2_fun_seq_NA_seq x)}.

Definition barind_meta2_fun_ind_con_cont3 {o} lib S P (R X : @CTerm o) v :=
  {f : meta2_fun_seq_NA lib P X -> nat
   , forall a : meta2_fun_seq_NA lib P X,
       !meta2_fun_on_upd_seq
          lib P X
          (meta2_fun_seq_NA_seq a)
          (meta2_fun_seq_NA_nat a)
          (f a) v
       /\ meta2_fun_on_seq lib S R (meta2_fun_seq_NA_nat a) (meta2_fun_seq_NA_seq a)}.

Lemma barind_meta2_fun_ind_con_cont_implies_cont2 {o} :
  forall lib S P (R X : @CTerm o) v,
    barind_meta2_fun_ind_con_cont lib S P R X v
    -> barind_meta2_fun_ind_con_cont2 lib S P R X v.
Proof.
  introv ind; introv.
  unfold meta2_fun_seq_NA in x; exrepnd.
  pose proof (ind n s x0 x1) as h; clear ind.
  simpl; auto.
Qed.

Lemma barind_meta2_fun_ind_con_cont2_implies_cont3 {o} :
  forall lib S P (R X : @CTerm o) v,
    barind_meta2_fun_ind_con_cont2 lib S P R X v
    -> barind_meta2_fun_ind_con_cont3 lib S P R X v.
Proof.
  introv ind; introv.
  apply FunctionalChoice_on in ind; auto.
Qed.

Definition meta2_fun_con_kseq_NA {o} lib C P (n : nat) (R A : @CTerm o) v :=
  {m : nat
   & {s : CTerm
   & is_kseq lib s n
   # seq_normalizable lib s n v
   # !meta2_fun_on_seq lib P A (S n) (update_seq s n m v)
   # meta2_fun_on_seq lib C R n s}}.

Definition mk_meta2_fun_con_kseq_NA {o} {lib} {C P} {n : nat} {R A : @CTerm o} {v}
           (m : nat)
           (s : CTerm)
           (i : is_kseq lib s n)
           (q : seq_normalizable lib s n v)
           (p : !meta2_fun_on_seq lib P A (S n) (update_seq s n m v))
           (c : meta2_fun_on_seq lib C R n s) : meta2_fun_con_kseq_NA lib C P n R A v :=
  existT _ m (existT _ s (i,(q,(p,c)))).

Definition meta2_fun_con_kseq_NA_nat {o} {lib} {C P} {n : nat} {R A : @CTerm o} {v}
           (x : meta2_fun_con_kseq_NA lib C P n R A v) : nat:=
  match x with
    | existT _ m _ => m
  end.

Definition meta2_fun_con_kseq_NA_seq {o} {lib} {C P} {n : nat} {R A : @CTerm o} {v}
           (x : meta2_fun_con_kseq_NA lib C P n R A v) : CTerm:=
  match x with
    | existT _ _ (existT _ s _) => s
  end.

Lemma eq_kseq_update_seq_implies {o} :
  forall lib (s : @CTerm o) n k v s2,
    eq_kseq lib (update_seq s n k v) s2 n
    -> eq_kseq lib s s2 n.
Proof.
  introv eqs.
  unfold eq_kseq in *.
  apply implies_equality_natk2nat.
  introv ltmn.
  apply (equality_natk2nat_implies _ m) in eqs; auto; exrepnd.
  exists k0; dands; auto.
  clear eqs0.
  apply cequivc_nat_implies_computes_to_valc.
  apply computes_to_valc_implies_cequivc in eqs1.
  unfold update_seq in eqs1.
  eapply cequivc_trans in eqs1;[|apply cequivc_sym;apply cequivc_beta].
  autorewrite with slow in *.
  eapply cequivc_trans in eqs1;[|apply cequivc_sym;apply cequivc_mkc_inteq_nat].
  boolvar; subst; try omega; auto.
Qed.

Lemma implies_meta2_fun_on_seq_update_seq {o} :
  forall lib C (R : @CTerm o) s n k v,
    is_kseq lib (update_seq s n k v) (S n)
    -> meta2_fun_on_seq lib C R n s
    -> meta2_fun_on_seq lib C R n (update_seq s n k v).
Proof.
  introv isk m eqs c.
  pose proof (m A2 s2) as q; clear m.
  repeat (autodimp q hyp).
  { apply eq_kseq_update_seq_implies in eqs; auto. }
  repnd; dands; auto.
Abort.

Fixpoint meta2_fun_con_alpha {o}
         (lib : library)
         C P
         (R X c : @CTerm o)
         (v : NVar)
         (q : seq_normalizable lib c 0 v)
         (h : !meta2_fun_on_seq lib P X 0 c)
         (f : meta2_fun_seq_NA lib P X -> nat)
         (ind : forall a : meta2_fun_seq_NA lib P X,
                  !meta2_fun_on_upd_seq
                     lib P X
                     (meta2_fun_seq_NA_seq a)
                     (meta2_fun_seq_NA_nat a) (f a) v
                  /\ meta2_fun_on_seq
                       lib C R
                       (meta2_fun_seq_NA_nat a)
                       (meta2_fun_seq_NA_seq a))
         (n : nat) : meta2_fun_con_kseq_NA lib C P n R X v :=
  match n with
    | 0 =>
      let i := is_kseq_0 lib c in
      let p := mk_meta2_fun_seq_NA 0 c i h in
      let k := f p in
      mk_meta2_fun_con_kseq_NA
        k
        c
        i
        q
        (proj1 (ind p))
        (proj2 (ind p))
    | S m =>
      let (x,r) := meta2_fun_con_alpha lib C P R X c v q h f ind m in
      let (s,r) := r in
      let (i,r) := r in
      let (z,r) := r in
      let (e,na) := r in
      let p := mk_meta2_fun_seq_NA (S m) (update_seq s m x v) (is_kseq_update _ _ _ _ _ i) e in
      let k := f p in
      mk_meta2_fun_con_kseq_NA
        k
        (update_seq s m x v)
        (is_kseq_update lib s m x v i)
        (seq_normalizable_update lib s m x v z)
        (proj1 (ind p))
        (proj2 (ind p))
  end.

Lemma meta2_fun_con_kseq_NA_seq_mk_meta2_fun_con_kseq_NA {o} :
  forall lib C P n (R A : @CTerm o) v m s i q e p,
    meta2_fun_con_kseq_NA_seq (@mk_meta2_fun_con_kseq_NA o lib C P n R A v m s i q e p) = s.
Proof. sp. Qed.
Hint Rewrite @meta2_fun_con_kseq_NA_seq_mk_meta2_fun_con_kseq_NA : slow.

Lemma meta2_fun_con_alpha_prop1 {o} :
  forall lib C P
         (R X c : @CTerm o)
         (v : NVar)
         (q : seq_normalizable lib c 0 v)
         (h : !meta2_fun_on_seq lib P X 0 c)
         (f : meta2_fun_seq_NA lib P X -> nat)
         (ind : forall a : meta2_fun_seq_NA lib P X,
                  !meta2_fun_on_upd_seq
                     lib P X
                     (meta2_fun_seq_NA_seq a)
                     (meta2_fun_seq_NA_nat a) (f a) v
                  /\ meta2_fun_on_seq
                       lib C R
                       (meta2_fun_seq_NA_nat a)
                       (meta2_fun_seq_NA_seq a))
         (n m : nat)
         (lemn : m <= n),
    equality
      lib
      (meta2_fun_con_kseq_NA_seq (meta2_fun_con_alpha lib C P R X c v q h f ind n))
      (meta2_fun_con_kseq_NA_seq (meta2_fun_con_alpha lib C P R X c v q h f ind m))
      (natk2nat (mkc_nat m)).
Proof.
  introv lemn.
  assert {k : nat & n = k + m} as e.
  { exists (n - m); omega. }
  exrepnd; subst.
  clear lemn.
  induction k; introv; allsimpl; apply implies_equality_natk2nat; introv ltm0.

  - remember (meta2_fun_con_alpha lib C P R X c v q h f ind m) as am.
    unfold meta2_fun_con_kseq_NA in am; exrepnd; allsimpl.

    dup am0 as i.
    apply (is_kseq_implies lib m0) in i; try omega; exrepnd.
    exists k; dands; auto.

  - remember (meta2_fun_con_alpha lib C P R X c v q h f ind (k + m)) as am.
    unfold meta2_fun_con_kseq_NA in am; exrepnd; simphyps.
    autorewrite with slow.

    eapply equality_natk2nat_implies in IHk;[|exact ltm0].
    exrepnd.
    exists k0; dands; auto.

    unfold update_seq.
    apply cequivc_nat_implies_computes_to_valc.
    eapply cequivc_trans;[apply cequivc_beta|].
    autorewrite with slow.
    eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
    boolvar; tcsp; GC; try omega.
    apply computes_to_valc_implies_cequivc; auto.
Qed.

Definition barind_meta2_fun_wf {o} lib C (R : @CTerm o) :=
  forall s1 s2 n,
    eq_kseq lib s1 s2 n
    -> meta2_fun_on_seq lib C R n s1
    -> meta2_fun_on_seq lib C R n s2.

Lemma bar_induction_meta4_con {o} :
  forall lib Q C P (B R X c : @CTerm o) v,
    barind_meta2_fun_wf lib C R
    -> barind_meta2_fun_bar_con lib Q C B R v
    -> barind_meta2_fun_imp_con lib Q C P B R X
    -> barind_meta2_fun_ind_con lib C P R X v
    -> meta2_fun_on_seq lib P X 0 (seq2kseq c 0 v).
Proof.
  introv wfR bar imp ind.
  pose proof (classic (meta2_fun_on_seq lib P X 0 (seq2kseq c 0 v))) as ni.
  repndors; auto.
  provefalse.

  apply barind_meta2_fun_ind_con_implies_cont in ind.
  apply barind_meta2_fun_ind_con_cont_implies_cont2 in ind.
  apply barind_meta2_fun_ind_con_cont2_implies_cont3 in ind.
  unfold barind_meta2_fun_ind_con_cont3 in ind; exrepnd.
  rename ind0 into ind.

  remember (seq_normalizable_seq2kseq lib c 0 v) as nc.
  clear Heqnc.

  remember (meta2_fun_con_alpha lib C P R X (seq2kseq c 0 v) v nc ni f ind) as g.
  remember (fun m => meta2_fun_con_kseq_NA_nat (g m)) as s.

  assert (forall n, eq_kseq lib (mkc_nseq s) (meta2_fun_con_kseq_NA_seq (g n)) n) as e.
  { introv.
    apply implies_equality_natk2nat; introv ltm.
    subst.
    exists (meta2_fun_con_kseq_NA_nat
              (meta2_fun_con_alpha lib C P R X (seq2kseq c 0 v) v nc ni f ind m)).
    dands.

    - apply cequivc_nat_implies_computes_to_valc.
      eapply cequivc_trans;[apply cequivc_beta_nseq|].
      simpl; auto.

    - pose proof (meta2_fun_con_alpha_prop1 lib C P R X (seq2kseq c 0 v) v nc ni f ind n (S m)) as q.
      autodimp q hyp; try omega.
      apply (equality_natk2nat_implies lib m) in q; try omega.
      exrepnd.

      apply cequivc_nat_implies_computes_to_valc.
      apply computes_to_valc_implies_cequivc in q1.
      apply computes_to_valc_implies_cequivc in q0.

      apply cequivc_sym in q1.
      eapply cequivc_trans in q1;[|exact q0].
      clear q0.
      eapply cequivc_trans;[apply cequivc_sym;exact q1|].
      clear q1.
      simpl.

      remember (meta2_fun_con_alpha lib C P R X (seq2kseq c 0 v) v nc ni f ind m) as am.
      unfold meta2_fun_con_kseq_NA in am; exrepnd; simphyps.
      autorewrite with slow.
      unfold meta2_fun_con_kseq_NA_nat.
      unfold update_seq.
      eapply cequivc_trans;[apply cequivc_beta|].
      autorewrite with slow.
      eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
      boolvar; auto; try omega.
  }

  pose proof (bar (mkc_nseq s)) as b.
  repeat (autodimp b hyp); eauto 3 with slow.
  {
    introv.
    pose proof (e m) as q; clear e.
    eapply wfR;[apply eq_kseq_sym; exact q|]; auto.
    subst.
    remember (meta2_fun_con_alpha lib C P R X (seq2kseq c 0 v) v nc ni f ind m) as a.
    unfold meta2_fun_con_kseq_NA in a; exrepnd; simpl in *; auto.
  }
  exrepnd.
  rename b0 into b.

  apply imp in b;
    [|apply implies_is_kseq_seq2kseq; eauto 3 with slow
     |pose proof (e m) as q; clear e;
      eapply wfR;[apply seq2kseq_prop3;apply is_kseq_if_eq_kseq in q; tcsp|];
      eapply wfR;[apply eq_kseq_sym;exact q|];
      subst;
      remember (meta2_fun_con_alpha lib C P R X (seq2kseq c 0 v) v nc ni f ind m) as a;
      unfold meta2_fun_con_kseq_NA in a; exrepnd; simpl in *; auto
    ].

  destruct m; allsimpl.

  {
    pose proof (eq_kseq_0 lib (mkc_nseq s) c) as h1.
    apply (seq2kseq_prop2 _ v) in h1.
    eapply cequivc_preserves_meta2_fun_on_seq in b;[|exact h1].
    auto.
  }

  pose proof (e (S m)) as q1.
  apply (seq2kseq_prop2 _ v) in q1.
  eapply cequivc_preserves_meta2_fun_on_seq in b;[clear q1|exact q1].
  clear e.

  subst; allsimpl.
  remember (meta2_fun_con_alpha lib C P R X (seq2kseq c 0 v) v nc ni f ind m) as am.
  unfold meta2_fun_con_kseq_NA in am; exrepnd; allsimpl.

  clear Heqam.
  apply (seq_normalizable_update _ _ _ m0) in am2.
  unfold seq_normalizable in am2.
  eapply cequivc_preserves_meta2_fun_on_seq in b;
    [|apply cequivc_sym;exact am2].
  tcsp.
Qed.

Definition barind_meta5_fun_ind_con {o} lib C P (R X : @CTerm o) v :=
  forall (n : nat) (s : CTerm),
    is_kseq lib s n
    -> (forall (m : nat),
           meta2_fun_on_upd_seq lib C R s n m v
           -> meta2_fun_on_upd_seq lib P X s n m v)
    -> meta2_fun_on_seq lib C R n s
    -> meta2_fun_on_seq lib P X n s.

Definition barind_meta5_fun_ind_con_cont {o} lib C P (R X : @CTerm o) v :=
  forall (n : nat) (s : CTerm),
    is_kseq lib s n
    -> meta2_fun_on_seq lib C R n s
    -> !meta2_fun_on_seq lib P X n s
    -> {m : nat
        , !meta2_fun_on_upd_seq lib P X s n m v
        /\ meta2_fun_on_upd_seq lib C R s n m v}.

Lemma barind_meta5_fun_ind_con_implies_cont {o} :
  forall lib C P (R X : @CTerm o) v,
    barind_meta5_fun_ind_con lib C P R X v
    -> barind_meta5_fun_ind_con_cont lib C P R X v.
Proof.
  introv ind i mr ni.
  pose proof (ind n s i) as h; clear ind.
  match goal with
  | [ H : ?a -> ?b -> ?c |- _ ] => assert (b -> a -> c) as q by tcsp; clear h
  end.
  autodimp q hyp.

  apply contraposition in q; auto.
  (* We use Markov's principle *)
  apply not_all_ex_not in q; auto.
  exrepnd.
  exists n0.
  dands.
  { intro h; tcsp. }
  { pose proof (classic (meta2_fun_on_upd_seq lib C R s n n0 v)) as k.
    repndors; auto.
    destruct q0; tcsp. }
Qed.

Definition meta5_fun_seq_NA {o} lib C P (R X : @CTerm o) :=
  {n : nat
   & {s : CTerm
   & is_kseq lib s n
   # meta2_fun_on_seq lib C R n s
   # !meta2_fun_on_seq lib P X n s }}.

Definition mk_meta5_fun_seq_NA {o} {lib} {C P} {R X : @CTerm o}
           (n : nat)
           (s : CTerm)
           (i : is_kseq lib s n)
           (r : meta2_fun_on_seq lib C R n s)
           (p : !meta2_fun_on_seq lib P X n s) : meta5_fun_seq_NA lib C P R X :=
  existT _ n (existT _ s (i,(r,p))).

Definition meta5_fun_seq_NA_nat {o} {lib} {C P} {R X : @CTerm o}
           (x : meta5_fun_seq_NA lib C P R X) : nat :=
  projT1 x.

Definition meta5_fun_seq_NA_seq {o} {lib} {C P} {R X : @CTerm o}
           (x : meta5_fun_seq_NA lib C P R X) : CTerm :=
  match x with
    | existT _ _ (existT _ s _) => s
  end.

Definition barind_meta5_fun_ind_con_cont2 {o} lib C P (R X : @CTerm o) v :=
  forall (x : meta5_fun_seq_NA lib C P R X),
    {m : nat
     , !meta2_fun_on_upd_seq
        lib P X
        (meta5_fun_seq_NA_seq x)
        (meta5_fun_seq_NA_nat x)
        m v
     /\ meta2_fun_on_upd_seq
          lib C R
          (meta5_fun_seq_NA_seq x)
          (meta5_fun_seq_NA_nat x)
          m v}.

Definition barind_meta5_fun_ind_con_cont3 {o} lib C P (R X : @CTerm o) v :=
  {f : meta5_fun_seq_NA lib C P R X -> nat
   , forall a : meta5_fun_seq_NA lib C P R X,
       !meta2_fun_on_upd_seq
          lib P X
          (meta5_fun_seq_NA_seq a)
          (meta5_fun_seq_NA_nat a)
          (f a) v
       /\ meta2_fun_on_upd_seq
            lib C R
            (meta5_fun_seq_NA_seq a)
            (meta5_fun_seq_NA_nat a)
            (f a) v}.

Lemma barind_meta5_fun_ind_con_cont_implies_cont2 {o} :
  forall lib C P (R X : @CTerm o) v,
    barind_meta5_fun_ind_con_cont lib C P R X v
    -> barind_meta5_fun_ind_con_cont2 lib C P R X v.
Proof.
  introv ind; introv.
  unfold meta5_fun_seq_NA in x; exrepnd.
  pose proof (ind n s x0 x2 x1) as h; clear ind.
  simpl; auto.
Qed.

Lemma barind_meta5_fun_ind_con_cont2_implies_cont3 {o} :
  forall lib C P (R X : @CTerm o) v,
    barind_meta5_fun_ind_con_cont2 lib C P R X v
    -> barind_meta5_fun_ind_con_cont3 lib C P R X v.
Proof.
  introv ind; introv.
  apply FunctionalChoice_on in ind; auto.
Qed.

Definition meta5_fun_con_kseq_NA {o} lib C P (n : nat) (R A : @CTerm o) v :=
  {m : nat
   & {s : CTerm
   & is_kseq lib s n
   # seq_normalizable lib s n v
   # !meta2_fun_on_seq lib P A (S n) (update_seq s n m v)
   # meta2_fun_on_seq lib C R (S n) (update_seq s n m v) }}.

Definition mk_meta5_fun_con_kseq_NA {o} {lib} {C P} {n : nat} {R A : @CTerm o} {v}
           (m : nat)
           (s : CTerm)
           (i : is_kseq lib s n)
           (q : seq_normalizable lib s n v)
           (p : !meta2_fun_on_seq lib P A (S n) (update_seq s n m v))
           (c : meta2_fun_on_seq lib C R (S n) (update_seq s n m v))
  : meta5_fun_con_kseq_NA lib C P n R A v :=
  existT _ m (existT _ s (i,(q,(p,c)))).

Fixpoint meta5_fun_con_alpha {o}
         (lib : library)
         C P
         (R X c : @CTerm o)
         (v : NVar)
         (q : seq_normalizable lib c 0 v)
         (r : meta2_fun_on_seq lib C R 0 c)
         (h : !meta2_fun_on_seq lib P X 0 c)
         (f : meta5_fun_seq_NA lib C P R X -> nat)
         (ind : forall a : meta5_fun_seq_NA lib C P R X,
                  !meta2_fun_on_upd_seq
                     lib P X
                     (meta5_fun_seq_NA_seq a)
                     (meta5_fun_seq_NA_nat a) (f a) v
                  /\ meta2_fun_on_upd_seq
                       lib C R
                       (meta5_fun_seq_NA_seq a)
                       (meta5_fun_seq_NA_nat a)
                       (f a) v)
         (n : nat) : meta5_fun_con_kseq_NA lib C P n R X v :=
  match n with
    | 0 =>
      let i := is_kseq_0 lib c in
      let p := mk_meta5_fun_seq_NA 0 c i r h in
      let k := f p in
      mk_meta5_fun_con_kseq_NA
        k
        c
        i
        q
        (proj1 (ind p))
        (proj2 (ind p))
    | S m =>
      let (x,r) := meta5_fun_con_alpha lib C P R X c v q r h f ind m in
      let (s,r) := r in
      let (i,r) := r in
      let (z,r) := r in
      let (e,r) := r in
      let p := mk_meta5_fun_seq_NA
                 (S m)
                 (update_seq s m x v)
                 (is_kseq_update _ _ _ _ _ i)
                 r e in
      let k := f p in
      mk_meta5_fun_con_kseq_NA
        k
        (update_seq s m x v)
        (is_kseq_update lib s m x v i)
        (seq_normalizable_update lib s m x v z)
        (proj1 (ind p))
        (proj2 (ind p))
  end.

Definition meta5_fun_con_kseq_NA_nat {o} {lib} {C P} {n : nat} {R A : @CTerm o} {v}
           (x : meta5_fun_con_kseq_NA lib C P n R A v) : nat:=
  match x with
    | existT _ m _ => m
  end.

Definition meta5_fun_con_kseq_NA_seq {o} {lib} {C P} {n : nat} {R A : @CTerm o} {v}
           (x : meta5_fun_con_kseq_NA lib C P n R A v) : CTerm:=
  match x with
    | existT _ _ (existT _ s _) => s
  end.

Lemma meta5_fun_con_kseq_NA_seq_mk_meta5_fun_con_kseq_NA {o} :
  forall lib C P n (R A : @CTerm o) v m s i q e p,
    meta5_fun_con_kseq_NA_seq (@mk_meta5_fun_con_kseq_NA o lib C P n R A v m s i q e p) = s.
Proof. sp. Qed.
Hint Rewrite @meta5_fun_con_kseq_NA_seq_mk_meta5_fun_con_kseq_NA : slow.

Lemma meta5_fun_con_alpha_prop1 {o} :
  forall lib C P
         (R X c : @CTerm o)
         (v : NVar)
         (q : seq_normalizable lib c 0 v)
         (r : meta2_fun_on_seq lib C R 0 c)
         (h : !meta2_fun_on_seq lib P X 0 c)
         (f : meta5_fun_seq_NA lib C P R X -> nat)
         (ind : forall a : meta5_fun_seq_NA lib C P R X,
                  !meta2_fun_on_upd_seq
                     lib P X
                     (meta5_fun_seq_NA_seq a)
                     (meta5_fun_seq_NA_nat a)
                     (f a) v
                  /\ meta2_fun_on_upd_seq
                       lib C R
                       (meta5_fun_seq_NA_seq a)
                       (meta5_fun_seq_NA_nat a)
                       (f a) v)
         (n m : nat)
         (lemn : m <= n),
    equality
      lib
      (meta5_fun_con_kseq_NA_seq (meta5_fun_con_alpha lib C P R X c v q r h f ind n))
      (meta5_fun_con_kseq_NA_seq (meta5_fun_con_alpha lib C P R X c v q r h f ind m))
      (natk2nat (mkc_nat m)).
Proof.
  introv lemn.
  assert {k : nat & n = k + m} as e.
  { exists (n - m); omega. }
  exrepnd; subst.
  clear lemn.
  induction k; introv; allsimpl; apply implies_equality_natk2nat; introv ltm0.

  - remember (meta5_fun_con_alpha lib C P R X c v q r h f ind m) as am.
    unfold meta5_fun_con_kseq_NA in am; exrepnd; allsimpl.

    dup am0 as i.
    apply (is_kseq_implies lib m0) in i; try omega; exrepnd.
    exists k; dands; auto.

  - remember (meta5_fun_con_alpha lib C P R X c v q r h f ind (k + m)) as am.
    unfold meta5_fun_con_kseq_NA in am; exrepnd; simphyps.
    autorewrite with slow.

    eapply equality_natk2nat_implies in IHk;[|exact ltm0].
    exrepnd.
    exists k0; dands; auto.

    unfold update_seq.
    apply cequivc_nat_implies_computes_to_valc.
    eapply cequivc_trans;[apply cequivc_beta|].
    autorewrite with slow.
    eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
    boolvar; tcsp; GC; try omega.
    apply computes_to_valc_implies_cequivc; auto.
Qed.

Lemma bar_induction_meta5_con {o} :
  forall lib Q C P (B R X c : @CTerm o) v,
    barind_meta2_fun_wf lib C R
    -> barind_meta2_fun_bar_con lib Q C B R v
    -> barind_meta2_fun_imp_con lib Q C P B R X
    -> barind_meta5_fun_ind_con lib C P R X v
    -> meta2_fun_on_seq lib C R 0 (seq2kseq c 0 v)
    -> meta2_fun_on_seq lib P X 0 (seq2kseq c 0 v).
Proof.
  introv wfR bar imp ind R0.
  pose proof (classic (meta2_fun_on_seq lib P X 0 (seq2kseq c 0 v))) as ni.
  repndors; auto.
  provefalse.

  apply barind_meta5_fun_ind_con_implies_cont in ind.
  apply barind_meta5_fun_ind_con_cont_implies_cont2 in ind.
  apply barind_meta5_fun_ind_con_cont2_implies_cont3 in ind.
  unfold barind_meta5_fun_ind_con_cont3 in ind; exrepnd.
  rename ind0 into ind.

  remember (seq_normalizable_seq2kseq lib c 0 v) as nc.
  clear Heqnc.

  remember (meta5_fun_con_alpha lib C P R X (seq2kseq c 0 v) v nc R0 ni f ind) as g.
  remember (fun m => meta5_fun_con_kseq_NA_nat (g m)) as s.

  assert (forall n, eq_kseq lib (mkc_nseq s) (meta5_fun_con_kseq_NA_seq (g n)) n) as e.
  { introv.
    apply implies_equality_natk2nat; introv ltm.
    subst.
    exists (meta5_fun_con_kseq_NA_nat
              (meta5_fun_con_alpha lib C P R X (seq2kseq c 0 v) v nc R0 ni f ind m)).
    dands.

    - apply cequivc_nat_implies_computes_to_valc.
      eapply cequivc_trans;[apply cequivc_beta_nseq|].
      simpl; auto.

    - pose proof (meta5_fun_con_alpha_prop1 lib C P R X (seq2kseq c 0 v) v nc R0 ni f ind n (S m)) as q.
      autodimp q hyp; try omega.
      apply (equality_natk2nat_implies lib m) in q; try omega.
      exrepnd.

      apply cequivc_nat_implies_computes_to_valc.
      apply computes_to_valc_implies_cequivc in q1.
      apply computes_to_valc_implies_cequivc in q0.

      apply cequivc_sym in q1.
      eapply cequivc_trans in q1;[|exact q0].
      clear q0.
      eapply cequivc_trans;[apply cequivc_sym;exact q1|].
      clear q1.
      simpl.

      remember (meta5_fun_con_alpha lib C P R X (seq2kseq c 0 v) v nc R0 ni f ind m) as am.
      unfold meta5_fun_con_kseq_NA in am; exrepnd; simphyps.
      autorewrite with slow.
      unfold meta5_fun_con_kseq_NA_nat.
      unfold update_seq.
      eapply cequivc_trans;[apply cequivc_beta|].
      autorewrite with slow.
      eapply cequivc_trans;[apply cequivc_mkc_inteq_nat|].
      boolvar; auto; try omega.
  }

  assert (forall m : nat, meta2_fun_on_seq lib C R m (mkc_nseq s)) as hr.
  {
    introv.
    destruct m.
    - eapply wfR;[|exact R0]; apply eq_kseq_0.
    - pose proof (e (S m)) as q; clear e.
      subst.
      simpl in q.
      remember (meta5_fun_con_alpha lib C P R X (seq2kseq c 0 v) v nc R0 ni f ind m) as a.
      unfold meta5_fun_con_kseq_NA in a; exrepnd; simpl in *; auto.
      eapply wfR;[apply eq_kseq_sym; exact q|]; auto.
  }

  pose proof (bar (mkc_nseq s)) as b.
  repeat (autodimp b hyp); eauto 3 with slow.
  exrepnd.
  rename b0 into b.

  apply imp in b;
    [|apply implies_is_kseq_seq2kseq; eauto 3 with slow
     |pose proof (hr m) as q;
      eapply wfR;[apply seq2kseq_prop3|];auto;
      pose proof (e m) as h;
      apply is_kseq_if_eq_kseq in h; tcsp
    ].

  destruct m; allsimpl.

  {
    pose proof (eq_kseq_0 lib (mkc_nseq s) c) as h1.
    apply (seq2kseq_prop2 _ v) in h1.
    eapply cequivc_preserves_meta2_fun_on_seq in b;[|exact h1].
    auto.
  }

  pose proof (e (S m)) as q1.
  apply (seq2kseq_prop2 _ v) in q1.
  eapply cequivc_preserves_meta2_fun_on_seq in b;[clear q1|exact q1].
  clear e.

  subst; allsimpl.
  remember (meta5_fun_con_alpha lib C P R X (seq2kseq c 0 v) v nc R0 ni f ind m) as am.
  unfold meta5_fun_con_kseq_NA in am; exrepnd; allsimpl.

  clear Heqam.
  apply (seq_normalizable_update _ _ _ m0) in am2.
  unfold seq_normalizable in am2.
  eapply cequivc_preserves_meta2_fun_on_seq in b;
    [|apply cequivc_sym;exact am2].
  tcsp.
Qed.


Require Import Morphisms Setoid Coq.Vectors.Fin.
Require Import Utf8.

Add LoadPath "../../theories" as CatQ.
From CatQ.Structures Require Import Structures.

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

Set Universe Polymorphism.

Program Definition One : Category :=
  to_Category
    {|
      cat_object := unit;
      cat_hom := fun _ _ => unit;
      cat_hom_equal := fun _ _ _ _ => True;
      cat_identity := fun _ => tt;
      cat_comp := fun _ _ _ _ _ => tt;
    |}.
Next Obligation.
  constructor.
  - auto.
  - auto.
  - auto.
Defined.
Next Obligation.
  constructor.
Defined.

Program Definition Product (C D : Category) : Category :=
  {|
    object := object C * object D;
    morphism := fun a b => @morphism C (fst a) (fst b) ** @morphism D (snd a) (snd b);
    identity := fun _ => Spair identity identity;
    compose := fun _ _ _ => {| mapping := fun gf => Spair (fst (fst gf) ∘ fst (snd gf)) (snd (fst gf) ∘ snd (snd gf)); |};
  |}.
Next Obligation.
  simpl.
  unfold Proper, respectful.
  simpl.
  intros x y H.
  destruct H.
  destruct H, H0.
  split.
  - rewrite H, H0.
    reflexivity.
  - rewrite H1, H2.
    reflexivity.
Defined.
Next Obligation.
  apply Build_Is_Category.
  - simpl.
    intros.
    split.
    + apply associativity.
    + apply associativity.
  - simpl.
    intros.
    split.
    + apply left_identity.
    + apply left_identity.
  - simpl.
    intros.
    split.
    + apply right_identity.
    + apply right_identity.
Defined.

Infix "×" := Product (at level 50).

Program Definition Product_mediating {X Y C D} (f : Functor X C) (g : Functor Y D) : Functor (X × Y) (C × D)
  := [fmap: fun _ _ u => (| fmap f (fst u), fmap g (snd u) |) with fun (xy : X × Y) => (f (fst xy), g (snd xy)) : C × D ].
Next Obligation.
  unfold Proper, respectful.
  simpl.
  intros.
  destruct H.
  rewrite H, H0.
  split.
  reflexivity. reflexivity.
Defined.
Next Obligation.
  split.
  apply fmap_identity.
  apply fmap_identity.
Defined.
Next Obligation.
  split.
  apply fmap_compose.
  apply fmap_compose.
Defined.

Notation "⟨ProductF: f , g 'of' X , Y , C , D ⟩" := (@Product_mediating X Y C D f g).
Notation "⟨ProductF: f , g ⟩" := ⟨ProductF: f , g of _ , _ , _ , _⟩.


(* -*- mode: coq; coq-prog-args: ("-emacs" "-nois" "-R" "." "Top" "-top" "bug_hom_anom_10") -*- *)
(* File reduced by coq-bug-finder from original input, then from 156 lines to 41 lines, then from 237 lines to 45 lines, then from 163 lines to 66 lines, then from 342 lines to 121 lines, then from 353 lines to 184 lines, then from 343 lines to 255 lines, then from 435 lines to 322 lines, then from 475 lines to 351 lines, then from 442 lines to 377 lines, then from 505 lines to 410 lines, then from 591 lines to 481 lines, then from 596 lines to 535 lines, then from 647 lines to 570 lines, then from 669 lines to 596 lines, then from 687 lines to 620 lines, then from 728 lines to 652 lines, then from 1384 lines to 683 lines, then from 984 lines to 707 lines, then from 1124 lines to 734 lines, then from 775 lines to 738 lines, then from 950 lines to 763 lines, then from 857 lines to 798 lines, then from 983 lines to 752 lines, then from 1598 lines to 859 lines, then from 873 lines to 859 lines, then from 875 lines to 862 lines, then from 901 lines to 863 lines, then from 1047 lines to 865 lines, then from 929 lines to 871 lines, then from 989 lines to 884 lines, then from 900 lines to 884 lines, then from 884 lines to 751 lines, then from 763 lines to 593 lines, then from 482 lines to 232 lines, then from 416 lines to 227 lines, then from 290 lines to 231 lines, then from 348 lines to 235 lines, then from 249 lines to 235 lines, then from 249 lines to 172 lines, then from 186 lines to 172 lines, then from 140 lines to 113 lines, then from 127 lines to 113 lines *) (* coqc version trunk (June 2016) compiled on Jun 2 2016 10:16:20 with OCaml 4.02.3
   coqtop version trunk (June 2016) *)

Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
Reserved Notation "x * y" (at level 40, left associativity).
Delimit Scope type_scope with type.
Open Scope type_scope.
Global Set Universe Polymorphism.
Notation "A -> B" := (forall (_ : A), B) : type_scope.
Set Implicit Arguments.
Global Set Nonrecursive Elimination Schemes.
Record prod (A B : Type) := pair { fst : A ; snd : B }.
Notation "x * y" := (prod x y) : type_scope.
Axiom admit : forall {T}, T.
Delimit Scope function_scope with function.
Notation compose := (fun g f x => g (f x)).
Notation "g 'o' f" := (compose g%function f%function) (at level 40, left associativity) : function_scope.
Record PreCategory :=
  Build_PreCategory {
      object :> Type;
      morphism : object -> object -> Type;
      identity : forall x, morphism x x }.
Bind Scope category_scope with PreCategory.
Record Functor (C D : PreCategory) := { object_of :> C -> D }.
Bind Scope functor_scope with Functor.
Class Isomorphic {C : PreCategory} (s d : C) := {}.
Definition oppositeC (C : PreCategory) : PreCategory
  := @Build_PreCategory C (fun s d => morphism C d s) admit.
Notation "C ^op" := (oppositeC C) (at level 3, format "C '^op'") : category_scope.
Definition oppositeF C D (F : Functor C D) : Functor C^op D^op
  := Build_Functor (C^op) (D^op) (object_of F).
Definition set_cat : PreCategory := @Build_PreCategory Type (fun x y => x -> y) admit.
Definition prodC (C D : PreCategory) : PreCategory
  := @Build_PreCategory
       (C * D)%type
       (fun s d => (morphism C (fst s) (fst d)
                    * morphism D (snd s) (snd d))%type)
       admit.
Infix "*" := prodC : category_scope.
Section composition.
  Variables B C D E : PreCategory.
  Definition composeF (G : Functor D E) (F : Functor C D) : Functor C E := Build_Functor C E (fun c => G (F c)).
End composition.
Infix "o" := composeF : functor_scope.
Definition fstF {C D} : Functor (C * D) C := admit.
Definition sndF {C D} : Functor (C * D) D := admit.
Definition prodF C D D' (F : Functor C D) (F' : Functor C D') : Functor C (D * D') := admit.
Local Infix "*" := prodF : functor_scope.
Definition pairF C D C' D' (F : Functor C D) (F' : Functor C' D') : Functor (C * C') (D * D')
  := (F o fstF) * (F' o sndF).
Section hom_functor.
  Variable C : PreCategory.
  Local Notation obj_of c'c :=
    ((morphism
        C
        (fst (c'c : object (C^op * C)))
        (snd (c'c : object (C^op * C))))).
  Definition hom_functor : Functor (C^op * C) set_cat
    := Build_Functor (C^op * C) set_cat (fun c'c => obj_of c'c).
End hom_functor.
Definition identityF C : Functor C C := admit.
Definition functor_category (C D : PreCategory) : PreCategory
  := @Build_PreCategory (Functor C D) admit admit.
Local Notation "C -> D" := (functor_category C D) : category_scope.
Definition NaturalIsomorphism (C D : PreCategory) F G := @Isomorphic (C -> D) F G.
Section Adjunction.
  Variables C D : PreCategory.
  Variable F : Functor C D.
  Variable G : Functor D C.
  Record AdjunctionHom :=
    {
      mate_of : @NaturalIsomorphism
                  (prodC (oppositeC C) D)
                  (@set_cat)
                  (@composeF
                     (prodC (oppositeC C) D)
                     (prodC (oppositeC D) D)
                     (@set_cat) (@hom_functor D)
                     (@pairF (oppositeC C)
                             (oppositeC D) D D
                             (@oppositeF C D F) (identityF D)))
                  (@composeF
                     (prodC (oppositeC C) D)
                     (prodC (oppositeC C) C)
                     (@set_cat) (@hom_functor C)
                     (@pairF (oppositeC C)
                             (oppositeC C) D C
                             (identityF (oppositeC C)) G))
    }.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2013-2018 Sylvie Boldo
#<br />#
Copyright (C) 2013-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** Translation from Flocq to Pff *)

Require Import Lia.
Require Import Pff Core Binary.

Section RND_Closest_c.
(* extension of pff for rounding function with arbitrary tie *)
Variable b : Fbound.
Variable beta : radix.
Variable p : nat.

Coercion FtoRradix := FtoR beta.
Hypothesis pGreaterThanOne : 1 < p.
Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat beta p.

Variable choice: Z -> bool.

Definition RND_Closest (r : R) :=
   let ru := RND_Max b beta p r in
   let rd := RND_Min b beta p r in
  match Rle_dec (Rabs (ru - r)) (Rabs (rd - r)) with
  | left H =>
      match
        Rle_lt_or_eq_dec (Rabs (ru - r)) (Rabs (rd - r)) H
      with
      | left _ => ru
      | right _ =>
          match choice (Zfloor (scaled_mantissa beta (FLT_exp (- dExp b) p) r)) with
          | true => ru
          | false => rd
          end
      end
  | right _ => rd
  end.

Theorem RND_Closest_canonic :
 forall r : R, Fcanonic beta b (RND_Closest r).
Proof.
intros r; unfold RND_Closest in |- *.
case (Rle_dec _ _ ); intros H1.
case (Rle_lt_or_eq_dec _ _ H1); intros H2.
apply RND_Max_canonic; try easy; apply radix_gt_1.
case (choice _).
now apply RND_Max_canonic; try easy; apply radix_gt_1.
now apply RND_Min_canonic; try easy; apply radix_gt_1.
now apply RND_Min_canonic; try easy; apply radix_gt_1.
Qed.

Theorem RND_Closest_correct :
 forall r : R, Closest b beta r (RND_Closest r).
Proof.
intros r.
generalize (radix_gt_1 beta); intros M.
split.
apply FcanonicBound with beta; apply RND_Closest_canonic.
intros f H3; fold FtoRradix.
(* *)
cut (RND_Min b beta p r <= r)%R; [ intros V1 | idtac ].
2: apply (RND_Min_correct b beta p) with (r:=r); easy.
cut (r <= RND_Max b beta p r)%R; [ intros V2 | idtac ].
2: apply (RND_Max_correct b beta p) with (r:=r); easy.
cut (forall v w : R, (v <= w)%R -> (0 <= w - v)%R); [ intros V3 | idtac ].
2: intros v w H; apply Rplus_le_reg_l with v; ring_simplify; auto with real.
cut (forall v w : R, (v <= w)%R -> (v - w <= 0)%R); [ intros V4 | idtac ].
2: intros v w H; apply Rplus_le_reg_l with w; ring_simplify; auto with real.
(* *)
unfold RND_Closest; case (Rle_dec _ _); intros H1.
case (Rle_lt_or_eq_dec _ _ H1); intros H2.
(* . *)
rewrite Rabs_right in H1; [ idtac | apply Rle_ge; apply V3; auto with real ].
rewrite Rabs_left1 in H1; [ idtac | apply V4; auto with real ].
rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ].
case (Rle_or_lt f r); intros H4.
rewrite Rabs_left1; [ idtac | apply V4; auto with real ].
apply Rle_trans with (1 := H1); apply Ropp_le_contravar;
 unfold Rminus in |- *; apply Rplus_le_compat_r.
apply (RND_Min_correct b beta p) with (r:=r); easy.
rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ].
unfold Rminus in |- *; apply Rplus_le_compat_r.
apply (RND_Max_correct b beta p) with (r:=r); try easy.
now apply Rlt_le.
(* . *)
case (choice _).
rewrite Rabs_right in H1; [ idtac | apply Rle_ge; apply V3; auto with real ].
rewrite Rabs_left1 in H1; [ idtac | apply V4; auto with real ].
rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ].
case (Rle_or_lt f r); intros H5.
rewrite Rabs_left1; [ idtac | apply V4; auto with real ].
apply Rle_trans with (1 := H1); apply Ropp_le_contravar;
 unfold Rminus in |- *; apply Rplus_le_compat_r.
apply (RND_Min_correct b beta p) with (r:=r); easy.
rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ].
unfold Rminus in |- *; apply Rplus_le_compat_r.
apply (RND_Max_correct b beta p) with (r:=r); try easy.
now apply Rlt_le.
(* . *)
rewrite Rabs_right in H1; [ idtac | apply Rle_ge; apply V3; auto with real ].
rewrite Rabs_left1 in H1; [ idtac | apply V4; auto with real ].
rewrite <- H2.
rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ].
case (Rle_or_lt f r); intros H5.
rewrite Rabs_left1; [ idtac | apply V4; auto with real ].
apply Rle_trans with (1 := H1); apply Ropp_le_contravar;
 unfold Rminus in |- *; apply Rplus_le_compat_r.
apply (RND_Min_correct b beta p) with (r:=r); easy.
rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ].
unfold Rminus in |- *; apply Rplus_le_compat_r.
apply (RND_Max_correct b beta p) with (r:=r); try easy.
now apply Rlt_le.
(* . *)
apply Rnot_le_lt in H1.
rewrite Rabs_left1 in H1; [ idtac | apply V4; auto with real ].
rewrite Rabs_right in H1; [ idtac | apply Rle_ge; apply V3; auto with real ].
rewrite Rabs_left1; [ idtac | apply V4; auto with real ].
case (Rle_or_lt f r); intros H4.
rewrite Rabs_left1; [ idtac | apply V4; auto with real ].
apply Ropp_le_contravar, Rplus_le_compat_r.
apply (RND_Min_correct b beta p) with (r:=r); easy.
rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ].
left; apply Rlt_le_trans with (1:=H1).
apply Rplus_le_compat_r.
apply (RND_Max_correct b beta p) with (r:=r); try easy.
now left.
Qed.

End RND_Closest_c.

Section Bounds.

Variable beta : radix.
Variable p E:Z.
Hypothesis precisionNotZero : (1 < p)%Z.

Definition make_bound := Bound
      (Z.to_pos (Zpower beta p))
      (Z.abs_N E).

Lemma make_bound_Emin: (E <= 0)%Z ->
        ((Z_of_N (dExp (make_bound)))=-E)%Z.
Proof.
simpl.
rewrite Zabs2N.id_abs.
now apply Z.abs_neq.
Qed.

Lemma make_bound_p:
        Zpos (vNum (make_bound))=(Zpower_nat beta (Z.abs_nat p)).
Proof.
unfold make_bound, vNum; simpl.
rewrite Z2Pos.id.
apply Zpower_nat_Zpower.
omega.
generalize (Zpower_gt_0 beta); simpl.
intros T; apply T.
omega.
Qed.

Lemma FtoR_F2R: forall (f:Pff.float) (g: float beta), Pff.Fnum f = Fnum g -> Pff.Fexp f = Fexp g ->
  FtoR beta f = F2R g.
Proof.
intros f g H1 H2; unfold FtoR, F2R.
rewrite H1, H2.
now rewrite bpow_powerRZ.
Qed.

End Bounds.
Section b_Bounds.

Definition bsingle := make_bound radix2 24 (-149)%Z.

Lemma psGivesBound: Zpos (vNum bsingle) = Zpower_nat 2 24.
Proof.
unfold bsingle; apply make_bound_p.
omega.
Qed.

Definition bdouble := make_bound radix2 53 1074.

Lemma pdGivesBound: Zpos (vNum bdouble) = Zpower_nat 2 53.
Proof.
unfold bdouble; apply make_bound_p.
omega.
Qed.

End b_Bounds.
Section Equiv.

Variable beta: radix.
Variable b : Fbound.
Variable p : Z.

Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat beta (Z.abs_nat p).
Hypothesis precisionNotZero : (1 < p)%Z.

Lemma pff_format_is_format: forall f, Fbounded b f ->
  (generic_format beta (FLT_exp (-dExp b) p) (FtoR beta f)).
Proof.
intros f Hf.
apply generic_format_FLT; auto with zarith.
exists (Float beta (Pff.Fnum f) (Pff.Fexp f)).
unfold F2R, FtoR; simpl.
rewrite bpow_powerRZ.
reflexivity.
destruct Hf.
apply Z.lt_le_trans with (1:=H).
rewrite pGivesBound.
rewrite Zpower_Zpower_nat; auto with zarith.
now destruct Hf.
Qed.

Lemma format_is_pff_format': forall r,
   (generic_format beta (FLT_exp (-dExp b) p) r) ->
    Fbounded b (Pff.Float (Ztrunc (scaled_mantissa beta (FLT_exp (-dExp b) p) r))
                            (cexp beta (FLT_exp (-dExp b) p) r)).
Proof.
intros x; unfold generic_format.
set (ex := cexp beta (FLT_exp (-dExp b) p) x).
set (mx := Ztrunc (scaled_mantissa beta (FLT_exp (-dExp b) p) x)).
intros Hx; repeat split ; simpl.
apply lt_IZR.
rewrite pGivesBound, IZR_Zpower_nat.
apply Rmult_lt_reg_r with (bpow beta ex).
apply bpow_gt_0.
rewrite <- bpow_plus.
rewrite inj_abs; try omega.
change (F2R (Float beta (Z.abs mx) ex) < bpow beta (p + ex))%R.
rewrite F2R_Zabs.
rewrite <- Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, Rabs_R0.
apply bpow_gt_0.
unfold cexp in ex.
destruct (mag beta x) as (ex', He).
simpl in ex.
specialize (He Hx0).
apply Rlt_le_trans with (1 := proj2 He).
apply bpow_le.
cut (ex' - p <= ex)%Z. omega.
unfold ex, FLT_exp.
apply Z.le_max_l.
apply Z.le_max_r.
Qed.

Lemma format_is_pff_format: forall r,
  (generic_format beta (FLT_exp (-dExp b) p) r)
  -> exists f, FtoR beta f = r /\ Fbounded b f.
Proof.
intros r Hr.
eexists; split.
2: apply (format_is_pff_format' _ Hr).
rewrite Hr at 3; unfold FtoR, F2R; simpl.
now rewrite bpow_powerRZ.
Qed.

Lemma format_is_pff_format_can: forall r,
  (generic_format beta (FLT_exp (-dExp b) p) r)
  -> exists f, FtoR beta f = r /\ Fcanonic beta b f.
Proof.
intros r Hr.
destruct (format_is_pff_format r Hr) as (f,(Hf1,Hf2)).
exists (Fnormalize beta b (Z.abs_nat p) f); split.
rewrite <- Hf1; apply FnormalizeCorrect.
apply radix_gt_1.
apply FnormalizeCanonic; try assumption.
apply radix_gt_1.
lia.
Qed.

Lemma equiv_RNDs_aux: forall z, Z.even z = true -> Even z.
Proof.
intros z; unfold Z.even, Even.
case z.
intros; exists 0%Z; auto with zarith.
intros p0; case p0.
intros p1 H; contradict H; auto.
intros p1 _.
exists (Zpos p1); auto with zarith.
intros H; contradict H; auto.
intros p0; case p0.
intros p1 H; contradict H; auto.
intros p1 _.
exists (Zneg p1); auto with zarith.
intros H; contradict H; auto.
Qed.

Lemma pff_canonic_is_canonic: forall f, Fcanonic beta b f -> FtoR beta f <> 0 ->
  canonical beta (FLT_exp (- dExp b) p)
    (Float beta (Pff.Fnum f) (Pff.Fexp f)).
Proof.
intros f Hf1 Hf2; unfold canonical; simpl.
assert (K:(F2R (Float beta (Pff.Fnum f) (Pff.Fexp f)) = FtoR beta f)).
  unfold FtoR, F2R; simpl.
  now rewrite bpow_powerRZ.
unfold cexp, FLT_exp.
rewrite K.
destruct (mag beta (FtoR beta f)) as (e, He).
simpl; destruct Hf1.
(* . *)
destruct H as (H1,H2).
cut (Pff.Fexp f = e-p)%Z.
intros V; rewrite V.
apply sym_eq; apply Zmax_left.
rewrite <- V; destruct H1; auto with zarith.
assert (e = Pff.Fexp f + p)%Z;[idtac|omega].
apply trans_eq with (mag beta (FtoR beta f)).
apply sym_eq; apply mag_unique.
apply He; assumption.
apply mag_unique.
rewrite <- K; unfold F2R; simpl.
rewrite Rabs_mult.
rewrite (Rabs_right (bpow beta (Pff.Fexp f))).
2: apply Rle_ge; apply bpow_ge_0.
split.
replace (Pff.Fexp f + p - 1)%Z with ((p-1)+Pff.Fexp f)%Z by ring.
rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
(* .. *)
apply Rmult_le_reg_l with (IZR beta).
apply IZR_lt.
apply radix_gt_0.
rewrite <- bpow_plus_1.
replace (p-1+1)%Z with (Z_of_nat (Z.abs_nat p)).
rewrite <- IZR_Zpower_nat.
simpl; rewrite <- pGivesBound.
rewrite Rabs_Zabs.
rewrite <- mult_IZR.
apply IZR_le.
rewrite <- (Z.abs_eq (beta)).
rewrite <- Zabs.Zabs_Zmult.
assumption.
apply Zlt_le_weak; apply radix_gt_0.
rewrite inj_abs; try ring.
omega.
(* .. *)
rewrite Zplus_comm, bpow_plus.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
rewrite <- (inj_abs p);[idtac|omega].
rewrite <- IZR_Zpower_nat.
simpl; rewrite <- pGivesBound.
rewrite Rabs_Zabs.
apply IZR_lt.
destruct H1; assumption.
(* . *)
destruct H as (H1,(H2,H3)).
rewrite H2.
apply sym_eq; apply Zmax_right.
assert ((e-1) < p-dExp b)%Z;[idtac|omega].
apply lt_bpow with beta.
apply Rle_lt_trans with (Rabs (FtoR beta f)).
apply He; auto.
apply Rlt_le_trans with (FtoR beta (firstNormalPos beta b (Z.abs_nat p))).
rewrite <- Fabs_correct.
2: apply radix_gt_0.
apply FsubnormalLtFirstNormalPos with (3 := pGivesBound).
apply radix_gt_1.
lia.
apply FsubnormFabs; auto with zarith.
apply radix_gt_1.
split; [idtac|split]; assumption.
rewrite Fabs_correct; auto with real zarith.
apply Rabs_pos.
apply radix_gt_0.
unfold firstNormalPos, FtoR, nNormMin.
simpl.
replace (IZR (Zpower_nat beta (Peano.pred (Z.abs_nat p)))) with (bpow beta (p-1)).
rewrite <- (bpow_powerRZ _).
rewrite <- bpow_plus.
apply bpow_le.
omega.
replace (p-1)%Z with (Z_of_nat (Peano.pred (Z.abs_nat p))).
rewrite <- IZR_Zpower_nat.
reflexivity.
rewrite inj_pred; lia.
Qed.

Lemma pff_round_NE_is_round: forall (r:R),
   (FtoR beta (RND_EvenClosest b beta (Z.abs_nat p) r)
     =  round beta (FLT_exp (-dExp b) p) rndNE r).
Proof.
intros.
assert (Rnd_NE_pt beta (FLT_exp (-dExp b) p) r
         (round beta (FLT_exp (-dExp b) p) rndNE r)).
apply round_NE_pt; auto with zarith.
apply FLT_exp_valid.
unfold Prec_gt_0; auto with zarith.
apply exists_NE_FLT.
now right.
unfold Rnd_NE_pt, Rnd_NG_pt, Rnd_N_pt, NE_prop in H.
destruct H as ((H1,H2),H3).
destruct (format_is_pff_format _ H1) as (f,(Hf1,Hf2)).
rewrite <- Hf1.
apply sym_eq.
eapply (EvenClosestUniqueP b beta (Z.abs_nat p)).
apply radix_gt_1.
lia.
exact pGivesBound.
split.
(* *)
split; auto; intros g Hg.
rewrite Hf1.
apply H2.
apply pff_format_is_format; auto.
(* *)
case (Req_dec (FtoR beta (Fnormalize beta b (Z.abs_nat p) f))  0%R); intros L.
left.
unfold FNeven, Feven, Even.
exists 0%Z.
rewrite Zmult_0_r.
apply eq_IZR.
apply Rmult_eq_reg_l with (powerRZ beta (Pff.Fexp (Fnormalize beta b (Z.abs_nat p) f)))%R.
rewrite Rmult_0_r.
rewrite <- L; unfold FtoR; simpl; ring.
apply powerRZ_NOR; auto with zarith real.
apply Rgt_not_eq.
apply IZR_lt; apply radix_gt_0.
destruct H3.
(* . *)
destruct H as (g,(Hg1,(Hg2,Hg3))).
left.
unfold FNeven, Feven.
apply equiv_RNDs_aux.
replace (Pff.Fnum (Fnormalize beta b (Z.abs_nat p) f)) with (Fnum g); try assumption.
replace g with (Float beta (Pff.Fnum (Fnormalize beta b (Z.abs_nat p) f)) (Pff.Fexp (Fnormalize beta b (Z.abs_nat p) f))).
easy.
apply canonical_unique with (FLT_exp (- dExp b) p).
2: assumption.
apply pff_canonic_is_canonic.
apply FnormalizeCanonic; auto with zarith real.
apply radix_gt_1.
lia.
exact L.
rewrite <- Hg1, <- Hf1.
rewrite <- FnormalizeCorrect with beta b (Z.abs_nat p) f; auto with zarith.
unfold F2R, FtoR; simpl.
rewrite bpow_powerRZ.
reflexivity.
apply radix_gt_1.
(* . *)
right; intros q (Hq1,Hq2).
rewrite Hf1.
apply H.
split.
apply pff_format_is_format; auto.
intros g Hg.
destruct (format_is_pff_format _ Hg) as (v,(Hv1,Hv2)).
rewrite <- Hv1.
apply Hq2; auto.
apply RND_EvenClosest_correct with (3 := pGivesBound).
apply radix_gt_1.
lia.
Qed.

Lemma round_NE_is_pff_round: forall (r:R),
   exists f:Pff.float, (Fcanonic beta b f /\ (EvenClosest b beta (Z.abs_nat p) r f) /\
    FtoR beta f =  round beta (FLT_exp (-dExp b) p) rndNE r).
Proof.
intros r.
exists (RND_EvenClosest b beta (Z.abs_nat p) r).
split.
apply RND_EvenClosest_canonic with (3 := pGivesBound).
apply radix_gt_1.
lia.
split.
apply RND_EvenClosest_correct with (3 := pGivesBound).
apply radix_gt_1.
lia.
apply pff_round_NE_is_round.
Qed.

Lemma pff_round_UP_is_round: forall (r:R),
  FtoR beta (RND_Max b beta (Z.abs_nat p) r)
             = round beta (FLT_exp (- dExp b) p) Zceil r.
Proof with auto with typeclass_instances.
intros r.
generalize (radix_gt_1 beta); intros M.
assert (K:Valid_exp (FLT_exp (- dExp b) p)).
apply FLT_exp_valid.
unfold Prec_gt_0; auto with zarith.
destruct (format_is_pff_format_can (round beta (FLT_exp (- dExp b) p) Zceil r)) as (fu,(Hfu1,Hfu2)).
apply generic_format_round...
rewrite <- Hfu1.
apply MaxUniqueP with b r.
apply RND_Max_correct; try assumption.
apply Nat2Z.inj_lt; rewrite inj_abs; simpl; omega.
split.
apply FcanonicBound with (1:=Hfu2).
assert (T:Rnd_UP_pt (generic_format beta (FLT_exp (- dExp b) p)) r
             (round beta (FLT_exp (- dExp b) p) Zceil r)).
apply round_UP_pt...
destruct T as (T1,(T2,T3)).
split.
rewrite Hfu1; apply T2.
intros g Hg1 Hg2.
rewrite Hfu1; apply T3; try assumption.
now apply pff_format_is_format.
Qed.

Lemma pff_round_DN_is_round: forall (r:R),
  FtoR beta (RND_Min b beta (Z.abs_nat p) r)
             = round beta (FLT_exp (- dExp b) p) Zfloor r.
Proof with auto with typeclass_instances.
intros r.
generalize (radix_gt_1 beta); intros M.
assert (K:Valid_exp (FLT_exp (- dExp b) p)).
apply FLT_exp_valid.
unfold Prec_gt_0; auto with zarith.
destruct (format_is_pff_format_can (round beta (FLT_exp (- dExp b) p) Zfloor r)) as (fd,(Hfd1,Hfd2)).
apply generic_format_round...
rewrite <- Hfd1.
apply MinUniqueP with b r.
apply RND_Min_correct; try assumption.
apply Nat2Z.inj_lt; rewrite inj_abs; simpl; omega.
split.
apply FcanonicBound with (1:=Hfd2).
assert (T:Rnd_DN_pt (generic_format beta (FLT_exp (- dExp b) p)) r
             (round beta (FLT_exp (- dExp b) p) Zfloor r)).
apply round_DN_pt...
destruct T as (T1,(T2,T3)).
split.
rewrite Hfd1; apply T2.
intros g Hg1 Hg2.
rewrite Hfd1; apply T3; try assumption.
now apply pff_format_is_format.
Qed.

Lemma pff_round_N_is_round: forall choice, forall (r:R),
   (FtoR beta (RND_Closest b beta (Z.abs_nat p) choice r)
     =  round beta (FLT_exp (-dExp b) p) (Znearest choice) r).
Proof with auto with typeclass_instances.
generalize (radix_gt_1 beta); intros M.
intros choice r; apply sym_eq.
assert (K:Valid_exp (FLT_exp (- dExp b) p)).
apply FLT_exp_valid.
unfold Prec_gt_0; auto with zarith.
unfold RND_Closest, FtoRradix.
rewrite pff_round_DN_is_round.
rewrite pff_round_UP_is_round.
case (Rle_dec _ _); intros H1.
case (Rle_lt_or_eq_dec _ _ H1); intros H2.
(* *)
rewrite pff_round_UP_is_round.
apply round_N_eq_UP...
rewrite Rabs_right in H2;[idtac| apply Rle_ge, Rle_0_minus, round_UP_pt; easy].
rewrite Rabs_left1 in H2;[idtac| apply Rle_minus, round_DN_pt; easy].
apply Rmult_lt_reg_r with 2%R; try apply Rlt_0_2.
unfold Rdiv; rewrite Rmult_assoc, Rinv_l.
2: apply Rgt_not_eq, Rlt_0_2.
apply Rplus_lt_reg_l with (-round beta (FLT_exp (- dExp b) p) Zfloor r - r)%R.
apply Rle_lt_trans with (round beta (FLT_exp (- dExp b) p) Zceil r - r)%R;[right;ring|idtac].
apply Rlt_le_trans with (1:=H2).
right; ring.
(* *)
rewrite round_N_middle.
rewrite inj_abs;[idtac|omega].
case (choice _).
apply sym_eq, pff_round_UP_is_round.
apply sym_eq, pff_round_DN_is_round.
rewrite Rabs_right in H2;[idtac| apply Rle_ge, Rle_0_minus, round_UP_pt; easy].
rewrite Rabs_left1 in H2;[idtac| apply Rle_minus, round_DN_pt; easy].
rewrite H2; ring.
(* *)
rewrite pff_round_DN_is_round.
apply round_N_eq_DN...
apply Rnot_le_lt in H1.
rewrite Rabs_left1 in H1;[idtac| apply Rle_minus, round_DN_pt; easy].
rewrite Rabs_right in H1;[idtac| apply Rle_ge, Rle_0_minus, round_UP_pt; easy].
apply Rmult_lt_reg_r with 2%R; try apply Rlt_0_2.
unfold Rdiv; rewrite Rmult_assoc, Rinv_l.
2: apply Rgt_not_eq, Rlt_0_2.
apply Rplus_lt_reg_l with (-round beta (FLT_exp (- dExp b) p) Zfloor r - r)%R.
apply Rle_lt_trans with (-(round beta (FLT_exp (- dExp b) p) Zfloor r - r))%R;[right;ring|idtac].
apply Rlt_le_trans with (1:=H1).
right; ring.
Qed.

Lemma round_N_is_pff_round: forall choice, forall (r:R),
   exists f:Pff.float, (Fcanonic beta b f /\ (Closest b beta r f) /\
    FtoR beta f =  round beta (FLT_exp (-dExp b) p) (Znearest choice) r).
Proof.
intros choice r.
assert (1 < Z.abs_nat p).
apply Nat2Z.inj_lt; simpl.
rewrite inj_abs; omega.
exists (RND_Closest b beta (Z.abs_nat p) choice r); split.
apply RND_Closest_canonic; easy.
split.
apply RND_Closest_correct; easy.
apply pff_round_N_is_round.
Qed.

Lemma pff_round_is_round_N: forall r f, Closest b beta r f ->
    exists (choice:Z->bool),
      FtoR beta f = round beta (FLT_exp (-dExp b) p) (Znearest choice) r.
Proof with auto with typeclass_instances.
intros r f Hf.
generalize (radix_gt_1 beta); intros M.
assert (M':1 < Z.abs_nat p).
apply Nat2Z.inj_lt; simpl.
rewrite inj_abs; omega.
pose (d := round beta (FLT_exp (-dExp b) p) Zfloor r).
pose (u := round beta (FLT_exp (-dExp b) p) Zceil r).
case (Rle_or_lt ((d+u)/2) r); intros L.
destruct L as [L|L].
(* rnd up *)
exists (fun _ => true).
rewrite <- pff_round_N_is_round.
apply trans_eq with (FtoR beta (RND_Max b beta (Z.abs_nat p) r)).
apply ClosestMaxEq with b r (RND_Min b beta (Z.abs_nat p) r); try assumption.
apply RND_Min_correct; assumption.
apply RND_Max_correct; assumption.
rewrite pff_round_DN_is_round; fold d.
rewrite pff_round_UP_is_round; fold u.
apply Rmult_lt_reg_r with (/2)%R.
apply pos_half_prf.
apply Rlt_le_trans with (1:=L).
right; simpl; field.
rewrite pff_round_N_is_round.
rewrite pff_round_UP_is_round; fold u.
apply sym_eq, round_N_eq_UP...
apply FLT_exp_valid.
unfold Prec_gt_0; auto with zarith.
(* middle *)
case (ClosestMinOrMax b beta r f); try assumption; intros LL.
exists (fun _ => false).
rewrite round_N_middle.
rewrite <- pff_round_DN_is_round.
apply (MinUniqueP b beta r); try assumption.
apply RND_Min_correct; assumption.
fold d; fold u; rewrite <- L; field.
exists (fun _ => true).
rewrite round_N_middle.
rewrite <- pff_round_UP_is_round.
apply (MaxUniqueP b beta r); try assumption.
apply RND_Max_correct; assumption.
fold d; fold u; rewrite <- L; field.
(* rnd down *)
exists (fun _ => true).
rewrite <- pff_round_N_is_round.
apply trans_eq with (FtoR beta (RND_Min b beta (Z.abs_nat p) r)).
apply ClosestMinEq with b r (RND_Max b beta (Z.abs_nat p) r); try assumption.
apply RND_Min_correct; assumption.
apply RND_Max_correct; assumption.
rewrite pff_round_DN_is_round; fold d.
rewrite pff_round_UP_is_round; fold u.
apply Rmult_lt_reg_r with (/2)%R.
apply pos_half_prf.
apply Rle_lt_trans with (2:=L).
right; simpl; field.
rewrite pff_round_N_is_round.
rewrite pff_round_DN_is_round; fold d.
apply sym_eq, round_N_eq_DN...
apply FLT_exp_valid.
unfold Prec_gt_0; auto with zarith.
Qed.

Lemma FloatFexp_gt:  forall e f, Fbounded b f ->
  (bpow beta (e+p) <= Rabs (FtoR beta f))%R ->
       (e < Pff.Fexp f)%Z.
Proof.
intros e f Ff H1.
apply lt_bpow with beta.
apply Rmult_lt_reg_r with (bpow beta p).
apply bpow_gt_0.
rewrite <- bpow_plus.
apply Rle_lt_trans with (1:=H1).
rewrite <- Fabs_correct.
2: apply radix_gt_0.
unfold Fabs, FtoR; simpl; rewrite Rmult_comm.
rewrite bpow_powerRZ.
apply Rmult_lt_compat_l.
apply powerRZ_lt.
apply IZR_lt, radix_gt_0.
destruct Ff as (T1,T2).
rewrite bpow_powerRZ.
replace p with (Z.of_nat (Z.abs_nat p)).
rewrite <- Zpower_nat_Z_powerRZ.
apply IZR_lt.
now rewrite <- pGivesBound.
rewrite inj_abs; omega.
Qed.

Lemma CanonicGeNormal:  forall f, Fcanonic beta b f ->
  (bpow beta (-dExp b+p-1) <= Rabs (FtoR beta f))%R ->
       (Fnormal beta b f)%Z.
Proof.
intros f Cf H1.
case Cf; trivial.
intros (H2,(H3,H4)).
contradict H1; apply Rlt_not_le.
rewrite <- Fabs_correct.
2: apply radix_gt_0.
unfold FtoR, Fabs; simpl.
rewrite H3, <- bpow_powerRZ.
apply Rlt_le_trans with (bpow beta (p-1)*bpow beta (-dExp b))%R.
2: rewrite <- bpow_plus.
2: right; f_equal; ring.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
apply Rmult_lt_reg_l with (IZR beta).
apply IZR_lt, radix_gt_0.
rewrite <- mult_IZR.
apply Rlt_le_trans with (IZR (Z.pos (vNum b))).
apply IZR_lt.
rewrite <- (Z.abs_eq beta).
now rewrite <- Zabs_Zmult.
apply Zlt_le_weak, radix_gt_0.
rewrite pGivesBound.
rewrite IZR_Zpower_nat.
rewrite <- bpow_1.
rewrite <- bpow_plus.
apply bpow_le.
rewrite inj_abs; omega.
Qed.

Lemma Fulp_ulp_aux:  forall f, Fcanonic beta b f ->
   Fulp b beta (Z.abs_nat p) f
    = ulp beta (FLT_exp (-dExp b) p) (FtoR beta f).
Proof.
intros f H.
case (Req_dec (FtoR beta f) 0); intros Zf.
(* f = 0 *)
rewrite Zf, ulp_FLT_small.
2: unfold Prec_gt_0; omega.
2: rewrite Rabs_R0; apply bpow_gt_0.
rewrite Fulp_zero.
apply sym_eq, bpow_powerRZ.
apply is_Fzero_rep2 with beta; try assumption.
apply radix_gt_1.
(* f <> 0 *)
rewrite ulp_neq_0; try assumption.
replace (FtoR beta f) with (F2R (Float beta (Pff.Fnum f) (Pff.Fexp f))).
rewrite <- pff_canonic_is_canonic; try assumption.
simpl; rewrite CanonicFulp; try assumption.
unfold FtoR; simpl; rewrite bpow_powerRZ; ring.
apply radix_gt_1.
replace 1 with (Z.abs_nat 1) by easy.
apply Zabs_nat_lt; omega.
unfold F2R, FtoR; simpl.
rewrite bpow_powerRZ; easy.
Qed.

Lemma Fulp_ulp:  forall f, Fbounded b f ->
   Fulp b beta (Z.abs_nat p) f
    = ulp beta (FLT_exp (-dExp b) p) (FtoR beta f).
Proof.
intros f H.
assert (Y1: (1 < beta)%Z) by apply radix_gt_1.
assert (Y2:Z.abs_nat p <> 0).
apply sym_not_eq, Nat.lt_neq.
replace 0 with (Z.abs_nat 0) by easy.
apply Zabs_nat_lt; omega.
rewrite FulpComp with (q:=Fnormalize beta b (Z.abs_nat p) f); try assumption.
rewrite <- FnormalizeCorrect with beta b (Z.abs_nat p) f; try assumption.
apply Fulp_ulp_aux.
apply FnormalizeCanonic; try assumption.
replace 1 with (Z.abs_nat 1) by easy.
apply Zabs_nat_lt; omega.
apply FnormalizeBounded; try assumption.
apply sym_eq, FnormalizeCorrect; try assumption.
Qed.

End Equiv.

Section Equiv_instanc.

Lemma round_NE_is_pff_round_b32: forall (r:R),
   exists f:Pff.float, (Fcanonic 2 bsingle f /\ (EvenClosest bsingle 2 24 r f) /\
    FtoR 2 f =  round radix2 (FLT_exp (-149) 24) rndNE r).
Proof.
apply (round_NE_is_pff_round radix2 bsingle 24).
apply psGivesBound.
apply eq_refl.
Qed.

Lemma round_NE_is_pff_round_b64: forall (r:R),
   exists f:Pff.float, (Fcanonic 2 bdouble f /\ (EvenClosest bdouble 2 53 r f) /\
    FtoR 2 f =  round radix2 (FLT_exp (-1074) 53) rndNE r).
Proof.
apply (round_NE_is_pff_round radix2 bdouble 53).
apply pdGivesBound.
apply eq_refl.
Qed.

End Equiv_instanc.


(** * Identity functor *)
Require Import Category.Core Functor.Core.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Section identity.
  (** There is an identity functor.  It does the obvious thing. *)
  Definition identity C : Functor C C
    := Build_Functor C C
                     (fun x => x)
                     (fun _ _ x => x)
                     (fun _ _ _ _ _ => idpath)
                     (fun _ => idpath).
End identity.

Module Export FunctorIdentityNotations.
  Notation "1" := (identity _) : functor_scope.
End FunctorIdentityNotations.


Require Import POCS.
Require Import LogAPI.
Require Import Common.OneDiskAPI.
Import ListNotations.

(** * Implementation of the atomic append-only log. *)

(** Your job is to implement the atomic append-only log API,
    as defined in [LogAPI.v], on top of a single disk, as
    defined in [OneDiskAPI.v].  The underlying disk is the
    same abstraction that you implemented in lab 2.

    To achieve crash-safety, you can rely on the fact that
    the underlying disk provides atomic block writes: that
    is, writing to a single disk block is atomic with respect
    to crash-safety.  If the system crashes in the middle of
    a write to a disk block, then after the crash, that block
    has either the old value or the new value, but not some
    other corrupted value.

    The disk provided by [OneDiskAPI.v] is synchronous, in
    the sense that disk writes that have fully completed (where
    [write] returned) are durable: if the computer crashes after
    a [write] finished, that [write] will still be there after
    the computer reboots. *)

(** To implement the log API, we assume that we have a procedure
    [addr_to_block] that encodes a number as a block, and a way
    to read the number back from the block (the function
    [block_to_addr]). This gives your implementation a way to
    serialize data onto disk.

    Note that [block_to_addr] is a pure Gallina function: given
    any block value [b], you can always talk about the address
    represented by that block, as [block_to_addr b].

    On the other hand, [addr_to_block] is a procedure: you can
    invoke it from your code, and if it returns, the return
    value will satisfy the specification in [addr_to_block_spec].
    This means that you can't use [addr_to_block] in your spec
    or abstraction relation, since a spec or abstraction relation
    cannot invoke a [proc].

    The reason for the difference is to ensure that these axioms
    are not false.  In particular, a [block] is 4 KBytes in size,
    whereas [addr] is, theoretically, a [nat] which is unbounded.
    If we posited the existence of [addr_to_block] and [block_to_addr]
    as pure Gallina functions, together with a theorem that says they
    are inverses of one another, it would be possible to prove [False]
    (i.e., the theory is inconsistent) by the pigeonhole principle. *)

Axiom addr_to_block : addr -> proc block.
Axiom block_to_addr : block -> addr.

Definition addr_to_block_spec State a : Specification unit block unit State :=
  fun (_ : unit) state => {|
    pre := True;
    post := fun r state' => state' = state /\ block_to_addr r = a;
    recovered := fun _ state' => state' = state
  |}.
Axiom addr_to_block_ok : forall State a recover abstr,
  proc_spec (@addr_to_block_spec State a) (addr_to_block a) recover abstr.
Hint Resolve addr_to_block_ok : core.

(** For this lab, we provide a notation for diskUpd. Not only can you use this
    to write [diskUpd d a b] as [d [a |-> b]] but you will also see this notation
    in goals. This should especially make it easier to read goals with many
    updates of the same disk.

    Remember that the code still uses diskUpd underneath, so the same theorems
    apply. We recommend using [autorewrite with upd] or [autorewrite with upd
    in *] in this lab to simplify diskGet/diskUpd expressions, rather than
    using the theorems manually. *)
Notation "d [ a |-> b ]" := (diskUpd d a b) (at level 8, left associativity).
Notation "d [ a |=> bs ]" := (diskUpds d a bs) (at level 8, left associativity).

(** In this lab, you will likely be doing reasoning about
    the contents of various disk blocks.  The following
    theorem will help you do so. *)
Theorem diskGet_eq_values : forall d a b b',
    diskGet d a =?= b ->
    diskGet d a =?= b' ->
    a < diskSize d ->
    b = b'.
Proof.
  (* Fill in your proof here. *)
Admitted.

(** On top of [diskGet_eq_values], we prove a variant that works for
    reading multiple disk blocks using [diskGets]. *)
Theorem diskGets_eq_values : forall d count a bs bs',
    diskGets d a count =??= bs ->
    diskGets d a count =??= bs' ->
    a + count <= diskSize d ->
    bs = bs'.
Proof.
  induction count; simpl.
  - destruct bs, bs'; eauto.
  - destruct bs, bs'; eauto.
    intuition eauto.
    f_equal.
    + eapply diskGet_eq_values; eauto. lia.
    + eapply IHcount; eauto. lia.
Qed.

(** We use the above theorems to implement the [eq_values]
    tactic.  [eq_values] can be used when you have hypotheses
    like:

<<
        H1: diskGet d a =?= eq b
        H2: diskGet d a =?= eq b'
>>

    In this context, the tactic proves [b = b'].
 *)
Ltac eq_values :=
  match goal with
  | [ H:  diskGet ?d ?a =?= ?b,
      H': diskGet ?d ?a =?= ?b' |- _ ] =>
    assert (b = b') by (apply (@diskGet_eq_values d a b b'); try lia; auto);
    subst
  | [ H:  diskGets ?d ?a ?count  =??= ?bs,
      H': diskGets ?d ?a ?count' =??= ?bs' |- _ ] =>
    replace (count') with (count) in H' by lia;
    assert (bs = bs') by (apply (@diskGets_eq_values d count a bs bs'); try lia; auto);
    subst
  end.

Module Log (d : OneDiskAPI) <: LogAPI.

  (** Fill in your implementation and proof here, replacing
      the placeholder axiom statements below with your own definitions
      and theorems as appropriate.  Feel free to introduce helper
      procedures and helper theorems to structure your implementation
      and proof. *)

  Definition init : proc InitResult := Ret Initialized.
  Definition get : proc (list block) := Ret nil.
  Definition append (bs : list block) : proc bool := Ret true.
  Definition reset : proc unit := Ret tt.
  Definition recover : proc unit := Ret tt.

  Axiom log_abstraction : OneDiskAPI.State -> LogAPI.State -> Prop.

  Definition abstr : Abstraction LogAPI.State :=
    abstraction_compose d.abstr {| abstraction := log_abstraction |}.

  (** Gain confidence in your abstraction relation by filling in the
      following examples.  You may need to tweak the contents of the
      disk based on your implementation's layout. *)

  Example abst_empty_ok :
    forall b,
      block_to_addr b = 0 ->
      log_abstraction ([b]) nil.
  Proof.
  Admitted.

  Example abst_empty_with_larger_disk_ok :
    forall b c,
      block_to_addr b = 0 ->
      log_abstraction ([b;c;c;c;c;c]) nil.
  Proof.
  Admitted.

  Example abst_two_blocks_ok :
    forall b c d,
      block_to_addr b = 2 ->
      log_abstraction ([b;c;d;b;c;d]) ([c;d]).
  Proof.
  Admitted.

  (* Marking [diskGet] opaque helps prevent Coq from unfolding its
     definition when you call the [simpl] tactic.  You can still
     reason about [diskGet] using various lemmas we provided for you.
     If you want, feel free to remove this statement, though it is
     likely to make for a more confusing and messy proof. *)
  Opaque diskGet.

  Axiom init_ok : init_abstraction init recover abstr inited_any.
  Axiom get_ok : proc_spec get_spec get recover abstr.
  Axiom append_ok : forall v, proc_spec (append_spec v) (append v) recover abstr.
  Axiom reset_ok : proc_spec reset_spec reset recover abstr.
  Axiom recover_wipe : rec_wipe recover abstr no_wipe.

End Log.

(** It's possible to layer the log from this lab on top
    of the bad-block remapper from the previous lab.
    The statements below do that, just as a sanity check.
  *)

Require Import Lab2.BadBlockImpl.
Require Import Lab2.RemappedDiskImpl.
Module bad_disk := BadBlockDisk.
Module remapped_disk := RemappedDisk bad_disk.
Module log := Log remapped_disk.
Print Assumptions log.append_ok.


Require Export Basics.

Require Export EnvListAux7.
Require Export EnvListAuxT1.
Require Export IdModType.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.

Module Static (IdT: IdModType) <: IdModType.
Export IdT.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition Loc_PI := IdT.Loc_PI.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

Instance NatV : ValTyp nat.

Instance UnitV : ValTyp unit.

Instance BoolV : ValTyp bool.

(** effect handler record *)

Record XFun (T1 T2: Type) : Type := {
    b_mod : W -> T1 -> prod W T2 ;
    b_exec : W -> T1 -> W := fun state input => fst (b_mod state input) ;
    b_eval : W -> T1 -> T2 := fun state input => snd (b_mod state input)
}.

(**** Value types *)

(** the type of value types -
    syntactic types are parametrised by semantic ones *)
Definition VTyp : Type := sig ValTyp.

(** smart value type constructor *)
Definition vtyp (T: Type) {VT: ValTyp T} : VTyp :=
    @exist Type ValTyp T VT.

(** value types *)
Definition Nat : VTyp := vtyp nat.

Definition Unit : VTyp := vtyp unit.

Definition Bool : VTyp := vtyp bool.

(** extractor *)
Definition vtypExt (t: VTyp) : Type := proj1_sig t.

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

(** Parameter types *)
Inductive PTyp : Type := PT (ts: list VTyp).

(** Value-typing contexts *)
Definition valTC : Type := list (Id * VTyp).

(** Function types *)
Inductive FTyp : Type := FT (prs_type: valTC) (ret_type: VTyp).

(** Function-typing contexts *)
Definition funTC : Type := list (Id * FTyp).

(** extractors for function types *)
Definition extParType (ft: FTyp) : valTC :=
  match ft with FT ps _ => ps end.

Definition extRetType (ft: FTyp) : VTyp :=
  match ft with FT _ t => t end.

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

(**** Value expressions *)

(** the internal type of values, parametrised by a semantic type *)
Inductive ValueI (T: Type) : Type := Cst (v: T).

(** the external type of values, hiding the semantic type *)
Definition Value : Type := sigT ValueI.

(** smart value constructor *)
Definition cst (T: Type) (v: T) : Value :=
           @existT Type ValueI T (Cst T v).

(** value constructors specialised with semantic types *)
Definition NatCst (v: nat) : Value := cst nat v.

Definition UnitCst (v: unit) : Value := cst unit v.

Definition BoolCst (v: bool) : Value := cst bool v.

(** extractors *)
Definition ValueI2T (T: Type) (v: ValueI T) : T :=
    match v with Cst _  x => x end.

Definition cstExt (v: Value) : projT1 v := ValueI2T (projT1 v) (projT2 v).

(** sanity conditions *)
Lemma cstSound1 (v: Value) : v = cst (projT1 v) (cstExt v).
Proof.
  unfold cst.
  unfold cstExt.
  destruct v as [T v].
  simpl.
  assert (v = Cst T (ValueI2T T v)).
  destruct v.
  simpl.
  reflexivity.
  rewrite <- H.
  reflexivity.
Defined.

Lemma cstSound2 (T: Type) (v: T) : v = cstExt (cst T v).
Proof.
  unfold cstExt.
  simpl.
  auto.
Defined.

Lemma cstEq (T: Type) (v1 v2: T) : cst T v1 = cst T v2 -> v1 = v2.
  intros.
  assert (projT2 (cst T v1) = projT2 (cst T v2)).
  intuition.
  simpl in H0.
  inversion H0; subst.
  reflexivity.
Defined.

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

(** Value environments *)
Definition valEnv : Type := list (Id * Value).

(** Quasi-values *)
Inductive QValue : Type := Var (x: Id) | QV (v: Value).

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

(** synactic tag type *)

Inductive Tag : Type := LL | RR.

(**** Terms *)

Inductive Fun : (** Functions *)
   Type := FC (fenv: Envr Id Fun)
              (tenv: valTC) (e0 e1: Exp) (x: Id) (n: nat)
with QFun : (** Quasi-functions *)
   Type := FVar (x: Id) | QF (v: Fun)
with Exp : (** Expressions *)
       Type :=
(*         Reset  *)
(*         | Read (W T: Type) (XF: XFun W T) (VT: ValTyp T)   *)
         | Modify (T1 T2: Type) (VT1: ValTyp T1) (VT2: ValTyp T2)
                  (XF: XFun T1 T2) (q: QValue)
         | Return (G: Tag) (q: QValue)
         | BindN (e1: Exp) (e2: Exp)
         | BindS (x: Id) (e1: Exp) (e2: Exp)
         | BindMS (fenv: Envr Id Fun) (venv: valEnv) (e: Exp)
         | Apply (q: QFun) (ps: Prms)
         | Val (v: Value)
         | IfThenElse (e1: Exp) (e2: Exp) (e3: Exp)
with Prms : (** Parameters *)
   Type := PS (es: list Exp).

Scheme Fun_mut := Induction for Fun Sort Type
with QFun_mut := Induction for QFun Sort Type
with Exp_mut := Induction for Exp Sort Type
with Prms_mut := Induction for Prms Sort Type.

Inductive Prog : (** Programs *)
       Type := prog (e: Exp)
             | define (x: Id) (f: Fun) (p: Prog).

(** Function environments *)
Definition funEnv : Type := Envr Id Fun.

(* Conversion from typing contexts to type lists *)
Definition env2ptyp (m: valTC) : PTyp := PT (map snd m).

(* Creation of value environments *)
Definition mkVEnv (tenv: valTC) (vs: list Value) : valEnv :=
     interleave (map fst tenv) vs.

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

(** Static semantics *)

(* definition of value typing *)
Inductive ValueTyping (v: Value) (t: VTyp) : Type :=
| ValueTypingC : let T := projT1 v
          in T = (proj1_sig t) ->
             ValTyp T ->
             ValueTyping v t.

(** smart value constructor *)
Definition valueTyping (T: Type) {VT: ValTyp T} (v: T) :
  ValueTyping (cst T v) (vtyp T) :=
   ValueTypingC (cst T v) (vtyp T) eq_refl VT.

Inductive IdTyping : valTC -> Id -> VTyp -> Type :=
   | Id_Typing : forall (tenv: valTC) (x: Id) (t: VTyp),
                    findET tenv x t ->
                    IdTyping tenv x t.

Inductive QValueTyping : valTC -> QValue -> VTyp -> Type :=
  | ProperValue_Typing : forall (tenv: valTC ) (v: Value) (t: VTyp),
                   ValueTyping v t ->
                   QValueTyping tenv (QV v) t
  | Var_Typing : forall (tenv: valTC) (x: Id) (t: VTyp),
                   IdTyping tenv x t ->
                   QValueTyping tenv (Var x) t.

Definition EnvTyping : valEnv -> valTC -> Type :=
    MatchEnvsT ValueTyping.

Inductive FunTyping : (** Functions *)
                  Fun -> FTyp -> Type :=
  | FunZ_Typing: forall (ftenv: funTC) (tenv: valTC)
                        (fenv: funEnv)
                        (e0 e1: Exp) (x: Id) (t: VTyp),
      MatchEnvsT FunTyping fenv ftenv ->
      ExpTyping ftenv tenv fenv e0 t ->
      FunTyping (FC fenv tenv e0 e1 x 0) (FT tenv t)
  | FunS_Typing: forall (ftenv ftenv': funTC) (tenv: valTC)
                        (fenv fenv': funEnv)
            (e0 e1: Exp) (x: Id) (n: nat) (t: VTyp),
      ftenv' = updateE ftenv x (FT tenv t) ->
      fenv' = updateE fenv x (FC fenv tenv e0 e1 x n) ->
      MatchEnvsT FunTyping fenv ftenv ->
      ExpTyping ftenv' tenv fenv' e1 t ->
      FunTyping (FC fenv tenv e0 e1 x n) (FT tenv t) ->
      FunTyping (FC fenv tenv e0 e1 x (S n)) (FT tenv t)
with QFunTyping : (** Quasi-functions *)
                  funTC -> funEnv -> QFun -> FTyp -> Type :=
  | QF_Typing: forall (ftenv: funTC) (fenv: funEnv) (f: Fun) (ft: FTyp),
      FunTyping f ft ->
      QFunTyping ftenv fenv (QF f) ft
  | FVar_Typing: forall (ftenv: funTC) (fenv: funEnv)
                       (x: Id) (f: Fun) (ft: FTyp),
      MatchEnvs2BT FunTyping x f ft fenv ftenv ->
      QFunTyping ftenv fenv (FVar x) ft
with ExpTyping : (** expressions *)
        funTC -> valTC -> funEnv -> Exp -> VTyp -> Type :=
  | Modify_Typing : forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                           (T1 T2: Type) (VT1: ValTyp T1) (VT2: ValTyp T2)
                           (XF: XFun T1 T2) (q: QValue),
                     QValueTyping tenv q (vtyp T1) ->
                     ExpTyping ftenv tenv fenv
                               (Modify T1 T2 VT1 VT2 XF q) (vtyp T2)
  | Return_Typing : forall (G: Tag)
                           (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                           (q: QValue) (t: VTyp),
                       QValueTyping tenv q t ->
                       ExpTyping ftenv tenv fenv (Return G q) t
  | BindN_Typing : forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                          (e1 e2: Exp) (t1 t2: VTyp),
                       ExpTyping ftenv tenv fenv e1 t1 ->
                       ExpTyping ftenv tenv fenv e2 t2 ->
                       ExpTyping ftenv tenv fenv (BindN e1 e2) t2
  | BindS_Typing : forall (ftenv: funTC) (tenv tenv': valTC)
                          (fenv: funEnv) (x: Id)
                          (e1 e2: Exp) (t1 t2: VTyp),
                       tenv' = updateE tenv x t1 ->
                       ExpTyping ftenv tenv fenv e1 t1 ->
                       ExpTyping ftenv tenv' fenv e2 t2 ->
                       ExpTyping ftenv tenv fenv (BindS x e1 e2) t2
  | BindMS_Typing : forall (ftenv ftenvP ftenv': funTC)
                           (tenv tenvP tenv': valTC)
                           (fenv fenvP fenv': funEnv) (envP: valEnv)
                           (e: Exp) (t: VTyp),
                       EnvTyping envP tenvP ->
                       MatchEnvsT FunTyping fenv ftenv ->
                       MatchEnvsT FunTyping fenvP ftenvP ->
                       tenv' = overrideE tenvP tenv ->
                       ftenv' = overrideE ftenvP ftenv ->
                       fenv' = overrideE fenvP fenv ->
                       ExpTyping ftenv' tenv' fenv' e t ->
                       ExpTyping ftenv tenv fenv (BindMS fenvP envP e) t
  | Apply_Typing : forall (ftenv: funTC) (tenv fps: valTC) (fenv: funEnv)
                          (q: QFun) (ps: Prms) (pt: PTyp) (t: VTyp),
              pt = env2ptyp fps ->
              MatchEnvsT FunTyping fenv ftenv ->
              QFunTyping ftenv fenv q (FT fps t) ->
              PrmsTyping ftenv tenv fenv ps pt ->
              ExpTyping ftenv tenv fenv (Apply q ps) t
  | Val_Typing : forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                        (v: Value) (t: VTyp),
                       ValueTyping v t ->
                       ExpTyping ftenv tenv fenv (Val v) t
  | IfThenElse_Typing : forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                               (e1 e2 e3: Exp) (t: VTyp),
             ExpTyping ftenv tenv fenv e1 Bool ->
             ExpTyping ftenv tenv fenv e2 t ->
             ExpTyping ftenv tenv fenv e3 t ->
             ExpTyping ftenv tenv fenv (IfThenElse e1 e2 e3) t
with PrmsTyping : (** parameters *)
         funTC -> valTC -> funEnv -> Prms -> PTyp -> Type :=
| PS_Typing: forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                    (es: list Exp) (ts: list VTyp),
      Forall2T (ExpTyping ftenv tenv fenv) es ts ->
      PrmsTyping ftenv tenv fenv (PS es) (PT ts).

Definition FEnvTyping : funEnv -> funTC -> Type :=
    MatchEnvsT FunTyping.

Inductive ProgTyping : (** Functions *)
    funTC -> funEnv -> Prog -> VTyp -> Type :=
| Prog_Typing : forall (ftenv: funTC) (fenv: funEnv) (e: Exp) (t: VTyp),
                   FEnvTyping fenv ftenv ->
                   ProgTyping ftenv fenv (prog e) t
| Define_Typing : forall (ftenv ftenv': funTC) (fenv fenv': funEnv)
                         (x: Id) (f: Fun) (p: Prog)
                         (ft: FTyp) (t: VTyp),
      FEnvTyping fenv ftenv ->
      ftenv' = updateE ftenv x ft ->
      fenv' = updateE fenv x f ->
      QFunTyping ftenv fenv (QF f) ft ->
      ProgTyping ftenv' fenv' p t ->
      ProgTyping ftenv fenv (define x f p) t.

Scheme FunTyping_mut := Induction for FunTyping Sort Type
with QFunTyping_mut := Induction for QFunTyping Sort Type
with ExpTyping_mut := Induction for ExpTyping Sort Type
with PrmsTyping_mut := Induction for PrmsTyping Sort Type.

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

Inductive isValue (e: Exp) : Prop :=
  IsValue : forall (v: Value), e = Val v -> isValue e.

Definition isValueList (ls : list Exp) : Prop :=
Forall isValue ls.

Inductive isValueList2
  (els : list Exp) (vls : list Value) : Prop :=
IsValueList2 :  els = map Val vls -> isValueList2 els vls.

Inductive isValueT (e: Exp) : Type :=
  IsValueT : forall (v: Value), e = Val v -> isValueT e.

Definition isValueListT (ls : list Exp) : Type :=
ForallT isValueT ls.

Inductive isValueList2T
  (els : list Exp) (vls : list Value) : Type :=
IsValueList2T :  els = map Val vls -> isValueList2T els vls.

(* was  ValLsTyping  *)
Definition vlsTyping (vs: list Value) (pt: list VTyp) : Type :=
           Forall2T ValueTyping vs pt.

Definition PrmsValTyping (es: list Exp) (ts: list VTyp) : Type :=
  sigT2 (isValueList2 es) (fun vs => vlsTyping vs ts).

Definition PrmsValTypingT (es: list Exp) (ts: list VTyp) : Type :=
  sigT2 (isValueList2T es) (fun vs => vlsTyping vs ts).

Lemma isValueList2IsValue (els : list Exp) (vls : list Value) :
  isValueList2 els vls -> isValueList els.
Proof.
  intros.
  inversion H; subst.
  unfold isValueList.
  revert H.
  induction vls.
  simpl.
  constructor.
  constructor.
  econstructor.
  reflexivity.
  eapply IHvls.
  constructor.
  auto.
Defined.

Lemma isValueList2IsValueT (els : list Exp) (vls : list Value) :
  isValueList2T els vls -> isValueListT els.
Proof.
  intros.
  inversion H; subst.
  unfold isValueList.
  revert H.
  induction vls.
  simpl.
  constructor.
  constructor.
  econstructor.
  reflexivity.
  eapply IHvls.
  constructor.
  auto.
Defined.

Lemma isValueList22 (ls : list Exp) : isValueList ls ->
             exists vs, isValueList2 ls vs.
Proof.
  induction ls.
  intros.
  exists nil.
  constructor.
  simpl.
  reflexivity.
  intros.
  assert (isValueList ls).
  inversion H; subst.
  assumption.
  inversion H; subst.
  inversion H3; subst.
  eapply IHls in H0.
  destruct H0.
  rename x into vs1.
  exists (v::vs1).
  constructor.
  inversion H0; subst.
  simpl.
  reflexivity.
Defined.

Lemma isValueList22_T (ls : list Exp) : isValueListT ls ->
             sigT (fun vs => isValueList2T ls vs).
Proof.
  induction ls.
  intros.
  exists nil.
  constructor.
  simpl.
  reflexivity.
  intros.
  assert (isValueListT ls).
  inversion X; subst.
  assumption.
  inversion X; subst.
  inversion X1; subst.
  eapply IHls in X0.
  destruct X0 as [vs1 X0].
  constructor 1 with (x := v::vs1).
  constructor.
  inversion X0; subst.
  simpl.
  reflexivity.
Defined.

Definition ExTDefVal := ExRelValT ValueTyping.

Definition ExTDefValProj1 := ExRelValTProj1 ValueTyping.

Definition ExTDefFun
  := ExRelValT FunTyping.

Definition ExTDefFunProj1
  := ExRelValTProj1 FunTyping.

Lemma ExTDefNatT (T: Type) {VT: ValTyp T}
           (tenv: valTC) (venv: valEnv) (t: VTyp) (x: Id):
    EnvTyping venv tenv ->
    findET tenv x t ->
    T = proj1_sig t ->
    sigT (fun v: T => findET venv x (cst T v)).
Proof.
  intros.
  subst.
  cut (sigT2 (findET venv x) (fun v: Value => ValueTyping v t)).
  intro.
  destruct X1 as [v E1 E2].
  inversion E2; subst.
  subst T.
  destruct v as [T b].
  destruct b.
  compute in H.
  assert (T = proj1_sig t).
  compute.
  assumption.
  clear H.
  subst.
  econstructor 1 with (x:=v).
  unfold cst.
  assumption.
  eapply ExTDefVal.
  eassumption.
  assumption.
Defined.

Definition updateVEnvLemma := updateEnvLemmaT ValueTyping.

Definition updateFEnvLemma
  := updateEnvLemmaT FunTyping.

Definition overrideVEnvLemma := overrideEnvLemmaT ValueTyping.

Definition overrideFEnvLemma
  := overrideEnvLemmaT FunTyping.

Definition ValTypedByEnv := RelatedByEnvEP2_T ValueTyping.

Definition FunTypedByEnv
  := RelatedByEnvEP2_T FunTyping.

Lemma prmsTypingAux_T (fps : valTC) (vls : list Value)
                       (h: length fps = length vls):
          vlsTyping vls (map snd fps) ->
                         EnvTyping (mkVEnv fps vls) fps.
Proof.
  unfold EnvTyping.
  unfold mkVEnv.
  intros.
  apply prmsTypingAux2_T.
  auto.
  eapply prmsTypingAux1_T.
  auto.
  auto.
Defined.

Lemma Exp2ValueTyping
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
      (v: Value) (t: VTyp) :
  ExpTyping ftenv tenv fenv (Val v) t ->
  ValueTyping v t.
Proof.
  intros.
  dependent induction X.
  auto.
Defined.

Lemma Exp2ValueTypingA
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
      (v: Value) (t: VTyp) :
  ExpTyping ftenv tenv fenv (Val v) t ->
  ExpTyping emptyE emptyE emptyE (Val v) t.
Proof.
intro.
constructor.
eapply Exp2ValueTyping.
eassumption.
Defined.

Lemma Value2ExpTyping
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
      (v: Value) (t: VTyp) :
  ValueTyping v t ->
  ExpTyping ftenv tenv fenv (Val v) t.
Proof.
  intros.
  inversion H; subst.
  constructor.
  auto.
Defined.

Lemma prmsTypingAux01_T
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
      (vs: list Value) (ts: list VTyp) :
          vlsTyping vs ts ->
          PrmsTyping ftenv tenv fenv (PS (map Val vs)) (PT ts).
Proof.
  unfold vlsTyping.
  intros.
  induction X.
  constructor.
  constructor.
  simpl.
  constructor.
  constructor.
  eapply Value2ExpTyping.
  auto.
  auto.
  inversion IHX; subst.
  auto.
Defined.

Lemma matchListsAux02_T
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                       (ts: list VTyp)
                       (es : list Exp) (vs : list Value) :
  isValueList2T es vs ->
  PrmsTyping ftenv tenv fenv (PS es) (PT ts) ->
  vlsTyping vs ts.
Proof.
  unfold vlsTyping.
  intros.
  inversion H; subst.
  inversion X; subst.
  revert X.
  revert H.
  dependent induction X0 generalizing vs.
  - intros.
    symmetry in x.
    eapply map_eq_nil in x.
    rewrite x.
    constructor.
  - intros.
    simpl in x.
    destruct vs.
    simpl in x.
    inversion x.
    constructor.
    simpl in x.
    inversion x; subst.
    eapply Exp2ValueTyping.
    eassumption.
    simpl in x.
    inversion x; subst.
    specialize (IHX0 vs).
    eapply IHX0.
    reflexivity.
    econstructor.
    auto.
    constructor.
    auto.
Defined.

Lemma matchListsAux02
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                       (ts: list VTyp)
                       (es : list Exp) (vs : list Value) :
  isValueList2 es vs ->
  PrmsTyping ftenv tenv fenv (PS es) (PT ts) ->
  vlsTyping vs ts.
Proof.
  unfold vlsTyping.
  intros.
  inversion H; subst.
  inversion X; subst.
  revert H.
  revert X.
  dependent induction X0 generalizing vs.
  - intros.
    symmetry in x.
    eapply map_eq_nil in x.
    rewrite x.
    constructor.
  - simpl in x.
    destruct vs.
    simpl in x.
    inversion x.
    constructor.
    simpl in x.
    inversion x; subst.
    eapply Exp2ValueTyping.
    eassumption.
    simpl in x.
    inversion x; subst.
    specialize (IHX0 vs).
    eapply IHX0.
    reflexivity.
    econstructor.
    auto.
    constructor.
    auto.
Defined.

Lemma matchListsAux1A
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv) (ts: list VTyp)
                       (es : list Exp) (vs : list Value) :
  isValueList2T es vs ->
  Forall2T (ExpTyping ftenv tenv fenv) es ts ->
  Forall2T (ExpTyping emptyE emptyE emptyE) es ts.
Proof.
  intros.
  revert H.
  revert vs.
  dependent induction X.
  intros.
  inversion H; subst.
  symmetry in H0.
  eapply map_eq_nil in H0; subst.
  constructor.
  intros.
  destruct vs.
  inversion H; subst.
  simpl in H0.
  inversion H0.
  inversion H; subst.
  simpl in H0.
  inversion H0; subst.
  assert (isValueList2T (map Val vs) vs).
  constructor.
  reflexivity.
  eapply IHX in H1.
  constructor.
  eapply Exp2ValueTypingA.
  eassumption.
  assumption.
Defined.

Lemma matchListsAux1
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv) (ts: list VTyp)
                       (es : list Exp) (vs : list Value) :
  isValueList2T es vs ->
  Forall2T (ExpTyping ftenv tenv fenv) es ts ->
  Forall2T ValueTyping vs ts.
Proof.
  intros.
  revert H.
  revert vs.
  dependent induction X.
  intros.
  inversion H; subst.
  symmetry in H0.
  eapply map_eq_nil in H0; subst.
  constructor.
  intros.
  destruct vs.
  inversion H; subst.
  simpl in H0.
  inversion H0.
  inversion H; subst.
  simpl in H0.
  inversion H0; subst.
  assert (isValueList2T (map Val vs) vs).
  constructor.
  reflexivity.
  eapply IHX in H1.
  constructor.
  eapply Exp2ValueTyping.
  eassumption.
  assumption.
Defined.

Lemma sameLengthVV (es : list Exp) (vs : list Value) :
  isValueList2 es vs -> length es = length vs.
Proof.
intros.
inversion H; subst.
clear H.
induction vs.
auto.
simpl.
rewrite IHvs.
reflexivity.
Defined.

Lemma sameLengthVV_T (es : list Exp) (vs : list Value) :
  isValueList2T es vs -> length es = length vs.
Proof.
intros.
inversion H; subst.
clear H.
induction vs.
auto.
simpl.
rewrite IHvs.
reflexivity.
Defined.

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

Lemma prmsAux2 (vls: list Value) (fps: valTC) :
vlsTyping vls (map snd fps) ->
  length fps = length vls.
Proof.
  intros.
  unfold vlsTyping in X.
  eapply sameBehSameLength_T in X.
  rewrite X.
  rewrite map_length.
  auto.
Defined.

Lemma prmsAux3
      (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
                (ls: list Exp) (fps: valTC) :
PrmsTyping ftenv tenv fenv (PS ls) (env2ptyp fps) ->
  length fps = length ls.
Proof.
  intros.
  unfold env2ptyp in X.
  inversion X; subst.
  eapply sameBehSameLength_T in X0.
  rewrite X0 at 1.
  rewrite map_length.
  auto.
Defined.

Lemma funTypingAux1
      (fenv: funEnv) (tenv fps: valTC) (e0 e1: Exp)
                     (x: Id) (i: nat) (t: VTyp) :
      FunTyping (FC fenv tenv e0 e1 x i) (FT fps t) ->
                        tenv = fps.
Proof.
  intros.
  inversion X; subst.
  reflexivity.
  reflexivity.
Defined.

Lemma mapEq (ls1 ls2: list Value) :
   map Val ls1 = map Val ls2 -> ls1 = ls2.
Proof.
  revert ls2.
  induction ls1.
  induction ls2.
  auto.
  intros.
  simpl in H.
  inversion H.
  intros.
  destruct ls2.
  simpl in H.
  inversion H.
  simpl in H.
  inversion H; subst.
  assert (ls1 = ls2).
  eapply IHls1.
  assumption.
  rewrite H0.
  auto.
Defined.

Lemma vlaMapEq (vs1 vs2: list Value) : map Val vs1 = map Val vs2 -> vs1 = vs2.
Proof.
  intros.
  revert H.
  revert vs2.
  induction vs1.
  intro vs2.
  destruct vs2.
  auto.
  intros.
  simpl in H.
  inversion H.
  intros.
  destruct vs2.
  simpl in H.
  inversion H.
  simpl in H.
  inversion H; subst.
  eapply IHvs1 in H2.
  rewrite H2.
  auto.
Defined.

End Static.
(*
Module StaticC := Static IdMod1.

Export IdMod1.
Export StaticC.
*)


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Machine- and ABI-dependent layout information for activation records. *)

Require Import Coqlib.
Require Import Bounds.

(** The general shape of activation records is as follows,
  from bottom (lowest offsets) to top:
- Space for outgoing arguments to function calls.
- Back link to parent frame
- Saved values of integer callee-save registers used by the function.
- Saved values of float callee-save registers used by the function.
- Local stack slots.
- Space for the stack-allocated data declared in Cminor
- Return address.

The [frame_env] compilation environment records the positions of
the boundaries between these areas of the activation record.
*)

Definition fe_ofs_arg := 0.

Record frame_env : Type := mk_frame_env {
  fe_size: Z;
  fe_ofs_link: Z;
  fe_ofs_retaddr: Z;
  fe_ofs_local: Z;
  fe_ofs_int_callee_save: Z;
  fe_num_int_callee_save: Z;
  fe_ofs_float_callee_save: Z;
  fe_num_float_callee_save: Z;
  fe_stack_data: Z
}.

(** Computation of the frame environment from the bounds of the current
  function. *)

Definition make_env (b: bounds) :=
  let olink := 4 * b.(bound_outgoing) in  (* back link *)
  let oics := olink + 4 in                (* integer callee-saves *)
  let ofcs := align (oics + 4 * b.(bound_int_callee_save)) 8 in (* float callee-saves *)
  let ol := ofcs + 8 * b.(bound_float_callee_save) in (* locals *)
  let ostkdata := align (ol + 4 * b.(bound_local)) 8 in (* stack data *)
  let oretaddr := align (ostkdata + b.(bound_stack_data)) 4 in (* return address *)
  let sz := oretaddr + 4 in (* total size *)
  mk_frame_env sz olink oretaddr
                  ol
                  oics b.(bound_int_callee_save)
                  ofcs b.(bound_float_callee_save)
                  ostkdata.

(** Separation property *)

Remark frame_env_separated:
  forall b,
  let fe := make_env b in
  0 <= fe_ofs_arg
  /\ fe_ofs_arg + 4 * b.(bound_outgoing) <= fe.(fe_ofs_link)
  /\ fe.(fe_ofs_link) + 4 <= fe.(fe_ofs_int_callee_save)
  /\ fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save) <= fe.(fe_ofs_float_callee_save)
  /\ fe.(fe_ofs_float_callee_save) + 8 * b.(bound_float_callee_save) <= fe.(fe_ofs_local)
  /\ fe.(fe_ofs_local) + 4 * b.(bound_local) <= fe.(fe_stack_data)
  /\ fe.(fe_stack_data) + b.(bound_stack_data) <= fe.(fe_ofs_retaddr)
  /\ fe.(fe_ofs_retaddr) + 4 <= fe.(fe_size).
Proof.
  intros.
  generalize (align_le (fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save)) 8 (refl_equal _)).
  generalize (align_le (fe.(fe_ofs_local) + 4 * b.(bound_local)) 8 (refl_equal _)).
  generalize (align_le (fe.(fe_stack_data) + b.(bound_stack_data)) 4 (refl_equal _)).
  unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr,
    fe_ofs_local, fe_ofs_int_callee_save, fe_num_int_callee_save,
    fe_ofs_float_callee_save, fe_num_float_callee_save,
    fe_stack_data, fe_ofs_arg.
  intros.
  generalize (bound_local_pos b); intro;
  generalize (bound_int_callee_save_pos b); intro;
  generalize (bound_float_callee_save_pos b); intro;
  generalize (bound_outgoing_pos b); intro;
  generalize (bound_stack_data_pos b); intro.
  omega.
Qed.

(** Alignment property *)

Remark frame_env_aligned:
  forall b,
  let fe := make_env b in
  (4 | fe.(fe_ofs_link))
  /\ (4 | fe.(fe_ofs_int_callee_save))
  /\ (8 | fe.(fe_ofs_float_callee_save))
  /\ (8 | fe.(fe_ofs_local))
  /\ (8 | fe.(fe_stack_data))
  /\ (4 | fe.(fe_ofs_retaddr))
  /\ (4 | fe.(fe_size)).
Proof.
  intros.
  unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr,
    fe_ofs_local, fe_ofs_int_callee_save,
    fe_num_int_callee_save,
    fe_ofs_float_callee_save, fe_num_float_callee_save,
    fe_stack_data.
  set (x1 := 4 * bound_outgoing b).
  assert (4 | x1). unfold x1; exists (bound_outgoing b); ring.
  set (x2 := x1 + 4).
  assert (4 | x2). unfold x2; apply Zdivide_plus_r; auto. exists 1; auto.
  set (x3 := x2 + 4 * bound_int_callee_save b).
  set (x4 := align x3 8).
  assert (8 | x4). unfold x4. apply align_divides. omega.
  set (x5 := x4 + 8 * bound_float_callee_save b).
  assert (8 | x5). unfold x5; apply Zdivide_plus_r; auto. exists (bound_float_callee_save b); ring.
  set (x6 := align (x5 + 4 * bound_local b) 8).
  assert (8 | x6). unfold x6; apply align_divides; omega.
  set (x7 := align (x6 + bound_stack_data b) 4).
  assert (4 | x7). unfold x7; apply align_divides; omega.
  set (x8 := x7 + 4).
  assert (4 | x8). unfold x8; apply Zdivide_plus_r; auto. exists 1; auto.
  tauto.
Qed.