Require Import rt.util.all.
Require Import rt.analysis.global.jitter.bertogna_fp_theory.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop div path.

Module ResponseTimeIterationFP.

  Import ResponseTimeAnalysisFP.

  (* In this section, we define the algorithm of Bertogna and Cirinei's
     response-time analysis for FP scheduling with release jitter. *)
  Section Analysis.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.
    Variable task_jitter: sporadic_task -> time.

    (* During the iterations of the algorithm, we pass around pairs
       of tasks and computed response-time bounds. *)
    Let task_with_response_time := (sporadic_task * time)%type.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> sporadic_task.
    Variable job_jitter: Job -> time.

    (* Consider a platform with num_cpus processors, ... *)
    Variable num_cpus: nat.

    (* ..., and priorities based on an FP policy. *)
    Variable higher_priority: FP_policy sporadic_task.

    (* Next we define the fixed-point iteration for computing
       Bertogna's response-time bound of a task set. *)

    (* First, given a sequence of pairs R_prev = <..., (tsk_hp, R_hp)> of
       response-time bounds for the higher-priority tasks, we define an
       iteration that computes the response-time bound of the current task:

           R_tsk (0) = task_cost tsk
           R_tsk (step + 1) =  f (R step),

       where f is the response-time recurrence, step is the number of iterations,
       and R_tsk (0) is the initial state. *)
    Definition per_task_rta (tsk: sporadic_task)
                            (R_prev: seq task_with_response_time) (step: nat) :=
      iter step
        (fun t => task_cost tsk +
                  div_floor
                    (total_interference_bound_fp task_cost task_period task_jitter tsk  R_prev t)
                    num_cpus)
        (task_cost tsk).

    (* To ensure that the iteration converges, we will apply per_task_rta
       a "sufficient" number of times: task_deadline tsk - task_cost tsk + 1.
       This corresponds to the time complexity of the iteration. *)
    Definition max_steps (tsk: sporadic_task) := task_deadline tsk - task_cost tsk + 1.

    (* Next we compute the response-time bounds for the entire task set.
       Since high-priority tasks may not be schedulable, we allow the
       computation to fail.
       Thus, given the response-time bound of previous tasks, we either
       (a) append the computed response-time bound (tsk, R) of the current task
           to the list of pairs, or,
       (b) return None if the response-time analysis failed. *)
    Definition fp_bound_of_task hp_pairs tsk :=
      if hp_pairs is Some rt_bounds then
        let R := per_task_rta tsk rt_bounds (max_steps tsk) in
          if task_jitter tsk + R <= task_deadline tsk then
            Some (rcons rt_bounds (tsk, R))
          else None
      else None.

    (* The response-time analysis for a given task set is defined
       as a left-fold (reduce) based on the function above.
       This either returns a list of task and response-time bounds, or None. *)
    Definition fp_claimed_bounds (ts: seq sporadic_task) :=
      foldl fp_bound_of_task (Some [::]) ts.

    (* The schedulability test simply checks if we got a list of
       response-time bounds (i.e., if the computation did not fail). *)
    Definition fp_schedulable (ts: seq sporadic_task) :=
      fp_claimed_bounds ts != None.

    (* In the following section, we prove several helper lemmas about the
       list of response-time bounds. The results seem trivial, but must be proven
       nonetheless since the list of response-time bounds is computed with
       a specific algorithm and there are no lemmas in the library for that. *)
    Section SimpleLemmas.

      (* First, we show that the first component of the computed list is the set of tasks. *)
      Lemma fp_claimed_bounds_unzip :
        forall ts hp_bounds,
          fp_claimed_bounds ts = Some hp_bounds ->
          unzip1 hp_bounds = ts.
      Proof.
        unfold fp_claimed_bounds in *; intros ts.
        induction ts using last_ind; first by destruct hp_bounds.
        {
          intros hp_bounds SOME.
          destruct (lastP hp_bounds) as [| hp_bounds'].
          {
            rewrite -cats1 foldl_cat /= in SOME.
            unfold fp_bound_of_task at 1 in SOME; simpl in *; desf.
            by destruct l.
          }
          rewrite -cats1 foldl_cat /= in SOME.
          unfold fp_bound_of_task at 1 in SOME; simpl in *; desf.
          move: H0 => /eqP EQSEQ.
          rewrite eqseq_rcons in EQSEQ.
          move: EQSEQ => /andP [/eqP SUBST /eqP EQSEQ]; subst.
          unfold unzip1; rewrite map_rcons; f_equal.
          by apply IHts.
        }
      Qed.

      (* Next, we show that some properties of the analysis are preserved for the
         prefixes of the list: (a) the tasks do not change, (b) R <= deadline,
         (c) R is computed using the response-time equation, ... *)
      Lemma fp_claimed_bounds_rcons :
        forall ts' hp_bounds tsk1 tsk2 R,
          (fp_claimed_bounds (rcons ts' tsk1) = Some (rcons hp_bounds (tsk2, R)) ->
           (fp_claimed_bounds ts' = Some hp_bounds /\
            tsk1 = tsk2 /\
            R = per_task_rta tsk1 hp_bounds (max_steps tsk1) /\
            task_jitter tsk1 + R <= task_deadline tsk1)).
      Proof.
        intros ts hp_bounds tsk tsk' R.
        rewrite -cats1.
        unfold fp_claimed_bounds in *.
        rewrite foldl_cat /=.
        unfold fp_bound_of_task at 1; simpl; desf.
        intros EQ; inversion EQ; move: EQ H0 => _ /eqP EQ.
        rewrite eqseq_rcons in EQ.
        move: EQ => /andP [/eqP EQ /eqP RESP].
        by inversion RESP; repeat split; subst.
      Qed.

      (* ..., which implies that any prefix of the computation is the computation
         of the prefix. *)
      Lemma fp_claimed_bounds_take :
        forall ts hp_bounds i,
          fp_claimed_bounds ts = Some hp_bounds ->
          i <= size hp_bounds ->
          fp_claimed_bounds (take i ts) = Some (take i hp_bounds).
      Proof.
        intros ts hp_bounds i SOME LTi.
        have UNZIP := fp_claimed_bounds_unzip ts hp_bounds SOME.
        rewrite <- UNZIP in *.
        rewrite -[hp_bounds]take_size /unzip1 map_take in SOME.
        fold (unzip1 hp_bounds) in *; clear UNZIP.
        rewrite leq_eqVlt in LTi.
        move: LTi => /orP [/eqP EQ | LTi]; first by subst.
        remember (size hp_bounds) as len; apply eq_leq in Heqlen.
        induction len; first by rewrite ltn0 in LTi.
        {
          assert (TAKElen: fp_claimed_bounds (take len (unzip1 (hp_bounds))) =
                             Some (take len (hp_bounds))).
          {
            assert (exists p, p \in hp_bounds).
            {
              destruct hp_bounds; first by rewrite ltn0 in Heqlen.
              by exists t; rewrite in_cons eq_refl orTb.
            } destruct H as [[tsk R] _].
             rewrite (take_nth tsk) in SOME; last by rewrite size_map.
            rewrite (take_nth (tsk,R)) in SOME; last by done.
            destruct (nth (tsk, R) hp_bounds len) as [tsk_len R_len].
            by apply fp_claimed_bounds_rcons in SOME; des.
          }
          rewrite ltnS leq_eqVlt in LTi.
          move: LTi => /orP [/eqP EQ | LESS]; first by subst.
          apply ltnW in Heqlen.
          by specialize (IHlen Heqlen TAKElen LESS).
        }
      Qed.

      (* If the analysis suceeds, the computed response-time bounds are no larger
         than the deadlines... *)
      Lemma fp_claimed_bounds_le_deadline :
        forall ts' rt_bounds tsk R,
          fp_claimed_bounds ts' = Some rt_bounds ->
          (tsk, R) \in rt_bounds ->
          task_jitter tsk + R <= task_deadline tsk.
      Proof.
        intros ts; induction ts as [| ts' tsk_lst] using last_ind.
        {
          intros rt_bounds tsk R SOME IN.
          by inversion SOME; subst; rewrite in_nil in IN.
        }
        {
          intros rt_bounds tsk_i R SOME IN.
          destruct (lastP rt_bounds) as [|rt_bounds (tsk_lst', R_lst)];
            first by rewrite in_nil in IN.
          rewrite mem_rcons in_cons in IN; move: IN => /orP IN.
          destruct IN as [LAST | FRONT].
          {
            move: LAST => /eqP LAST.
            rewrite -cats1 in SOME.
            unfold fp_claimed_bounds in *.
            rewrite foldl_cat /= in SOME.
            unfold fp_bound_of_task in SOME.
            desf; rename H0 into EQ.
            move: EQ => /eqP EQ.
            rewrite eqseq_rcons in EQ.
            move: EQ => /andP [_ /eqP EQ].
            inversion EQ; subst.
            by apply Heq0.
          }
          {
            apply IHts with (rt_bounds := rt_bounds); last by ins.
            by apply fp_claimed_bounds_rcons in SOME; des.
          }
        }
      Qed.

      (* ... and the computed response-time bounds are no smaller
         than the task costs. *)
      Lemma fp_claimed_bounds_ge_cost :
        forall ts' rt_bounds tsk R,
          fp_claimed_bounds ts' = Some rt_bounds ->
          (tsk, R) \in rt_bounds ->
          R >= task_cost tsk.
      Proof.
        intros ts; induction ts as [| ts' tsk_lst] using last_ind.
        {
          intros rt_bounds tsk R SOME IN.
          by inversion SOME; subst; rewrite in_nil in IN.
        }
        {
          intros rt_bounds tsk_i R SOME IN.
          destruct (lastP rt_bounds) as [|rt_bounds (tsk_lst', R_lst)];
            first by rewrite in_nil in IN.
          rewrite mem_rcons in_cons in IN; move: IN => /orP IN.
          destruct IN as [LAST | FRONT].
          {
            move: LAST => /eqP LAST.
            rewrite -cats1 in SOME.
            unfold fp_claimed_bounds in *.
            rewrite foldl_cat /= in SOME.
            unfold fp_bound_of_task in SOME.
            desf; rename H0 into EQ.
            move: EQ => /eqP EQ.
            rewrite eqseq_rcons in EQ.
            move: EQ => /andP [_ /eqP EQ].
            inversion EQ; subst.
            by destruct (max_steps tsk_lst');
              [by apply leqnn | by apply leq_addr].
          }
          {
            apply IHts with (rt_bounds := rt_bounds); last by ins.
            by apply fp_claimed_bounds_rcons in SOME; des.
          }
        }
      Qed.

      (* Short lemma about unfolding the iteration one step. *)
      Lemma per_task_rta_fold :
        forall tsk rt_bounds,
          task_cost tsk +
           div_floor (total_interference_bound_fp task_cost task_period task_jitter tsk rt_bounds
                     (per_task_rta tsk rt_bounds (max_steps tsk))) num_cpus
          = per_task_rta tsk rt_bounds (max_steps tsk).+1.
      Proof.
          by done.
      Qed.

    End SimpleLemmas.

    (* In this section, we prove that if the task set is sorted by priority,
       the tasks in fp_claimed_bounds are interfering tasks.  *)
    Section HighPriorityTasks.

      (* Consider a list of previous tasks and a task tsk to be analyzed. *)
      Variable ts: taskset_of sporadic_task.

      (* Assume that the task set is sorted by unique priorities, ... *)
      Hypothesis H_task_set_is_sorted: sorted higher_priority ts.
      Hypothesis H_task_set_has_unique_priorities:
        FP_is_antisymmetric_over_task_set higher_priority ts.

      (* ...the priority order is transitive, ...*)
      Hypothesis H_priority_transitive: FP_is_transitive higher_priority.

      (* ... and that the response-time analysis succeeds. *)
      Variable hp_bounds: seq task_with_response_time.
      Variable R: time.
      Hypothesis H_analysis_succeeds: fp_claimed_bounds ts = Some hp_bounds.

      (* Let's refer to tasks by index. *)
      Variable elem: sporadic_task.
      Let TASK := nth elem ts.

      (* We prove that higher-priority tasks have smaller index. *)
      Lemma fp_claimed_bounds_hp_tasks_have_smaller_index :
        forall hp_idx idx,
          hp_idx < size ts ->
          idx < size ts ->
          hp_idx != idx ->
          higher_priority (TASK hp_idx) (TASK idx) ->
          hp_idx < idx.
      Proof.
        unfold TASK; clear TASK.
        rename ts into ts'; destruct ts' as [ts UNIQ]; simpl in *.
        intros hp_idx idx LThp LT NEQ HP.
        rewrite ltn_neqAle; apply/andP; split; first by done.
        by apply sorted_rel_implies_le_idx with (leT := higher_priority) (s := ts) (x0 := elem).
      Qed.

    End HighPriorityTasks.

    (* In this section, we show that the fixed-point iteration converges. *)
    Section Convergence.

      (* Consider any set of higher-priority tasks. *)
      Variable ts_hp: seq sporadic_task.

      (* Assume that the response-time analysis succeeds for the higher-priority tasks. *)
      Variable rt_bounds: seq task_with_response_time.
      Hypothesis H_test_succeeds: fp_claimed_bounds ts_hp = Some rt_bounds.

      (* Consider any task tsk to be analyzed, ... *)
      Variable tsk: sporadic_task.

      (* ... and assume all tasks have valid parameters. *)
      Hypothesis H_valid_task_parameters:
        valid_sporadic_taskset task_cost task_period task_deadline (rcons ts_hp tsk).

      (* To simplify, let f denote the fixed-point iteration. *)
      Let f := per_task_rta tsk rt_bounds.

      (* Assume that f (max_steps tsk) is no larger than the deadline. *)
      Hypothesis H_no_larger_than_deadline: f (max_steps tsk) <= task_deadline tsk.

      (* First, we show that f is monotonically increasing. *)
      Lemma bertogna_fp_comp_f_monotonic :
        forall x1 x2, x1 <= x2 -> f x1 <= f x2.
      Proof.
        unfold valid_sporadic_taskset, is_valid_sporadic_task in *.
        rename H_test_succeeds into SOME,
               H_valid_task_parameters into VALID.
        intros x1 x2 LEx; unfold f, per_task_rta.
        apply fun_mon_iter_mon; [by ins | by ins; apply leq_addr |].
        clear LEx x1 x2; intros x1 x2 LEx.
        unfold div_floor, total_interference_bound_fp.
        rewrite leq_add2l leq_div2r //.
        rewrite big_seq_cond.
        rewrite [\sum_(_ <- _ | true) _]big_seq_cond.
        apply leq_sum; move => i /andP [IN _].
        destruct i as [i R].
        have GE_COST := fp_claimed_bounds_ge_cost ts_hp rt_bounds i R SOME IN.
        have UNZIP := fp_claimed_bounds_unzip ts_hp rt_bounds SOME.
        unfold interference_bound_generic; simpl.
        rewrite leq_min; apply/andP; split.
        {
          apply leq_trans with (n := W_jitter task_cost task_period task_jitter i R x1); first by apply geq_minl.
          apply W_monotonic; try (by done).
          have INts: i \in ts_hp by rewrite -UNZIP; apply/mapP; exists (i, R).
          by exploit (VALID i);
            [by rewrite mem_rcons in_cons INts orbT | by ins; des].
        }
        {
          apply leq_trans with (n := x1 - task_cost tsk + 1); first by apply geq_minr.
          by rewrite leq_add2r leq_sub2r //.
        }
      Qed.

      (* If the iteration converged at an earlier step, then it remains stable. *)
      Lemma bertogna_fp_comp_f_converges_early :
        (exists k, k <= max_steps tsk /\ f k = f k.+1) ->
        f (max_steps tsk) = f (max_steps tsk).+1.
      Proof.
        by intros EX; des; apply iter_fix with (k := k).
      Qed.

      (* Else, we derive a contradiction. *)
      Section DerivingContradiction.

        (* Assume instead that the iteration continued to diverge. *)
        Hypothesis H_keeps_diverging:
          forall k,
            k <= max_steps tsk -> f k != f k.+1.

        (* By monotonicity, it follows that the value always increases. *)
        Lemma bertogna_fp_comp_f_increases :
          forall k,
            k <= max_steps tsk ->
            f k < f k.+1.
        Proof.
          intros k LT.
          rewrite ltn_neqAle; apply/andP; split.
            by apply H_keeps_diverging.
            by apply bertogna_fp_comp_f_monotonic, leqnSn.
        Qed.

        (* In the end, the response-time bound must exceed the deadline. Contradiction! *)
        Lemma bertogna_fp_comp_rt_grows_too_much :
          forall k,
            k <= max_steps tsk ->
            f k > k + task_cost tsk - 1.
        Proof.
          have INC := bertogna_fp_comp_f_increases.
          rename H_valid_task_parameters into TASK_PARAMS.
          unfold valid_sporadic_taskset, is_valid_sporadic_task in *; des.
          exploit (TASK_PARAMS tsk);
            [by rewrite mem_rcons in_cons eq_refl orTb | intro PARAMS; des].
          induction k.
          {
            intros _; rewrite add0n -addn1 subh1;
              first by rewrite -addnBA // subnn addn0 /= leqnn.
            by apply PARAMS.
          }
          {
            intros LT.
            specialize (IHk (ltnW LT)).
            apply leq_ltn_trans with (n := f k);
              last by apply INC, ltnW.
            rewrite -addn1 -addnA [1 + _]addnC addnA -addnBA // subnn addn0.
            rewrite -(ltn_add2r 1) in IHk.
            rewrite subh1 in IHk;
              last by apply leq_trans with (n := task_cost tsk);
                [by apply PARAMS | by apply leq_addl].
            by rewrite -addnBA // subnn addn0 addn1 ltnS in IHk.
          }
        Qed.

      End DerivingContradiction.

      (* Using the lemmas above, we prove the convergence of the iteration after max_steps. *)
      Lemma per_task_rta_converges:
        f (max_steps tsk) = f (max_steps tsk).+1.
      Proof.
        have TOOMUCH := bertogna_fp_comp_rt_grows_too_much.
        have INC := bertogna_fp_comp_f_increases.
        rename H_no_larger_than_deadline into LE,
               H_valid_task_parameters into TASK_PARAMS.
        unfold valid_sporadic_taskset, is_valid_sporadic_task in *; des.

        (* Either f converges by the deadline or not. *)
        destruct ([exists k in 'I_(max_steps tsk).+1, f k == f k.+1]) eqn:EX.
        {
          move: EX => /exists_inP EX; destruct EX as [k _ ITERk].
          apply bertogna_fp_comp_f_converges_early.
          by exists k; split; [by rewrite -ltnS; apply ltn_ord | by apply/eqP].
        }

        (* If not, then we reach a contradiction *)
        apply negbT in EX; rewrite negb_exists_in in EX.
        move: EX => /forall_inP EX.
        rewrite leqNgt in LE; move: LE => /negP LE.
        exfalso; apply LE.

        assert (DIFF: forall k : nat, k <= max_steps tsk -> f k != f k.+1).
        {
          intros k LEk; rewrite -ltnS in LEk.
          by exploit (EX (Ordinal LEk)); [by done | intro DIFF; apply DIFF].
        }
        exploit TOOMUCH; [by apply DIFF | by apply leq_addr |].
        exploit (TASK_PARAMS tsk);
          [by rewrite mem_rcons in_cons eq_refl orTb | intro PARAMS; des].
        rewrite subh1; last by apply PARAMS2.
        rewrite -addnBA // subnn addn0 subn1 prednK //.
        intros LT; apply (leq_ltn_trans LT).
        by rewrite /max_steps [_ - _ + 1]addn1; apply INC, leq_addr.
      Qed.

    End Convergence.

    Section MainProof.

      (* Consider a task set ts. *)
      Variable ts: taskset_of sporadic_task.

      (* Assume that all tasks have valid parameters, ... *)
      Hypothesis H_valid_task_parameters:
        valid_sporadic_taskset task_cost task_period task_deadline ts.

      (* ...and constrained deadlines.*)
      Hypothesis H_constrained_deadlines:
        forall tsk, tsk \in ts -> task_deadline tsk <= task_period tsk.

       (* Assume that the task set is totally ordered by unique priorities,
          and that the priority order is transitive. *)
      Hypothesis H_task_set_is_sorted: sorted higher_priority ts.
      Hypothesis H_task_set_has_unique_priorities:
        FP_is_antisymmetric_over_task_set higher_priority ts.
      Hypothesis H_priority_is_total:
        FP_is_total_over_task_set higher_priority ts.
      Hypothesis H_priority_transitive: FP_is_transitive higher_priority.

      (* Next, consider any arrival sequence such that...*)
      Context {arr_seq: arrival_sequence Job}.

     (* ...all jobs come from task set ts, ...*)
      Hypothesis H_all_jobs_from_taskset:
        forall j, arrives_in arr_seq j -> job_task j \in ts.

      (* ...they have valid parameters,...*)
      Hypothesis H_valid_job_parameters:
        forall j,
          arrives_in arr_seq j ->
          valid_sporadic_job_with_jitter task_cost task_deadline task_jitter job_cost
                                                   job_deadline job_task job_jitter j.

      (* ... and satisfy the sporadic task model.*)
      Hypothesis H_sporadic_tasks:
        sporadic_task_model task_period job_arrival job_task arr_seq.

      (* Then, consider any schedule of this arrival sequence such that... *)
      Variable sched: schedule Job num_cpus.
      Hypothesis H_at_least_one_cpu: num_cpus > 0.
      Hypothesis H_jobs_come_from_arrival_sequence:
        jobs_come_from_arrival_sequence sched arr_seq.

      (* ...jobs only execute after jitter and no longer than their execution costs. *)
      Hypothesis H_jobs_must_arrive_to_execute:
        jobs_execute_after_jitter job_arrival job_jitter sched.
      Hypothesis H_completed_jobs_dont_execute:
        completed_jobs_dont_execute job_cost sched.

      (* Also assume that jobs are sequential (as required by the workload bound). *)
      Hypothesis H_sequential_jobs: sequential_jobs sched.

      (* Assume that the scheduler is work-conserving and respects the FP policy. *)
      Hypothesis H_work_conserving: work_conserving job_arrival job_cost job_jitter arr_seq sched.
      Hypothesis H_respects_FP_policy:
        respects_FP_policy job_arrival job_cost job_task job_jitter arr_seq sched higher_priority.

      Let no_deadline_missed_by_task (tsk: sporadic_task) :=
        task_misses_no_deadline job_arrival job_cost job_deadline job_task arr_seq sched tsk.
      Let no_deadline_missed_by_job :=
        job_misses_no_deadline job_arrival job_cost job_deadline sched.
      Let response_time_bounded_by (tsk: sporadic_task) :=
        is_response_time_bound_of_task job_arrival job_cost job_task arr_seq sched tsk.

      (* In the following theorem, we prove that any response-time bound contained
         in fp_claimed_bounds is safe. The proof follows by induction on the task set:

           Induction hypothesis: all higher-priority tasks have safe response-time bounds.
           Inductive step: We prove that the response-time bound of the current task is safe.

         Note that the inductive step is a direct application of the main Theorem from
         bertogna_fp_theory.v. *)
      Theorem fp_analysis_yields_response_time_bounds :
        forall tsk R,
          (tsk, R) \In fp_claimed_bounds ts ->
          response_time_bounded_by tsk (task_jitter tsk + R).
      Proof.
        rename H_valid_job_parameters into JOBPARAMS, H_valid_task_parameters into TASKPARAMS,
               H_constrained_deadlines into RESTR, H_completed_jobs_dont_execute into COMP,
               H_jobs_must_arrive_to_execute into MUSTARRIVE,
               H_all_jobs_from_taskset into ALLJOBS.
        intros tsk R MATCH.
        assert (SOME: exists hp_bounds, fp_claimed_bounds ts = Some hp_bounds /\
                                        (tsk, R) \in hp_bounds).
        {
          destruct (fp_claimed_bounds ts); last by done.
          by exists l; split.
        } clear MATCH; des; rename SOME0 into IN.

        have UNZIP := fp_claimed_bounds_unzip ts hp_bounds SOME.

        set elem := (tsk,R).
        move: IN => /(nthP elem) [idx LTidx EQ].
        set NTH := fun k => nth elem hp_bounds k.
        set TASK := fun k => (NTH k).1.
        set RESP := fun k => (NTH k).2.
        cut (response_time_bounded_by (TASK idx) (task_jitter (TASK idx) + RESP idx));
          first by unfold TASK, RESP, NTH; rewrite EQ.
        clear EQ.

        assert (PAIR: forall idx, (TASK idx, RESP idx) = NTH idx).
        {
          by intros i; unfold TASK, RESP; destruct (NTH i).
        }

        assert (SUBST: forall i, i < size hp_bounds -> TASK i = nth tsk ts i).
        {
          by intros i LTi; rewrite /TASK /NTH -UNZIP (nth_map elem) //.
        }

        assert (SIZE: size hp_bounds = size ts).
        {
          by rewrite -UNZIP size_map.
        }

        induction idx as [idx IH'] using strong_ind.

        assert (IH: forall tsk_hp R_hp, (tsk_hp, R_hp) \in take idx hp_bounds -> response_time_bounded_by tsk_hp (task_jitter tsk_hp + R_hp)).
        {
          intros tsk_hp R_hp INhp.
          move: INhp => /(nthP elem) [k LTk EQ].
          rewrite size_take LTidx in LTk.
          rewrite nth_take in EQ; last by done.
          cut (response_time_bounded_by (TASK k) (task_jitter (TASK k) + RESP k));
            first by unfold TASK, RESP, NTH; rewrite EQ.
          by apply IH'; try (by done); apply (ltn_trans LTk).
        } clear IH'.

        unfold response_time_bounded_by in *.

        exploit (fp_claimed_bounds_rcons (take idx ts) (take idx hp_bounds) (TASK idx) (TASK idx) (RESP idx)).
        {
          by rewrite PAIR SUBST // -2?take_nth -?SIZE // (fp_claimed_bounds_take _ hp_bounds).
        }
        intros [_ [_ [REC DL]]].

        apply bertogna_cirinei_response_time_bound_fp with
              (task_cost0 := task_cost) (task_period0 := task_period)
              (task_deadline0 := task_deadline) (job_deadline0 := job_deadline) (tsk0 := (TASK idx))
              (job_task0 := job_task) (ts0 := ts) (hp_bounds0 := take idx hp_bounds)
              (job_jitter0 := job_jitter) (higher_eq_priority := higher_priority); try (by done).
        {
          cut (NTH idx \in hp_bounds = true);
            [intros IN | by apply mem_nth].
          by rewrite set_mem -UNZIP; apply/mapP; exists (TASK idx, RESP idx); rewrite PAIR.
        }
        {
          intros hp_tsk IN INTERF.
          exists (RESP (index hp_tsk ts)).
          move: (IN) => INDEX; apply nth_index with (x0 := tsk) in INDEX.
          rewrite -{1}[hp_tsk]INDEX -SUBST; last by rewrite SIZE index_mem.
          assert (UNIQ: uniq hp_bounds).
          {
            apply map_uniq with (f := fst); unfold unzip1 in *; rewrite UNZIP.
            by destruct ts.
          }
          rewrite -filter_idx_lt_take //.
          {
            rewrite PAIR mem_filter; apply/andP; split;
              last by apply mem_nth; rewrite SIZE index_mem.
            {
              rewrite /NTH index_uniq; [| by rewrite SIZE index_mem | by done ].
              {
                move: INTERF => /andP [HP NEQ].
                apply fp_claimed_bounds_hp_tasks_have_smaller_index with
                  (ts := ts) (elem := tsk) (hp_bounds := hp_bounds);
                  try (by done);
                  [by rewrite index_mem | by rewrite -SIZE | | by rewrite INDEX -SUBST].
                apply/eqP; intro BUG; subst idx.
                rewrite SUBST -{1}INDEX in NEQ;
                  first by rewrite eq_refl in NEQ.
                by rewrite SIZE index_mem INDEX.
              }
            }
          }
        }
        {
          intros hp_tsk R_hp IN; apply mem_take in IN.
          by apply fp_claimed_bounds_ge_cost with (ts' := ts) (rt_bounds := hp_bounds).
        }
        {
          intros hp_tsk R_hp IN; apply mem_take in IN.
          by apply fp_claimed_bounds_le_deadline with (ts' := ts) (rt_bounds := hp_bounds).
        }
        {
          rewrite REC per_task_rta_fold.
          apply per_task_rta_converges with (ts_hp := take idx ts);
            first by apply fp_claimed_bounds_take; try (by apply ltnW).
          {
            rewrite SUBST // -take_nth -?SIZE //.
            by intros i IN; eapply TASKPARAMS, mem_take, IN.
          }
          {
            rewrite -REC.
            by apply leq_trans with (n := task_jitter (TASK idx) + RESP idx); first by apply leq_addl.
          }
        }
      Qed.

      (* Therefore, if the schedulability test suceeds, ...*)
      Hypothesis H_test_succeeds: fp_schedulable ts.

      (*..., no task misses its deadline. *)
      Theorem taskset_schedulable_by_fp_rta :
        forall tsk, tsk \in ts -> no_deadline_missed_by_task tsk.
      Proof.
        have RLIST := (fp_analysis_yields_response_time_bounds).
        have UNZIP := (fp_claimed_bounds_unzip ts).
        have DL := (fp_claimed_bounds_le_deadline ts).
        unfold no_deadline_missed_by_task, task_misses_no_deadline,
               job_misses_no_deadline, completed,
               fp_schedulable,
               valid_sporadic_job_with_jitter, valid_sporadic_job in *.
        rename H_valid_job_parameters into JOBPARAMS.
        move => tsk INtsk j ARRj JOBtsk.
        destruct (fp_claimed_bounds ts) as [rt_bounds |]; last by ins.
        feed (UNZIP rt_bounds); first by done.
        assert (EX: exists R, (tsk, R) \in rt_bounds).
        {
          rewrite set_mem -UNZIP in INtsk; move: INtsk => /mapP EX.
          by destruct EX as [p]; destruct p as [tsk' R]; simpl in *; subst tsk'; exists R.
        } des.
        exploit (RLIST tsk R); [by done | by apply ARRj | by done | intro COMPLETED].
        exploit (DL rt_bounds tsk R); [by ins | by ins | clear DL; intro DL].

        rewrite eqn_leq; apply/andP; split; first by apply cumulative_service_le_job_cost.
        apply leq_trans with (n := service sched j (job_arrival j + (task_jitter tsk + R)));
          last first.
        {
          unfold valid_sporadic_taskset, is_valid_sporadic_task in *.
          apply extend_sum; rewrite // leq_add2l.
          by specialize (JOBPARAMS j ARRj); des; rewrite JOBPARAMS2 JOBtsk.
        }
        rewrite leq_eqVlt; apply/orP; left; rewrite eq_sym.
        by apply COMPLETED.
      Qed.

      (* For completeness, since all jobs of the arrival sequence
         are spawned by the task set, we also conclude that no job in
         the schedule misses its deadline. *)
      Theorem jobs_schedulable_by_fp_rta :
        forall j,
          arrives_in arr_seq j -> no_deadline_missed_by_job j.
      Proof.
        intros j ARRj.
        have SCHED := taskset_schedulable_by_fp_rta.
        unfold no_deadline_missed_by_task, task_misses_no_deadline in *.
        apply SCHED with (tsk := job_task j); try (by done).
        by apply H_all_jobs_from_taskset.
      Qed.

    End MainProof.

  End Analysis.

End ResponseTimeIterationFP.


Require Import BinNat.
Require Import Omega.
Require Import micromega.Lia.
Require Import Logic.FunctionalExtensionality.
Require Import Program.Basics.
Require Import Nnat.
Require Import bin_prelims.
Require Import bin_repeater.
Require Import bin_countdown.
Require Import bin_inverse.
Require inv_ack.

(*
==========================================================================
******* SECTION 13: THE BINARY INVERSE ACKERMANN FUNCTION ****************
==========================================================================
 *)

(*
 * This section contains the most important application of countdown,
 * the Inverse Ackermann function.
 *
 * We first define an inverse tower for the Ackermann hierarchy,
 * then write a theorem proving its correctness.
 *
 * Then we define a structurally terminating definition for the inverse
 * Ackermann function, and prove its correctness using the above theorem.
 *
 * We digress briefly to state and prove the two-argument inverse
 * Ackermann function, which some authors prefer. Again, inputs are in binary.
 *
 * Finally we state and prove the correctness of the time-bound improvement,
 * which runs in linear time.
 *)

Lemma to_nat_diag_ack :
  (fun n => repeater.ackermann n n) =
  to_nat_func (fun n : N => bin_ackermann n n).
Proof.
  apply functional_extensionality. unfold to_nat_func. intro n.
  rewrite bin_ackermann_correct. repeat rewrite Nat2N.id. trivial.
Qed.

(* Diagonal Strict Increasing *)
Lemma diag_ack_incr : increasing (fun n => bin_ackermann n n).
Proof.
  rewrite to_nat_func_incr.
  rewrite <- to_nat_diag_ack. apply inv_ack.diag_ack_incr.
Qed.

(* *********** INVERSE ACKERMANN HIERARCHY ******************* *)

(* Definition *)
Fixpoint bin_alpha (m : nat) (x : N) : N :=
  match m with
  | 0%nat => x - 1          | 1%nat => x - 2
  | 2%nat => N.div2 (x - 2) | 3%nat => N.log2 (x + 2) - 2
  | S m'  => bin_countdown_to (bin_alpha m') 1 (bin_alpha m' x)
  end.

(* Crucial Lemma to prove the link from level 2 to level 3 *)
Lemma bin_alpha_2_bin_contract :
    bin_contract_strict_above 1 (bin_alpha 2).
Proof.
  split; intro n; simpl; rewrite N.div2_div;
    [apply N.div_le_upper_bound|intro; apply N.div_le_mono]; lia.
Qed.

(* Recursion *)
Theorem bin_alpha_recursion :
    forall m, (2 <= m)%nat ->
              bin_alpha (S m) =
              compose (bin_countdown_to (bin_alpha m) 1) (bin_alpha m).
Proof.
  destruct m as [|[|[|m]]]; trivial;
    [omega | omega | intro]. clear H.
  apply functional_extensionality; intro n. unfold compose.
  simpl. rewrite N.div2_div.
  replace (n - 2) with (n + 2 - 2*2) by lia.
  rewrite div_sub by lia.
  replace (N.log2 (n + 2) - 2)
    with (N.log2 ((n + 2) / 2) - 1)
    by (rewrite <- N.div2_div, N.div2_spec, N.log2_shiftr; lia).
  remember ((n + 2) / 2) as m. clear n Heqm.
  destruct m as [|p]; trivial.
  induction p; trivial;
    rewrite bin_countdown_recursion by apply bin_alpha_2_bin_contract;
    rewrite N.div2_div;
      [remember (N.pos p~1) as m | remember (N.pos p~0) as m];
        replace (m - 2 - 2) with (m - 2 * 2) by lia;
          rewrite div_sub by lia;
            rewrite <- N.log2_shiftr, <- N.div2_spec, N.div2_div;
              remember (m - 2 <=? 1) as b;
                destruct b; symmetry in Heqb.
  1, 3: rewrite N.leb_le, N.le_sub_le_add_l in Heqb;
    apply (N.div_le_mono _ _ 2) in Heqb.
  2, 4: lia.
  1, 2: unfold N.div at 2 in Heqb; simpl in Heqb;
    rewrite N.log2_null; trivial.
  1, 2: replace (Npos p) with (m / 2) in IHp.
  2: rewrite <- N.div2_succ_double.
  4: rewrite <- N.div2_double.
  2, 4: rewrite <- N.div2_div; f_equal; trivial.
  1, 2: rewrite N.leb_gt in Heqb; rewrite N.add_comm, <- IHp;
    symmetry; apply N.sub_add;
      rewrite N.le_ngt, N.lt_1_r, N.log2_null, <- N.lt_succ_r;
      simpl; rewrite <- N.le_ngt, le_div_mul_N by lia; lia.
Qed.

(* ******* CORRECTNESS OF INVERSE ACKERMANN HIERARCHY ************** *)

(* Countdown composed with self preserves binary contractiveness *)
Theorem countdown_bin_contract : forall f a b,
    bin_contract_strict_above a f ->
    bin_contract_strict_above b (compose (bin_countdown_to f a) f).
Proof.
  intros f a b Haf0. assert (H:=Haf0). destruct H as [Hf Haf].
  split; intro n; [ |intro Hbn]; unfold compose;
    rewrite bin_countdown_repeat by assumption; rewrite <- repeat_S_comm;
      rewrite N.le_ngt; intro;
        apply (repeat_bin_contract_strict _ _ _ _ Haf0) in H.
  - specialize (nat_size_contract (n - a)).
    rewrite N2Nat.inj_sub. omega.
  - replace (nat_size (n - a)) with
      (S (nat_size ((n - a) / 2))) in H.
    + specialize (nat_size_contract ((n - a) / 2)) as H0.
      simpl in H. rewrite <- Nat.succ_le_mono in H.
      apply (Nat.le_trans _ _ _ H) in H0.
      assert (S (N.to_nat (n/2)) <= N.to_nat (n/2))%nat as contra.
      2: omega.
      apply (Nat.le_trans _ (S (N.to_nat ((n + b) / 2))) _);
        [rewrite <- Nat.succ_le_mono |
         apply (Nat.le_trans _ (N.to_nat ((n - a) / 2)) _)].
      1,3 : rewrite <- le_N_nat; apply N.div_le_mono; lia.
      apply (Nat.le_trans _
            (S (N.to_nat ((n + b) / 2) +
                nat_size (f (f (repeat f (N.to_nat ((n + b) / 2)) n)) - a)))
             _);
        omega.
    + rewrite <- N.div2_div.
      destruct (n - a); [simpl in H; omega | induction p; trivial].
Qed.

Lemma bin_alpha_2_correct : forall n,
    bin_alpha 2 n = N.of_nat (inv_ack.alpha 2 (N.to_nat n)).
Proof.
  intro n. unfold bin_alpha. unfold to_N_func.
  remember (N.to_nat n) as m.
  replace (n - 2) with (N.of_nat (m - 2)) by lia.
  rewrite <- Nat2N.inj_div2. f_equal. clear Heqm. clear n.
  replace (inv_ack.alpha 2 m) with
    (countdown.countdown_to (inv_ack.alpha 1) 1 (inv_ack.alpha 1 m))
      by trivial.
  rewrite inv_ack.alpha_1.
  generalize (m - 2)%nat. clear m. intro n.
  assert (Nat.div2 n =
          countdown.countdown_to (fun n0 : nat => (n0 - 2)%nat) 1 n
          /\ Nat.div2 (S n) =
             countdown.countdown_to (fun n0 : nat => (n0 - 2)%nat) 1 (S n)).
  { induction n; split; trivial. apply IHn.
    destruct (countdown.countdown_recursion 1
               (fun n0 => (n0-2)%nat) (S(S n))) as [_ H].
    - split; intro m; omega.
    - rewrite H by omega. replace (S(S n) - 2)%nat with n by omega.
      simpl. f_equal. apply IHn. }
  apply H.
Qed.

(*
 * Every bin_alpha level starting from 2 is strictly binary
 * contracting above 1, so bin_countdown_to to 1 works
 * properly for them.
 *)
Theorem bin_alpha_contract_strict_above_1 : forall m,
    (2 <= m)%nat -> bin_contract_strict_above 1 (bin_alpha m).
Proof.
  destruct m as [|[|m]]; try omega; intro; clear H. induction m.
  - split; intro n; simpl; rewrite N.div2_div;
      [apply N.div_le_upper_bound|intro; apply N.div_le_mono]; lia.
  - rewrite bin_alpha_recursion; [| omega].
    apply (countdown_bin_contract _ _ _ IHm).
Qed.

Theorem bin_alpha_correct :
    forall m, bin_alpha m = to_N_func (inv_ack.alpha m).
Proof.
  induction m as [|[|[|m]]]; apply functional_extensionality;
    intro n; unfold to_N_func. 2: rewrite inv_ack.alpha_1.
  1,2: simpl; lia. 1: apply bin_alpha_2_correct.
  rewrite bin_alpha_recursion by omega. unfold compose.
  rewrite bin_countdown_correct by
      (apply bin_alpha_contract_strict_above_1; omega).
  rewrite IHm. rewrite <- nat_N_func_id.
  replace (N.to_nat 1) with 1%nat by trivial.
  unfold to_N_func. f_equal. rewrite Nat2N.id. trivial.
Qed.

Corollary bin_alpha_ackermann :
    forall m, upp_inv_rel (bin_alpha m) (bin_ackermann (N.of_nat m)).
Proof.
  intros m n p. rewrite <- (N2Nat.id n). rewrite bin_ackermann_correct.
  rewrite bin_alpha_correct. unfold to_N_func. rewrite <- le_nat_N.
  rewrite le_N_nat. repeat rewrite Nat2N.id.
  destruct (inv_ack.alpha_correct m) as [_ H]. apply H.
Qed.

(* ********* TWO PARAMETERS INVERSE ACKERMANN ************* *)

(* Two parameters Binary Inverse Ackerman worker function *)
Fixpoint two_params_bin_inv_ack_wkr (f : N -> N) (n k : N) (b : nat) : N :=
  match b with
  | 0%nat => 0
  | S b'  => if (n <=? k) then 0
              else let g := (bin_countdown_to f 1) in
                   N.succ (two_params_bin_inv_ack_wkr (compose g f) (g n) k b')
  end.

(* Two parameters Binary Inverse Ackermann function *)
Definition two_params_bin_inv_ack (m n : N) : N :=
  let n' := (N.log2_up n) in
    let m' := m / n in
      if (n' - 2 <=? m') then 1
        else if (N.div2 (n' - 2) <=? m') then 2
          else let f := (fun x => N.log2 (x + 2) - 2) in
            3 + two_params_bin_inv_ack_wkr f (f n') m' (nat_size n).

(* Correctness proofs begin here *)

(* Small helper lemma - alpha decreases by level *)
Lemma bin_alpha_decr_by_lvl :
    forall i n, bin_alpha (S i) n <= bin_alpha i n.
Proof.
  intros i n. repeat rewrite bin_alpha_correct.
  unfold to_N_func. rewrite <- le_nat_N.
  apply inv_ack.alpha_decr_by_lvl.
Qed.

(* Lemma about worker function's inner working *)
Lemma two_params_bin_inv_ack_wkr_intermediate :
    forall i n k b, k < bin_alpha (S (S i)) n -> (i <= b)%nat ->
      two_params_bin_inv_ack_wkr (bin_alpha 3) (bin_alpha 3 n) k b =
        N.of_nat i +
          two_params_bin_inv_ack_wkr
            (bin_alpha (S (S (S i)))) (bin_alpha (S (S (S i))) n) k (b - i).
Proof.
  induction i; intros n k b Hin Hib.
  - rewrite N.add_0_l. f_equal. omega.
  - rewrite IHi.
    2: apply (N.lt_le_trans _ (bin_alpha (S (S (S i))) n) _ Hin),
               bin_alpha_decr_by_lvl.
    2: omega.
    unfold two_params_bin_inv_ack_wkr at 1.
    replace (b - i)%nat with (S (b - (S i)))%nat by omega.
    rewrite <- N.leb_gt in Hin. rewrite Hin.
    fold two_params_bin_inv_ack_wkr.
    rewrite <- N.add_succ_comm. f_equal. lia.
Qed.

(* Correctness theorem for two_params_bin_inv_ack worker *)
Theorem two_params_bin_inv_ack_upp_inv :
    forall m n, two_params_bin_inv_ack m n =
      1 + upp_inv (fun x => bin_ackermann (N.succ x) (m / n)) (N.log2_up n).
Proof.
  intros m n. unfold two_params_bin_inv_ack.
  remember (N.log2_up n) as b. remember (m / n) as a.
  fold (bin_alpha 2 b). fold (bin_alpha 1 b). fold (bin_alpha 3 b).
  assert (increasing (fun x : N => bin_ackermann (N.succ x) a)) as HF.
  { unfold increasing. intros x y.
    repeat rewrite bin_ackermann_correct.
    rewrite <- lt_nat_N. repeat rewrite N2Nat.inj_succ.
    rewrite lt_N_nat, Nat.succ_lt_mono. apply inv_ack.ack_incr_by_lvl.
  }
  assert (N.to_nat b <= nat_size n)%nat as Hb.
  { rewrite Heqb, nat_size_log2_up, <- le_N_nat.
    apply N.log2_up_le_mono. lia. }
  remember (nat_size n) as t. clear Heqb Heqa Heqt m n.
  remember (upp_inv (fun x : N => bin_ackermann (N.succ x) a) b) as q.
  assert (upp_inv_rel (upp_inv (fun x : N => bin_ackermann (N.succ x) a))
          (fun x : N => bin_ackermann (N.succ x) a)) as HfF.
  { apply upp_inv_correct, HF. }
  assert (bin_alpha (S (N.to_nat q)) b <= a) as Hq.
  { apply bin_alpha_ackermann.
    replace (N.of_nat _) with (N.succ q) by lia. apply HfF. lia. }
  remember (N.to_nat q) as p. replace q with (N.of_nat p) in * by lia.
  clear Heqp q. destruct p.
  - rewrite <- N.leb_le in Hq. rewrite Hq. trivial.
  - assert (a < bin_alpha (S p) b) as Hp.
    { rewrite N.lt_nge, (bin_alpha_ackermann (S p) a b), Nat2N.inj_succ.
      rewrite <- (HfF (N.of_nat p) b). lia. }
    destruct p.
    + rewrite <- N.leb_gt in Hp. rewrite Hp.
      rewrite <- N.leb_le in Hq. rewrite Hq. trivial.
    + assert (a < bin_alpha 2 b <= bin_alpha 1 b) as H12.
      { split; [|apply bin_alpha_decr_by_lvl].
        apply (N.lt_le_trans _ (bin_alpha (S (S p)) b) _ Hp).
        clear Hq Hp Heqq. induction p; [lia|].
        apply (N.le_trans _ (bin_alpha (S (S p)) b) _).
        apply bin_alpha_decr_by_lvl. apply IHp. }
      destruct H12 as [H2 H1]. apply (N.lt_le_trans _ _ _ H2) in H1.
      rewrite <- N.leb_gt in H1. rewrite <- N.leb_gt in H2.
      rewrite H1, H2. fold (bin_alpha 3).
      replace (1 + N.of_nat (S (S p))) with (3 + (N.of_nat p)) by lia.
      f_equal.
      rewrite (two_params_bin_inv_ack_wkr_intermediate p _ _ _ Hp).
      * rewrite <- N.add_0_r. f_equal.
        destruct (t - p)%nat; trivial. rewrite <- N.leb_le in Hq.
        unfold two_params_bin_inv_ack_wkr. rewrite Hq. trivial.
      * apply (Nat.le_trans _ (N.to_nat b) _); trivial.
        rewrite N.lt_nge, (bin_alpha_ackermann (S (S p)) a b),
          <- N.lt_nge, lt_N_nat in Hp.
        apply (Nat.le_trans _
                 (N.to_nat (bin_ackermann (N.of_nat (S (S p))) a)) _);
        [|lia]. rewrite bin_ackermann_correct. repeat rewrite Nat2N.id.
        clear Hq Heqq Hp. induction p; [omega|]. rewrite Nat.le_succ_l.
        apply (Nat.le_lt_trans _ _ _ IHp).
        apply inv_ack.ack_incr_by_lvl. omega.
Qed.

(* *********** INVERSE ACKERMANN FUNCTION ******************** *)

Fixpoint bin_inv_ack_wkr (f : N -> N) (n k : N) (b : nat) : N :=
  match b with
  | 0%nat  => k
  | S b' =>
    if n <=? k then k
    else let g := (bin_countdown_to f 1) in
         bin_inv_ack_wkr (compose g f) (g n) (N.succ k) b'
  end.

(* IMPORTANT *)
(* Definition by hard-coding the second bin_alpha level, runtime O(n) *)
Definition bin_inv_ack n :=
  if (n <=? 1) then 0
  else if (n <=? 3) then 1
       else if (n <=? 7) then 2
            else let f := (fun x => N.log2 (x + 2) - 2) in
                 bin_inv_ack_wkr f (f n) 3 (nat_size n).

(* Below we give a correctness proof of the above definition. *)

(* Intermediate lemmas about bin_inv_ack_wkr *)
Lemma bin_alpha_contr : forall i n,
    (S i < N.to_nat (bin_alpha (S i) n))%nat ->
    (i < N.to_nat (bin_alpha i n))%nat.
Proof.
  intros i n. specialize (bin_alpha_ackermann i (N.of_nat i) n).
  specialize (bin_alpha_ackermann (S i) (N.of_nat (S i)) n).
  specialize (diag_ack_incr (N.of_nat i) (N.of_nat (S i))). lia.
Qed.

Lemma bin_inv_ack_wkr_intermediate : forall i n b,
    (S (S i) < N.to_nat (bin_alpha (S (S i)) n))%nat ->
    (S (S i) < b)%nat ->
    bin_inv_ack_wkr (bin_alpha 3) (bin_alpha 3 n) 3 b =
    bin_inv_ack_wkr (bin_alpha (S (S (S i))))
                    (bin_alpha (S (S (S i))) n) (N.of_nat (S (S (S i)))) (b - i).
Proof.
  induction i; intros n b Hn Hib; symmetry;
    [f_equal; omega | rewrite bin_alpha_recursion by omega].
  rewrite IHi; [replace (b - i)%nat with (S (b - S i))%nat by omega
               |apply (bin_alpha_contr _ _ Hn) | omega].
  rewrite lt_nat_N, N2Nat.id in Hn. rewrite <- N.leb_gt in Hn.
  unfold bin_inv_ack_wkr at 2. rewrite Hn. rewrite <- Nat2N.inj_succ. trivial.
Qed.

(* Proof that bin_inv_ack_wkr is correct given sufficient budget *)
Lemma bin_inv_ack_wkr_sufficient :
  forall n b,
    (8 <= n <= bin_ackermann b b) ->
      bin_inv_ack_wkr (bin_alpha 3) (bin_alpha 3 n) 3 (N.to_nat b)
        = upp_inv (fun m => bin_ackermann m m) n.
Proof.
  assert (Hincr := diag_ack_incr).
  assert (Hack := upp_inv_correct _ Hincr).
  unfold upp_inv_rel in Hack. intros n b [Hn Hnb].
  remember (N.to_nat (upp_inv (fun m : N => bin_ackermann m m) n)) as p.
  rewrite <- (Nat2N.id p) in Heqp. apply N2Nat.inj in Heqp.
  assert (n <= bin_ackermann (N.of_nat p) (N.of_nat p)) as Hp0 by
        (apply Hack; lia).
  destruct p as [|[|[|p]]].
  1,2,3 : unfold N.of_nat in Heqp; unfold bin_ackermann in Hp0;
    simpl in Hp0; lia.
  assert (bin_ackermann (N.of_nat (S (S p))) (N.of_nat (S (S p))) < n)
      as Hp1
      by (rewrite N.lt_nge; rewrite <- Hack; lia).
  assert (S (S p) < N.to_nat b)%nat as Hpb.
  { rewrite Nat.lt_nge. intro Hc.
    inversion Hc as [Hc0|Hc1]. rewrite <- Hc0 in Hp1.
    rewrite N2Nat.id in Hp1. lia.
    rewrite prelims.lt_S_le, lt_nat_N, N2Nat.id in H.
    apply Hincr in H. lia. }
  rewrite (bin_inv_ack_wkr_intermediate p).
  - replace (N.to_nat b - p)%nat with
      (S (N.to_nat b - S p))%nat by omega.
    unfold bin_inv_ack_wkr.
    replace (bin_alpha (S (S (S p))) n <=? N.of_nat (S (S (S p))))
      with true;
        trivial.
    symmetry. rewrite N.leb_le.
    rewrite (bin_alpha_ackermann (S (S (S p))) _ _). apply Hp0.
  - rewrite lt_nat_N. rewrite N2Nat.id. rewrite N.lt_nge.
    rewrite (bin_alpha_ackermann (S (S p)) _ _). lia.
  - apply Hpb.
Qed.

(* Helper lemmas regarding ackermann at level 3 *)
Open Scope nat_scope.

Lemma ack_2 : forall n, repeater.ackermann 2 n = 2 * n + 3.
Proof.
  induction n; trivial.
  replace (repeater.ackermann 2 (S n)) with
    (repeater.ackermann 1 (repeater.ackermann 2 n)) by trivial.
  rewrite IHn. rewrite inv_ack.ack_1. omega.
Qed.

Lemma ack_3 : forall n, repeater.ackermann 3 n = 2 ^ (n + 3) - 3.
Proof.
  induction n; trivial.
  replace (repeater.ackermann 3 (S n)) with
    (repeater.ackermann 2 (repeater.ackermann 3 n)) by trivial.
  rewrite IHn. rewrite ack_2.
  replace (S n + 3) with (S (n + 3)) by trivial.
  replace (2 ^ (S (n+3))) with (2 * 2 ^ (n+3)) by trivial.
  assert (3 <= 2 ^ (n+3)).
  { apply (Nat.le_trans _ (2^3) _); [simpl; omega|].
    apply Nat.pow_le_mono_r; omega. } omega.
Qed.

Close Scope nat_scope.

(* Proof that bin_inv_ack is correct *)
Theorem bin_inv_ack_correct : bin_inv_ack = to_N_func (inv_ack.inv_ack).
Proof.
  apply functional_extensionality. intro n.
  assert (n = 0 \/ n = 1 \/ n = 2 \/ n = 3 \/ n = 4 \/
          n = 5 \/ n = 6 \/ n = 7 \/ 8 <= n) as Hn by lia.
  repeat destruct Hn as [Hn|Hn]; try rewrite Hn; trivial.
  unfold bin_inv_ack.
  replace (n <=? 1) with false by (symmetry; rewrite N.leb_gt; lia).
  replace (n <=? 3) with false by (symmetry; rewrite N.leb_gt; lia).
  replace (n <=? 7) with false by (symmetry; rewrite N.leb_gt; lia).
  rewrite <- (Nat2N.id (nat_size n)). fold (bin_alpha 3).
  fold (bin_alpha 3 n). rewrite bin_inv_ack_wkr_sufficient.
  - unfold upp_inv. f_equal. rewrite <- to_nat_diag_ack. symmetry.
    apply inverse.upp_inv_unique. apply inv_ack.diag_ack_incr.
    apply inv_ack.inv_ack_correct.
  - split; [lia|]. rewrite bin_ackermann_correct. rewrite Nat2N.id.
    apply (N.le_trans _ (N.of_nat (repeater.ackermann 3 (nat_size n))) _).
    + clear Hn. rewrite le_N_nat. rewrite Nat2N.id.
      rewrite ack_3. destruct n; simpl; [lia|].
      induction p; [| |simpl; lia]; simpl;
        [rewrite Pos2Nat.inj_xI|rewrite Pos2Nat.inj_xO];
        assert (3 <=
          2 ^ ((fix nat_pos_size (x : positive) : nat :=
                 match x with
                 | (y~1)%positive | (y~0)%positive => S (nat_pos_size y)
                 | 1%positive => 1
                 end) p + 3))%nat
          by (apply (Nat.le_trans _ (2^3) _); [simpl; omega|];
              apply Nat.pow_le_mono_r; omega); omega.
    + rewrite <- le_nat_N. rewrite Nat.le_ngt.
      assert (H := inv_ack.ack_incr_by_lvl (nat_size n)).
      apply (increasing_expanding.incr_twoways _ (nat_size n) 3) in H.
      simpl in *. rewrite <- H. apply nat_size_incr in Hn.
      simpl in Hn. omega.
Qed.

(* Please see inv_ack_test.v for a demonstration of the runtime of bin_inv_ack *)


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.
Require real.Real.
Require real.RealInfix.

Parameter pow2: Z -> R.

Axiom Power_0 : ((pow2 0%Z) = 1%R).

Axiom Power_s : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p : forall (n:Z), (n <= 0%Z)%Z ->
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_s_all : forall (n:Z), ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p_all : forall (n:Z),
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_1_2 : ((05 / 10)%R = (Rdiv 1%R 2%R)%R).

Axiom Power_1 : ((pow2 1%Z) = 2%R).

Axiom Power_neg1 : ((pow2 (-1%Z)%Z) = (05 / 10)%R).

Axiom Power_non_null_aux : forall (n:Z), (0%Z <= n)%Z -> ~ ((pow2 n) = 0%R).

Axiom Power_neg_aux : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (-n)%Z) = (Rdiv 1%R (pow2 n))%R).

Axiom Power_non_null : forall (n:Z), ~ ((pow2 n) = 0%R).

Axiom Power_neg : forall (n:Z), ((pow2 (-n)%Z) = (Rdiv 1%R (pow2 n))%R).

Open Scope Z_scope.

(* Why3 goal *)
Theorem Power_sum_aux : forall (n:Z) (m:Z), (0%Z <= m)%Z ->
  ((pow2 (n + m)%Z) = ((pow2 n) * (pow2 m))%R).
(* YOU MAY EDIT THE PROOF BELOW *)
intros n m Hmpos.
cut (0 <= m); auto with zarith.
apply Z_lt_induction with
  (P:= fun m =>
      0 <= m ->pow2 (n + m) = (pow2 n * pow2 m)%R);
  auto with zarith.
intros x Hind Hxpos.
assert (h:(x = 0 \/ x > 0)) by omega.
destruct h.
subst x.
rewrite Power_0.
replace (n+0) with n by omega.
rewrite Rmult_1_r.
auto.
replace (x) with ((x-1)+1) by omega.
rewrite Power_s_all;auto with zarith.
replace (n + (x-1+1)) with (n+(x-1)+1) by omega.
rewrite Power_s_all;auto with zarith.
rewrite Hind;auto with zarith.
rewrite <-Rmult_assoc.
rewrite <-Rmult_assoc.
rewrite Rmult_comm with (r1:=pow2 n)(r2:=2%R).
auto with zarith.

Qed.


Require Import Problem Omega Znumtheory.
Import ZArith.Zdiv.

Lemma prime_not_0 : forall p, prime p -> p <> 0.
Proof.
  intros.
  contradict H.
  subst p.
  apply not_prime_0.
Qed.

Lemma zero_factor (p a b : Z) : prime p -> (a * b) mod p = 0 -> a mod p = 0 \/ b mod p = 0.
Proof.
  intros.
  assert (p <> 0) by (apply prime_not_0; auto).
  apply (Zmod_divide (a * b) p H1) in H0; clear H1.
  apply (prime_mult p H) in H0.
  destruct H0; apply Zdivide_mod in H0; auto.
Qed.

Lemma transpose (p a b : Z) : p > 0 -> a mod p = b mod p -> (a - b) mod p = 0.
Proof.
  intros.
  rewrite (Zmod_eq a p H) in H0.
  rewrite (Zmod_eq b p H) in H0.
  assert (forall x y z w : Z, x - z = y - w -> x - y = z - w) by (intros; omega).
  apply (H1 a b (a / p * p) (b / p * p)) in H0; clear H1.
  rewrite <- Z.mul_sub_distr_r in H0.
  rewrite H0.
  apply Z_mod_mult.
Qed.

Theorem solution: task.
Proof.
  unfold task.
  intros.
  destruct H0; destruct H1; destruct H2.
  apply transpose in H3; [|omega].
  rewrite <- Z.mul_sub_distr_r in H3.
  apply zero_factor in H3; [|auto].
  destruct H3.
  - assert (0 <= k1 - k2 < p \/ 0 <= k2 - k1 < p) by omega.
    destruct H7.
    * rewrite Zmod_small in H3; omega.
    * apply Z_mod_zero_opp_full in H3.
      rewrite Zmod_small in H3; omega.
  - rewrite Zmod_small in H3; omega.
Qed.


(* This file contains lemmas regarding the accuracy of floating point
  operations such as BPLUS, BFMA, and BMULT. *)

Require Import vcfloat.VCFloat vcfloat.FPLib.
From vcfloat Require Import IEEE754_extra.
Require Import common op_defs.
Require Import ZArith.
Local Open Scope R.

Section NAN.

Definition fma_no_overflow (t: type) (x y z: R) : Prop :=
  (Rabs (rounded t  (x * y + z)) < Raux.bpow Zaux.radix2 (femax t))%R.

Definition Bmult_no_overflow (t: type) (x y: R) : Prop :=
  (Rabs (rounded t  (x * y)) < Raux.bpow Zaux.radix2 (femax t))%R.

Lemma generic_round_property:
  forall (t: type) (x: R),
exists delta epsilon : R,
   delta * epsilon = 0 /\
  (Rabs delta <= default_rel t)%R /\
  (Rabs epsilon <= default_abs t)%R /\
   Generic_fmt.round Zaux.radix2
              (SpecFloat.fexp (fprec t) (femax t))
              (BinarySingleNaN.round_mode BinarySingleNaN.mode_NE)
               x = (x * (1+delta)+epsilon)%R.
Proof.
intros.
destruct (Relative.error_N_FLT Zaux.radix2 (SpecFloat.emin (fprec t) (femax t)) (fprec t)
             (fprec_gt_0 t) (fun x0 : Z => negb (Z.even x0)) x)
  as [delta [epsilon [? [? [? ?]]]]].
exists delta, epsilon.
split; [ | split]; auto.
Qed.

Lemma fma_accurate {NAN: Nans} :
   forall (t: type)
             (x: ftype t) (FINx: finite x)
             y (FINy: finite y)
             z (FINz: finite z)
          (FIN: fma_no_overflow t (FT2R x) (FT2R y) (FT2R z)),
  exists delta, exists epsilon,
   delta * epsilon = 0 /\
   Rabs delta <= default_rel t /\
   Rabs epsilon <= default_abs t /\
   (FT2R (BFMA x y z) = (FT2R x * FT2R y + FT2R z) * (1+delta) + epsilon)%R.
Proof.
intros.
rewrite finite_is_finite in FINx.
rewrite finite_is_finite in FINy.
rewrite finite_is_finite in FINz.
pose proof (Binary.Bfma_correct  (fprec t) (femax t)  (fprec_gt_0 t) (fprec_lt_femax t) (fma_nan t)
                      BinarySingleNaN.mode_NE x y z FINx FINy FINz).
change (Binary.B2R (fprec t) (femax t) ?x) with (@FT2R t x) in *.
cbv zeta in H.
pose proof (
   Raux.Rlt_bool_spec
        (Rabs
           (Generic_fmt.round Zaux.radix2
              (SpecFloat.fexp (fprec t) (femax t))
              (BinarySingleNaN.round_mode
                 BinarySingleNaN.mode_NE) (FT2R x * FT2R y + FT2R z)))
        (Raux.bpow Zaux.radix2 (femax t))).
destruct H0.
-
destruct H as [? _].
fold (@BFMA NAN t) in H.
rewrite H.
apply generic_round_property.
-
red in FIN. unfold rounded in FIN.
Lra.lra.
Qed.

Lemma is_finite_fma_no_overflow {NAN: Nans} (t : type) :
  forall (x y z : ftype t)
  (HFINb : finite (BFMA x y z)),
  fma_no_overflow t (FT2R x) (FT2R y) (FT2R z).
Proof.
intros.
red. set (ov:= bpow Zaux.radix2 (femax t)).
pose proof Rle_or_lt ov (Rabs (rounded t (FT2R x * FT2R y + FT2R z)))  as Hor;
  destruct Hor; auto.
apply Rlt_bool_false in H.
destruct (BFMA_finite_e _ _ _ HFINb) as (A & B & C).
unfold rounded, FT2R, ov in H.
rewrite finite_is_finite in *.
pose proof (Binary.Bfma_correct  (fprec t) (femax t)
    (fprec_gt_0 t) (fprec_lt_femax t) (fma_nan t) BinarySingleNaN.mode_NE x y z A B C) as
  H0.
simpl in H0; simpl in H;
rewrite H in H0. clear H. fold (@BFMA NAN t) in H0.
destruct (BFMA x y z); try discriminate.
Qed.

Lemma fma_accurate' {NAN: Nans} :
   forall (t: type) (x y z : ftype t)
          (FIN: finite (BFMA x y z)),
  exists delta, exists epsilon,
   delta * epsilon = 0 /\
   Rabs delta <= default_rel t /\
   Rabs epsilon <= default_abs t /\
   (FT2R (BFMA x y z) = (FT2R x * FT2R y + FT2R z) * (1+delta) + epsilon)%R.
Proof.
intros.
destruct (BFMA_finite_e _ _ _ FIN) as (A & B & C).
apply fma_accurate; auto.
apply is_finite_fma_no_overflow; auto.
Qed.

Lemma BMULT_accurate {NAN: Nans}:
   forall (t: type) (x y: ftype t) (FIN: Bmult_no_overflow t (FT2R x) (FT2R y)),
  exists delta, exists epsilon,
   delta * epsilon = 0 /\
   Rabs delta <= default_rel t /\
   Rabs epsilon <= default_abs t /\
   (FT2R (BMULT x y) = (FT2R x * FT2R y) * (1+delta) + epsilon)%R.
Proof.
intros.
pose proof (Binary.Bmult_correct (fprec t) (femax t) (fprec_gt_0 t) (fprec_lt_femax t)
                (mult_nan t) BinarySingleNaN.mode_NE x y).
change (Binary.B2R (fprec t) (femax t) ?x) with (@FT2R t x) in *.
cbv zeta in H.
pose proof (
   Raux.Rlt_bool_spec
        (Rabs
           (Generic_fmt.round Zaux.radix2
              (SpecFloat.fexp (fprec t) (femax t))
              (BinarySingleNaN.round_mode
                 BinarySingleNaN.mode_NE) (FT2R x * FT2R y)))
        (Raux.bpow Zaux.radix2 (femax t))).
destruct H0.
destruct H as [? _].
unfold BMULT, BINOP.
rewrite H.
apply generic_round_property.
red in FIN. unfold rounded in FIN.
Lra.lra.
Qed.

Lemma finite_BMULT_no_overflow {NAN: Nans} (t : type) :
  forall (x y : ftype t)
  (HFINb :finite (BMULT x y)),
  Bmult_no_overflow t (FT2R x) (FT2R y).
Proof.
intros.
rewrite finite_is_finite in HFINb.
pose proof Rle_or_lt (bpow Zaux.radix2 (femax t))
  (Rabs (rounded t (FT2R x * FT2R y)))  as Hor;
  destruct Hor; auto.
apply Rlt_bool_false in H; red.
unfold rounded, FT2R  in H.
pose proof (Binary.Bmult_correct  (fprec t) (femax t)
    (fprec_gt_0 t) (fprec_lt_femax t) (mult_nan t) BinarySingleNaN.mode_NE x y) as
  H0.
simpl in H0; simpl in H;
rewrite H in H0.  unfold BMULT, BINOP in HFINb.
destruct ((Binary.Bmult (fprec t) (femax t) (fprec_gt_0 t)
             (fprec_lt_femax t) (mult_nan t) BinarySingleNaN.mode_NE x y));
simpl;  try discriminate.
Qed.

Lemma BMULT_accurate' {NAN: Nans}:
  forall (t: type)
  (x y : ftype t)
  (FIN: finite (BMULT x y)),
  exists delta, exists epsilon,
   delta * epsilon = 0 /\
   Rabs delta <= default_rel t /\
   Rabs epsilon <= default_abs t /\
   (FT2R (BMULT x y) = (FT2R x * FT2R y) * (1+delta) + epsilon)%R.
Proof.
intros.
pose proof BMULT_accurate t x y (finite_BMULT_no_overflow t x y FIN); auto.
Qed.

Definition Bplus_no_overflow (t: type) (x y: R) : Prop :=
  (Rabs ( Generic_fmt.round Zaux.radix2
              (SpecFloat.fexp (fprec t) (femax t))
              (BinarySingleNaN.round_mode
                 BinarySingleNaN.mode_NE)  (x + y )) < Raux.bpow Zaux.radix2 (femax t))%R.

Lemma BPLUS_neg_zero {NAN: Nans} (t : type) (a : ftype t) :
  finite a ->
  BPLUS a neg_zero = a.
Proof.
destruct a; try contradiction; unfold neg_zero; simpl; auto.
destruct s; auto.
Qed.

Lemma BPLUS_accurate {NAN: Nans} (t : type) :
 forall   (x: ftype t) (FINx: finite x)
             y (FINy: finite y)
          (FIN: Bplus_no_overflow t (FT2R x) (FT2R y)),
  exists delta,
   Rabs delta <= default_rel t /\
   (FT2R (BPLUS x y ) = (FT2R x + FT2R y) * (1+delta))%R.
Proof.
intros.
rewrite finite_is_finite in FINx, FINy.
pose proof (Binary.Bplus_correct  (fprec t) (femax t)  (fprec_gt_0 t) (fprec_lt_femax t) (plus_nan t)
                      BinarySingleNaN.mode_NE x y FINx FINy).
change (Binary.B2R (fprec t) (femax t) ?x) with (@FT2R t x) in *.
cbv zeta in H.
pose proof (
   Raux.Rlt_bool_spec
        (Rabs
           (Generic_fmt.round Zaux.radix2
              (SpecFloat.fexp (fprec t) (femax t))
              (BinarySingleNaN.round_mode
                 BinarySingleNaN.mode_NE) (FT2R x + FT2R y)))
        (Raux.bpow Zaux.radix2 (femax t))).
destruct H0.
-
destruct H as [? _].
unfold BPLUS, BINOP.
rewrite H.
assert (A: Generic_fmt.generic_format Zaux.radix2
       (FLT.FLT_exp (SpecFloat.emin (fprec t) (femax t)) (fprec t))
       (FT2R x) ) by (apply Binary.generic_format_B2R).
assert (B: Generic_fmt.generic_format Zaux.radix2
       (FLT.FLT_exp (SpecFloat.emin (fprec t) (femax t)) (fprec t))
       (FT2R y) ) by (apply Binary.generic_format_B2R).
pose proof Plus_error.FLT_plus_error_N_ex   Zaux.radix2 (SpecFloat.emin (fprec t) (femax t))
 (fprec t) (fun x0 : Z => negb (Z.even x0)) (FT2R x) (FT2R y) A B.
unfold Relative.u_ro in H1. fold (default_rel t) in H1.
destruct H1 as (d & Hd & Hd').

assert (  Generic_fmt.round Zaux.radix2 (SpecFloat.fexp (fprec t) (femax t))
    (BinarySingleNaN.round_mode BinarySingleNaN.mode_NE)
    (FT2R x + FT2R y)  =  Generic_fmt.round Zaux.radix2
        (FLT.FLT_exp (SpecFloat.emin (fprec t) (femax t)) (fprec t))
        (Generic_fmt.Znearest (fun x0 : Z => negb (Z.even x0)))
        (FT2R x + FT2R y)) by auto.
rewrite <- H1 in Hd'. clear H1. rewrite Hd'; clear Hd'.
exists d; split; auto.
eapply Rle_trans; [apply Hd |].
apply Rdiv_le_left.
apply Fourier_util.Rlt_zero_pos_plus1.
apply default_rel_gt_0.
eapply Rle_trans with (default_rel t * 1); try nra.
-
red in FIN.
Lra.lra.
Qed.

Lemma BPLUS_finite_e {NAN: Nans} (t : type) :
  forall (x y : ftype t)
  (FIN: finite (BPLUS x y)),
  finite x /\ finite y.
Proof.
intros.
destruct x,y; try contradiction; simpl; auto.
destruct s,s0; simpl in FIN; auto.
Qed.

Lemma finite_sum_no_overflow {NAN: Nans} (t : type) :
  forall (x y: ftype t)
  (HFINb : finite (BPLUS x y)),
  Bplus_no_overflow t (FT2R x) (FT2R y).
Proof.
intros.
 destruct (BPLUS_finite_e _ _ _ HFINb) as [A B].
rewrite finite_is_finite in HFINb.
pose proof Rle_or_lt (bpow Zaux.radix2 (femax t)) (Rabs (rounded t (FT2R x + FT2R y)))  as Hor;
  destruct Hor; auto.
apply Rlt_bool_false in H.
unfold rounded, FT2R in H.
rewrite finite_is_finite in *.
pose proof (Binary.Bplus_correct  (fprec t) (femax t)
    (fprec_gt_0 t) (fprec_lt_femax t) (plus_nan t) BinarySingleNaN.mode_NE x y A B) as
  H0;
rewrite H in H0;
destruct H0 as ( C & _).
unfold BPLUS, BINOP in HFINb.
destruct ((Binary.Bplus (fprec t) (femax t) (fprec_gt_0 t) (fprec_lt_femax t)
             (plus_nan t) BinarySingleNaN.mode_NE x y));
simpl; try discriminate.
Qed.

Lemma BPLUS_accurate' {NAN: Nans} (t : type) :
  forall (x y : ftype t)
  (FIN: finite (BPLUS x y)),
  exists delta,
   Rabs delta <= default_rel t /\
   (FT2R (BPLUS x y ) = (FT2R x + FT2R y) * (1+delta))%R.
Proof.
intros.
destruct (BPLUS_finite_e _ _ _ FIN) as [A B].
apply BPLUS_accurate; auto.
apply finite_sum_no_overflow; auto.
Qed.

Lemma BDIV_sep_zero' {NAN: Nans} (t : type) :
  forall (f1 f2 : ftype t)
  (Hfin: finite (BDIV f1 f2))
  (Hfin1: Binary.is_finite_strict _ _ f1 = true)
  (Hfin2: finite f2),
  Binary.is_finite_strict _ _ f2 = true.
Proof.
intros ? ?;
destruct f2; destruct f1; simpl; try discriminate; auto.
Qed.

Lemma fprec_lb {NAN: Nans} (t : type) :
  (2 <= fprec t)%Z.
Proof. pose proof ( fprec_gt_one t); lia. Qed.

Lemma femax_lb {NAN: Nans} (t : type) :
  (3 <= femax t)%Z.
Proof.
pose proof fprec_lb t;
pose proof fprec_lt_femax t; lia.
Qed.

Lemma femax_minus_fprec (t: type):
  (0 < (femax t - fprec t))%Z.
Proof.
pose proof fprec_lt_femax t; lia.
Qed.

Lemma in_fprec_bound1 {NAN: Nans} (t : type) :
 (- 2 ^ fprec t <= 1 <= 2 ^ fprec t)%Z.
Proof.
split. eapply Z.le_trans with (-2 ^ 2)%Z; [|lia].
apply Z.opp_le_mono; rewrite !Z.opp_involutive.
apply Z.pow_le_mono_r; [lia |apply fprec_lb ].
eapply Z.le_trans with (2 ^ 2)%Z; [lia|].
apply Z.pow_le_mono_r; [lia |apply fprec_lb ].
Qed.

Lemma in_fprec_bound0 {NAN: Nans} (t : type) :
 (- 2 ^ fprec t <= 0 <= 2 ^ fprec t)%Z.
Proof.
split. eapply Z.le_trans with (-2 ^ 2)%Z; [|lia].
apply Z.opp_le_mono; rewrite !Z.opp_involutive.
apply Z.pow_le_mono_r; [lia |apply fprec_lb ].
eapply Z.le_trans with (2 ^ 2)%Z; [lia|].
apply Z.pow_le_mono_r; [lia |apply fprec_lb ].
Qed.

Lemma Bone_strict_finite {NAN: Nans} (t : type) :
  Binary.is_finite_strict _ _ (Zconst t 1) = true.
Proof.
destruct
  (BofZ_exact (fprec t) (femax t) (Pos2Z.is_pos (fprecp t)) (fprec_lt_femax t) 1 (in_fprec_bound1 t))
  as ( A & H & _); fold (Zconst t 1) in *.
destruct (Zconst t 1);
  simpl; simpl in A; try discriminate; auto.
nra.
Qed.

Lemma BDIV_sep_zero1 {NAN: Nans} (t : type) :
  forall (f1 : ftype t)
  (Hfin: finite (BDIV (Zconst t 1) f1))
  (Hfin1: finite f1),
  f1 <> (Zconst t 0).
Proof.
intros. intros HF.
pose proof BDIV_sep_zero' t (Zconst t 1) f1 Hfin (Bone_strict_finite t) Hfin1.
destruct f1; try discriminate; auto.
Qed.

Lemma BDIV_sep_zero2 {NAN: Nans} (t : type) :
  forall (f1 : ftype t)
  (Hfin: finite (BDIV (Zconst t 1) f1))
  (Hfin1: finite f1),
  f1 <> (neg_zero).
Proof.
intros. intros HF.
pose proof BDIV_sep_zero' t (Zconst t 1) f1 Hfin (Bone_strict_finite t) Hfin1.
destruct f1; try discriminate; auto.
Qed.

Lemma BDIV_FT2R_sep_zero {NAN: Nans} (t : type) :
  forall (f1 : ftype t)
  (Hfin: finite (BDIV (Zconst t 1) f1))
  (Hfin1: finite f1),
  FT2R f1 <> 0.
Proof.
intros. intros HF.
pose proof BDIV_sep_zero1 t f1 Hfin Hfin1 as H0.
pose proof BDIV_sep_zero2 t f1 Hfin Hfin1 as H1.
pose proof BDIV_sep_zero' t (Zconst t 1) f1 Hfin (Bone_strict_finite t) Hfin1 as HFINx.
rewrite finite_is_finite in Hfin.
rewrite finite_is_finite in Hfin1.
pose proof Binary.B2R_Bsign_inj (fprec t) (femax t) f1 neg_zero Hfin1 (eq_refl _) as HA.
pose proof Binary.B2R_Bsign_inj (fprec t) (femax t) f1 (Zconst t 0) Hfin1 (eq_refl _) as HB.
destruct f1; try discriminate; auto.
destruct s; try discriminate; auto.
Qed.

Lemma is_finite_fma_no_overflow' {NAN: Nans} (t : type) :
  forall (x y z: ftype t)
  (Hfinx: finite x)
  (Hfiny: finite y)
  (Hfinz: finite z)
  (Hov : fma_no_overflow t (FT2R x) (FT2R y) (FT2R z)),
 finite (BFMA x y z).
Proof.
intros.
rewrite finite_is_finite in Hfinx, Hfiny, Hfinz|-*.
pose proof (Binary.Bfma_correct  (fprec t) (femax t)  (fprec_gt_0 t) (fprec_lt_femax t) (fma_nan t)
                      BinarySingleNaN.mode_NE x y z Hfinx Hfiny Hfinz).
unfold fma_no_overflow, FT2R, rounded in Hov;
apply Rlt_bool_true in Hov.
cbv zeta in H.
rewrite Hov in H; simpl in H; destruct H as (_ & B & _); simpl; auto.
Qed.

Lemma finite_BOPP: forall {NAN: Nans} (t: type) (x: ftype t),
   finite (BOPP x) <-> finite x.
Proof.
intros.
unfold BOPP.
rewrite !finite_is_finite, Binary.is_finite_Bopp.
tauto.
Qed.

End NAN.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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