Require Import "F01_Defs".
(** * III. Affaiblissement par déclaration d'une sorte
Dans cette partie, nous étudions essentiellement l'affaiblissement de l'environnement par ajout d'une déclaration d'une variable de type. Nous utilisons pour cela un prédicat inductif caractérisant de tels affaiblissements d'un environnement. *)

(** [insert_kind] est le prédicat inductif tel que [insert_kind X e e'] est prouvable ssi [e'] est une extension de [e] par une déclaration de sorte à l'indice [X] (et donc [e'] est l'affaiblissement de [e]). *)
Inductive insert_kind : var -> env -> env -> Prop :=
| Top : forall e K, insert_kind 0 e (ConsK K e)
| BelowK : forall e e' X K, insert_kind X e e' ->
      insert_kind (S X) (ConsK K e) (ConsK K e')
| BelowT : forall e e' X T, insert_kind X e e' ->
      insert_kind (S X) (ConsT T e) (ConsT (tshift X T) e').
(** *)

(** ** Préservation du typage *)

(** On montre ici deux lemmes intermédiaires puis on montre que l'affaiblissement par déclaration de sorte préserve les trois formes de typage. *)

(** Le lemme suivant montre que l'ajout d'une sorte dans un environnement n'empêche pas d'accéder à ses anciens éléments, tant que l'on tient compte de l'éventuel shifting provoqué par l'insertion. *)
Lemma insert_kind_get_kind : forall X e e', insert_kind X e e' ->
                forall Y, get_kind Y e = (get_kind (if leb X Y then S Y else Y) e').
(** *)
Proof.
  intros X e e' H. induction H; intros.
  + easy.
  + destruct Y; simpl.
    reflexivity.
    rewrite IHinsert_kind.
    destruct (leb X Y) eqn:?.
    reflexivity. reflexivity.
  + destruct Y; simpl.
    reflexivity.
    rewrite IHinsert_kind.
    destruct (leb X Y) eqn:?.
    reflexivity. reflexivity.
Qed.
(** *)

(** De même, on montre que les types accessibles avant insertion d'une sorte le sont toujours après. *)
Lemma insert_kind_get_type : forall X e e', insert_kind X e e' -> forall x,
            get_type x e' = match nat_compare X x with
                              | Lt => option_map (tshift X) (get_type (x-1) e)
                              | Eq => None
                              | Gt => option_map (tshift (X)) (get_type x e) end.
(** *)
Proof.
  intros X e e' H. induction H; intros.
  + destruct x; simpl. reflexivity. now rewrite <- minus_n_O.
  + destruct x; simpl. reflexivity.
    rewrite IHinsert_kind.
    destruct (nat_compare X x) eqn:?; try reflexivity.
    * apply nat_compare_Lt_lt in Heqc. destruct x. inv Heqc. rewrite <- minus_n_O. replace (S x - 1) with x. simpl.  destruct (get_type x e); [|reflexivity]. simpl. apply f_equal. specialize (tshift_tshift t 0 X). rewrite plus_O_n. easy. omega.
    * apply nat_compare_Gt_gt in Heqc. destruct (get_type x e) as [T|]; [|reflexivity]. simpl. apply f_equal.      specialize (tshift_tshift T 0 X). rewrite plus_O_n. easy.
  + destruct x; simpl. apply f_equal.  specialize (tshift_tshift T 0 X). rewrite plus_O_n. easy.
    rewrite IHinsert_kind.
    destruct (nat_compare X x) eqn:?; try reflexivity.
    * apply nat_compare_Lt_lt in Heqc. destruct x. inv Heqc. rewrite <- minus_n_O. replace (S x - 1) with x.
      simpl.  destruct (get_type x e); [|reflexivity]. simpl. apply f_equal. specialize (tshift_tshift t 0 X). rewrite plus_O_n. easy. omega.
    * apply nat_compare_Gt_gt in Heqc. destruct (get_type x e); [|reflexivity]. simpl. apply f_equal.
      specialize (tshift_tshift t 0 X). rewrite plus_O_n. easy.
Qed.
(** *)

(** On montre ici, que l'affaiblissement préserve les jugements de typage [wf] et [kinding].
La preuve se fait par induction mutuelle sur le jugement de typage, c'est pour cela que nous montrons les deux propriétés en même temps. *)
Lemma insert_kind_wf_kinding :
  (forall e, wf e -> forall X e', insert_kind X e e' -> wf e')
      /\
        (forall e T K, kinding e T K -> forall X e', insert_kind X e e' -> kinding e' (tshift X T) K).
(** *)
Proof.
  apply wf_kinding_ind_mut.
  + intros X e' Hins. inv Hins. apply WfConsK. apply WfNil.
  + intros K e w IHHwf X e' Hins. inv Hins. apply WfConsK. now apply WfConsK.
    apply WfConsK. eapply IHHwf. eassumption.
  + intros T e K k IHHwf w IHHwf0 X e' Hins. inv Hins. apply WfConsK. eapply WfConsT; eassumption. eapply WfConsT. apply IHHwf.
assumption. eapply IHHwf0. eassumption.
  + intros e Y p q w IHHwf H H' X e' Hins. specialize (insert_kind_get_kind _ _ _ Hins Y). intros. simpl. destruct (leb X Y); eapply KVar; eauto. congruence.
    congruence.
  + intros e T1 T2 p q k IHHwf Hk IHHwf0 X e' Hins. apply KArrow; auto.
  + intros e T p q k IHHwf X e' Hins. apply KFAll. apply IHHwf. now apply BelowK.
Qed.
(** *)

(** Et on montre ici la préservation du troisième jugement de typage : [typing]. *)
Lemma insert_kind_typing : forall e t T, typing e t T ->
       forall X e', insert_kind X e e' -> typing e' (shift X t) (tshift X T).
(** *)
Proof.
  intros e t T Ht. induction Ht; intros X e' Hins.
  + simpl. destruct (leb X x) eqn:?.
    * econstructor. eapply insert_kind_wf_kinding; eassumption.
      rewrite (insert_kind_get_type _ _ _ Hins (S x)).
      replace (nat_compare X (S x)) with Lt. simpl.
      rewrite <- minus_n_O. now rewrite H0. symmetry.
      apply nat_compare_lt. apply leb_complete in Heqb. omega.
    * constructor. eapply insert_kind_wf_kinding; eassumption.
      rewrite (insert_kind_get_type _ _ _ Hins (x)).
      replace (nat_compare X (x)) with Gt. now rewrite H0. symmetry.
      apply nat_compare_gt. apply leb_complete_conv in Heqb. omega.
  + simpl. constructor. specialize (IHHt (S X) (ConsT (tshift X T1) e')). specialize (tshift_tshift T2 0 X). intro Htt.
    rewrite plus_O_n in Htt. rewrite Htt. apply IHHt.
    now constructor.
  + econstructor. now apply IHHt1.
    now apply IHHt2.
  + constructor. apply IHHt. now constructor.
  + replace (tshift X (tsubst 0 T2 T1)) with (tsubst 0 (tshift X T2) (tshift (S X) T1)).
    apply (TAppT _ _ K). replace (FAll K (tshift (S X) T1)) with (tshift X (FAll K T1)).
    now apply IHHt. reflexivity.
    eapply insert_kind_wf_kinding; eassumption.
    specialize  (tsubst_tshift T1 0 X T2).
    now rewrite plus_O_n.
Qed.
(** *)

(** ** Préservation de [kinding] par substitution  *)

(** Ici, nous profitons de [insert_kind] pour exprimer le fait que la substitution préserve [kinding]. *)

(**  *)
Lemma kinding_wf : forall e T K, kinding e T K -> wf e.
(** *)
Proof.
intros e T K H. induction H; auto.
now inv IHkinding.
Qed.
(** *)

(**  *)
Lemma tsubst_kinding : forall T e' K, kinding e' T K ->
                                      forall X e L U, insert_kind X e e' -> get_kind X e' = Some L -> kinding e U L -> kinding e (tsubst X U T) K.
(** *)
Proof.
  induction T as [Y|T1 IHT1 T2 IHT2|k T]; intros e' K HkT X e L U Hik Hgk HkU.
  - destruct (nat_compare X Y) eqn:H.
    + simpl. rewrite H. destruct (le_lt_dec K L) as [H1|H1].
      inversion HkT. comp.
      replace L with p in HkU.
      now apply (cumulativity U e p K).
      rewrite <- H in H3. rewrite H3 in Hgk. now injection Hgk.
      apply (cumulativity U e L K). omega. assumption.
    + simpl. rewrite H. inversion HkT. comp. apply KVar with p.
      apply (kinding_wf e U L HkU).
      rewrite (insert_kind_get_kind X e e'). replace (leb X (Y-1)) with true.
      replace (S (Y-1)) with Y. assumption.
      destruct Y; [omega|]. now mysimpl.
      symmetry. comp. omega.
      assumption. assumption.
      (* comme les 2e et 3e + se ressemblent,
         comment on les traite de la meme façon ? *)
    + simpl. rewrite H. inversion HkT. apply KVar with p.
      apply (kinding_wf e U L HkU).
      rewrite (insert_kind_get_kind X e e'). replace (leb X Y) with false. assumption.
      symmetry. comp. omega.
      assumption. assumption.
  - simpl. inversion HkT. apply KArrow.
    + now apply IHT1 with e' L.
    + now apply IHT2 with e' L.
  - simpl. inversion HkT. apply KFAll.
    apply IHT with (ConsK k e') L. assumption.
    now constructor.
    assumption.
    apply (proj2 (insert_kind_wf_kinding)) with e. assumption.
    constructor.
Qed.

(** #<script src="jquery.min.js"></script>#
    #<script src="coqjs.js"></script># *)


(* P. Casteran *)

Require Import Arith.

Fixpoint mult2 (n:nat) : nat :=
  match n with
  | O => 0
  | S p => S (S (mult2 p))
  end.

Lemma mult2_double : forall n:nat, mult2 n = n + n.
Proof.
 intro n; elim n; simpl; auto.
 intros n0 H; rewrite H.
 rewrite <- plus_n_Sm; trivial.
Qed.


Require Import prosa.classic.util.all.
Require Import prosa.classic.analysis.global.parallel.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 parallel jobs. *)
  Section Analysis.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: 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.

    (* 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 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 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) /\
            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 deadline... *)
      Lemma fp_claimed_bounds_le_deadline :
        forall ts' rt_bounds tsk R,
          fp_claimed_bounds ts' = Some rt_bounds ->
          (tsk, R) \in rt_bounds ->
          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 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) (xs := ts) (default := 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.
        rewrite leq_add2l leq_div2r //.
        unfold total_interference_bound_fp.
        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.
        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].
      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 fixedpoint.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...*)
      Variable 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 task_cost task_deadline job_cost job_deadline job_task 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 they arrived and no longer
         than their execution costs,... *)
      Hypothesis H_jobs_must_arrive_to_execute:
        jobs_must_arrive_to_execute job_arrival sched.
      Hypothesis H_completed_jobs_dont_execute:
        completed_jobs_dont_execute job_cost sched.

      (* Assume that the scheduler is work-conserving and respects the FP policy. *)
      Hypothesis H_work_conserving: work_conserving job_arrival job_cost arr_seq sched.
      Hypothesis H_respects_FP_policy:
        respects_FP_policy job_arrival job_cost job_task 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 R.
      Proof.
        rename H_valid_job_parameters into JOBPARAMS, H_valid_task_parameters into TASKPARAMS.
        unfold valid_sporadic_taskset in *.
        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) (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 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) (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)
              (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.
              }
            }
          }
        }
        {
          rewrite REC per_task_rta_fold.
          apply per_task_rta_converges with (ts_hp := take idx ts);
            [by apply fp_claimed_bounds_take; try (by apply ltnW) | | by rewrite -REC ].
          rewrite SUBST // -take_nth -?SIZE //.
          by intros i IN; eapply TASKPARAMS, mem_take, IN.
        }
      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 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); eauto 1; intro COMPLETED.
        exploit (DL rt_bounds tsk R); [by ins | by ins | clear DL; intro DL].
        apply leq_trans with (n := service sched j (job_arrival j + R)); last first.
        {
          unfold valid_sporadic_taskset, is_valid_sporadic_task in *.
          apply extend_sum; rewrite // leq_add2l.
          specialize (JOBPARAMS j ARRj); des; rewrite JOBPARAMS1.
          by rewrite JOBtsk.
        }
        by done.
      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
  MathClasses.theory.naturals.
Require Import
  Coq.setoid_ring.Ring MathClasses.interfaces.abstract_algebra MathClasses.interfaces.naturals MathClasses.interfaces.orders MathClasses.interfaces.additional_operations.

(* * Properties of Nat Pow *)
Section nat_pow_properties.
Context `{SemiRing A} `{Naturals B} `{!NatPowSpec A B pw}.

Add Ring A: (rings.stdlib_semiring_theory A).
Add Ring B: (rings.stdlib_semiring_theory B).

Global Instance: Proper ((=) ==> (=) ==> (=)) (^) | 0.
Proof nat_pow_proper.

Global Instance nat_pow_mor_1: ∀ x : A, Setoid_Morphism (x^) | 0.
Proof. split; try apply _. Qed.

Global Instance nat_pow_mor_2: ∀ n : B, Setoid_Morphism (^n) | 0.
Proof. split; try apply _. solve_proper. Qed.

Lemma nat_pow_base_0 (n : B) : n ≠ 0 → 0 ^ n = 0.
Proof.
  pattern n. apply naturals.induction; clear n.
    solve_proper.
   intros E. now destruct E.
  intros. rewrite nat_pow_S. ring.
Qed.

Global Instance nat_pow_1: RightIdentity (^) (1:B).
Proof.
  intro. assert ((1:B) = 1 + 0) as E by ring. rewrite E.
  rewrite nat_pow_S, nat_pow_0. ring.
Qed.

Lemma nat_pow_2 x : x ^ (2:B) = x * x.
Proof. now rewrite nat_pow_S, nat_pow_1. Qed.

Lemma nat_pow_3 x : x ^ (3:B) = x * (x * x).
Proof. now rewrite nat_pow_S, nat_pow_2. Qed.

Lemma nat_pow_4 x : x ^ (4:B) = x * (x * (x * x)).
Proof. now rewrite nat_pow_S, nat_pow_3. Qed.

Global Instance nat_pow_base_1: LeftAbsorb (^) 1.
Proof.
  intro.
  pattern y. apply naturals.induction; clear y.
    solve_proper.
   apply nat_pow_0.
  intros n E. rewrite nat_pow_S. rewrite E. ring.
Qed.

Lemma nat_pow_exp_plus (x : A) (n m : B) :
  x ^ (n + m) = x ^ n * x ^ m.
Proof.
  pattern n. apply naturals.induction; clear n.
    solve_proper.
   rewrite nat_pow_0, left_identity. ring.
  intros n E.
  rewrite <-associativity.
  rewrite 2!nat_pow_S.
  rewrite E. ring.
Qed.

Lemma nat_pow_base_mult (x y : A) (n : B) :
  (x * y) ^ n = x ^ n * y ^ n.
Proof.
  pattern n. apply naturals.induction; clear n.
    solve_proper.
   rewrite ?nat_pow_0. ring.
  intros n E.
  rewrite ?nat_pow_S.
  rewrite E. ring.
Qed.

Lemma nat_pow_exp_mult (x : A) (n m : B) :
  x ^ (n * m) = (x ^ n) ^ m.
Proof.
  pattern m. apply naturals.induction; clear m.
    solve_proper.
   rewrite right_absorb. now rewrite ?nat_pow_0.
  intros m E.
  rewrite nat_pow_S, <-E.
  rewrite distribute_l, right_identity.
  now rewrite nat_pow_exp_plus.
Qed.

Instance nat_pow_ne_0 `{!NoZeroDivisors A} `{!PropHolds ((1:A) ≠ 0)} (x : A) (n : B) :
  PropHolds (x ≠ 0) → PropHolds (x ^ n ≠ 0).
Proof.
  pattern n. apply naturals.induction; clear n.
    solve_proper.
    intros. rewrite nat_pow_0. now apply (rings.is_ne_0 1).
  intros n E F G. rewrite nat_pow_S in G.
  unfold PropHolds in *.
  apply (no_zero_divisors x); split; eauto.
Qed.

Context `{Apart A} `{!FullPseudoSemiRingOrder (A:=A) Ale Alt} `{PropHolds (1 ≶ 0)}.

Instance: StrongSetoid A := pseudo_order_setoid.

Instance nat_pow_apart_0 (x : A) (n : B) : PropHolds (x ≶ 0) → PropHolds (x ^ n ≶ 0).
Proof.
  pattern n. apply naturals.induction; clear n.
    solve_proper.
   intros. now rewrite nat_pow_0.
  intros n E F. rewrite nat_pow_S.
  rewrite <-(rings.mult_0_r x).
  apply (strong_left_cancellation (.*.) x). now apply E.
Qed.

Instance nat_pow_nonneg (x : A) (n : B) : PropHolds (0 ≤ x) → PropHolds (0 ≤ x ^ n).
Proof.
  intros. pattern n. apply naturals.induction; clear n.
    solve_proper.
   rewrite nat_pow_0. apply _.
  intros. rewrite nat_pow_S. apply _.
Qed.

Instance nat_pow_pos (x : A) (n : B) : PropHolds (0 < x) → PropHolds (0 < x ^ n).
Proof.
  rewrite !lt_iff_le_apart.
  intros [? ?]. split.
   now apply nat_pow_nonneg.
  symmetry. apply nat_pow_apart_0.
  red. now symmetry.
Qed.

Lemma nat_pow_ge_1 (x : A) (n : B) : 1 ≤ x → 1 ≤ x ^ n.
Proof.
  intros. pattern n. apply naturals.induction.
    solve_proper.
   now rewrite nat_pow_0.
  intros. rewrite nat_pow_S.
  now apply semirings.ge_1_mult_compat.
Qed.
End nat_pow_properties.

(* Due to bug #2528 *)
#[global]
Hint Extern 18 (PropHolds (_ ^ _ ≠ 0)) => eapply @nat_pow_ne_0 : typeclass_instances.
#[global]
Hint Extern 18 (PropHolds (_ ^ _ ≶ 0)) => eapply @nat_pow_apart_0 : typeclass_instances.
#[global]
Hint Extern 18 (PropHolds (0 ≤ _ ^ _)) => eapply @nat_pow_nonneg : typeclass_instances.
#[global]
Hint Extern 18 (PropHolds (0 < _ ^ _)) => eapply @nat_pow_pos : typeclass_instances.

Section preservation.
  Context `{Naturals B} `{SemiRing A1} `{!NatPowSpec A1 B pw1} `{SemiRing A2} `{!NatPowSpec A2 B pw2}
    {f : A1 → A2} `{!SemiRing_Morphism f}.

  Add Ring B2 : (rings.stdlib_semiring_theory B).

  Lemma preserves_nat_pow x (n : B) : f (x ^ n) = (f x) ^ n.
  Proof.
    revert n. apply naturals.induction.
      solve_proper.
     rewrite nat_pow_0, nat_pow_0. now apply rings.preserves_1.
    intros n E.
    rewrite nat_pow_S, rings.preserves_mult, E.
    now rewrite nat_pow_S.
  Qed.
End preservation.

Section exp_preservation.
  Context `{SemiRing A} `{Naturals B1} `{Naturals B2} `{!NatPowSpec A B1 pw1} `{!NatPowSpec A B2 pw2}
    {f : B1 → B2} `{!SemiRing_Morphism f}.

  Lemma preserves_nat_pow_exp x (n : B1) : x ^ (f n) = x ^ n.
  Proof.
    revert n. apply naturals.induction.
      solve_proper.
     rewrite rings.preserves_0.
     now rewrite 2!nat_pow_0.
    intros n E.
    rewrite rings.preserves_plus, rings.preserves_1.
    rewrite 2!nat_pow_S.
    now rewrite E.
  Qed.
End exp_preservation.

(* Very slow default implementation by translation into Peano *)
Section nat_pow_default.
  Context `{SemiRing A}.

  Global Instance nat_pow_peano: Pow A nat :=
    fix nat_pow_rec (x: A) (n : nat) : A := match n with
    | 0 => 1
    | S n => x * @pow _ _ nat_pow_rec x n
    end.

  Instance: Proper ((=) ==> (=) ==> (=)) nat_pow_peano.
  Proof.
    intros ? ? E a ? [].
    induction a; try easy.
    simpl. now rewrite IHa, E.
  Qed.

  Global Instance: NatPowSpec A nat nat_pow_peano.
  Proof. split; try apply _; easy. Qed.

  Context `{Naturals B}.

  Global Instance default_nat_pow: Pow A B | 10 := λ x n, x ^ naturals_to_semiring B nat n.
  Global Instance: NatPowSpec A B default_nat_pow.
  Proof.
    split; unfold pow, default_nat_pow.
      solve_proper.
     intros x. now rewrite rings.preserves_0.
    intros x n. now rewrite rings.preserves_plus, rings.preserves_1.
  Qed.
End nat_pow_default.

Set Warnings "-unsupported-attributes". (* FIXME: remove when minimal Coq version is enough *)

#[global]
Typeclasses Opaque default_nat_pow.


Require Export GeoCoq.Tarski_dev.Ch06_out_lines.

Section Sums.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

(** Existence of the sum *)

Lemma ex_sums : forall A B C D, exists E F, SumS A B C D E F.
Proof.
  intros A B C D.
  destruct (segment_construction A B C D) as [R [HR1 HR2]].
  exists A, R, A, B, R.
  repeat split; Cong.
Qed.

(** Commutativity of the sum. *)

Lemma sums_sym : forall A B C D E F, SumS A B C D E F -> SumS C D A B E F.
Proof.
  intros A B C D E F HSumS.
  destruct HSumS as [P [Q [R [HBet [HCong1 [HCong2 HCong3]]]]]].
  exists R, Q, P.
  repeat split; Between; Cong.
Qed.

(** Unicity of the sum. *)

Lemma sums2__cong56 : forall A B C D E F E' F', SumS A B C D E F -> SumS A B C D E' F' ->
  Cong E F E' F'.
Proof.
  intros A B C D E F E' F' HSumS HSumS'.
  destruct HSumS as [P [Q [R [HBet [HCong1 [HCong2 HCong3]]]]]].
  destruct HSumS' as [P' [Q' [R' [HBet' [HCong1' [HCong2' HCong3']]]]]].
  apply cong_transitivity with P R; Cong.
  apply cong_transitivity with P' R'; trivial.
  apply l2_11 with Q Q'; trivial.
  apply cong_transitivity with A B; Cong.
  apply cong_transitivity with C D; Cong.
Qed.

(** Unicity of the difference of segments. *)

Lemma sums2__cong12 : forall A B C D E F A' B', SumS A B C D E F -> SumS A' B' C D E F ->
  Cong A B A' B'.
Proof.
  intros A B C D E F A' B' HSumS HSumS'.
  destruct HSumS as [P [Q [R [HBet [HCong1 [HCong2 HCong3]]]]]].
  destruct HSumS' as [P' [Q' [R' [HBet' [HCong1' [HCong2' HCong3']]]]]].
  apply cong_transitivity with P Q; Cong.
  apply cong_transitivity with P' Q'; trivial.
  apply l4_3 with R R'; trivial.
  apply cong_transitivity with E F; Cong.
  apply cong_transitivity with C D; Cong.
Qed.

(** Unicity of the difference of segments on the right. *)

Lemma sums2__cong34 : forall A B C D E F C' D', SumS A B C D E F -> SumS A B C' D' E F ->
  Cong C D C' D'.
Proof.
  intros A B C D E F C' D' HSumS HSumS'.
  apply sums2__cong12 with A B E F; apply sums_sym; trivial.
Qed.

(** Cong preserves SumS *)

Lemma cong3_sums__sums : forall A B C D E F A' B' C' D' E' F',
  Cong A B A' B' -> Cong C D C' D' -> Cong E F E' F' -> SumS A B C D E F ->
  SumS A' B' C' D' E' F'.
Proof.
  intros A B C D E F A' B' C' D' E' F' HCong1 HCong2 HCong3 HSumS.
  destruct HSumS as [P [Q [R [HBet [HCong4 [HCong5 HCong6]]]]]].
  exists P, Q, R; repeat split; trivial; eapply cong_transitivity; eauto.
Qed.

(** The degenerate segments represent the additive identity *)

Lemma sums123312 : forall A B C, SumS A B C C A B.
Proof.
  intros A B C.
  exists A, B, B.
  repeat split; Between; Cong.
Qed.

Lemma sums__cong1245 : forall A B C D E, SumS A B C C D E -> Cong A B D E.
Proof.
  intros A B C D E HSum.
  apply (sums2__cong56 A B C C); trivial.
  apply sums123312.
Qed.

Lemma sums__eq34 : forall A B C D, SumS A B C D A B -> C = D.
Proof.
  intros A B C D HSum.
  apply cong_identity with C.
  apply sums2__cong34 with A B A B; trivial.
  apply sums123312.
Qed.

Lemma sums112323 : forall A B C, SumS A A B C B C.
Proof.
  intros; apply sums_sym, sums123312.
Qed.

Lemma sums__cong2345 : forall A B C D E, SumS A A B C D E -> Cong B C D E.
Proof.
  intros A B C D E HSum.
  apply (sums2__cong56 A A B C); trivial.
  apply sums112323.
Qed.

Lemma sums__eq12 : forall A B C D, SumS A B C D C D -> A = B.
Proof.
  intros A B C D HSum.
  apply cong_identity with A.
  apply sums2__cong12 with C D C D; trivial.
  apply sums112323.
Qed.

(** Some permutation properties *)

Lemma sums_left_comm : forall A B C D E F, SumS A B C D E F -> SumS B A C D E F.
Proof.
  intros A B C D E F HSumS.
  apply (cong3_sums__sums A B C D E F); Cong.
Qed.

Lemma sums_middle_comm : forall A B C D E F, SumS A B C D E F -> SumS A B D C E F.
Proof.
  intros; apply sums_sym, sums_left_comm, sums_sym; trivial.
Qed.

Lemma sums_right_comm : forall A B C D E F, SumS A B C D E F -> SumS A B C D F E.
Proof.
  intros A B C D E F HSumS.
  apply (cong3_sums__sums A B C D E F); Cong.
Qed.

Lemma sums_comm : forall A B C D E F, SumS A B C D E F -> SumS B A D C F E.
Proof.
  intros; apply sums_left_comm, sums_middle_comm, sums_right_comm; trivial.
Qed.

(** Basic case of sum *)

Lemma bet__sums : forall A B C, Bet A B C -> SumS A B B C A C.
Proof.
  intros A B C HBet.
  exists A, B, C; repeat split; Cong.
Qed.

Lemma sums_assoc_1 : forall A B C D E F G H I J K L,
  SumS A B C D G H -> SumS C D E F I J -> SumS G H E F K L ->
  SumS A B I J K L.
Proof.
  intros A B C D E F G H I J K L HSumS1 HSumS2 HSumS3.
  destruct HSumS1 as [P [Q [R [HBet [HCong1 [HCong2 HCong3]]]]]].
  destruct (segment_construction P R E F) as [S [HS1 HS2]].
  exists P, Q, S; repeat split; trivial.
  - apply between_exchange4 with R; trivial.
  - apply (sums2__cong56 C D E F); trivial.
    exists Q, R, S; repeat split; Cong.
    apply between_exchange3 with P; trivial.
  - apply (sums2__cong56 G H E F); trivial.
    exists P, R, S; repeat split; Cong.
Qed.

Lemma sums_assoc_2 : forall A B C D E F G H I J K L,
  SumS A B C D G H -> SumS C D E F I J -> SumS A B I J K L ->
  SumS G H E F K L.
Proof.
  intros A B C D E F G H I J K L HSumS1 HSumS2 HSumS3.
  apply sums_sym, sums_assoc_1 with C D A B I J; apply sums_sym; trivial.
Qed.

(** Associativity of the sum. *)

Lemma sums_assoc : forall A B C D E F G H I J K L,
  SumS A B C D G H -> SumS C D E F I J ->
  (SumS G H E F K L <-> SumS A B I J K L).
Proof.
  intros A B C D E F G H I J K L HSumS1 HSumS2.
  split; intro HSumS3.
  - apply sums_assoc_1 with C D E F G H; trivial.
  - apply sums_assoc_2 with A B C D I J; trivial.
Qed.

(** AB <= AB + CD *)

Lemma sums__le1256 : forall A B C D E F, SumS A B C D E F -> Le A B E F.
Proof.
  intros A B C D E F HSumS.
  destruct HSumS as [P [Q [R [HBet [HCong1 [HCong2 HCong3]]]]]].
  apply (l5_6 P Q P R); trivial.
  exists Q; Cong.
Qed.

(** CD <= AB + CD *)

Lemma sums__le3456 : forall A B C D E F, SumS A B C D E F -> Le C D E F.
Proof.
  intros A B C D E F HSumS.
  apply sums__le1256 with A B, sums_sym; trivial.
Qed.

(** If the sum of two segments is degenerate, then the segments are degenerate *)

Lemma eq_sums__eq : forall A B C D E, SumS A B C D E E -> A = B /\ C = D.
Proof.
  intros A B C D E HSumS.
  split; apply le_zero with E; [apply sums__le1256 with C D|apply (sums__le3456 A B)]; assumption.
Qed.

Lemma sums_diff_1 : forall A B C D E F, A <> B -> SumS A B C D E F -> E <> F.
Proof.
  intros A B C D E F Hdiff HSumS Heq.
  subst F.
  apply Hdiff.
  destruct (eq_sums__eq A B C D E HSumS); assumption.
Qed.

Lemma sums_diff_2 : forall A B C D E F, C <> D -> SumS A B C D E F -> E <> F.
Proof.
  intros A B C D E F Hdiff HSumS Heq.
  subst F.
  apply Hdiff.
  destruct (eq_sums__eq A B C D E HSumS); assumption.
Qed.

(** SumS preserves Le *)

Lemma le2_sums2__le : forall A B C D E F A' B' C' D' E' F',
  Le A B A' B' -> Le C D C' D' -> SumS A B C D E F -> SumS A' B' C' D' E' F' ->
  Le E F E' F'.
Proof.
  intros A B C D E F A' B' C' D' E' F' HLe1 HLe2 HSumS HSumS'.
  destruct HSumS as [P [Q [R [HBet [HCong1 [HCong2 HCong3]]]]]].
  destruct HSumS' as [P' [Q' [R' [HBet' [HCong1' [HCong2' HCong3']]]]]].
  apply (l5_6 P R P' R'); trivial.
  apply bet2_le2__le1346 with Q Q'; trivial.
  apply (l5_6 A B A' B'); Cong.
  apply (l5_6 C D C' D'); Cong.
Qed.

(** If AB <= A'B', CD <= C'D' and AB + CD = A'B' + C'D', then AB = A'B' and CD = C'D' *)

Lemma le2_sums2__cong12 : forall A B C D E F A' B' C' D',
  Le A B A' B' -> Le C D C' D' -> SumS A B C D E F -> SumS A' B' C' D' E F ->
  Cong A B A' B'.
Proof.
  intros A B C D E F A' B' C' D' HLe1 HLe2 HSum HSum'.
  apply sums2__cong12 with C D E F; trivial.
  destruct (ex_sums A' B' C D) as [E' [F' HSum1]].
  apply (cong3_sums__sums A' B' C D E' F'); Cong.
  apply le_anti_symmetry.
    apply le2_sums2__le with A' B' C D A' B' C' D'; Le.
    apply le2_sums2__le with A B C D A' B' C D; Le.
Qed.

Lemma le2_sums2__cong34 : forall A B C D E F A' B' C' D',
  Le A B A' B' -> Le C D C' D' -> SumS A B C D E F -> SumS A' B' C' D' E F ->
  Cong C D C' D'.
Proof.
  intros A B C D E F A' B' C' D' HLe1 HLe2 HSum HSum'.
  apply le2_sums2__cong12 with A B E F A' B'; try (apply sums_sym); trivial.
Qed.

(** If AB < A'B' and CD <= C'D', then AB + CD < A'B' + C'D' *)

Lemma le_lt12_sums2__lt : forall A B C D E F A' B' C' D' E' F',
  Lt A B A' B' -> Le C D C' D' -> SumS A B C D E F -> SumS A' B' C' D' E' F' ->
  Lt E F E' F'.
Proof.
  intros A B C D E F A' B' C' D' E' F' HLt HLe HSum HSum'.
  split.
    apply le2_sums2__le with A B C D A' B' C' D'; Le.
  intro HCong.
  destruct HLt as [HLe1 HNCong].
  apply HNCong.
  apply le2_sums2__cong12 with C D E F C' D'; trivial.
  apply (cong3_sums__sums A' B' C' D' E' F'); Cong.
Qed.

Lemma le_lt34_sums2__lt : forall A B C D E F A' B' C' D' E' F',
  Le A B A' B' -> Lt C D C' D' -> SumS A B C D E F -> SumS A' B' C' D' E' F' ->
  Lt E F E' F'.
Proof.
  intros A B C D E F A' B' C' D' E' F' HLe HLt HSum HSum'.
  apply le_lt12_sums2__lt with C D A B C' D' A' B'; try (apply sums_sym); trivial.
Qed.

Lemma lt2_sums2__lt : forall A B C D E F A' B' C' D' E' F',
  Lt A B A' B' -> Lt C D C' D' -> SumS A B C D E F -> SumS A' B' C' D' E' F' ->
  Lt E F E' F'.
Proof.
  intros A B C D E F A' B' C' D' E' F' HLt1 HLt2 HSum HSum'.
  apply le_lt12_sums2__lt with A B C D A' B' C' D'; Le.
Qed.

(** If CD >= C'D' and AB + CD <= A'B' + C'D', then AB <= A'B' *)

Lemma le2_sums2__le12 : forall A B C D E F A' B' C' D' E' F',
  Le C' D' C D -> Le E F E' F' -> SumS A B C D E F -> SumS A' B' C' D' E' F' ->
  Le A B A' B'.
Proof.
  intros A B C D E F A' B' C' D' E' F' HLe1 HLe2 HSum HSum'.
  apply nlt__le; intro HLt.
  apply le__nlt in HLe2; apply HLe2.
  apply le_lt12_sums2__lt with A' B' C' D' A B C D; trivial.
Qed.

Lemma le2_sums2__le34 : forall A B C D E F A' B' C' D' E' F',
  Le A' B' A B -> Le E F E' F' -> SumS A B C D E F -> SumS A' B' C' D' E' F' ->
  Le C D C' D'.
Proof.
  intros A B C D E F A' B' C' D' E' F' HLe1 HLe2 HSum HSum'.
  apply le2_sums2__le12 with A B E F A' B' E' F'; try (apply sums_sym); trivial.
Qed.

(** If CD > C'D' and AB + CD <= A'B' + C'D', then AB < A'B' *)

Lemma le_lt34_sums2__lt12 : forall A B C D E F A' B' C' D' E' F',
  Lt C' D' C D -> Le E F E' F' -> SumS A B C D E F -> SumS A' B' C' D' E' F' ->
  Lt A B A' B'.
Proof.
  intros A B C D E F A' B' C' D' E' F' HLt HLe HSum HSum'.
  apply nle__lt; intro HLe1.
  apply le__nlt in HLe; apply HLe.
  apply le_lt34_sums2__lt with A' B' C' D' A B C D; trivial.
Qed.

Lemma le_lt12_sums2__lt34 : forall A B C D E F A' B' C' D' E' F',
  Lt A' B' A B -> Le E F E' F' -> SumS A B C D E F -> SumS A' B' C' D' E' F' ->
  Lt C D C' D'.
Proof.
  intros A B C D E F A' B' C' D' E' F' HLe1 HLe2 HSum HSum'.
  apply le_lt34_sums2__lt12 with A B E F A' B' E' F'; try (apply sums_sym); trivial.
Qed.

(** If CD >= C'D' and AB + CD < A'B' + C'D', then AB < A'B' *)

Lemma le_lt56_sums2__lt12 : forall A B C D E F A' B' C' D' E' F',
  Le C' D' C D -> Lt E F E' F' -> SumS A B C D E F -> SumS A' B' C' D' E' F' ->
  Lt A B A' B'.
Proof.
  intros A B C D E F A' B' C' D' E' F' HLe HLt HSum HSum'.
  apply nle__lt; intro HLe1.
  apply lt__nle in HLt; apply HLt.
  apply le2_sums2__le with A' B' C' D' A B C D; trivial.
Qed.

Lemma le_lt56_sums2__lt34 : forall A B C D E F A' B' C' D' E' F',
  Le A' B' A B -> Lt E F E' F' -> SumS A B C D E F -> SumS A' B' C' D' E' F' ->
  Lt C D C' D'.
Proof.
  intros A B C D E F A' B' C' D' E' F' HLe HLt HSum HSum'.
  apply le_lt56_sums2__lt12 with A B E F A' B' E' F'; try (apply sums_sym); trivial.
Qed.

Lemma lt2_sums2__lt12 : forall A B C D E F A' B' C' D' E' F',
  Lt C' D' C D -> Lt E F E' F' -> SumS A B C D E F -> SumS A' B' C' D' E' F' ->
  Lt A B A' B'.
Proof.
  intros A B C D E F A' B' C' D' E' F' HLt1 HLt2 HSum HSum'.
  apply le_lt56_sums2__lt12 with C D E F C' D' E' F'; Le.
Qed.

Lemma lt2_sums2__lt34 : forall A B C D E F A' B' C' D' E' F',
  Lt A' B' A B -> Lt E F E' F' -> SumS A B C D E F -> SumS A' B' C' D' E' F' ->
  Lt C D C' D'.
Proof.
  intros A B C D E F A' B' C' D' E' F' HLe HLt HSum HSum'.
  apply le_lt56_sums2__lt34 with A B E F A' B' E' F'; Le.
Qed.

End Sums.

#[global]
Hint Resolve sums_sym sums_left_comm sums_middle_comm sums_right_comm
             sums_comm sums112323 sums123312 bet__sums : sums.

Ltac Sums := auto 4 with sums.


(** 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 (z : natural) (x : natural) : natural := mult z x.


Require Import SyDPaCC.Core.Bmf.
Require Import Program Lia Bool NArith (*Classical_Pred_Type*).

Set Implicit Arguments.

Open Scope sydpacc_scope.
Open Scope N.

(* * Binary Trees: Type and Properties *)

(* ** Binary Trees: Definition *)

Inductive t (A B: Type) :=
| Leaf : A -> t A B
| Node : B -> t A B -> t A B -> t A B.

Arguments Leaf [A B].

(* ** Binary Trees: Same Form Property *)

Inductive same_form {A B C D:Type} : t A B -> t C D ->  Prop :=
| sfi_leaf :
    forall a1 a2,
      same_form (Leaf a1) (Leaf a2)
| sfi_node :
    forall a1 a2 l1 r1 l2 r2,
      same_form l1 l2
      -> same_form r1 r2
      -> same_form (Node a1 l1 r1) (Node a2 l2 r2).

Lemma same_form_trans :
  forall A B C D E F (t1:t A B) (t2:t C D) (t3:t E F),
    same_form t1 t2 -> same_form t2 t3 -> same_form t1 t3.
Proof.
  intros A B C D E F tree1;
    induction tree1; intros tree2 tree3;
    destruct tree2, tree3; intros H1 H2;
    try solve [ constructor ];
    try solve [ inversion H1 ] ;
    try solve [ inversion H2 ].
  inversion H1; inversion H2; subst; constructor;
    eauto using IHtree1_1, IHtree1_2.
Qed.

Arguments same_form_trans [A B C D E F].

Class Same_Form {A B C D} (t1: t A B) (t2: t C D) :=
  MkSF
    {
      c_same_form : same_form t1 t2
    }.

Class Same_Form_RT {A B C D} (t1: t A B) (t2:t C D) {H: Same_Form t1 t2}.

Generalizable All Variables.

#[export] Instance Same_Form_Trans {A B C D E F} (t1:t A B) (t2:t C D) (t3:t E F)
         {H1:Same_Form t1 t2} `{H2: @Same_Form_RT _ _ _ _ t2 t3 H}:
  @Same_Form_RT _ _ _ _ t1 t3
                (MkSF (same_form_trans t1 t2 t3
                                       (c_same_form (Same_Form := H1))
                                       (@c_same_form _ _ _ _ _ _ H))).
Defined.

#[export] Instance sameform_node_left {A B C D:Type} (a1:B) (l1 r1:t A B) (a2:D) (l2 r2:t C D) t1 t2:
  t1 = Node a1 l1 r1 ->
  t2 = Node a2 l2 r2 ->
  Same_Form t1 t2 -> Same_Form l1 l2.
Proof.
  intros H1 H2 Hsf; subst. inversion Hsf; inversion c_same_form0.
  constructor; assumption.
Qed.

#[export] Instance sameform_node_right {A B C D:Type} (a1:B) (l1 r1:t A B) (a2:D) (l2 r2:t C D) t1 t2:
  t1 = Node a1 l1 r1 ->
  t2 = Node a2 l2 r2 ->
  Same_Form t1 t2 -> Same_Form r1 r2.
Proof.
  intros H1 H2 Hsf; subst. inversion Hsf; inversion c_same_form0.
  constructor; assumption.
Qed.

#[export] Instance sameform_node_left'
         {A B C D:Type} (a1:B) (l1 r1:t A B) (a2:D) (l2 r2:t C D)
         {H: Same_Form (Node a1 l1 r1) (Node a2 l2 r2)}
  : Same_Form l1 l2.
Proof.
  eapply sameform_node_left; eauto.
Qed.

#[export] Instance sameform_node_right'
         {A B C D:Type} (a1:B) (l1 r1:t A B) (a2:D) (l2 r2:t C D)
         { H:Same_Form (Node a1 l1 r1) (Node a2 l2 r2)}
  : Same_Form r1 r2.
Proof.
  eapply sameform_node_right; eauto.
Qed.

Lemma not_same_form_tn:
  forall (A B C D: Type) (a:A) (d:D) (r l:t C D) (t1:t A B) (t2:t C D),
    t1 = Leaf a ->
    t2 = Node d r l ->
    not(Same_Form t1 t2).
Proof.
  intros; subst; intro HH; inversion HH as [ H' ]; inversion H'.
Qed.

Lemma not_same_form_nt:
  forall (A B C D: Type) (a:A) (d:D) (r l:t C D) t1 (t2:t A B),
    t2 = Leaf a ->
    t1 = Node d r l ->
    not(Same_Form t1 t2).
Proof.
  intros; subst; intro HH; inversion HH as [ H' ]; inversion H'.
Qed.

(** * Functions on Binary Trees *)

(** ** Specifications *)

Module Spec.

  Fixpoint size `(tree: t A B) : N :=
    match tree with
    | Leaf _ => 1
    | Node _ l r => 1 + (size l) + (size r)
    end.

  Fixpoint map (A B C D :Type) (kL:A -> C)(kN:B -> D)(tree: t A B): t C D :=
    match tree with
    | Leaf n => Leaf (kL n)
    | Node n l r => Node (kN n) (map kL kN l) (map kL kN r)
    end.

  Fixpoint mapt (A B C D:Type) (kL: A -> C)
           (kN: B -> t A B -> t A B -> D) (tree:t A B) : t C D :=
    match tree with
    | Leaf n =>  Leaf (kL n)
    | Node n l r => Node (kN n l r) (mapt kL kN l) (mapt kL kN r)
    end.

  (* TODO: change the type of k to A -> B -> A -> A *)
  Fixpoint reduce (A B:Type) (k: A * B * A -> A)(tree: t A B): A :=
    match tree with
    | Leaf n => n
    | Node n l r => k (reduce k l, n, reduce k r)
    end.

    (* TODO: change the type of k to A -> B -> A -> A *)
  Fixpoint uAcc (A B : Type) (k: A * B * A -> A)(tree: t A B): t A A :=
    match tree with
    | Leaf n => Leaf n
    | Node n l r => let n' := reduce k tree in
                   Node n' (uAcc k l) (uAcc k r)
    end.

    (* TODO: change the type of gl, gr to C -> B -> C *)
  Fixpoint dAcc (A B C:Type) (gl gr:C * B -> C) (c:C) (tree: t A B): t C C :=
    match tree with
    | Leaf n => Leaf c
    | Node n l r =>
      let l' := dAcc gl gr (gl (c,n)) l in
      let r' := dAcc gl gr (gr (c,n)) r in
      Node c l' r'
    end.

  Program Fixpoint zip (A B C D:Type) (tree1 : t A B) (tree2 : t C D) (H: Same_Form tree1 tree2)
    : t (A*C) (B*D) :=
    match (tree1,tree2) with
    | (Leaf a, Leaf c) => Leaf (a,c)
    | (Node b l1 r1, Node d l2 r2) =>
      let l := (zip (@sameform_node_left _ _ _ _ b l1 r1 d l2 r2 _ _ _ _  H)) in
      let r := (zip (@sameform_node_right _ _ _ _ b l1 r1 d l2 r2 _ _ _ _ H)) in
      Node (b,d) l r
    | _ => _
    end.
  Next Obligation.
    inversion H.
    destruct tree1, tree2.
    + contradiction H1 with (a0:=a) (c0:=c). reflexivity.
    + contradict H; intro H; inversion H; inversion c_same_form0.
    + contradict H; intro H; inversion H; inversion c_same_form0.
    + contradiction H0 with (b0:=b) (l1:=tree1_1) (r1:=tree1_2)
                            (d0:=d) (l2:=tree2_1) (r2:=tree2_2); reflexivity.
  Defined.
  Next Obligation.
    split; intros; discriminate.
  Defined.
  Next Obligation.
    inversion H; split; intros; discriminate.
  Defined.

  Arguments zip [A B C D] tree1 tree2 {H}.

End Spec.

(** ** Tail-Recursive Definitions *)

Definition root {A:Type} (tree : t A A) : A :=
  match tree with
  | Leaf a => a
  | Node b _ _ => b
  end.

(* ====================================== *)
(* TODO: externalize all the internal fix *)
(* ====================================== *)

Fixpoint size_aux (A B: Type) (tree:t A B)(k: N -> N) :=
  match tree with
  | Leaf _ => k 1
  | Node _ l r =>
    size_aux l (fun lm => size_aux r (fun rm =>k (1 + lm + rm)))
  end.

Definition size (A B:Type) (tree: t A B) : N :=
  size_aux tree (fun x => x).

Fixpoint map_aux (A B C D:Type) (kL : A -> C) (kN : B -> D) (tree: t A B) (k: t C D -> t C D) : t C D :=
  match tree with
  | Leaf a => k (Leaf (kL a))
  | Node b l r =>
    map_aux kL kN l (fun lm => map_aux kL kN r (fun rm => k(Node (kN b) lm rm)))
  end.

Definition map (A B C D:Type) (kL : A -> C) (kN : B -> D) (tree: t A B) : t C D :=
  map_aux kL kN tree (fun x => x).

Fixpoint mapt_aux (A B C D:Type) (kL: A -> C) (kN: B -> t A B -> t A B -> D) (tree:t A B) (k: t C D -> t C D) :=
  match tree with
  | Leaf a => k (Leaf (kL a))
  | Node b l r =>
    mapt_aux kL kN l (fun lm => mapt_aux kL kN r (fun rm => k(Node (kN b l r) lm rm)))
  end.

Definition mapt (A B C D:Type) (kL: A -> C) (kN: B -> t A B -> t A B -> D) (tree:t A B) : t C D :=
  mapt_aux kL kN tree (fun x => x).

Fixpoint reduce_aux (A B: Type)(kr: A * B * A -> A)(tree: t A B) (k:A->A) : A :=
  match tree with
  | Leaf a => k a
  | Node b l r =>
    reduce_aux kr l (fun lm => reduce_aux kr r (fun rm => k( kr (lm,b,rm))))
  end.

Definition reduce (A B: Type)(kr: A * B * A -> A)(tree: t A B): A :=
  reduce_aux kr tree (fun x => x).

Fixpoint uAcc_aux (A B : Type) (ka: A * B * A -> A) (tree:t A B) (k: t A A -> t A A) :=
  match tree with
  | Leaf a => k (Leaf a)
  | Node b l r =>
    uAcc_aux ka l (fun lm => uAcc_aux ka r (fun rm => k(Node (ka ((root lm),b,(root rm))) lm rm )))
  end.

Definition uAcc (A B : Type) (ka: A * B * A -> A)(tree: t A B): t A A :=
  uAcc_aux ka tree (fun x => x).

Fixpoint dAcc_aux (A B C: Type) (gl gr:C * B -> C) (c:C) (tree: t A B) (k: t C C -> t C C) :=
  match tree with
  | Leaf n => k (Leaf c)
  | Node n l r =>
    dAcc_aux gl gr (gl (c,n)) l (fun lm => dAcc_aux gl gr (gr (c,n)) r (fun rm => k(Node c lm rm)))
  end.

Definition dAcc (A B C: Type) (gl gr:C * B -> C) (c:C) (tree: t A B) : t C C :=
  dAcc_aux gl gr c tree (fun x => x).

Fixpoint zip_aux (A B C D:Type) (tree1 : t A B) (tree2 : t C D) {HH: Same_Form tree1 tree2}
         (k:  t (A*C) (B*D) ->  t (A*C) (B*D)) :=
  (match (tree1,tree2) as pair return tree1 = (fst pair) -> tree2 = (snd pair) -> t (A*C) (B*D) with
   | (Leaf a, Leaf c) => fun _ _ => k (Leaf (a,c))
   | (Node b l1 r1, Node d l2 r2) =>
     fun H1 H2 =>
       zip_aux (HH := @sameform_node_left _ _ _ _ b l1 r1 d l2 r2 _ _ H1 H2 HH)
               (fun lm => zip_aux (HH := @sameform_node_right _ _ _ _ b l1 r1 d l2 r2 _ _ H1 H2 HH)
                               (fun rm => k(Node (b,d) lm rm)))
   | (Leaf a, Node d l r) =>
     fun H1 H2 =>  False_rect _ (not_same_form_tn H1 H2 HH)
   | (Node d l r, Leaf a) => fun H1 H2 => False_rect _ (not_same_form_nt H2 H1 HH)
   end) eq_refl eq_refl.

Arguments zip_aux [A B C D] tree1 tree2 {HH} k.

Definition zip (A B C D:Type) (tree1 : t A B) (tree2 : t C D) {H: Same_Form tree1 tree2}
  : t (A*C) (B*D) :=
  zip_aux tree1 tree2 (fun x => x) (HH:=H).

Arguments zip [A B C D] tree1 tree2 {H}.

(** ** Correctness of Tail-Recursive Definitions  *)

Section EqSpec.

  (* ================================================================ *)
  (* TODO: Auxiliary lemmas about the auxiliary recursive definitions *)
  (* ================================================================ *)

  Lemma size_aux_prop:
    forall `(tree:t A B) f,
      size_aux tree f = f(Spec.size tree).
  Proof.
    intros A B tree. induction tree as [ a | a l IHl r IHr ]; intro f; simpl.
    - trivial.
    - rewrite IHl, IHr; trivial.
  Qed.

  Lemma size_spec_size :
    forall `(tree:t A B),
      size tree = Spec.size tree.
  Proof.
    unfold size. intros A B tree.
    now rewrite size_aux_prop.
  Qed.

  Lemma map_aux_prop:
    forall A B C D (kL:A->C) (kN:B->D) (tree:t A B) (k:t C D->t C D),
      map_aux kL kN tree k = k(Spec.map kL kN tree).
  Proof.
    intros A B C D kL kN tree.
    induction tree as [ a | a l IHl r IHr ]; intro k; simpl.
    - trivial.
    - rewrite IHl, IHr; trivial.
  Qed.

  Lemma map_spec_map :
    forall `(kL : A -> C) `(kN : B -> D) (tree: t A B),
      map kL kN tree = Spec.map kL kN tree.
  Proof.
    unfold map; intros; now rewrite map_aux_prop.
  Qed.

  Lemma mapt_aux_prop:
    forall `(kL: A -> C) `(kN: B -> t A B -> t A B -> D) (tree:t A B) k,
      mapt_aux kL kN tree k = k(Spec.mapt kL kN tree).
  Proof.
    intros A C kL B D kN tree;
      induction tree as [ a | a l IHl r IHr ]; intro k; simpl.
    - trivial.
    - rewrite IHl, IHr; trivial.
  Qed.

  Lemma mapt_spec_mapt: forall `(kL: A -> C) `(kN: B -> t A B -> t A B -> D) (tree:t A B),
      mapt kL kN tree = Spec.mapt kL kN tree.
  Proof.
    unfold mapt; intros; now rewrite mapt_aux_prop.
  Qed.

  Lemma reduce_aux_prop:
    forall `(kr: A * B * A -> A)(tree: t A B) k,
      reduce_aux kr tree k = k (Spec.reduce kr tree).
  Proof.
    intros A B kr tree;
      induction tree as [ a | a l IHl r IHr ]; intro k; simpl.
    - trivial.
    - rewrite IHl, IHr; trivial.
  Qed.

  Lemma reduce_spec_reduce: forall (A B: Type)(kr: A * B * A -> A)(tree: t A B),
      reduce kr tree = Spec.reduce kr tree.
  Proof.
    unfold reduce; intros; now rewrite reduce_aux_prop.
  Qed.

  Lemma uAcc_aux_prop:
    forall (A B : Type) (ka: A * B * A -> A)(tree: t A B) k,
      uAcc_aux ka tree k = k(Spec.uAcc ka tree).
  Proof.
    intros A B ka tree;
    induction tree as [ a | a l IHl r IHr ]; intro k; simpl.
    - trivial.
    - rewrite IHl, IHr; simpl; repeat f_equal;
      match goal with
      | [ |- _ = Spec.reduce _ ?tree] => destruct tree; auto
      end.
  Qed.

  Lemma uAcc_spec_uAcc: forall (A B : Type) (ka: A * B * A -> A)(tree: t A B),
      uAcc ka tree = Spec.uAcc ka tree.
  Proof.
    unfold uAcc; intros; now rewrite uAcc_aux_prop.
  Qed.

  Lemma dAcc_aux_prop:
    forall (A B C: Type) (gl gr:C * B -> C) (tree: t A B) c k,
      dAcc_aux gl gr c tree k = k(Spec.dAcc gl gr c tree).
  Proof.
    intros A B C gl gr tree.
    induction tree as [ a | a l IHl r IHr ]; intros c k; simpl.
    - trivial.
    - rewrite IHl, IHr; trivial.
  Qed.

  Lemma dAcc_spec_dAcc: forall (A B C: Type) (gl gr:C * B -> C) (c:C) (tree: t A B),
      dAcc gl gr c tree = Spec.dAcc gl gr c tree.
  Proof.
    unfold dAcc; intros; now rewrite dAcc_aux_prop.
  Qed.

  Lemma zip_aux_prop:
    forall (A B C D:Type) (t1: t A B) (t2: t C D) {H:Same_Form t1 t2} k,
      zip_aux t1 t2 k (HH:=H) = k(Spec.zip t1 t2 (H:=H)).
  Proof.
    intros A B C D t1; induction t1 as [ a1 | a1 l1 IHl1 r1 IHr1]; intros [ a2 | a2 l2 r2 ] H k.
    - trivial.
    - contradict H. eapply not_same_form_tn; eauto.
    - contradict H. eapply not_same_form_nt; eauto.
    - simpl; now rewrite IHl1, IHr1.
  Qed.

  Lemma zip_spec_zip: forall (A B C D:Type) (t1: t A B) (t2: t C D) {H:Same_Form t1 t2},
      zip t1 t2 (H:=H) = Spec.zip t1 t2 (H:=H).
  Proof.
    unfold zip; intros; now rewrite zip_aux_prop.
  Qed.

End EqSpec.

(** ** Preservation of the Same Form Property *)

#[export] Instance same_form_map {A B C D} (kL : A -> C) (kN : B -> D) (tree:t A B) :
  Same_Form tree (map kL kN tree).
Proof.
  induction tree as [| x tl Hl tr Hr].
  + simpl. constructor; apply sfi_leaf.
  + simpl. constructor.
    rewrite map_spec_map.
    rewrite map_spec_map in Hr, Hl.
    apply sfi_node.
    ++ inversion Hl; assumption.
    ++ inversion Hr; assumption.
Qed.

#[export] Instance same_form_mapt {A B C D} (kL : A -> C)  (kN: B -> t A B -> t A B -> D) (tree:t A B) :
  Same_Form tree (mapt kL kN tree).
Proof.
  induction tree as [| x tl Hl tr Hr].
  + simpl. constructor; apply sfi_leaf.
  + simpl. constructor.
    rewrite mapt_spec_mapt. rewrite mapt_spec_mapt in Hl, Hr.
    apply sfi_node.
    ++ inversion Hl; assumption.
    ++ inversion Hr; assumption.
Qed.

#[export] Instance same_form_uAcc {A B} (k: A * B * A -> A)(tree: t A B) :
  Same_Form tree (uAcc k tree).
Proof.
  induction tree as [| x tl Hl tr Hr].
  + simpl. constructor; apply sfi_leaf.
  + simpl; constructor.
    rewrite uAcc_spec_uAcc; rewrite uAcc_spec_uAcc in Hr, Hl.
    apply sfi_node.
    ++ inversion Hl; assumption.
    ++ inversion Hr; assumption.
Qed.

#[export] Instance same_form_dAcc {A B C} (gl gr:C * B -> C) (c:C) (tree: t A B) :
  Same_Form tree (dAcc gl gr c tree).
Proof.
  generalize dependent c. induction tree as [| a l IHl r IHr].
  - simpl. constructor; apply sfi_leaf.
  - intro c. rewrite dAcc_spec_dAcc.
    simpl. repeat rewrite <- dAcc_spec_dAcc.
    constructor; apply sfi_node.
    + apply IHl.
    + apply IHr.
Qed.

#[export] Instance same_form_comp {A B C D E F} (tree1: t A B)
         (f: t A B -> t C D) (g: t C D -> t E F)
         {Hf_sf: forall x, Same_Form x (f x)} {Hg_sf: forall x, Same_Form x (g x)} :
  Same_Form tree1 ((g ∘ f) tree1).
Proof.
  autounfold. constructor.
  apply same_form_trans with (t2:=f tree1).
  apply c_same_form. apply Hg_sf.
Qed.

Close Scope N.
Close Scope sydpacc_scope.


(** A _strategy_ is any function $\gamma$ of type [positive -> positive]
such that, if $n>3$, then $1<\gamma(n)<n$.

*)

Require Import Arith NArith Pow Compatibility More_on_positive.
Open Scope positive_scope.

Open Scope positive_scope.
(* begin snippet StrategyDef *)
Class Strategy (gamma : positive -> positive):=
  {
  gamma_lt :forall p:positive, 3 < p -> gamma  p < p;
  gamma_gt : forall p:positive, 3 < p -> 1 < gamma  p
  }.
(* end snippet StrategyDef *)

Ltac gamma_bounds gamma i H1 H2 :=
  assert (H1 : 1 < gamma i) by (apply gamma_gt;auto with chains);
  assert (H2 : gamma i < i) by (apply gamma_lt; auto with chains).

Lemma div_gamma_pos {gamma}{Hgamma : Strategy gamma}
: forall (p:positive) q r,
    N.pos_div_eucl p (N.pos (gamma p)) = (q, r) ->
    3 < p ->
    (0 < q)%N.
Proof.
  destruct q; [ | reflexivity].
  intros r H H0;assert (H1  : p = N2pos r) by
                   (apply (N_pos_div_eucl_q0 _ _ _ H);auto).
  destruct (Pos.lt_irrefl p).
  transitivity (gamma  p).
  -   rewrite H1 at 1.
      generalize  (N.pos_div_eucl_remainder  p
                                             (N.pos (gamma p)));
        rewrite H; cbn.
      intros H2; destruct r.
      +  apply gamma_gt; auto.
      +  rewrite  <- pos2N_inj_lt in H2;  cbn; auto with chains.
  -  apply gamma_lt;auto with chains.
Qed.


(* Definition of high-level semantics *)

Require Import Program Arith.

(* Model *)

Record HLocalState := HHonest {hhl_input : bool; hhl_decision : option bool}.

Record HGlobalState := HGS {hg_n : nat; h_localstates : nat -> option HLocalState}.

(* Semantics *)

Definition Hstep_decide_loc (ls : HLocalState) (b : bool) : HLocalState :=
  HHonest (hhl_input ls) (Some b).

Definition Hstep_decide (gs : HGlobalState) (i : nat) (b : bool) : HGlobalState :=
  let n := hg_n gs in
  let ls := h_localstates gs in
  HGS n
    (fun j =>
    if j =? i then
      match ls i with
      | Some ls => Some (Hstep_decide_loc ls b)
      | None => None
      end
    else
      ls j).

Definition Hextract_loc (ls : option HLocalState) : option bool :=
  match ls with
  | Some (HHonest _ d) => d
  | _ => None
  end.

Definition mergeb (l : option bool) (r : option bool) : option bool :=
  match l with
  | Some b => Some b
  | None => r
  end.

Definition Hextract (gs : HGlobalState) (i : nat) : option bool :=
  match gs with
  | HGS n ls => if i <? n then Hextract_loc (ls i) else None
  end.

(* TODO Hide behind a monad, so it can be written as a fun *)
Inductive HStep : HGlobalState -> HGlobalState -> Prop :=
  | NOTHING : forall gs, HStep gs gs
  | DECIDE : forall gs i b gs', ((forall j, Hextract gs j = None) /\ (gs' = Hstep_decide gs i b)) -> HStep gs gs'
  | AGREE : forall gs i b gs', ((exists j, Hextract gs j = Some b) /\ (gs' = Hstep_decide gs i b)) -> HStep gs gs'.

Inductive HSteps : HGlobalState -> HGlobalState -> Prop :=
  | HONE : forall gs gs', HStep gs gs' -> HSteps gs gs'
  | HMANY : forall gs gs' gs'', HSteps gs gs' -> HStep gs' gs'' -> HSteps gs gs''.


Require Import PeanoNat.
Require Import Reals.

Require Import Coquelicot.Continuity.
Require Import Coquelicot.Hierarchy.
Require Import Coquelicot.Rcomplements.

Require Import Lia.
Require Import Lra.

Section Lim_seq_US_def.
Context {U : UniformSpace}.

(** * Limit of sequences *)
(** ** Definition *)
Definition is_lim_seq (u : nat -> U) (l : U) :=
  filterlim u eventually (locally l).

Definition ex_lim_seq (u : nat -> U) :=
  exists l, is_lim_seq u l.

Definition ex_lim_seq_inf (u : nat -> U) :=
  {l & is_lim_seq u l}.

(** Extensionality *)

Lemma is_lim_seq_ext_loc (u v : nat -> U) (l : U) :
  eventually (fun n => u n = v n) ->
  is_lim_seq u l -> is_lim_seq v l.
Proof.
  intros H1 H2.
  intros P Hl.
  specialize (H2 P Hl).
  unfold filtermap.
  destruct H1 as [N1 H1].
  destruct H2 as [N2 H2].
  split with (Nat.max N1 N2).
  intros n H.
  rewrite <- H1; try lia.
  apply H2; lia.
Qed.

Lemma ex_lim_seq_ext_loc (u v : nat -> U) :
  eventually (fun n => u n = v n) ->
  ex_lim_seq u -> ex_lim_seq v.
Proof.
  intros H1 [l H2].
  split with l.
  apply is_lim_seq_ext_loc with u; assumption.
Qed.

Lemma is_lim_seq_ext (u v : nat -> U) (l : U) :
  (forall n, u n = v n) -> is_lim_seq u l -> is_lim_seq v l.
Proof.
  intros H1 H2.
  intros P Hl.
  specialize (H2 P Hl).
  destruct H2 as [N H2].
  split with N.
  intros n H.
  rewrite <- H1.
  apply H2; assumption.
Qed.

Lemma ex_lim_seq_ext (u v : nat -> U) :
  (forall n, u n = v n) -> ex_lim_seq u -> ex_lim_seq v.
Proof.
  intros H1 [l H2].
  split with l; apply is_lim_seq_ext with u; assumption.
Qed.

(** ** Arithmetic operations and order *)

(** Constants *)
Lemma is_lim_seq_const (a : U) :
  is_lim_seq (fun n => a) a.
Proof.
  intros P Hl.
  destruct Hl as [e Hl].
  split with 0%nat.
  intros n _.
  apply Hl.
  apply ball_center.
Qed.

Lemma ex_lim_seq_const (a : U) :
  ex_lim_seq (fun n => a).
Proof.
  split with a.
  apply is_lim_seq_const.
Qed.

(** Increasing natural functions *)
Definition subseq_support phi := forall n, (phi n < phi (S n))%nat.

Lemma subseq_support_implies_incr : forall phi,
    subseq_support phi ->
    forall a b, (a < b)%nat -> (phi a < phi b)%nat.
Proof.
  intros phi Hsup a b.
  revert a; induction b; intros a Hlt; try now inversion Hlt.
  inversion Hlt.
  { apply Hsup. }
  transitivity (phi b).
  - apply IHb.
    apply H0.
  - apply Hsup.
Qed.

Lemma subseq_support_ge_id : forall phi,
    subseq_support phi ->
    forall n, (n <= phi n)%nat.
Proof.
  intros phi Hsup n.
  induction n; try lia.
  transitivity (S (phi n)); try lia.
  apply Hsup.
Qed.

Lemma eventually_subseq_loc_gt_id :
  forall phi N k, (forall n, (N <= n)%nat -> (phi n < phi (S n))%nat) ->
                  (k <= phi (N + k))%nat.
Proof.
  intros phi N k H.
  induction k; try lia.
  rewrite Nat.add_succ_r.
  transitivity (S (phi (N + k)))%nat; try lia.
  apply H.
  lia.
Qed.

Lemma eventually_subseq_loc_incr :
  forall phi N n k, (forall n, (N <= n)%nat -> (phi n < phi (S n))%nat) ->
                    (N <= n)%nat -> (n <= k)%nat ->
                    (phi n <= phi k)%nat.
Proof.
  intros phi N n k H; revert n; induction k; intros n Hln Hlk.
  - inversion Hlk; inversion Hln; subst; lia.
  - inversion Hlk; try lia; subst.
    etransitivity; [ apply IHk; try lia | ].
    apply Nat.lt_le_incl.
    apply H; lia.
Qed.

Lemma eventually_subseq_loc :
  forall phi,  eventually (fun n => (phi n < phi (S n))%nat) ->
               filterlim phi eventually eventually.
Proof.
  intros phi [N H].
  intros P [N' H'].
  split with (N + N')%nat.
  intros n Hle.
  apply H'.
  etransitivity; [ apply eventually_subseq_loc_gt_id; apply H | ].
  apply eventually_subseq_loc_incr with N; try lia.
  apply H.
Qed.

Lemma eventually_subseq :
  forall phi,
    subseq_support phi ->
    filterlim phi eventually eventually.
Proof.
  intros phi H.
  apply eventually_subseq_loc.
  split with 0%nat.
  intros n _; apply H.
Qed.

(** Subsequences *)

Definition is_subseq {A} (v u : nat -> A) := { phi & prod (subseq_support phi) (forall n, v n = u (phi n))}.

Lemma is_lim_seq_subseq_eventually (u : nat -> U) (l : U) (phi : nat -> nat) :
  filterlim phi eventually eventually ->
  is_lim_seq u l ->
  is_lim_seq (fun n => u (phi n)) l.
Proof.
  intros Hes H.
  intros P Hloc.
  specialize (H P Hloc) as [N H].
  specialize (Hes (fun x => N <= x)%nat).
  assert (eventually (fun x : nat => (N <= x)%nat)).
  { split with N.
    intros; lia. }
  specialize (Hes H0); clear H0.
  destruct Hes as [N' Hes].
  split with N'.
  intros n Hle'.
  apply H.
  apply Hes.
  apply Hle'.
Qed.

Lemma is_lim_seq_subseq (u v : nat -> U) (l : U) :
  is_subseq v u ->
  is_lim_seq u l ->
  is_lim_seq v l.
Proof.
  intros [phi [sub_support Heqn]] Hlim.
  apply is_lim_seq_ext with (fun n => u (phi n)); [intros n; rewrite Heqn; reflexivity | ].
  apply is_lim_seq_subseq_eventually; try assumption.
  apply eventually_subseq.
  apply sub_support.
Qed.

Lemma ex_lim_seq_subseq (u v : nat -> U) :
  is_subseq v u ->
  ex_lim_seq u ->
  ex_lim_seq v.
Proof.
  intros Hsubseq [l Hlim].
  split with l.
  apply is_lim_seq_subseq with u; assumption.
Qed.

Lemma is_lim_seq_incr_1 (u : nat -> U) (l : U) :
  is_lim_seq u l <-> is_lim_seq (fun n => u (S n)) l.
Proof.
  split.
  - apply is_lim_seq_subseq.
    split with S.
    split; try auto.
    intro n.
    lia.
  - intros Hlim P H.
    specialize (Hlim P H) as [N Hlim].
    split with (S N).
    intros n Hle.
    destruct n; try now inversion Hle.
    apply Hlim; lia.
Qed.

Lemma ex_lim_seq_incr_1 (u : nat -> U) :
  ex_lim_seq u <-> ex_lim_seq (fun n => u (S n)).
Proof.
  split; intros [l Hlim]; split with l.
  - apply ->is_lim_seq_incr_1; assumption.
  - apply is_lim_seq_incr_1; assumption.
Qed.

Lemma is_lim_seq_incr_n (u : nat -> U) (N : nat) (l : U) :
  is_lim_seq u l <-> is_lim_seq (fun n => u (n + N)%nat) l.
Proof.
  induction N.
  - split; intros Hlim; eapply is_lim_seq_ext; try apply Hlim; intros; simpl; rewrite Nat.add_0_r; reflexivity.
  - eapply iff_trans; [ apply IHN | ].
    eapply iff_trans; [ apply is_lim_seq_incr_1 | ].
    split; intros Hlim; eapply is_lim_seq_ext; try apply Hlim; intros; simpl; rewrite Nat.add_succ_r; reflexivity.
Qed.

Lemma ex_lim_seq_incr_n (u : nat -> U) (N : nat) :
  ex_lim_seq u <-> ex_lim_seq (fun n => u (n + N)%nat).
Proof.
  split; intros [l Hlim]; split with l.
  - apply ->is_lim_seq_incr_n; assumption.
  - apply <-is_lim_seq_incr_n; eassumption.
Qed.

End Lim_seq_US_def.

Section Lim_US_CT.
(** ** Image by a continuous function *)
Context {U V : UniformSpace}.
Lemma is_lim_seq_continuous (f : U -> V) (u : nat -> U) (l : U) :
  continuous f l -> is_lim_seq u l ->
  is_lim_seq (fun n => f (u n)) (f l).
Proof.
  intros Hc Hlim.
  intros P Hloc.
  specialize (Hlim (fun x => P (f x))).
  assert (locally l (fun x => P (f x))) as Hlocf.
  { apply Hc.
    apply Hloc. }
  specialize (Hlim Hlocf).
  destruct Hlim as [N Hlim].
  split with N.
  apply Hlim.
Qed.
End Lim_US_CT.

(** Unicity *)
Section Lim_US_Unicity.

Context {U : UniformSpace}.
Hypothesis all_ball_eq : forall (x y : U), (forall (eps : posreal), ball x eps y) -> x = y.

Lemma is_lim_seq_unique (u : nat -> U) (l1 l2 : U) :
  is_lim_seq u l1 -> is_lim_seq u l2 ->
  l1 = l2.
Proof.
  intros Hlim1 Hlim2.
  apply all_ball_eq.
  intros eps.
  specialize (Hlim1 (fun x => ball l1 (pos_div_2 eps) x)).
  assert (locally l1 (fun x => ball l1 (pos_div_2 eps) x)).
  { split with (pos_div_2 eps); auto. }
  specialize (Hlim1 H); clear H.
  destruct Hlim1 as [N Hlim1].
  specialize (Hlim2 (fun x => ball l2 (pos_div_2 eps) x)).
  assert (locally l2 (fun x => ball l2 (pos_div_2 eps) x)).
  { split with (pos_div_2 eps); auto. }
  specialize (Hlim2 H); clear H.
  destruct Hlim2 as [N2 Hlim2].
  destruct eps; simpl in *.
  replace pos with (pos / 2 + pos / 2) by lra.
  apply ball_triangle with (u (Nat.max N N2)).
  - apply Hlim1; lia.
  - apply ball_sym; apply Hlim2; lia.
Qed.
End Lim_US_Unicity.


Require Export Iron.Language.SystemF2Data.Type.Exp.

(********************************************************************)
(* Well formed types are closed under the given kind environment. *)
Inductive wfT (kn: nat) : ty -> Prop :=
 | WfT_TVar
   :  forall ki
   ,  ki < kn
   -> wfT kn (TVar ki)

 | WfT_TCon
   :  forall n
   ,  wfT kn (TCon n)

 | WfT_TForall
   :  forall t
   ,  wfT (S kn) t
   -> wfT kn (TForall t)

 | WfT_TApp
   :  forall t1 t2
   ,  wfT kn t1 -> wfT kn t2
   -> wfT kn (TApp t1 t2).
Hint Constructors wfT.

(* Closed types are well formed under an empty environment. *)
Definition closedT : ty -> Prop
 := wfT O.
Hint Unfold closedT.

(********************************************************************)
Lemma wfT_succ
 :  forall tn t1
 ,  wfT tn     t1
 -> wfT (S tn) t1.
Proof.
 intros. gen tn.
 induction t1; intros; inverts H; eauto.
Qed.
Hint Resolve wfT_succ.

Lemma wfT_more
 :  forall tn1 tn2 tt
 ,  tn1 <= tn2
 -> wfT tn1 tt
 -> wfT tn2 tt.
Proof.
 intros. gen tn1 tn2.
 induction tt; intros; inverts H0; eauto.
Qed.
Hint Resolve wfT_more.

Lemma wfT_max
 :  forall tn1 tn2 tt
 ,  wfT tn1 tt
 -> wfT (max tn1 tn2) tt.
Proof.
 intros.
 assert (  ((tn1 <  tn2) /\ max tn1 tn2 = tn2)
        \/ ((tn2 <= tn1) /\ max tn1 tn2 = tn1)).
  eapply Max.max_spec.

 inverts H0.
 - rip. rewritess.
   eapply wfT_more; eauto.

 - inverts H1.
   rip. rewritess. auto.
Qed.
Hint Resolve wfT_max.

Lemma wfT_exists
 :  forall t1
 ,  (exists tn, wfT tn t1).
Proof.
 intros.
 induction t1.
 - Case "TCon".
   exists 0. auto.

 - Case "TVar".
   exists (S n). eauto.

 - Case "TForall".
   shift tn.
   eapply WfT_TForall; eauto.

 - Case "TApp".
   destruct IHt1_1 as [tn1].
   destruct IHt1_2 as [tn2].
   exists (max tn1 tn2).
   eapply WfT_TApp.
    eauto.
    rewrite Max.max_comm. eauto.
Qed.
Hint Resolve wfT_exists.