Require Import rt.util.all.
Require Import rt.model.arrival.basic.job rt.model.arrival.basic.task rt.model.priority.
Require Import rt.model.schedule.uni.schedule rt.model.schedule.uni.schedulability.
Require Import rt.analysis.uni.basic.workload_bound_fp
               rt.analysis.uni.basic.fp_rta_comp.
Require Import rt.implementation.job rt.implementation.task
               rt.implementation.arrival_sequence.
Require Import rt.implementation.uni.basic.schedule.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq bigop div.

Module ResponseTimeAnalysisFP.

  Import Job UniprocessorSchedule SporadicTaskset Priority Schedulability
         WorkloadBoundFP ResponseTimeIterationFP.
  Import ConcreteJob ConcreteTask ConcreteArrivalSequence ConcreteScheduler.

  (* In this section, we run the FP RTA on a simple task set to show that the theorems
     contain no contradictory assumptions. *)
  Section ExampleRTA.

    Let tsk1 := {| task_id := 1; task_cost := 1; task_period := 4; task_deadline := 5|}.
    Let tsk2 := {| task_id := 2; task_cost := 1; task_period := 6; task_deadline := 5|}.
    Let tsk3 := {| task_id := 3; task_cost := 1; task_period := 6; task_deadline := 6|}.

    (* Let ts be a task set containing these three tasks.
       (Note that periods are not unique and one of the tasks has an arbitrary deadline.) *)
    Program Let ts := Build_set [:: tsk1; tsk2; tsk3] _.

    (* Also note that the task set has valid parameters. *)
    Fact ts_has_valid_parameters:
      valid_sporadic_taskset task_cost task_period task_deadline ts.
    Proof.
      intros tsk IN.
      repeat (move: IN => /orP [/eqP EQ | IN]; subst; compute); by done.
    Qed.

    (* Next, recall the FP RTA schedulability test using RM as the FP policy. *)
    Let RTA_claimed_bounds :=
      fp_claimed_bounds task_cost task_period task_deadline (RM task_period).
    Let schedulability_test :=
      fp_schedulable task_cost task_period task_deadline (RM task_period).

    (* First, we show that the schedulability test returns the following bounds, ... *)
    Fact RTA_yields_these_bounds :
      RTA_claimed_bounds ts = Some [:: (tsk1, 1); (tsk2, 3); (tsk3, 3)].
    Proof.
      rewrite /RTA_claimed_bounds /fp_claimed_bounds.
      set RESP := [seq _ | tsk <- ts].
      suff EQ: RESP = [:: (tsk1, Some 1); (tsk2, Some 3); (tsk3, Some 3)] by rewrite EQ; compute.
      rewrite /RESP /ts /=; do 2 f_equal.
      {
        rewrite /per_task_rta /=.
        have WORK: total_workload_bound_fp task_cost task_period (RM task_period)
                                                 [:: tsk1; tsk2; tsk3] tsk1 1 = 1.
        {
          by compute; rewrite unlock; compute.
        }
        by rewrite !WORK /=.
      }
      f_equal.
      {
        rewrite /per_task_rta /=.
        have WORK: total_workload_bound_fp task_cost task_period (RM task_period)
                                                 [:: tsk1; tsk2; tsk3] tsk2 1 = 3.
        {
          by compute; rewrite unlock; compute.
        }
        rewrite !WORK /=; clear WORK.
        have WORK: total_workload_bound_fp task_cost task_period (RM task_period)
                                                 [:: tsk1; tsk2; tsk3] tsk2 3 = 3.
        {
          by compute; rewrite unlock; compute.
        }
        by rewrite !WORK /=.
      }
      do 2 f_equal.
      {
        rewrite /per_task_rta /=.
        have WORK: total_workload_bound_fp task_cost task_period (RM task_period)
                                                 [:: tsk1; tsk2; tsk3] tsk3 1 = 3.
        {
          by compute; rewrite unlock; compute.
        }
        rewrite !WORK /=; clear WORK.
        have WORK: total_workload_bound_fp task_cost task_period (RM task_period)
                                                 [:: tsk1; tsk2; tsk3] tsk3 3 = 3.
        {
          by compute; rewrite unlock; compute.
        }
        by rewrite !WORK /=; clear WORK.
      }
    Qed.

    (* ...so the schedulability test indeed returns true. *)
    Fact schedulability_test_succeeds :
      schedulability_test ts = true.
    Proof.
      rewrite /schedulability_test /fp_schedulable -/RTA_claimed_bounds.
      by rewrite RTA_yields_these_bounds.
    Qed.

    (* Now, let's show that the task set is schedulable. *)

    (* Let arr_seq be the periodic arrival sequence from ts. *)
    Let arr_seq := periodic_arrival_sequence ts.

    (* Assume rate-monotonic priorities... *)
    Let higher_eq_priority := FP_to_JLDP job_task (RM task_period).

    (* ... and recall that this priority assignment is total. *)
    Fact priority_is_total:
      forall t, total (higher_eq_priority t).
    Proof.
      rewrite /higher_eq_priority /FP_to_JLDP /RM /FP_to_JLFP.
      intros t x y; apply/orP.
      case LEQ: (_ <= _); first by left.
      apply negbT in LEQ; rewrite -ltnNge in LEQ.
      by right; apply ltnW.
    Qed.

    (* Let sched be the work-conserving RM scheduler. *)
    Let sched := scheduler job_arrival job_cost arr_seq higher_eq_priority.

    (* Recall the definition of deadline miss. *)
    Let no_deadline_missed_by :=
      task_misses_no_deadline job_arrival job_cost job_deadline job_task arr_seq sched.

    (* Next, by using the result of the RTA, we prove that the task set is schedulable. *)
    Corollary ts_is_schedulable:
      forall tsk,
        tsk \in ts ->
        no_deadline_missed_by tsk.
    Proof.
      intros tsk IN.
      have VALID := periodic_arrivals_valid_job_parameters ts ts_has_valid_parameters.
      have TSVALID := ts_has_valid_parameters.
      unfold valid_sporadic_job, valid_realtime_job in *; des.
      apply taskset_schedulable_by_fp_rta with (task_cost := task_cost)
       (task_period := task_period) (task_deadline := task_deadline)
       (ts0 := ts) (higher_eq_priority0 := RM task_period); try (by done).
      - by apply periodic_arrivals_are_consistent.
      - by apply periodic_arrivals_is_a_set.
      - by apply periodic_arrivals_all_jobs_from_taskset.
      - by apply periodic_arrivals_are_sporadic.
      - by apply RM_is_reflexive.
      - by apply RM_is_transitive.
      - by apply scheduler_jobs_come_from_arrival_sequence, periodic_arrivals_are_consistent.
      - by apply scheduler_jobs_must_arrive_to_execute, periodic_arrivals_are_consistent.
      - apply scheduler_completed_jobs_dont_execute, periodic_arrivals_are_consistent.
      - by apply scheduler_work_conserving, periodic_arrivals_are_consistent.
      - apply scheduler_respects_policy; first by apply periodic_arrivals_are_consistent.
        -- by intros t; apply RM_is_transitive.
        -- by apply priority_is_total.
      - by apply schedulability_test_succeeds.
    Qed.

  End ExampleRTA.

End ResponseTimeAnalysisFP.


Set Implicit Arguments.
Require Import Coq.Program.Basics.
Require Import Coq.QArith.QArith.
Require Import Coq.micromega.Lqa.
Require Import Coq.micromega.Lia.
Require Import ExtLib.Structures.Monoid.
Require Import Coq.Sorting.Permutation.
Require Import List.
Import ListNotations.
Local Open Scope program_scope.

Require Import axioms.
Require Import borel.
Require Import cpGCL.
Require Import geometric.
Require Import infer.
Require Import misc.
Require Import order.
Require Import Q.
Require Import regular.
Require Import tree.

Definition option_measure (x : option (list bool)) : Q :=
  match x with
  | None => 0
  | Some bs => interval_measure bs
  end.

Lemma option_measure_nonnegative (x : option (list bool)) :
  0 <= option_measure x.
Proof.
  destruct x; simpl; try lra; apply interval_measure_nonnegative.
Qed.

Lemma option_measure_None (x : option (list bool)) :
  option_measure x == 0 -> x = None.
Proof.
  unfold option_measure; intro H.
  destruct x; auto; exfalso; eapply interval_measure_nonzero; eauto.
Qed.

Lemma partial_sum_const (x : Q) (i : nat) :
  partial_sum (fun _ => x) i == sum_Q_list (repeat x i).
Proof.
  induction i; simpl.
  - reflexivity.
  - rewrite partial_sum_S; lra.
Qed.

Lemma partial_sum_singleton (f : nat -> Q) (n : nat) :
  (forall i, (0 < i)%nat -> f i == 0) ->
  partial_sum f (S n) == f O.
Proof.
  intros Hf; induction n.
  - unfold partial_sum; simpl; lra.
  - rewrite partial_sum_S, IHn.
    cut (f (S n) == 0). lra. apply Hf; lia.
Qed.

Lemma partial_sum_union (f g : nat -> Q) (i : nat) :
  partial_sum (seq_union f g) (i+i) == partial_sum f i + partial_sum g i.
Proof.
  induction i.
  - unfold partial_sum, seq_union; simpl. lra.
  - simpl.
    replace (S (i + S i)) with (S (S (i + i))) by lia.
    rewrite 4!partial_sum_S.
    rewrite IHi; clear IHi.
    cut (seq_union f g (i+i) + seq_union f g (S (i+i)) == f i + g i).
    + lra.
    + unfold seq_union.
      replace (i + i)%nat with (i * 2)%nat by lia.
      replace (S (i * 2)) with (1 + i * 2)%nat by lia.
      rewrite Nat.mod_mul; auto.
      rewrite Nat.mod_add; auto.
      replace ((i * 2) / 2)%nat with i.
      * replace ((1 + i * 2) / 2)%nat with i.
        -- reflexivity.
        -- rewrite Nat.div_add; auto.
      * rewrite Nat.div_mul; auto.
Qed.

Definition crunch (f : nat -> Q) (i : nat) : Q := f (i+i)%nat + f (S (i+i)).

Lemma partial_sum_crunch (f : nat -> Q) (i : nat) :
  partial_sum (crunch f) i == partial_sum f (i+i).
Proof.
  unfold crunch. simpl.
  induction i.
  - unfold partial_sum; simpl; lra.
  - replace (S i + S i)%nat with (S (S (i + i))) by lia.
    rewrite 3!partial_sum_S, IHi; lra.
Qed.

Lemma chain_partial_sum (s : nat -> Q) :
  (forall j, 0 <= s j) ->
  chain (partial_sum s).
Proof.
  intros Hnonneg i; simpl; rewrite partial_sum_S; specialize (Hnonneg i); lra.
Qed.

Lemma partial_sum_increasing (f : nat -> Q) (i j : nat) :
  (forall k, 0 <= f k) ->
  (i <= j)%nat ->
  partial_sum f i <= partial_sum f j.
Proof.
  revert i; induction j; intros i Hpos Hle.
  - inversion Hle; subst; lra.
  - destruct (Nat.eqb_spec i (S j)); subst.
    + lra.
    + eapply Qle_trans.
      apply IHj; auto; lia.
      apply chain_partial_sum; auto.
Qed.

Lemma partial_sum_le_crunch (f : nat -> Q) (i : nat) :
  (forall j, 0 <= f j) ->
  partial_sum f i <= partial_sum (crunch f) i.
Proof.
  intro Hle.
  rewrite partial_sum_crunch.
  apply partial_sum_increasing; auto; lia.
Qed.

Lemma crunch_partial_sum_supremum (f : nat -> Q) (sup : Q) :
  (forall i, 0 <= f i) ->
  supremum sup (partial_sum f) <-> supremum sup (partial_sum (crunch f)).
Proof.
  intro Hle; split; intros [Hub Hlub].
  - split.
    + intro y. specialize (Hub (y+y)%nat).
      rewrite partial_sum_crunch; auto.
    + intros y Hy.
      specialize (Hlub y).
      apply Hlub.
      eapply ge_upper_bound; eauto.
      intro i; apply partial_sum_le_crunch; auto.
  - split.
    + intro y. etransitivity; eauto.
      apply partial_sum_le_crunch; auto.
    + intros x Hx.
      apply Hlub.
      intro j. specialize (Hx (j+j)%nat).
      rewrite partial_sum_crunch; auto.
Qed.

(** Addition on rationals is continuous. *)
Lemma supremum_sum_Q (f g : nat -> Q) (supF supG : Q) :
  chain f ->
  chain g ->
  supremum supF f ->
  supremum supG g ->
  supremum (supF + supG) (fun i => f i + g i).
Proof.
  intros Hchainf Hchaing [Hubf Hlubf] [Hubg Hlubg].
  split.
  - intro x.
    specialize (Hubf x); specialize (Hubg x).
    simpl in *; lra.
  - intros x Hx; unfold upper_bound in Hx; simpl in *.
    cut (supF <= x - supG).
    { lra. }
    apply Hlubf; intro i; simpl in *.
    cut (supG <= x - f i).
    { lra. }
    apply Hlubg; intro j; simpl.
    destruct (Nat.leb_spec i j).
    + specialize (Hx j).
      assert (f i <= f j).
      { cut (leq (f i) (f j)). auto.
        apply chain_leq; auto. }
      lra.
    + specialize (Hx i).
      assert (g j <= g i).
      { cut (leq (g j) (g i)). auto.
        apply chain_leq; auto; lia. }
      lra.
Qed.

Lemma partial_sum_linear (f g : nat -> Q) (i : nat) :
  partial_sum (fun j => f j + g j) i == partial_sum f i + partial_sum g i.
Proof.
  induction i.
  - unfold partial_sum; simpl; lra.
  - rewrite 3!partial_sum_S, IHi; lra.
Qed.

Lemma partial_sum_scalar (f : nat -> Q) (c : Q) (i : nat) :
  partial_sum (fun j => c * f j) i == c * partial_sum f i.
Proof.
  induction i.
  - unfold partial_sum. simpl. lra.
  - rewrite 2!partial_sum_S.
    rewrite IHi. lra.
Qed.

Lemma supremum_scalar (f : nat -> Q) (c sup : Q):
  (0 <= c) ->
  supremum sup f -> supremum (c * sup) (fun i => c * f i).
Proof.
  intro Hpos.
  destruct (Qeq_dec 0 c); intros [Hub Hlub]; split.
  - intro i; simpl; rewrite <- q; lra.
  - intros x Hx; simpl; specialize (Hx O); simpl in Hx; nra.
  - intro x; specialize (Hub x); simpl in *; nra.
  - intros x Hx; simpl in *.
    cut (sup <= x / c).
    { intro H.
      assert (0 < c). lra.
      apply Qle_Qdiv' with (c := c); auto.
      assert (H': c * sup / c == sup).
      { field; lra. }
      rewrite H'; clear H'.
      apply Hlub; intro i; specialize (Hx i); simpl in *.
      apply Qle_shift_div_l; auto; lra. }
    apply Hlub; intro i; specialize (Hx i); simpl in *.
    apply Qle_shift_div_l; lra.
Qed.

Lemma supremum_scalar' (f : nat -> Q) (c sup : Q):
  (0 < c) ->
  supremum (c * sup) (fun i => c * f i) -> supremum sup f.
Proof.
  intros Hpos [Hub Hlub].
  split.
  -  intro i; specialize (Hub i); simpl in *; nra.
  - intros x Hx; simpl in *.
    cut (c * sup <= c * x).
    { nra. }
    apply Hlub; intro i; specialize (Hx i); simpl in *; nra.
Qed.

Lemma crunch_union_sum {A : Type} (f : A -> Q) (s1 s2 : nat -> A) (i : nat) :
  crunch (f ∘ seq_union s1 s2) i == f (s1 i) + f (s2 i).
Proof.
  unfold compose, crunch, seq_union.
  replace (i+i)%nat with (i*2)%nat by lia.
  rewrite Nat.mod_mul; auto.
  replace (S (i * 2)) with (1 + i * 2)%nat by lia.
  rewrite Nat.mod_add, Nat.div_add, Nat.div_mul; auto; simpl; lra.
Qed.

Lemma partial_sum_proper (f g : nat -> Q) :
  f_Qeq f g ->
  f_Qeq (partial_sum f) (partial_sum g).
Proof.
  intros Hfg i.
  unfold f_Qeq in Hfg.
  induction i.
  - unfold partial_sum; simpl; reflexivity.
  - rewrite 2!partial_sum_S, IHi, Hfg; reflexivity.
Qed.

Instance Proper_partial_sum : Proper (equ ==> equ) partial_sum.
Proof.
  intros s1 s2 Hequ. apply f_Qeq_equ, partial_sum_proper.
  intro i; apply Qeq_equ; firstorder.
Qed.

Lemma partial_sum_measure_factor (b : bool) (i : nat) (s : nat -> option (list bool)):
  partial_sum (fun j : nat =>
                 option_measure (option_mult MonoidList (Some [b]) (s j))) i ==
  (1#2) * partial_sum (fun j => option_measure (s j)) i.
Proof.
  etransitivity; try apply partial_sum_scalar.
  apply partial_sum_proper. intro j.
  unfold option_measure, option_mult; simpl.
  destruct (s j). unfold interval_measure. simpl. field.
  apply Qpow_nonzero; lra.
  unfold interval_measure; simpl; lra.
Qed.

Lemma interval_measure_app (l1 l2 : list bool) :
  interval_measure (l1 ++ l2) == interval_measure l1 * interval_measure l2.
Proof.
  revert l2; induction l1; intro l2; simpl.
  - unfold interval_measure. simpl.
    rewrite Qdiv_1_den; lra.
  - unfold interval_measure in *; simpl.
    specialize (IHl1 l2).
    rewrite 2!Qdiv_Qmult_den; try lra.
    + rewrite IHl1; lra.
    + apply Qlt_not_eq, Qpow_positive; lra.
    + apply Qlt_not_eq, Qpow_positive; lra.
Qed.

(** The measure of the product is the product of the measures. *)
Lemma option_measure_product (x y : option (list bool)) :
  option_measure (option_mult MonoidList x y) ==
  option_measure x * option_measure y.
Proof.
  destruct x, y; simpl; try lra.
  apply interval_measure_app.
Qed.

Lemma option_measure_homo s1 s2 i :
  option_measure (seq_product MonoidList s1 s2 i) ==
  option_measure (s1 (fst (nat_f i))) * option_measure (s2 (snd (nat_f i))).
Proof.
  unfold seq_product.
  destruct (nat_f i).
  unfold option_mult. simpl.
  destruct (s1 n); destruct (s2 n0); simpl; try lra.
  apply interval_measure_app.
Qed.

Lemma seq_product_flatten {A : Type} (M : Monoid A) (s1 s2 : nat -> option A) (i : nat) :
  seq_product M s1 s2 i = seq_flatten (fun i j => option_mult M (s1 i) (s2 j)) i.
Proof. reflexivity. Qed.

Lemma sum_Q_list_permutation (l1 l2 : list Q) :
  Permutation l1 l2 ->
  sum_Q_list l1 == sum_Q_list l2.
Proof. induction 1; simpl; lra. Qed.

Definition row_ixs (l : list nat) : list nat :=
  range (S (list_max (map (fst ∘ nat_f) l))).

Definition col_ixs (l : list nat) (r : nat) : list nat :=
  map (snd ∘ nat_f) (filter (fun n => let (i, j) := nat_f n in i =? r) l).

Lemma map_nat_f_g_rows {A : Type} (a : nat) (rows : nat -> nat -> A) (l : list nat) :
  map (fun j => rows a j) l =
  map (fun n => let (i, j) := nat_f n in rows i j)
      (map (fun j => nat_g (a, j)) l).
Proof.
  induction l; simpl; auto.
  rewrite nat_f_g, IHl; reflexivity.
Qed.

Lemma concat_map_rows {A : Type} (l : list nat) (f : nat -> list nat) (rows : nat -> nat -> A) :
  concat (map (fun i => map (fun j => rows i j) (f i)) l) =
  map (seq_flatten rows)
      (concat
         (map (fun i => map (fun j => nat_g (i, j))
                         (f i))
              l)).
Proof.
  induction l; simpl; auto.
  rewrite map_app.
  f_equal; auto; apply map_nat_f_g_rows.
Qed.

Definition list_disjoint {A : Type} (l1 l2 : list A) : Prop :=
  forall x, ~ (In x l1 /\ In x l2).

Lemma list_disjoint_injection {A B : Type} (l1 l2 : list A) (f : A -> B) :
  injection f ->
  list_disjoint l1 l2 ->
  list_disjoint (map f l1) (map f l2).
Proof.
  intros [g Hgf] Hdisj y [Hin1 Hin2].
  - apply in_map_iff in Hin1.
    apply in_map_iff in Hin2.
    destruct Hin1 as [x [? Hin1]]; subst.
    destruct Hin2 as [x' [? Hin2]]; subst.
    apply injection_injective in H; firstorder; subst; firstorder.
Qed.

Lemma list_disjoint_nodup_app {A : Type} (l1 l2 : list A) :
  list_disjoint l1 l2 ->
  NoDup l1 ->
  NoDup l2 ->
  NoDup (l1 ++ l2).
Proof.
  revert l2; induction l1; intros l2 Hdisj Hnodup1 Hnodup2; simpl; auto.
  constructor.
  - intros Hx.
    apply NoDup_cons_iff in Hnodup1.
    destruct Hnodup1.
    apply in_app_or in Hx. destruct Hx; auto.
    apply (Hdisj a); intuition.
  - apply IHl1; auto.
    + intros x [H0 H1]; apply (Hdisj x); intuition.
    + apply NoDup_cons_iff in Hnodup1; intuition.
Qed.

Inductive all_disjoint {A : Type} : list (list A) -> Prop :=
| all_disjoint_nil : all_disjoint []
| all_disjoint_cons : forall l ls,
    all_disjoint ls ->
    (forall l', In l' ls -> list_disjoint l l') ->
    all_disjoint (l :: ls).

Lemma all_disjoint_single {A : Type} (l : list A) :
  all_disjoint [l].
Proof. constructor; try constructor; intros ? HC; inversion HC. Qed.

Instance Symmetric_list_disjoint {A : Type} : Symmetric (@list_disjoint A).
Proof. firstorder. Qed.

Lemma NoDup_concat {A : Type} (ls : list (list A)) :
  (forall l, In l ls -> NoDup l) ->
  all_disjoint ls ->
  NoDup (concat ls).
Proof.
  induction ls; intros Hnodup Hdisj; simpl; try constructor.
  apply list_disjoint_nodup_app.
  - intros x [Hin1 Hin2].
    apply in_concat in Hin2.
    destruct Hin2 as [l [Hin2 Hin3]].
    inversion Hdisj; subst.
    specialize (H2 l Hin2 x).
    intuition.
  - apply Hnodup; left; reflexivity.
  - apply IHls.
    + intros l Hin; apply Hnodup; right; auto.
    + inversion Hdisj; auto.
Qed.

Lemma map_injection {A B : Type} (l : list A) (f : A -> B) :
  (forall x y, In x l -> In y l -> f x = f y -> x = y) ->
  NoDup l ->
  NoDup (map f l).
Proof.
  induction l; intros Hinj Hnodup; simpl; constructor.
  - intro HC. apply in_map_iff in HC.
    destruct HC as [x [Heq Hin]].
    apply Hinj in Heq; subst; intuition.
    apply NoDup_cons_iff in Hnodup; intuition.
  - apply IHl; intuition.
    apply NoDup_cons_iff in Hnodup; intuition.
Qed.

Lemma all_disjoint_app {A : Type} (ls1 ls2 : list (list A)) :
  all_disjoint ls1 ->
  all_disjoint ls2 ->
  (forall l1 l2, In l1 ls1 -> In l2 ls2 -> list_disjoint l1 l2) ->
  all_disjoint (ls1 ++ ls2).
Proof.
  revert ls2; induction ls1; intros ls2 Hdisj1 Hdisj2 Hdisj; simpl; auto.
  constructor.
  - apply IHls1; auto; intuition; inversion Hdisj1; subst; auto.
  - intros l Hin.
    apply in_app_or in Hin.
    destruct Hin as [Hin | Hin].
    + inversion Hdisj1; subst; auto.
    + apply Hdisj; intuition.
Qed.

Lemma all_disjoint_injective {A B : Type} (ls : list A) (f : A -> list B) :
  (forall x y, x <> y -> list_disjoint (f x) (f y)) ->
  NoDup ls ->
  all_disjoint (map f ls).
Proof.
  induction ls; intros Hdisj Hnodup; simpl; constructor.
  - apply IHls; auto.
    apply NoDup_cons_iff in Hnodup; intuition.
  - intros l Hin y.
    apply in_map_iff in Hin.
    destruct Hin as [x [? Hin]]; subst.
    apply NoDup_cons_iff in Hnodup.
    destruct Hnodup.
    apply Hdisj; intro HC; subst; congruence.
Qed.

Lemma Permutation_flatten_concat_ixs {A : Type} (rows : nat -> nat -> A) n :
  Permutation (first_n (seq_flatten rows) n)
              (concat
                 (map (fun i => map (fun j => rows i j)
                                 (col_ixs (range n) i))
                      (row_ixs (range n)))).
Proof.
  rewrite first_n_first_n'.
  unfold first_n'.
  rewrite concat_map_rows.
  apply Permutation_map.
  apply NoDup_Permutation.
  - apply NoDup_range.
  - apply NoDup_concat.
    + intros l Hin.
      apply in_map_iff in Hin.
      destruct Hin as [i [? Hin]]; subst.
      apply FinFun.Injective_map_NoDup.
      * intros j k Heq.
        apply injection_injective in Heq.
        -- inversion Heq; reflexivity.
        -- exists nat_f; apply nat_f_g.
      * unfold col_ixs. unfold compose.
        apply map_injection.
        -- intros j k Hin1 Hin2 Heq.
           apply filter_In in Hin1; apply filter_In in Hin2.
           destruct Hin1 as [Hin1 Hj]; destruct Hin2 as [Hin2 Hk].
           destruct (nat_f j) eqn:H0; destruct (nat_f k) eqn:H1.
           simpl in *.
           apply Nat.eqb_eq in Hj; apply Nat.eqb_eq in Hk; subst.
           rewrite <- H0 in H1; apply injection_injective in H1; auto.
           exists nat_g; apply nat_g_f.
        -- apply NoDup_filter, NoDup_range.
    + unfold row_ixs, col_ixs, compose; simpl.
      rewrite map_app; simpl.
      apply all_disjoint_app.
      * apply all_disjoint_injective.
        -- intros i j Hneq k [H0 H1].
           apply in_map_iff in H0; destruct H0 as [x [? H0]].
           apply in_map_iff in H0; destruct H0 as [y [? H0]].
           apply in_map_iff in H1; destruct H1 as [z [? H1]].
           apply in_map_iff in H1; destruct H1 as [w [? H1]].
           subst.
           apply injection_injective in H3.
           2: { exists nat_f; apply nat_f_g. }
           inversion H3; subst; congruence.
        -- apply NoDup_range.
      * apply all_disjoint_single.
      * intros l1 l2 Hin1 Hin2 i [H0 H1].
        simpl in *.
        destruct Hin2; auto.
        subst.
        apply in_map_iff in Hin1.
        apply in_map_iff in H1.
        destruct Hin1 as [j [HHeq Hin1]]; subst.
        destruct H1 as [k [HHeq Hin2]]; subst.
        apply in_map_iff in H0.
        destruct H0 as [m [Heq Hin0]]; subst.
        apply in_map_iff in Hin2.
        destruct Hin2 as [o [Heq' Hin2]]; subst.
        apply in_map_iff in Hin0.
        destruct Hin0 as [p [Heq' Hin0]]; subst.
        apply filter_In in Hin0.
        destruct Hin0.
        apply filter_In in Hin2.
        destruct Hin2.
        apply injection_injective in Heq.
        2: { exists nat_f; apply nat_f_g. }
        inversion Heq; subst; clear Heq.
        rewrite 2!range_seq in Hin1.
        apply in_seq in Hin1. lia.
  - intro k; split; intro Hin.
    + apply in_concat.
      destruct (nat_f k) as [i j] eqn:Hk.
      exists (map (fun j0 : nat => nat_g (i, j0)) (col_ixs (range n) i)).
      split.
      * apply in_map_iff.
        exists i; intuition.
        unfold row_ixs.
        rewrite range_seq.
        apply in_seq. split; try lia.
        simpl.
        assert (In ((fst ∘ nat_f) k) (map (fst ∘ nat_f) (range n))).
        { apply in_map; auto. }
        unfold compose in H.
        rewrite Hk in H. simpl in H.
        apply list_max_spec in H. unfold compose. lia.
      * apply in_map_iff.
        exists j. split.
        -- rewrite <- Hk; apply nat_g_f.
        -- unfold col_ixs.
           apply in_map_iff. unfold compose. exists k. split.
           ++ rewrite Hk; reflexivity.
           ++ apply filter_In. split; auto.
              rewrite Hk. apply Nat.eqb_refl.
    + apply in_concat in Hin; destruct Hin as [l [Hin1 Hin2]].
      apply in_map_iff in Hin1; destruct Hin1 as [i [? Hin1]]; subst.
      apply in_map_iff in Hin2; destruct Hin2 as [j [? Hin2]]; subst.
      unfold row_ixs in Hin1; rewrite range_seq in Hin1.
      apply in_seq in Hin1; simpl in Hin1.
      unfold col_ixs in Hin2; apply in_map_iff in Hin2.
      destruct Hin2 as [k [? Hin2]]; subst.
      apply filter_In in Hin2; destruct Hin2 as [H0 H1].
      unfold compose; destruct (nat_f k) eqn:Hk. simpl.
      apply Nat.eqb_eq in H1; subst; rewrite <- Hk, nat_g_f; auto.
Qed.

Lemma sum_Q_list_concat (ls : list (list Q)) :
  sum_Q_list (concat ls) == sum_Q_list (map sum_Q_list ls).
Proof.
  induction ls; simpl; try lra.
  rewrite sum_Q_list_app; rewrite IHls; reflexivity.
Qed.

(* Fixpoint get {A : Type} (default : A) (l : list A) (n : nat) : A := *)
(*   match l with *)
(*   | [] => default *)
(*   | (x :: xs) => match n with *)
(*                | O => x *)
(*                | S n' => get default xs n' *)
(*                end *)
(*   end. *)

Lemma list_rel_length {A B : Type} (l1 : list A) (l2 : list B) (R : A -> B -> Prop) :
  list_rel R l1 l2 ->
  length l1 = length l2.
Proof. induction 1; simpl; auto. Qed.

(* Lemma list_rel_get {A B : Type} (l1 : list A) (l2 : list B) (R : A -> B -> Prop) (defA : A) (defB : B) : *)
(*   R defA defB -> *)
(*   list_rel R l1 l2 <-> length l1 = length l2 /\ forall i, R (get defA l1 i) (get defB l2 i). *)
(* Proof. *)
(*   intro Hdef; split. *)
(*   - induction 1; split; simpl; intuition; destruct i; auto. *)
(*   - revert l2; induction l1; intros l2 [Hlen Hget]. *)
(*     + destruct l2. *)
(*       * constructor. *)
(*       * simpl in Hlen; lia. *)
(*     + destruct l2. *)
(*       * simpl in Hlen; lia. *)
(*       * constructor. *)
(*         -- apply (Hget O). *)
(*         -- apply IHl1; intuition; apply (Hget (S i)). *)
(* Qed. *)

Lemma list_rel_map {A B C D: Type} (l1 : list A) (l2 : list B)
      (R : C -> D -> Prop) (f : A -> C) (g : B -> D) :
  list_rel (fun x y => R (f x) (g y)) l1 l2 ->
  list_rel R (map f l1) (map g l2).
Proof. induction 1; simpl; constructor; auto. Qed.

Lemma sub_perm_map {A B : Type} (l1 l2 : list A) (f : A -> B) :
  sub_perm l1 l2 -> sub_perm (map f l1) (map f l2).
Proof.
  unfold sub_perm; intros [l Hperm].
  exists (map f l). rewrite <- map_app.
  apply Permutation_map; auto.
Qed.

Lemma filter_app_exists {A : Type} (f : A -> bool) (l l1 l2 : list A) :
  filter f l = l1 ++ l2 ->
  exists l1' l2', l = l1' ++ l2' /\ filter f l1' = l1 /\ filter f l2' = l2.
Proof.
  revert l1 l2; induction l; simpl; intros l1 l2 Hfilter.
  - symmetry in Hfilter; apply app_eq_nil in Hfilter.
    destruct Hfilter; subst; exists [], []; intuition.
  - destruct (f a) eqn:Ha.
    + destruct l1, l2; simpl in *.
      * inversion Hfilter.
      * inversion Hfilter; subst.
        exists [], (a0 :: l); intuition; simpl; rewrite Ha; reflexivity.
      * rewrite app_nil_r in Hfilter.
        inversion Hfilter; subst.
        exists (a0 :: l), []; intuition; simpl; rewrite Ha; reflexivity.
      * inversion Hfilter; subst.
        apply IHl in H1.
        destruct H1 as [l1' [l2' [? [H0 H1]]]]; subst.
        exists (a0 :: l1'), l2'; simpl; rewrite Ha; intuition.
    + apply IHl in Hfilter. destruct Hfilter as [l1' [l2' [? [H0 H1]]]]; subst.
      exists (a :: l1'), l2'; simpl; rewrite Ha; intuition.
Qed.

Lemma not_in_filter_orb (f : nat -> bool) (l : list nat) (n : nat) :
  ~ In n l ->
  filter f l = filter (fun m => (m =? n) || f m) l.
Proof.
  induction l; intros Hnotin; simpl; auto.
  destruct (f a) eqn:Ha.
  - rewrite orb_true_r; rewrite IHl; intuition.
  - rewrite orb_false_r.
    destruct (Nat.eqb_spec a n); subst.
    + exfalso; apply Hnotin; left; reflexivity.
    + apply IHl; intuition.
Qed.

Lemma in_filter_orb {A : Type} (l : list A) (f g : A -> bool) :
  (forall x, In x (filter (fun y => f y || g y) l) -> g x = false) ->
  forall x, In x l -> g x = false.
Proof.
  intros Heq x Hin.
  destruct (g x) eqn:Hgx; auto.
  specialize (Heq x).
  assert (In x (filter (fun y => f y || g y) l)).
  { apply filter_In; intuition. }
  apply Heq in H. congruence.
Qed.

Lemma NoDup_app_disjoint {A : Type} (l1 l2 : list A) :
  NoDup (l1 ++ l2) ->
  list_disjoint l1 l2.
Proof.
  revert l2; induction l1; simpl; intros l2 Hnodup x [H0 H1].
  - inversion H0.
  - apply NoDup_cons_iff in Hnodup.
    destruct Hnodup.
    simpl in H0. destruct H0; subst.
    + apply H; apply in_or_app; right; auto.
    + eapply IHl1; eauto.
Qed.

Lemma nodup_filter_orb_app (f : nat -> bool) (l l1 l2 : list nat) (n : nat) :
  NoDup l ->
  f n = false ->
  filter (fun i => (i =? n) || f i) l = l1 ++ n :: l2 ->
  filter f l = l1 ++ l2.
Proof.
  intros Hnodup Hfalse Hfilter.
  apply filter_app_exists in Hfilter.
  destruct Hfilter as [l1' [l2' [? [H0 H1]]]]; subst.
  replace (n :: l2) with ([n] ++ l2) in H1 by reflexivity.
  apply filter_app_exists  in H1.
  destruct H1 as [l1'' [l2'' [? [H1 H2]]]]; subst.
  assert (filter f l1'' = []).
  { apply filter_nil.
    intros x Hin.
    apply in_filter_orb with (l:=l1'') (f0:=fun i => i =? n); auto.
    rewrite H1; intros i []; subst; auto. inversion H. }
  assert (In n l1'').
  { cut (In n (filter (fun i => (i =? n) || f i) l1'')).
    { intro Hin; apply filter_In in Hin; firstorder. }
    rewrite H1; left; reflexivity. }
  pose proof Hnodup as Hnodup1.
  rewrite app_assoc in Hnodup1.
  apply NoDup_app in Hnodup1.
  apply NoDup_app_comm in Hnodup.
  apply NoDup_app in Hnodup.
  apply NoDup_app_disjoint in Hnodup.
  apply NoDup_app_disjoint in Hnodup1.
  unfold list_disjoint in *.
  simpl. rewrite 2!filter_app. rewrite H. simpl.
  f_equal; apply not_in_filter_orb; intuition.
  - eapply Hnodup1; eauto.
  - eapply Hnodup; eauto.
Qed.

Lemma inc_nodup_permutation_filter_orb (l1 l2 : list nat) :
  incl l1 l2 ->
  NoDup l1 ->
  NoDup l2 ->
  Permutation l1 (filter (fun i => existsb (eqb i) l1) l2).
Proof.
  revert l2. induction l1; intros l2 Hincl Hnodup1 Hnodup2; simpl.
  - rewrite filter_nil; auto.
  - assert (H: In a (filter (fun i : nat => (i =? a) || existsb (Nat.eqb i) l1) l2)).
    { apply filter_In. split; intuition; rewrite Nat.eqb_refl; reflexivity. }
    apply in_split in H.
    destruct H as [l [l' Heq]].
    rewrite Heq.
    apply Permutation_cons_app.
    apply nodup_filter_orb_app in Heq; auto.
    rewrite <- Heq.
    apply IHl1; auto.
    + intros x Hin; apply Hincl; right; auto.
    + inversion Hnodup1; auto.
    + apply existsb_not_in.
      apply NoDup_cons_iff in Hnodup1; intuition.
Qed.

Lemma Permutation_filter_existsb (l : list nat) :
  NoDup l ->
  Permutation l (filter (fun i => existsb (eqb i) l) (range (S (list_max l)))).
Proof.
  intro Hnodup.
  apply inc_nodup_permutation_filter_orb; auto.
  - intros x Hin; apply in_range_list_max; auto.
  - apply NoDup_range.
Qed.

Lemma sub_perm_range_list_max (l : list nat) :
  NoDup l ->
  sub_perm l (range (S (list_max l))).
Proof.
  intros Hnodup.
  exists (filter (negb ∘ fun i => existsb (eqb i) l) (range (S (list_max l)))).
  etransitivity.
  apply Permutation_app_tail, Permutation_filter_existsb; auto.
  apply Permutation_filter_partition.
Qed.

Lemma list_rel_Qle_sup_ixs (l : list nat) (i : nat) (rows : nat -> nat -> Q) (sups : nat -> Q) :
  (forall i j, 0 <= rows i j) ->
  (forall i, supremum (sups i) (partial_sum (rows i))) ->
  list_rel (fun l k => sum_Q_list l <= sups k)
           (map (fun i0 => map (fun j => rows i0 j) (col_ixs (range i) i0)) l) l.
Proof.
  intros Hnonneg Hsups; induction l; simpl; constructor; auto.
  eapply Qle_trans.
  2: { specialize (Hsups a). destruct Hsups.
       unfold upper_bound in H. simpl in H.
       apply (H (S (list_max (col_ixs (range i) a)))). }
  unfold partial_sum.
  rewrite first_n_first_n'. unfold first_n'.
  replace (fun j => rows a j) with (rows a) by reflexivity.
  apply sub_perm_sum_Q_list; auto.
  - intros x Hin. apply in_map_iff in Hin.
    destruct Hin as [? [? Hin]]; subst; auto.
  - apply sub_perm_map.
    apply sub_perm_range_list_max.
    unfold col_ixs. simpl.
    apply map_injection.
    + unfold compose.
      intros x y Hinx Hiny Heq.
      apply filter_In in Hinx; destruct Hinx as [Hinx H0].
      apply filter_In in Hiny; destruct Hiny as [Hiny H1].
      destruct (nat_f x) eqn:Hx.
      destruct (nat_f y) eqn:Hy.
      apply Nat.eqb_eq in H0; apply Nat.eqb_eq in H1; simpl in *; subst.
      rewrite <- Hx in Hy. apply injection_injective in Hy; auto.
      exists nat_g; apply nat_g_f.
    + apply NoDup_filter, NoDup_range.
Qed.

Lemma forall_Qlt_Qle (x ub : Q) :
  (forall y, y < x -> y <= ub) ->
  x <= ub.
Proof.
  intros Hle.
  destruct (Qlt_le_dec ub x); auto.
  assert (H0: (x + ub) / 2 < x).
  { apply Qlt_shift_div_r; lra. }
  assert (H1: ub < (x + ub) / 2).
  { apply Qlt_shift_div_l; lra. }
  specialize (Hle ((x + ub) / 2) H0); lra.
Qed.

(* Lemma forall_list_rel_Qlt_Qle (l : list Q) (ub : Q) : *)
(*   (forall l', list_rel Qlt l' l -> sum_Q_list l' <= ub) -> *)
(*   sum_Q_list l <= ub. *)
(* Proof. *)
(*   revert ub. *)
(*   induction l; simpl; intros ub Hle. *)
(*   - specialize (Hle [] (list_rel_nil _)); simpl in Hle; auto. *)
(*   - cut (sum_Q_list l <= ub - a). *)
(*     { lra. } *)
(*     apply IHl. *)
(*     intros l' Hrel. *)
(*     cut (a + sum_Q_list l' <= ub). *)
(*     { lra. } *)
(*     apply forall_Qlt_Qle; intros y Hlt. *)
(*     assert (y - sum_Q_list l' < a). *)
(*     { lra. } *)
(*     specialize (Hle (((y - sum_Q_list l' + a) / 2) :: l')). *)
(*     simpl in Hle. *)
(*     eapply Qle_trans. *)
(*     2: { apply Hle; constructor; auto; apply Qlt_shift_div_r; lra. } *)
(*     cut (y - sum_Q_list l' <= (y - sum_Q_list l' + a) / 2). *)
(*     { lra. } *)
(*     apply Qle_shift_div_l; lra. *)
(* Qed. *)

Lemma concat_map_nil {A B : Type} (l : list A) :
  concat (map (const (@nil B)) l) = [].
Proof. induction l; simpl; auto. Qed.

Lemma rows_sups_upper_bound (rows : list (nat -> Q)) (sups : list Q) (ub : Q) :
  (forall row, In row rows -> forall i, 0 <= row i) ->
  list_rel (fun sup row => supremum sup (partial_sum row)) sups rows ->
  (forall j, sum_Q_list (map (fun row => sum_Q_list (first_n' row j)) rows) <= ub) ->
  sum_Q_list sups <= ub.
Proof.
  revert ub rows. induction sups; intros ub rows Hnonneg Hrel Hle.
  - inversion Hrel; subst. simpl in *; apply (Hle O).
  - simpl.
    inversion Hrel; subst.
    assert (H: forall row : nat -> Q, In row ys -> forall i : nat, 0 <= row i).
    { intros row Hin i; apply Hnonneg; right; auto. }
    specialize (IHsups (ub - a) ys H H3); clear H.
    cut (sum_Q_list sups <= ub - a).
    { lra. }
    apply IHsups; intro j.
    simpl in Hle.
    clear Hrel H3 IHsups.
    cut (a + sum_Q_list (map (fun row => sum_Q_list (first_n' row j)) ys) <= ub).
    { lra. }
    apply forall_Qlt_Qle.
    set (b := sum_Q_list (map (fun row : nat -> Q => sum_Q_list (first_n' row j)) ys)).
    intros x Hlt.
    set (eps := a + b - x).
    assert (Heps: 0 < eps).
    { unfold eps; lra. }
    apply supremum_converges with (eps:=eps) in H1; auto.
    + destruct H1 as [k Hepsle].
      set (c := sum_Q_list (map (fun row : nat -> Q => sum_Q_list (first_n' row k)) ys)).
      destruct (Nat.leb_spec0 j k).
      * specialize (Hle k). unfold partial_sum in *.
        rewrite first_n_first_n' in Hepsle.
        unfold eps in Heps.
        assert (H0: x < sum_Q_list (first_n' y k) + b).
        { unfold eps in Hepsle; lra. }
        assert (H1: b <= c).
        { unfold b, c.
          apply sum_Q_list_pointwise_Qle.
          apply list_rel_map.
          apply list_rel_reflexive.
          intros row Hin.
          rewrite <- 2!first_n_first_n'.
          apply sum_Q_list_first_n_Qle; auto; apply Hnonneg; right; auto. }
        unfold b, c, eps in *; lra.
      * specialize (Hle j). unfold partial_sum in *.
        rewrite first_n_first_n' in Hepsle.
        unfold eps in Heps.
        assert (H0: (k < j)%nat).
        { lia. }
        assert (H1: x < sum_Q_list (first_n' y j) + b).
        { unfold eps in Hepsle.
          apply Qlt_le_trans with (y:=sum_Q_list (first_n' y k) + b).
          - lra.
          - cut (sum_Q_list (first_n' y k) <= sum_Q_list (first_n' y j)).
            { lra. }
            rewrite <- 2!first_n_first_n'.
            apply sum_Q_list_first_n_Qle; try lia.
            intros i; apply Hnonneg; left; reflexivity. }
        assert (H2: c <= b).
        { unfold b, c.
          apply sum_Q_list_pointwise_Qle.
          apply list_rel_map.
          apply list_rel_reflexive.
          intros row Hin.
          rewrite <- 2!first_n_first_n'.
          apply sum_Q_list_first_n_Qle; try lia; apply Hnonneg; right; auto. }
        unfold b, c, eps in *; lra.
    + apply chain_partial_sum.
      apply Hnonneg; left; reflexivity.
Qed.

(* Lemma map_rows {A B C : Type} (rows : A -> B -> C) (l1 : list B) (l2 : list A) (f : list C -> C) : *)
(*   map (fun g : B -> C => f (map g l1)) (map rows l2) = *)
(*   map f (map (fun x : A => map (rows x) l1) l2). *)
(* Proof. induction l2; simpl; auto; rewrite IHl2; auto. Qed. *)

(* Lemma jsdfg (rows : nat -> nat -> Q) (sups : nat -> Q) (ub : Q) (n : nat) : *)
(*   (forall i j, 0 <= rows i j) -> *)
(*   (forall i, supremum (sups i) (partial_sum (rows i))) -> *)
(*   (forall j, sum_Q_list (concat (map (fun i => map (rows i) (range j)) (range n))) <= ub) -> *)
(*   partial_sum sups n <= ub. *)
(* Proof. *)
(*   intros Hnonneg Hsups Hle. *)
(*   apply jsdfgsdf with (rows := first_n rows n). *)
(*   - intros row Hin i. apply in_first_n in Hin. *)
(*     destruct Hin as [j [Hle' Heq]]; subst; auto. *)
(*   - clear Hle. clear ub. *)
(*     induction n; simpl; try constructor. *)
(*     simpl. apply list_rel_app; split; auto; constructor; auto; constructor. *)
(*   - intro j. *)
(*     specialize (Hle j). *)
(*     rewrite sum_Q_list_concat in Hle.  *)
(*     rewrite first_n_first_n'. *)
(*     unfold first_n'. *)
(*     eapply Qle_trans; eauto. *)
(*     apply lkmdfgkdfgdfg. *)
(*     apply list_eq_sum_Q_list. *)
(*     apply odfg. *)
(* Qed. *)

Lemma map_nat_f_g_rows' (rows : nat -> nat -> Q) (l1 l2 : list nat) :
  map (map (fun n0 : nat => let (i, j) := nat_f n0 in rows i j))
      (map (fun i : nat => map (fun j : nat => nat_g (i, j)) l2) l1) =
  map (fun row : nat -> Q => map row l2) (map rows l1).
Proof.
  revert l2.
  induction l1; intros l2; simpl; auto.
  rewrite IHl1. f_equal.
  clear IHl1. clear l1.
  induction l2; simpl; auto.
  rewrite nat_f_g. rewrite IHl2; auto.
Qed.

Lemma supremum_flatten (rows : nat -> nat -> Q) (sups : nat -> Q) (sup : Q) :
  (forall i j, 0 <= rows i j) ->
  (forall i, supremum (sups i) (partial_sum (rows i))) ->
  supremum sup (partial_sum sups) ->
  supremum sup (partial_sum (seq_flatten rows)).
Proof.
  intros Hnonneg Hsups [Hub Hlub].
  split.
  - intro i. simpl in *.
    unfold partial_sum.
    rewrite sum_Q_list_permutation.
    2: { apply Permutation_flatten_concat_ixs. }
    rewrite sum_Q_list_concat.
    unfold row_ixs.
    apply Qle_trans with (y:= partial_sum sups (S (list_max (map (fst ∘ nat_f) (range i))))).
    2: { apply Hub. }
    unfold partial_sum. rewrite first_n_first_n'. unfold first_n'.
    apply sum_Q_list_pointwise_Qle.
    apply list_rel_map.
    apply list_rel_Qle_sup_ixs; auto.
  - intros ub H.
    apply Hlub.
    intro i. simpl.
    unfold upper_bound in H; simpl in *.
    apply rows_sups_upper_bound with (rows := first_n rows i).
    + intros row Hin j. apply in_first_n in Hin.
      destruct Hin as [k [Hle Heq]]; subst; auto.
    + rewrite 2!first_n_first_n'.
      apply list_rel_map.
      induction i; try constructor.
      simpl. apply list_rel_app; split; auto; constructor; auto; constructor.
    + intro j.
      apply Qle_trans with (y := sum_Q_list (concat (map (fun row => first_n row j) (first_n rows i)))).
      { rewrite sum_Q_list_concat. rewrite first_n_first_n'.
        apply Qeq_Qle.
        apply sum_Q_list_pointwise_Qeq.
        apply list_rel_map.
        apply list_rel_map.
        unfold first_n'.
        induction i. simpl. constructor.
        - simpl. rewrite map_app; simpl.
          apply list_rel_app; split; auto.
          constructor.
          + rewrite first_n_first_n'; reflexivity.
          + constructor. }
      rename i into n.
      rename j into m.
      set (l := concat (map (fun i => map (fun j => nat_g (i, j)) (range m)) (range n))).
      (** There is some index k for which the goal inequality follows
          by transitivity using H. *)
      set (k := S (list_max l)).
      specialize (H k).
      eapply Qle_trans; eauto.
      unfold partial_sum.
      apply sub_perm_sum_Q_list.
      * intros x Hin. apply in_first_n in Hin. destruct Hin as [i [Hle Heq]]; subst.
        unfold seq_flatten; destruct (nat_f i); auto.
      * exists (map (seq_flatten rows) (filter (fun n => negb (existsb (Nat.eqb n) l)) (range k))).
        replace (concat (map (fun row : nat -> Q => first_n row m) (first_n rows n))) with
            (map (seq_flatten rows) l).
        2: { unfold seq_flatten. unfold l. rewrite concat_map.
             f_equal.
             replace (map (fun row => first_n row m) (first_n rows n)) with
                 (map (fun row => first_n' row m) (first_n' rows n)).
             { apply map_nat_f_g_rows'. }
             rewrite first_n_first_n'.
             apply map_ext; intros f; rewrite first_n_first_n'; reflexivity. }
        etransitivity.
        -- apply Permutation_app_tail.
           eapply Permutation_map.
           apply nodup_incl_permutation with (l2:=range k).
           ++
             unfold l. apply NoDup_concat.
             ** intros l' Hin.
                apply in_map_iff in Hin.
                destruct Hin as [x [Heq Hin]]; subst.
                apply FinFun.Injective_map_NoDup.
                { intros y z Heq. apply injection_injective in Heq; inversion Heq; auto.
                  exists nat_f; apply nat_f_g. }
                apply NoDup_range.
             ** apply all_disjoint_injective.
                { intros x y Hneq z [H0 H1].
                  apply in_map_iff in H0; destruct H0 as [i [? H0]]; subst.
                  apply in_map_iff in H1; destruct H1 as [j [? H1]]; subst.
                  apply injection_injective in H2; inversion H2; subst; try congruence.
                  exists nat_f; apply nat_f_g. }
                apply NoDup_range.
           ++ apply NoDup_range.
           ++ unfold l; intros x Hin.
              assert (Hle: (x < k)%nat).
              { apply le_lt_n_Sm; apply list_max_spec; auto. }
              apply in_concat in Hin.
              destruct Hin as [l' [Hin Hin']].
              apply in_map_iff in Hin; destruct Hin as [y [? Hin]]; subst.
              apply in_map_iff in Hin'. destruct Hin' as [z [? Hin']]; subst.
              rewrite range_seq in *.
              apply in_seq in Hin.
              apply in_seq in Hin'.
              apply in_seq. simpl in *.
              split; try lia.
        -- rewrite first_n_first_n'.
           unfold first_n'.
           rewrite <- map_app.
           apply Permutation_map.
           apply Permutation_filter_partition.
Qed.

Lemma supremum_le (s : nat -> Q) (c sup : Q) :
  (forall i, c <= s i) ->
  supremum sup s ->
  c <= sup.
Proof.
  intros Hle [Hub Hlub]; simpl in *.
  apply Qle_trans with (y := s O); eauto; apply Hub.
Qed.

Lemma partial_sum_nonnegative (s : nat -> Q) (i : nat) :
  (forall j, 0 <= s j) ->
  0 <= partial_sum s i.
Proof.
  intros Hle; unfold partial_sum; induction i; simpl; try lra.
  rewrite sum_Q_list_app; simpl; specialize (Hle i); lra.
Qed.

Lemma supremum_product (s1 s2 : nat -> option (list bool)) (a b : Q) :
  supremum a (partial_sum (option_measure ∘ s1)) ->
  supremum b (partial_sum (option_measure ∘ s2)) ->
  supremum (a * b)
           (partial_sum (option_measure ∘ seq_product MonoidList s1 s2)).
Proof.
  intros Hsupa Hsupb.
  eapply supremum_f_Qeq.
  - apply partial_sum_proper.
    intro i.
    unfold compose. rewrite seq_product_flatten. reflexivity.
  - eapply Proper_supremum.
    { reflexivity. }
    { apply Proper_partial_sum, seq_flatten_compose. }
    apply supremum_flatten with (sups := fun i => option_measure (s1 i) * b).
    + intros i j; apply option_measure_nonnegative.
    + intros i.
      eapply supremum_f_Qeq.
      apply partial_sum_proper.
      intro j. symmetry. apply option_measure_product.
      eapply supremum_f_Qeq.
      intro j. symmetry. apply partial_sum_scalar.
      apply supremum_scalar; auto.
      apply option_measure_nonnegative.
    + eapply supremum_f_Qeq.
      apply partial_sum_proper.
      intro j.
      rewrite 2Qmult_comm. reflexivity.
      eapply equ_supremum.
      apply Qeq_equ. apply Qmult_comm.
      eapply supremum_f_Qeq.
      intro j. symmetry. apply partial_sum_scalar.
      apply supremum_scalar; auto.
      eapply supremum_le; eauto.
      intro i; unfold compose.
      apply partial_sum_nonnegative; intros; apply option_measure_nonnegative.
Qed.

Lemma seq_bijection_seq_star (r1 r2 : RE bool) :
  seq_bijection (RE_sequence (RE_seq (RE_star r1) r2))
                (seq_flatten
                   (fun i j => seq_product MonoidList
                                        (seq_reps_n MonoidList (RE_sequence r1) i)
                                        (RE_sequence r2) j)).
Proof.
  exists (fun n => let (i, j) := nat_f n in
           let (i0, j0) := nat_f i in
           nat_g (i0, nat_g (j0, j))).
  split.
  - exists (fun n => let (i, j) := nat_f n in
             let (i0, j0) := nat_f j in
             nat_g (nat_g (i, i0), j0)).
    split; intro n.
    + destruct (nat_f n) eqn:Hn.
      destruct (nat_f n0) eqn:Hn0.
      rewrite 2!nat_f_g.
      rewrite <- Hn0, nat_g_f, <- Hn, nat_g_f; reflexivity.
    + destruct (nat_f n) eqn:Hn.
      destruct (nat_f n1) eqn:Hn0.
      rewrite 2!nat_f_g.
      rewrite <- Hn0, nat_g_f, <- Hn, nat_g_f; reflexivity.
  - intro i; simpl; unfold seq_product, seq_reps, seq_flatten.
    destruct (nat_f i) eqn:Hi.
    destruct (nat_f n) eqn:Hn.
    rewrite 2!nat_f_g; reflexivity.
Qed.

Lemma supremum_seq_reps_n (s : nat -> option (list bool)) (a : Q) (n : nat) :
  supremum a (partial_sum (option_measure ∘ s)) ->
  supremum (Qpow a n) (partial_sum (option_measure ∘ seq_reps_n MonoidList s n)).
Proof.
  induction n.
  - unfold compose; simpl; intros _.
    apply const_supremum'.
    + intro i; unfold partial_sum; simpl; rewrite sum_Q_list_app; simpl.
      assert (0 <= option_measure (seq_one [] i)).
      { apply option_measure_nonnegative. }
      lra.
    + exists (S O).
      intros n Hle; apply Qeq_equ; induction n; unfold partial_sum.
      * inversion Hle.
      * destruct n.
        -- reflexivity.
        -- assert (H: (1 <= S n)%nat).
           { lia. }
           apply IHn in H.
           unfold partial_sum in H. simpl in H.
           rewrite sum_Q_list_app in H. simpl in H.
           simpl. rewrite 2!sum_Q_list_app. simpl.
           lra.
  - intro Hsup. simpl. unfold compose. simpl.
    eapply Proper_supremum.
    { apply Qeq_equ. apply Qmult_comm. }
    { reflexivity. }
    apply supremum_product; auto.
Qed.

Lemma RE_star_seq_geometric (r1 r2 : RE bool) (a b : Q) :
  0 <= a -> 0 <= b -> b < 1 ->
  supremum a (partial_sum (option_measure ∘ RE_sequence r2)) ->
  supremum b (partial_sum (option_measure ∘ RE_sequence r1)) ->
  supremum (a / (1 - b)) (partial_sum (option_measure ∘ RE_sequence (RE_seq (RE_star r1) r2))).
Proof.
  intros Ha0 Hb0 Hb1 Hsup1 Hsup2.
  eapply seq_bijection_supremum.
  3: {
    eapply seq_bijection_compose.
    symmetry. apply seq_bijection_seq_star. }
  - intros; apply option_measure_nonnegative.
  - intros; apply option_measure_nonnegative.
  - eapply supremum_f_Qeq.
    + apply partial_sum_proper.
      symmetry; intro j.
      apply f_Qeq_equ, seq_flatten_compose; auto.
    +  apply supremum_flatten with (sups := geometric_sequence a b).
       * intros i j; apply option_measure_nonnegative.
       * intros j.
         unfold geometric_sequence.
         eapply Proper_supremum.
         { apply Qeq_equ, Qmult_comm. }
         { reflexivity. }
         apply supremum_product; auto.
         apply supremum_seq_reps_n; auto.
       * apply geometric_series'_supremum; lra.
Qed.

Lemma partial_sum_singleton_seq {A : Type} (f : option A -> Q) (x : A) (i : nat) :
  (1 <= i)%nat ->
  (f None == 0) ->
  partial_sum (fun j => f (seq_one x j)) i == f (Some x).
Proof.
  intros Hle Hnone.
  induction i.
  - inversion Hle.
  - rewrite partial_sum_S.
    destruct i.
    + unfold partial_sum; simpl; lra.
    + assert (H: (1 <= S i)%nat).
      { lia. }
      apply IHi in H; rewrite H.
      simpl; rewrite Hnone; lra.
Qed.

Lemma infer_fail_supremum {A : Type} (t : tree A) (n : nat) :
  wf_tree t ->
  unbiased t ->
  not_bound_in n t ->
  supremum (infer_fail n t)
           (partial_sum (option_measure ∘ RE_sequence (RE_of_tree_fail t n))).
Proof.
  generalize n.
  induction t; intros m Hwf Hunbiased Hnotbound.
  - unfold compose; simpl.
    apply const_supremum.
    intro i; apply Qeq_equ.
    rewrite partial_sum_const, sum_Q_list_repeat_0; lra.
  - unfold compose; simpl.
    destruct (Nat.eqb_spec n0 m); subst.
    + apply const_supremum'.
      * apply chain_partial_sum.
        intros; apply option_measure_nonnegative.
      * exists (S O).
        intros i Hle; apply Qeq_equ.
        apply partial_sum_singleton_seq; auto; reflexivity.
    + apply const_supremum.
      intro i; apply Qeq_equ.
      unfold option_measure; simpl.
      rewrite partial_sum_const, sum_Q_list_repeat_0; lra.
  - apply crunch_partial_sum_supremum.
    { intro i; apply option_measure_nonnegative. }
    eapply Proper_supremum_Q.
    + reflexivity.
    + etransitivity.
      apply partial_sum_proper; simpl.
      intro j; apply crunch_union_sum.
      intro j; apply partial_sum_linear.
    + simpl; inversion Hwf; inversion Hunbiased; inversion Hnotbound;
        subst; apply supremum_sum_Q; specialize (IHt1 m); specialize (IHt2 m).
      * intro i; apply partial_sum_increasing; auto.
        intro j; apply option_measure_nonnegative.
      * intro i; apply partial_sum_increasing; auto.
        intro j; apply option_measure_nonnegative.
      * eapply Proper_supremum.
        { apply Qeq_equ; rewrite H8; reflexivity. }
        apply f_Qeq_equ; intro i.
        apply partial_sum_measure_factor.
        apply supremum_scalar; auto; lra.
      * eapply Proper_supremum.
        { apply Qeq_equ; rewrite H8; reflexivity. }
        apply f_Qeq_equ; intro i.
        apply partial_sum_measure_factor.
        apply supremum_scalar; auto; lra.
  - rewrite infer_fail_fix, RE_of_tree_fail_fix.
    inversion Hwf; inversion Hunbiased; inversion Hnotbound; subst.
    destruct (RE_nonemptyb_spec (RE_of_tree_fail t m)).
    + apply RE_nonempty_RE_of_tree_fail_infer_fail in r; auto.
      apply RE_star_seq_geometric; auto.
      * apply infer_fail_0_le; auto.
      * apply infer_fail_0_le; auto.
      * apply infer_fail_lt_1; auto.
        assert (infer_fail m t + infer_fail n0 t <= 1).
        { apply infer_fail_infer_fail_le_1; auto. }
        lra.
    + apply RE_is_empty_not_nonempty in n1.
      assert (forall i, RE_sequence (RE_of_tree_fail t m) i = None).
      { intro i; apply RE_is_empty_sequence; auto. }
      apply supremum_f_Qeq with (f := const 0).
      { intro i. simpl. unfold compose, const.
        transitivity (partial_sum (const 0) i).
        { symmetry; apply partial_sum_0. }
        apply partial_sum_proper; intro j.
        unfold const, seq_product. simpl. destruct (nat_f j).
        rewrite H, option_mult_none_r; reflexivity. }
      apply RE_is_empty_infer_fail in n1; auto.
      eapply equ_supremum. apply Qeq_equ. rewrite n1, Qdiv_0_num; reflexivity.
      apply const_supremum; intro i; reflexivity.
Qed.

Lemma infer_f_supremum {A : Type} (t : tree A) (P : A -> bool) :
  wf_tree t ->
  unbiased t ->
  supremum (infer_f (fun x => if P x then 1 else 0) t)
           (partial_sum (option_measure ∘ tree_sequence_f t P)).
Proof.
  induction t; intros Hwf Hunbiased.
  - unfold compose, tree_sequence_f; simpl.
    destruct (P a) eqn:Ha.
    + apply const_supremum'.
      * apply chain_partial_sum.
        intros; apply option_measure_nonnegative.
      * exists (S O).
        intros i Hle; apply Qeq_equ.
        apply partial_sum_singleton_seq; auto; reflexivity.
    + apply const_supremum.
      intro i; apply Qeq_equ.
      unfold option_measure; simpl.
      rewrite partial_sum_const, sum_Q_list_repeat_0; lra.
  - apply const_supremum; intro i; apply Qeq_equ.
    unfold compose, option_measure; simpl.
    rewrite partial_sum_const, sum_Q_list_repeat_0; lra.
  - apply crunch_partial_sum_supremum.
    { intro i; apply option_measure_nonnegative. }
    eapply Proper_supremum_Q.
    + reflexivity.
    + etransitivity.
      apply partial_sum_proper.
      unfold tree_sequence. simpl.
      intro j; apply crunch_union_sum.
      intro j; apply partial_sum_linear.
    + simpl; inversion Hwf; inversion Hunbiased; subst; apply supremum_sum_Q.
      * intro i; apply partial_sum_increasing; auto.
        intro j; apply option_measure_nonnegative.
      * intro i; apply partial_sum_increasing; auto.
        intro j; apply option_measure_nonnegative.
      * eapply Proper_supremum.
        { apply Qeq_equ; rewrite H8; reflexivity. }
        apply f_Qeq_equ; intro i.
        apply partial_sum_measure_factor.
        apply supremum_scalar; auto; lra.
      * eapply Proper_supremum.
        { apply Qeq_equ; rewrite H8; reflexivity. }
        apply f_Qeq_equ; intro i.
        apply partial_sum_measure_factor.
        apply supremum_scalar; auto; lra.
  - unfold tree_sequence_f.
    rewrite infer_f_fix, RE_of_tree_f_fix.
    inversion Hwf; inversion Hunbiased; subst.
    destruct (RE_nonemptyb_spec (RE_of_tree_f t P)).
    + apply RE_nonempty_RE_of_tree_f_infer_f in r; auto.
      apply RE_star_seq_geometric; auto; try lra.
      * apply infer_fail_0_le; auto.
      * apply infer_fail_lt_1; auto.
        assert (infer_f (fun x => if P x then 1 else 0) t + infer_fail n t <= 1).
        { apply infer_f_infer_fail_le_1; auto.
          intro x; destruct (P x); lra. }
        lra.
      * apply infer_fail_supremum; auto.
    + apply RE_is_empty_not_nonempty in n0.
      assert (forall i, RE_sequence (RE_of_tree_f t P) i = None).
      { intro i; apply RE_is_empty_sequence; auto. }
      apply supremum_f_Qeq with (f := const 0).
      { intro i. simpl. unfold compose, const.
        transitivity (partial_sum (const 0) i).
        { symmetry; apply partial_sum_0. }
        apply partial_sum_proper; intro j.
        unfold const, seq_product. simpl. destruct (nat_f j).
        rewrite H, option_mult_none_r; reflexivity. }
      apply RE_is_empty_infer_f in n0; auto.
      eapply equ_supremum. apply Qeq_equ. rewrite n0, Qdiv_0_num; reflexivity.
      apply const_supremum; intro i; reflexivity.
Qed.

(** PLAN:
        Show a bijection (maybe trivial?) between the sequence and a
        flattened table where the nth row has measure equal to a^n*b
        where a is [infer_fail n t] and b is [infer_f P t]. The nth
        row is be the cartesian product of the nth repetitions of r1
        (seq_product_n r1 n) with r2 where the sequence is [RE_seq
        (RE_star r1) r2].
 *)

(** foster, kozen, netkat*)

Lemma infer_supremum {A : Type} (t : tree A) (P : A -> bool) (n : nat) :
  wf_tree t ->
  unbiased t ->
  (forall m, free_in m t -> m = n) ->
  not_bound_in n t ->
  supremum (infer (fun x => if P x then 1 else 0) t)
           (partial_sum (option_measure ∘ tree_sequence t P n)).
Proof.
  intros Hwf Hunbiased Hfree Hnotbound.
  unfold infer. eapply supremum_Qeq.
  { rewrite infer_f_lib_infer_fail_complement; eauto; reflexivity. }
  destruct (RE_nonemptyb_spec (RE_of_tree_f t P)).
  - apply RE_nonempty_infer_fail with (n0:=n) in r; auto.
    apply RE_star_seq_geometric; auto.
    + apply infer_f_expectation_0_le; auto.
      intros x; destruct (P x); lra.
    + apply infer_fail_0_le; auto.
    + apply infer_f_supremum; auto.
    + apply infer_fail_supremum; auto.
  - apply RE_is_empty_not_nonempty in n0.
    pose proof n0 as H.
    apply RE_is_empty_infer_f in H; auto.
    eapply supremum_Qeq.
    { rewrite H, Qdiv_0_num; reflexivity. }
    clear H.
    unfold tree_sequence.
    eapply supremum_f_Qeq.
    apply partial_sum_proper.
    intro x. unfold compose.
    rewrite RE_is_empty_sequence.
    + reflexivity.
    + apply RE_is_empty_seq2; auto.
    + apply const_supremum; intro i; apply Qeq_equ; apply partial_sum_0.
Qed.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Relations.Relation_Definitions.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.Semantics.Kripke.
Require Import Logic.MinimunLogic.DeepEmbedded.MinimunLanguage.

Import MinimunLanguage.

Record frame: Type := {
  underlying_set:> Type;
  underlying_relation: relation underlying_set
}.

Infix "<=" := (underlying_relation _): TheKripkeSemantics.

Local Open Scope TheKripkeSemantics.

Definition sem (f: frame) := @Ensemble (underlying_set f).

Definition denotation {Var: Type} (F: frame) (eval: Var -> sem F): expr Var -> sem F :=
  fix denotation (x: expr Var): sem F:=
  match x with
  | impp y z => @Semantics.impp F (underlying_relation F) (denotation y) (denotation z)
  | varp p => eval p
  end.

Section KripkeSemantics.
Context (Var: Type).

Record Kmodel : Type := {
  underlying_frame :> frame;
  sem_var: Var -> sem underlying_frame
}.

Record model: Type := {
  underlying_model :> Kmodel;
  elm: underlying_model
}.

Instance L: Language := MinimunLanguage.L Var.
Instance MD: Model := Build_Model model.

Instance kMD: KripkeModel MD :=
  Build_KripkeModel _
    Kmodel
    (fun M => M)
    (fun M m => Build_model M m).

Instance R (M: Kmodel): Relation (Kworlds M) :=
  @underlying_relation M.

Definition Kmodel_Monotonic: Kmodel -> Prop := fun M =>
  forall v: Var, upwards_closed_Kdenote (sem_var M v).

Definition Kmodel_PreOrder: Kmodel -> Prop := fun M =>
  PreOrder (@Krelation _ (R M)).

Instance SM: Semantics L MD :=
  Build_Semantics L MD (fun x M => (denotation M (sem_var M) x) (elm M)).

Instance kiSM (M: Kmodel) {_: Kmodel_Monotonic M} {_: Kmodel_PreOrder M}:
  KripkeIntuitionisticSemantics L MD M SM.
Proof.
  hnf in H, H0.
  constructor; intros.
  induction x.
  + apply (Semantics.impp_closed _ _ IHx1 IHx2).
  + apply H.
Qed.

Instance kminSM (M: Kmodel): KripkeMinimunSemantics L MD M SM.
Proof.
  apply Build_KripkeMinimunSemantics.
  intros; apply Same_set_refl.
Defined.

End KripkeSemantics.

Arguments Kmodel_Monotonic {Var} _.
Arguments Kmodel_PreOrder {Var} _.


(** * Theorems about string-like types *)
Require Import Coq.Setoids.Setoid.
Require Import Coq.Arith.Lt.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.omega.Omega.
Require Import Parsers.StringLike.Core Common.Le Common.UIP.
Require Import Common.Equality.

Set Implicit Arguments.

Definition stringlike_dec {CharType} {String : string_like CharType} (s1 s2 : String)
: { s1 = s2 } + { s1 <> s2 }.
Proof.
  case_eq (bool_eq s1 s2); intro H; [ left | right ].
  { apply bool_eq_correct; exact H. }
  { intro H'; apply bool_eq_correct in H'.
    generalize dependent (s1 =s s2)%string_like; clear; intros.
    abstract congruence. }
Defined.

Global Instance str_le_refl {CharType String} : Reflexive (@str_le CharType String).
Proof.
  repeat intro; right; reflexivity.
Qed.

Global Instance str_le_antisym {CharType String} : Antisymmetric _ eq (@str_le CharType String).
Proof.
  intros ? ? [H0|H0]; repeat subst; intros [H1|H1]; repeat subst; try reflexivity.
  exfalso; eapply lt_irrefl;
  etransitivity; eassumption.
Qed.

Global Instance str_le_trans {CharType String} : Transitive (@str_le CharType String).
Proof.
  intros ? ? ? [H0|H0]; repeat subst; intros [H1|H1]; repeat subst;
  first [ reflexivity
        | left; assumption
        | left; etransitivity; eassumption ].
Qed.

Add Parametric Relation {CharType String} : _ (@str_le CharType String)
    reflexivity proved by reflexivity
    transitivity proved by transitivity
      as str_le_rel.

Local Open Scope string_like_scope.

Local Ltac str_le_append_t :=
  repeat match goal with
           | _ => intro
           | _ => progress subst
           | [ H : (_ =s _) = true |- _ ] => apply bool_eq_correct in H
           | _ => progress rewrite ?LeftId, ?RightId
           | _ => right; reflexivity
           | [ H : Length _ = 0 |- _ ] => apply Empty_Length in H
           | [ H : Length ?s <> 0 |- _ ] => destruct (Length s)
           | [ H : ?n <> ?n |- _ ] => destruct (H eq_refl)
           | [ |- ?x < ?x + S _ \/ _ ] => left; omega
           | [ |- ?x < S _ + ?x \/ _ ] => left; omega
         end.

Lemma str_le1_append CharType (String : string_like CharType) (s1 s2 : String)
: s1 ≤s s1 ++ s2.
Proof.
  hnf.
  rewrite <- Length_correct.
  case_eq (s2 =s (Empty _));
  destruct (NPeano.Nat.eq_dec (Length s2) 0);
  str_le_append_t.
Qed.

Lemma str_le2_append CharType (String : string_like CharType) (s1 s2 : String)
: s2 ≤s s1 ++ s2.
Proof.
  hnf.
  rewrite <- Length_correct.
  case_eq (s1 =s Empty _);
  destruct (NPeano.Nat.eq_dec (Length s1) 0);
  str_le_append_t.
Qed.

Lemma length_le_trans {CharType} {String : string_like CharType}
      {a b c : String} (H : Length a < Length b) (H' : b ≤s c)
: Length a < Length c.
Proof.
  destruct H'; subst.
  { etransitivity; eassumption. }
  { assumption. }
Qed.

Lemma strle_to_sumbool {CharType} {String : string_like CharType}
      (s1 s2 : String) (f : String -> nat)
      (H : f s1 < f s2 \/ s1 = s2)
: {f s1 < f s2} + {s1 = s2}.
Proof.
  case_eq (s1 =s s2).
  { intro H'; right.
    abstract (apply bool_eq_correct in H'; exact H'). }
  { intro H'; left.
    abstract (
        destruct H; trivial;
        apply bool_eq_correct in H;
        generalize dependent (s1 =s s2)%string_like; intros; subst;
        discriminate
      ). }
Defined.

Section strle_choose.
  Context {CharType} {String : string_like CharType}
          (s1 s2 : String) (f : String -> nat)
          (H : f s1 < f s2 \/ s1 = s2).

  Definition strle_left (H' : f s1 < f s2)
  : H = or_introl H'.
  Proof.
    destruct H as [H''|H'']; subst; [ apply f_equal | exfalso ].
    { apply le_proof_irrelevance. }
    { eapply lt_irrefl; eassumption. }
  Qed.

  Definition strle_right (H' : s1 = s2)
  : H = or_intror H'.
  Proof.
    destruct H as [H''|H'']; [ subst; exfalso | apply f_equal ].
    { eapply lt_irrefl; eassumption. }
    { apply dec_eq_uip.
      clear.
      intro y.
      destruct (Bool.bool_dec (bool_eq s1 y) true) as [H|H].
      { left.
        apply bool_eq_correct; assumption. }
      { right; intro H'.
        apply bool_eq_correct in H'.
        auto. } }
  Qed.
End strle_choose.

Lemma NonEmpty_Length {CharType} {String : string_like CharType}
      (a : String)
      (H : a <> Empty _)
: Length a > 0.
Proof.
  case_eq (Length a); intro H'; try omega.
  apply Empty_Length in H'; subst.
  destruct (H eq_refl).
Qed.

Local Ltac lt_nonempty_t :=
  repeat match goal with
           | [ H : _ ≤s _ |- _ ] => destruct H
           | [ H : _ |- _ ] => progress rewrite ?plus_O_n, <- ?Length_correct in H
           | _ => progress rewrite ?plus_O_n, <- ?Length_correct
           | _ => assumption
           | _ => intro
           | _ => progress subst
           | _ => omega
           | [ H : _ <> Empty _ |- _ ] => apply NonEmpty_Length in H
         end.

Lemma strle_to_lt_nonempty_r {CharType} {String : string_like CharType}
      {a b c : String}
      (H : a <> Empty _)
      (H' : a ++ b ≤s c)
: Length b < Length c.
Proof. lt_nonempty_t. Qed.

Lemma strle_to_lt_nonempty_l {CharType} {String : string_like CharType}
      {a b c : String}
      (H : b <> Empty _)
      (H' : a ++ b ≤s c)
: Length a < Length c.
Proof. lt_nonempty_t. Qed.

Lemma neq_some_none_state_val {CharType} {String : string_like CharType} {P}
      {s1 s2 : StringWithSplitState String (fun x => option (P x))}
      (H : s1 = s2)
: match state_val s1, state_val s2 with
    | None, Some _ => False
    | Some _, None => False
    | _, _ => True
  end.
Proof.
  destruct H.
  destruct (state_val s1); exact I.
Qed.

Definition string_val_path {CharType String A}
      {s0 s1 : @StringWithSplitState CharType String A}
      (H : s0 = s1)
: string_val s0 = string_val s1
  := f_equal (@string_val _ _ _) H.

Definition state_val_path {CharType String A}
      {s0 s1 : @StringWithSplitState CharType String A}
      (H : s0 = s1)
: eq_rect _ _ (state_val s0) _ (string_val_path H) = state_val s1.
Proof.
  destruct H; reflexivity.
Defined.

(** This proof would be so much easier to read if we were using HoTT conventions, tactics, and lemmas. *)
Lemma lift_StringWithSplitState_injective {CharType String A B}
           (s0 s1 : @StringWithSplitState CharType String A)
           (lift : forall s, A s -> B s)
           (lift_injective : forall s a1 a2, lift s a1 = lift s a2 -> a1 = a2)
           (H : lift_StringWithSplitState s0 (lift _) = lift_StringWithSplitState s1 (lift _))
: s0 = s1.
Proof.
  pose proof (state_val_path H) as H'.
  generalize dependent (string_val_path H); clear H.
  destruct s0, s1; simpl in *.
  intro H'.
  destruct H'; simpl.
  intro H'.
  apply lift_injective in H'.
  destruct H'.
  reflexivity.
Qed.

Lemma lift_StringWithSplitState_pair_injective {CharType String A A' B B'}
           (s0 s1 : @StringWithSplitState CharType String A * @StringWithSplitState CharType String A')
           (lift : forall s, A s -> B s)
           (lift' : forall s, A' s -> B' s)
           (lift_injective : forall s a1 a2, lift s a1 = lift s a2 -> a1 = a2)
           (lift'_injective : forall s a1 a2, lift' s a1 = lift' s a2 -> a1 = a2)
           (H : (lift_StringWithSplitState (fst s0) (lift _),
                 lift_StringWithSplitState (snd s0) (lift' _))
                =
                (lift_StringWithSplitState (fst s1) (lift _),
                 lift_StringWithSplitState (snd s1) (lift' _)))
: s0 = s1.
Proof.
  pose proof (f_equal (@fst _ _) H) as H0.
  pose proof (f_equal (@snd _ _) H) as H1.
  clear H; simpl in *.
  apply lift_StringWithSplitState_injective in H0; [ | assumption.. ].
  apply lift_StringWithSplitState_injective in H1; [ | assumption.. ].
  apply injective_projections; assumption.
Qed.

Lemma in_lift_pair_StringWithSplitState_iff_injective {CharType String A A' B B'}
      {s0s1 : @StringWithSplitState CharType String A * @StringWithSplitState CharType String A'}
      {lift : forall s, A s -> B s}
      {lift' : forall s, A' s -> B' s}
      {lift_injective : forall s a1 a2, lift s a1 = lift s a2 -> a1 = a2}
      {lift'_injective : forall s a1 a2, lift' s a1 = lift' s a2 -> a1 = a2}
      {ls : list (StringWithSplitState String A * StringWithSplitState String A')}
      (H : List.In (lift_StringWithSplitState (fst s0s1) (lift _),
                    lift_StringWithSplitState (snd s0s1) (lift' _))
                   (List.map (fun s0s1 =>
                                (lift_StringWithSplitState (fst s0s1) (lift _),
                                 lift_StringWithSplitState (snd s0s1) (lift' _)))
                             ls))
: List.In s0s1 ls.
Proof.
  eapply in_map_iff_injective; [ | exact H ].
  simpl; intro.
  apply lift_StringWithSplitState_pair_injective; assumption.
Qed.


Require Import rt.model.basic.time rt.util.all.
Require Import rt.model.basic.task.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.

Module ConcreteTask.

  Import Time SporadicTaskset.

  Section Defs.

    (* Definition of a concrete task. *)
    Record concrete_task :=
    {
      task_id: nat; (* for uniqueness *)
      task_cost: time;
      task_period: time;
      task_deadline: time
    }.

    (* To make it compatible with ssreflect, we define a decidable
       equality for concrete tasks. *)
    Definition task_eqdef (t1 t2: concrete_task) :=
      (task_id t1 == task_id t2) &&
      (task_cost t1 == task_cost t2) &&
      (task_period t1 == task_period t2) &&
      (task_deadline t1 == task_deadline t2).

    (* Next, we prove that task_eqdef is indeed an equality, ... *)
    Lemma eqn_task : Equality.axiom task_eqdef.
    Proof.
      unfold Equality.axiom; intros x y.
      destruct (task_eqdef x y) eqn:EQ.
      {
        apply ReflectT.
        unfold task_eqdef in *.
        move: EQ => /andP [/andP [/andP [/eqP ID /eqP COST] /eqP PERIOD] /eqP DL].
        by destruct x, y; simpl in *; subst.
      }
      {
        apply ReflectF.
        unfold task_eqdef, not in *; intro BUG.
        apply negbT in EQ; rewrite negb_and in EQ.
        destruct x, y.
        rewrite negb_and in EQ.
        move: EQ => /orP [EQ | /eqP DL]; last by apply DL; inversion BUG.
        move: EQ => /orP [EQ | /eqP PERIOD].
        rewrite negb_and in EQ.
        move: EQ => /orP [/eqP ID | /eqP COST].
        by apply ID; inversion BUG.
        by apply COST; inversion BUG.
        by apply PERIOD; inversion BUG.
      }
    Qed.

    (* ..., which allows instantiating the canonical structure. *)
    Canonical concrete_task_eqMixin := EqMixin eqn_task.
    Canonical concrete_task_eqType := Eval hnf in EqType concrete_task concrete_task_eqMixin.

  End Defs.

  Section ConcreteTaskset.

    Definition concrete_taskset :=
      taskset_of concrete_task_eqType.

  End ConcreteTaskset.

End ConcreteTask.


(*|
################################################
Interaction between type classes and auto tactic
################################################

:Link: https://stackoverflow.com/q/46244909
|*)

(*|
Question
********

Consider this simple development. I have two trivial data types:
|*)

Inductive A :=
| A1
| A2.

Inductive B :=
| B1 : A -> B
| B2.

(*|
Now I introduce a concept of relation and define ordering on data
types ``A`` and ``B`` expressed as an inductive data type:
|*)

Definition relation (X : Type) := X -> X -> Prop.

Reserved Notation "a1 '<=A' a2" (at level 70).

Inductive AOrd : relation A :=
| A1_Ord : A1 <=A A1
| A2_Ord : A2 <=A A2
| A1_A2  : A1 <=A A2
where "a1 '<=A' a2" := (AOrd a1 a2).

Reserved Notation "b1 '<=B' b2" (at level 70).

Inductive BOrd : relation B :=
| B1_Ord : forall a1 a2,
    a1 <=A a2 -> B1 a1 <=B B1 a2
| B2_Ord :
  B2 <=B B2
| B1_B2  : forall a,
    B1 a <=B B2
where "b1 '<=B' b2" := (BOrd b1 b2).

(*|
Finally, I introduce a concept of reflexivity and prove that both of
my relations are reflexive:
|*)

Definition reflexive {X : Type} (R : relation X) :=
  forall a : X, R a a.

Hint Constructors AOrd BOrd.

Theorem AOrd_reflexive : reflexive AOrd.
Proof.
  intro a. induction a; auto.
Qed.

Hint Resolve AOrd_reflexive.

Theorem BOrd_reflexive : reflexive BOrd.
Proof.
  intro b. induction b; auto.
Qed.

(*|
Both proofs are finished with ``auto`` tactic, with the first proof
crucially relying on ``Hint Constructors`` and the second one
additionally on ``Hint Resolve AOrd_reflexive`` being added to hint
database.

An ugly thing about the code above is having a separate notation for
ordering relation for ``A`` and ``B`` data types. I'd like to be able
to uniformly use ``<=`` everywhere. `This answer
<https://stackoverflow.com/a/44057494/1273482>`__ provides a solution
to the problem: use type classes. So I introduce a type class for
ordering and redefine my ordering relations to use this new notation:
|*)

Reset AOrd. (* .none *)
Class OrderR (T : Type) := orderR : relation T.
Notation "x '<=' y" := (orderR x y) (at level 70).

Inductive AOrd : OrderR A :=
| A1_Ord : A1 <= A1
| A2_Ord : A2 <= A2
| A1_A2  : A1 <= A2.

Inductive BOrd `{OrderR A} : OrderR B :=
| B1_Ord : forall a1 a2,
    a1 <= a2 -> B1 a1 <= B1 a2
| B2_Ord :
  B2 <= B2
| B1_B2  : forall a,
    B1 a <= B2.

Definition reflexive {X : Type} (R : relation X) :=
  forall a : X, R a a. (* .none *)
Hint Constructors AOrd BOrd.

(*| But now proof automation breaks! For example: |*)

Theorem AOrd_reflexive : reflexive AOrd.
Proof.
  intro a. induction a.

(*| leaves me with a goal: |*)

  Show. (* .unfold .messages *)
Abort. (* .none *)

(*|
that ``auto`` no longer solves despite ``AOrd`` constructors being in
hint database. I can solve the goal with ``constructor`` though:
|*)

Theorem AOrd_reflexive : reflexive AOrd.
Proof.
  intro a. induction a; constructor.
Qed.

(*| More problems arise in second proof. After doing: |*)

Theorem BOrd_reflexive `{OrderR A} : reflexive BOrd.
Proof.
  intro b. induction b; constructor.

(*| I am left with goal: |*)

  Show. (* .unfold .messages *)

(*|
Again, ``auto`` no longer solves this goal. Even ``apply
AOrd_reflexive`` does not work.

My question is: is it possible to have a uniform notation by relying
on type classes and maintain benefits of proof automation? Or is there
a different solution to having a uniform notation for various data
types.
|*)

(*|
Answer (eponier)
****************

A solution that does not involve typeclasses is to take advantage of
the scope mechanism of Coq.
|*)

Reset Initial. (* .none *)
Inductive A :=
| A1
| A2.

Inductive B :=
| B1 : A -> B
| B2.

Definition relation (X : Type) := X -> X -> Prop.

Reserved Notation "a1 '<=' a2" (at level 70).

Inductive AOrd : relation A :=
| A1_Ord : A1 <= A1
| A2_Ord : A2 <= A2
| A1_A2  : A1 <= A2
where "a1 '<=' a2" := (AOrd a1 a2) : a_scope.

Delimit Scope a_scope with a.

Inductive BOrd : relation B :=
| B1_Ord : forall a1 a2,
    (a1 <= a2)%a -> B1 a1 <= B1 a2
| B2_Ord :
  B2 <= B2
| B1_B2  : forall a,
    B1 a <= B2
where "b1 '<=' b2" := (BOrd b1 b2) : b_scope.

Delimit Scope b_scope with b.

Definition reflexive {X : Type} (R : relation X) :=
  forall a : X, R a a.

Hint Constructors AOrd BOrd.

Theorem AOrd_reflexive : reflexive AOrd.
Proof.
  intro a. induction a; auto.
Qed.

Hint Resolve AOrd_reflexive.

Theorem BOrd_reflexive : reflexive BOrd.
Proof.
  intro b. induction b; auto.
Qed.

(*|
Answer (Jason Gross)
********************

The issue is that your hints are set to trigger on, e.g., ``@orderR _
AOrd A1 A2``, not ``AOrd A1 A2``. So the automation never sees the
pattern it's looking for, and never triggers the hints. Here are two
solutions:

1. You can adjust the type of your constructors when adding them to
   the hint database, so that they trigger when you want them to:

   .. coq:: none
|*)

Reset AOrd.
Class OrderR (T : Type) := orderR : relation T.
Notation "x '<=' y" := (orderR x y) (at level 70).

Inductive AOrd : OrderR A :=
| A1_Ord : A1 <= A1
| A2_Ord : A2 <= A2
| A1_A2  : A1 <= A2.

Inductive BOrd `{OrderR A} : OrderR B :=
| B1_Ord : forall a1 a2,
    a1 <= a2 -> B1 a1 <= B1 a2
| B2_Ord :
  B2 <= B2
| B1_B2  : forall a,
    B1 a <= B2.

Definition reflexive {X : Type} (R : relation X) :=
  forall a : X, R a a.

Hint Constructors AOrd BOrd.

(*||*)

Hint Resolve (A1_Ord : AOrd _ _) (A2_Ord : AOrd _ _) (A1_A2 : AOrd _ _).
Hint Resolve (@B1_Ord : forall H a1 a2, _ -> BOrd _ _)
     (@B2_Ord : forall H, BOrd _ _)
     (@B1_B2 : forall H a, BOrd _ _).

(*|
2. You can define "folding" lemmas that convert the types, and add
   those to the database:
|*)

Definition fold_AOrd a1 a2 (v : a1 <= a2) : AOrd a1 a2 := v.
Definition fold_BOrd `{OrderR A} (a1 a2 : B) (v : a1 <= a2) : BOrd a1 a2 := v.
Hint Resolve fold_AOrd fold_BOrd.

(*|
----

**Q:** Thanks Jason. I'm afraid your solution does not work for me.
Folding lemmas don't seem to change anything. Adjusting type of
constructors works when proving ``AOrd_reflexive`` but in the proof of
``BOrd_reflexive`` it is still not possible to prove ``a <= a`` from
``AOrd_reflexive``.
|*)


Axiom functional_extensionality:
    forall {X Y: Type} {f g: X -> Y},
    (forall (x: X), f x = g x) -> f = g.

Notation "x :: xs" := (cons x xs)(at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) .. ).
Notation "x ++ y" := (app x y) (at level 60, right associativity).

Fixpoint rev {X: Type} (l: list X) : list X :=
    match l with
    | nil => nil
    | x::xs => (rev xs) ++ [x]
    end.

Fixpoint rev_append {X: Type} (l1 l2: list X): list X:=
    match l1 with
    | [] => l2
    | x::l1' => rev_append l1' (x::l2)
    end.

Definition tr_rev {X} (l: list X): list X := rev_append l [].

Lemma cons_app: forall (X: Type) (l1 l2: list X) (a: X),
    a :: l1 ++ l2 = (a::l1) ++ l2. Admitted.

Lemma rev_append_app': forall (X: Type) (l l1 l2 : list X),
    rev_append l (l1 ++ l2) = rev_append l l1 ++ l2.
Proof.
    intros.
    generalize dependent l1.
    generalize dependent l2.
    induction l.
    - reflexivity.
    - simpl.
      intros.
      rewrite -> cons_app.
      apply (@IHl l2 (a::l1)).
Qed.

Lemma tr_rev_correct: forall X, @tr_rev X = @rev X.
Proof.
    intros.
    apply functional_extensionality.
    intro x. induction x as [| t ts IHt].
    - reflexivity.
    - simpl.
      rewrite <- IHt.
      simpl. unfold tr_rev. simpl.
      apply (@rev_append_app' X ts [] [t]).
Qed.

Fixpoint eqb (n m : nat) : bool :=
    match n with
    | O =>  match m with
            | O => true
            | S _ => false
            end
    | S n' => match m with
            | O => false
            | S m' => eqb n' m'
            end
    end.

Fixpoint eqb_list (l1 l2: list nat): bool :=
    match l1, l2 with
    | [], [] => true
    | x::l1', [] => false
    | [], x::l2' => false
    | x::l1', y::l2' => if eqb x y
                        then eqb_list l1' l2'
                        else false
    end.

Lemma eq_cons: forall (x y: nat) (xs ys: list nat),
    x = y -> xs = ys <-> (x::xs) = (y::ys). Admitted.

Theorem eqb_list_true:
    (forall a1 a2, eqb a1 a2 = true <-> a1 = a2) ->
    forall l1 l2, eqb_list l1 l2 = true <-> l1 = l2.
Proof.
    intros H.
    intro l1. induction l1 as [|x xs IHx].
    - intro l2. induction l2 as [|y ys IHy].
      + simpl. split.
        reflexivity. reflexivity.
      + simpl. split.
        intro. discriminate H0.
        intro. discriminate H0.
    - intro l2. induction l2 as [|y ys IHy].
      + simpl. split.
        intro. discriminate H0.
        intro. discriminate H0.
      + split.
        {
            intro. simpl in H0.
            destruct (eqb x y) eqn: P.
            apply IHx in H0.
            apply eq_cons.
            apply H. apply P.
            apply H0.
            discriminate H0.
        }
        {
            intro. simpl.
            destruct (eqb x y) eqn: P.
            apply IHx.
            inversion H0.
            reflexivity.
            inversion H0.
            apply H in H2.
            destruct P.
            apply H2.
        }
Qed.

Require Import Setoid.

Lemma neg_or: forall (P Q: Prop), ~ (P \/ Q) = (~P /\ ~Q). Admitted.
Lemma double_neg: forall P: Prop, ~~P = P.
Proof.
    intro. unfold not.
    intros. destruct H. reflexivity.
Qed.

Lemma fal: forall P: Prop, ~ (P /\ ~P ).
Proof.
    intro.
    unfold not.
    intros.
    destruct H.
    apply H0 in H.
    apply H.
Qed.

Lemma unnot: forall P: Prop, ~ P = P -> False. Admitted.

Theorem exmd: forall (P: Prop),
    ~ ~ (P \/ ~ P).
Proof.
    intro P.
    assert (H: ~ (P \/ ~P) = (~P /\ ~~P)).
    {
        apply (@neg_or P (~P)).
    }
Abort.

(* Qed. *)


(*** Word-By-Word Montgomery Multiplication *)
(** This file implements Montgomery Form, Montgomery Reduction, and
    Montgomery Multiplication on an abstract [ℤⁿ].  See
    https://github.com/REDACTED/REDACTED/issues/157 for a discussion
    of the algorithm; note that it may be that none of the algorithms
    there exactly match what we're doing here. *)
Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.Saturated.MontgomeryAPI.
Require Import Crypto.Arithmetic.MontgomeryReduction.WordByWord.Abstract.Dependent.Definition.
Require Import Crypto.Util.Notations.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.CPS.

Local Open Scope Z_scope.

Section WordByWordMontgomery.
  Local Coercion Z.pos : positive >-> Z.
  (** TODO: pick better names for the arguments to this definition. *)
  Context
    {r : positive}
    {R_numlimbs : nat}
    (N : T R_numlimbs).

  Local Notation scmul := (@scmul (Z.pos r)).
  Local Notation addT' := (@MontgomeryAPI.add_S1 (Z.pos r)).
  Local Notation addT := (@MontgomeryAPI.add (Z.pos r)).
  Local Notation conditional_sub_cps := (fun V => @conditional_sub_cps (Z.pos r) _ V N _).
  Local Notation conditional_sub := (fun V => @conditional_sub (Z.pos r) _ V N).
  Local Notation sub_then_maybe_add_cps :=
    (fun V1 V2 => @sub_then_maybe_add_cps (Z.pos r) R_numlimbs (Z.pos r - 1) V1 V2 N).
  Local Notation sub_then_maybe_add := (fun V1 V2 => @sub_then_maybe_add (Z.pos r) R_numlimbs (Z.pos r - 1) V1 V2 N).

  Definition redc_body_no_cps (B : T R_numlimbs) (k : Z) {pred_A_numlimbs} (A_S : T (S pred_A_numlimbs) * T (S R_numlimbs))
    : T pred_A_numlimbs * T (S R_numlimbs)
    := @redc_body T (@divmod) r R_numlimbs (@scmul) (@addT) (@addT') (@drop_high (S R_numlimbs)) N B k _ A_S.
  Definition redc_loop_no_cps (B : T R_numlimbs) (k : Z) (count : nat) (A_S : T count * T (S R_numlimbs))
    : T 0 * T (S R_numlimbs)
    := @redc_loop T (@divmod) r R_numlimbs (@scmul) (@addT) (@addT') (@drop_high (S R_numlimbs)) N B k count A_S.
  Definition pre_redc_no_cps {A_numlimbs} (A : T A_numlimbs) (B : T R_numlimbs) (k : Z) : T (S R_numlimbs)
    := @pre_redc T (@zero) (@divmod) r R_numlimbs (@scmul) (@addT) (@addT') (@drop_high (S R_numlimbs)) N _ A B k.
  Definition redc_no_cps {A_numlimbs} (A : T A_numlimbs) (B : T R_numlimbs) (k : Z) : T R_numlimbs
    := @redc T (@zero) (@divmod) r R_numlimbs (@scmul) (@addT) (@addT') (@drop_high (S R_numlimbs)) conditional_sub N _ A B k.

  Definition redc_body_cps {pred_A_numlimbs} (A : T (S pred_A_numlimbs)) (B : T R_numlimbs) (k : Z) (S' : T (S R_numlimbs))
             {cpsT} (rest : T pred_A_numlimbs * T (S R_numlimbs) -> cpsT)
    : cpsT
    := divmod_cps A (fun '(A, a) =>
       @scmul_cps r _ a B _ (fun aB => @add_cps r _ S' aB _ (fun S1 =>
       divmod_cps S1 (fun '(_, s) =>
       Z.mul_split_cps' r s k (fun mul_split_r_s_k =>
       dlet q := fst mul_split_r_s_k in
       @scmul_cps r _ q N _ (fun qN => @add_S1_cps r _ S1 qN _ (fun S2 =>
       divmod_cps S2 (fun '(S3, _) =>
       @drop_high_cps (S R_numlimbs) S3 _ (fun S4 => rest (A, S4)))))))))).

  Section loop.
    Context {A_numlimbs} (A : T A_numlimbs) (B : T R_numlimbs) (k : Z) {cpsT : Type}.
    Fixpoint redc_loop_cps (count : nat) (rest : T 0 * T (S R_numlimbs) -> cpsT) : T count * T (S R_numlimbs) -> cpsT
      := match count with
         | O => rest
         | S count' => fun '(A, S') => redc_body_cps A B k S' (redc_loop_cps count' rest)
         end.

    Definition pre_redc_cps (rest : T (S R_numlimbs) -> cpsT) : cpsT
      := redc_loop_cps A_numlimbs (fun '(A, S') => rest S') (A, zero).

    Definition redc_cps (rest : T R_numlimbs -> cpsT) : cpsT
      := pre_redc_cps (fun v => conditional_sub_cps v rest).
  End loop.

  Definition redc_body {pred_A_numlimbs} (A : T (S pred_A_numlimbs)) (B : T R_numlimbs) (k : Z) (S' : T (S R_numlimbs))
    : T pred_A_numlimbs * T (S R_numlimbs)
    := redc_body_cps A B k S' id.
  Definition redc_loop (B : T R_numlimbs) (k : Z) (count : nat) : T count * T (S R_numlimbs) -> T 0 * T (S R_numlimbs)
    := redc_loop_cps B k count id.
  Definition pre_redc {A_numlimbs} (A : T A_numlimbs) (B : T R_numlimbs) (k : Z) : T (S R_numlimbs)
    := pre_redc_cps A B k id.
  Definition redc {A_numlimbs} (A : T A_numlimbs) (B : T R_numlimbs) (k : Z) : T R_numlimbs
    := redc_cps A B k id.

  Definition add_no_cps (A B : T R_numlimbs) : T R_numlimbs
    := @add T R_numlimbs (@addT) (@conditional_sub) A B.
  Definition sub_no_cps (A B : T R_numlimbs) : T R_numlimbs
    := @sub T R_numlimbs (@sub_then_maybe_add) A B.
  Definition opp_no_cps (A : T R_numlimbs) : T R_numlimbs
    := @opp T (@zero) R_numlimbs (@sub_then_maybe_add) A.

  Definition add_cps (A B : T R_numlimbs) {cpsT} (rest : T R_numlimbs -> cpsT) : cpsT
    := @add_cps r _ A B
                _ (fun v => conditional_sub_cps v rest).
  Definition add (A B : T R_numlimbs) : T R_numlimbs
    := add_cps A B id.
  Definition sub_cps (A B : T R_numlimbs) {cpsT} (rest : T R_numlimbs -> cpsT) : cpsT
    := @sub_then_maybe_add_cps A B _ rest.
  Definition sub (A B : T R_numlimbs) : T R_numlimbs
    := sub_cps A B id.
  Definition opp_cps (A : T R_numlimbs) {cpsT} (rest : T R_numlimbs -> cpsT) : cpsT
    := sub_cps zero A rest.
  Definition opp (A : T R_numlimbs) : T R_numlimbs
    := opp_cps A id.
  Definition nonzero_cps (A : T R_numlimbs) {cpsT} (f : Z -> cpsT) : cpsT
    := @nonzero_cps R_numlimbs A cpsT f.
  Definition nonzero (A : T R_numlimbs) : Z
    := nonzero_cps A id.
End WordByWordMontgomery.

Hint Opaque redc pre_redc redc_body redc_loop add sub opp nonzero : uncps.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

Require Import Setoid.
Require Import Ring.

(** Generic properties of ordered rings on a setoid equality *)

Set Implicit Arguments.

Module Import OrderedRingSyntax.
Export RingSyntax.

Reserved Notation "x ~= y" (at level 70, no associativity).
Reserved Notation "x [=] y" (at level 70, no associativity).
Reserved Notation "x [~=] y" (at level 70, no associativity).
Reserved Notation "x [<] y" (at level 70, no associativity).
Reserved Notation "x [<=] y" (at level 70, no associativity).
End OrderedRingSyntax.

Section DEFINITIONS.

Variable R : Type.
Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R).
Variable req rle rlt : R -> R -> Prop.
Notation "0" := rO.
Notation "1" := rI.
Notation "x + y" := (rplus x y).
Notation "x * y " := (rtimes x y).
Notation "x - y " := (rminus x y).
Notation "- x" := (ropp x).
Notation "x == y" := (req x y).
Notation "x ~= y" := (~ req x y).
Notation "x <= y" := (rle x y).
Notation "x < y" := (rlt x y).

Record SOR : Type := mk_SOR_theory {
  SORsetoid : Setoid_Theory R req;
  SORplus_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2;
  SORtimes_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2;
  SORopp_wd : forall x1 x2, x1 == x2 ->  -x1 == -x2;
  SORle_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 <= y1 <-> x2 <= y2);
  SORlt_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 < y1 <-> x2 < y2);
  SORrt : ring_theory rO rI rplus rtimes rminus ropp req;
  SORle_refl : forall n : R, n <= n;
  SORle_antisymm : forall n m : R, n <= m -> m <= n -> n == m;
  SORle_trans : forall n m p : R, n <= m -> m <= p -> n <= p;
  SORlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m;
  SORlt_trichotomy : forall n m : R,  n < m \/ n == m \/ m < n;
  SORplus_le_mono_l : forall n m p : R, n <= m -> p + n <= p + m;
  SORtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m;
  SORneq_0_1 : 0 ~= 1
}.

(* We cannot use Relation_Definitions.order.ord_antisym and
Relations_1.Antisymmetric because they refer to Leibniz equality *)

End DEFINITIONS.

Section STRICT_ORDERED_RING.

Variable R : Type.
Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R).
Variable req rle rlt : R -> R -> Prop.

Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.

Notation "0" := rO.
Notation "1" := rI.
Notation "x + y" := (rplus x y).
Notation "x * y " := (rtimes x y).
Notation "x - y " := (rminus x y).
Notation "- x" := (ropp x).
Notation "x == y" := (req x y).
Notation "x ~= y" := (~ req x y).
Notation "x <= y" := (rle x y).
Notation "x < y" := (rlt x y).

Add Relation R req
  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _)
  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _)
  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _)
as sor_setoid.

Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
Proof.
exact sor.(SORplus_wd).
Qed.
Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
Proof.
exact sor.(SORtimes_wd).
Qed.
Add Morphism ropp with signature req ==> req as ropp_morph.
Proof.
exact sor.(SORopp_wd).
Qed.
Add Morphism rle with signature req ==> req ==> iff as rle_morph.
Proof.
exact sor.(SORle_wd).
Qed.
Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
Proof.
exact sor.(SORlt_wd).
Qed.

Add Ring SOR : sor.(SORrt).

Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
Proof.
intros x1 x2 H1 y1 y2 H2.
rewrite (sor.(SORrt).(Rsub_def) x1 y1).
rewrite (sor.(SORrt).(Rsub_def) x2 y2).
rewrite H1; now rewrite H2.
Qed.

Theorem Rneq_symm : forall n m : R, n ~= m -> m ~= n.
Proof.
intros n m H1 H2; rewrite H2 in H1; now apply H1.
Qed.

(* Propeties of plus, minus and opp *)

Theorem Rplus_0_l : forall n : R, 0 + n == n.
Proof.
intro; ring.
Qed.

Theorem Rplus_0_r : forall n : R, n + 0 == n.
Proof.
intro; ring.
Qed.

Theorem Rtimes_0_r : forall n : R, n * 0 == 0.
Proof.
intro; ring.
Qed.

Theorem Rplus_comm : forall n m : R, n + m == m + n.
Proof.
intros; ring.
Qed.

Theorem Rtimes_0_l : forall n : R, 0 * n == 0.
Proof.
intro; ring.
Qed.

Theorem Rtimes_comm : forall n m : R, n * m == m * n.
Proof.
intros; ring.
Qed.

Theorem Rminus_eq_0 : forall n m : R, n - m == 0 <-> n == m.
Proof.
intros n m.
split; intro H. setoid_replace n with ((n - m) + m) by ring. rewrite H.
now rewrite Rplus_0_l.
rewrite H; ring.
Qed.

Theorem Rplus_cancel_l : forall n m p : R, p + n == p + m <-> n == m.
Proof.
intros n m p; split; intro H.
setoid_replace n with (- p + (p + n)) by ring.
setoid_replace m with (- p + (p + m)) by ring. now rewrite H.
now rewrite H.
Qed.

(* Relations *)

Theorem Rle_refl : forall n : R, n <= n.
Proof sor.(SORle_refl).

Theorem Rle_antisymm : forall n m : R, n <= m -> m <= n -> n == m.
Proof sor.(SORle_antisymm).

Theorem Rle_trans : forall n m p : R, n <= m -> m <= p -> n <= p.
Proof sor.(SORle_trans).

Theorem Rlt_trichotomy : forall n m : R,  n < m \/ n == m \/ m < n.
Proof sor.(SORlt_trichotomy).

Theorem Rlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m.
Proof sor.(SORlt_le_neq).

Theorem Rneq_0_1 : 0 ~= 1.
Proof sor.(SORneq_0_1).

Theorem Req_em : forall n m : R, n == m \/ n ~= m.
Proof.
intros n m. destruct (Rlt_trichotomy n m) as [H | [H | H]]; try rewrite Rlt_le_neq in H.
right; now destruct H.
now left.
right; apply Rneq_symm; now destruct H.
Qed.

Theorem Req_dne : forall n m : R, ~ ~ n == m <-> n == m.
Proof.
intros n m; destruct (Req_em n m) as [H | H].
split; auto.
split. intro H1; false_hyp H H1. auto.
Qed.

Theorem Rle_lt_eq : forall n m : R, n <= m <-> n < m \/ n == m.
Proof.
intros n m; rewrite Rlt_le_neq.
split; [intro H | intros [[H1 H2] | H]].
destruct (Req_em n m) as [H1 | H1]. now right. left; now split.
assumption.
rewrite H; apply Rle_refl.
Qed.

Ltac le_less := rewrite Rle_lt_eq; left; try assumption.
Ltac le_equal := rewrite Rle_lt_eq; right; try reflexivity; try assumption.
Ltac le_elim H := rewrite Rle_lt_eq in H; destruct H as [H | H].

Theorem Rlt_trans : forall n m p : R, n < m -> m < p -> n < p.
Proof.
intros n m p; repeat rewrite Rlt_le_neq; intros [H1 H2] [H3 H4]; split.
now apply Rle_trans with m.
intro H. rewrite H in H1. pose proof (Rle_antisymm H3 H1). now apply H4.
Qed.

Theorem Rle_lt_trans : forall n m p : R, n <= m -> m < p -> n < p.
Proof.
intros n m p H1 H2; le_elim H1.
now apply Rlt_trans with (m := m). now rewrite H1.
Qed.

Theorem Rlt_le_trans : forall n m p : R, n < m -> m <= p -> n < p.
Proof.
intros n m p H1 H2; le_elim H2.
now apply Rlt_trans with (m := m). now rewrite <- H2.
Qed.

Theorem Rle_gt_cases : forall n m : R, n <= m \/ m < n.
Proof.
intros n m; destruct (Rlt_trichotomy n m) as [H | [H | H]].
left; now le_less. left; now le_equal. now right.
Qed.

Theorem Rlt_neq : forall n m : R, n < m -> n ~= m.
Proof.
intros n m; rewrite Rlt_le_neq; now intros [_ H].
Qed.

Theorem Rle_ngt : forall n m : R, n <= m <-> ~ m < n.
Proof.
intros n m; split.
intros H H1; assert (H2 : n < n) by now apply Rle_lt_trans with m. now apply (Rlt_neq H2).
intro H. destruct (Rle_gt_cases n m) as [H1 | H1]. assumption. false_hyp H1 H.
Qed.

Theorem Rlt_nge : forall n m : R, n < m <-> ~ m <= n.
Proof.
intros n m; split.
intros H H1; assert (H2 : n < n) by now apply Rlt_le_trans with m. now apply (Rlt_neq H2).
intro H. destruct (Rle_gt_cases m n) as [H1 | H1]. false_hyp H1 H. assumption.
Qed.

(* Plus, minus and order *)

Theorem Rplus_le_mono_l : forall n m p : R, n <= m <-> p + n <= p + m.
Proof.
intros n m p; split.
apply sor.(SORplus_le_mono_l).
intro H. apply (sor.(SORplus_le_mono_l) (p + n) (p + m) (- p)) in H.
setoid_replace (- p + (p + n)) with n in H by ring.
setoid_replace (- p + (p + m)) with m in H by ring. assumption.
Qed.

Theorem Rplus_le_mono_r : forall n m p : R, n <= m <-> n + p <= m + p.
Proof.
intros n m p; rewrite (Rplus_comm n p); rewrite (Rplus_comm m p).
apply Rplus_le_mono_l.
Qed.

Theorem Rplus_lt_mono_l : forall n m p : R, n < m <-> p + n < p + m.
Proof.
intros n m p; do 2 rewrite Rlt_le_neq. rewrite Rplus_cancel_l.
now rewrite <- Rplus_le_mono_l.
Qed.

Theorem Rplus_lt_mono_r : forall n m p : R, n < m <-> n + p < m + p.
Proof.
intros n m p.
rewrite (Rplus_comm n p); rewrite (Rplus_comm m p); apply Rplus_lt_mono_l.
Qed.

Theorem Rplus_lt_mono : forall n m p q : R, n < m -> p < q -> n + p < m + q.
Proof.
intros n m p q H1 H2.
apply Rlt_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_lt_mono_l].
Qed.

Theorem Rplus_le_mono : forall n m p q : R, n <= m -> p <= q -> n + p <= m + q.
Proof.
intros n m p q H1 H2.
apply Rle_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_le_mono_l].
Qed.

Theorem Rplus_lt_le_mono : forall n m p q : R, n < m -> p <= q -> n + p < m + q.
Proof.
intros n m p q H1 H2.
apply Rlt_le_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_le_mono_l].
Qed.

Theorem Rplus_le_lt_mono : forall n m p q : R, n <= m -> p < q -> n + p < m + q.
Proof.
intros n m p q H1 H2.
apply Rle_lt_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_lt_mono_l].
Qed.

Theorem Rplus_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n + m.
Proof.
intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_mono.
Qed.

Theorem Rplus_pos_nonneg : forall n m : R, 0 < n -> 0 <= m -> 0 < n + m.
Proof.
intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_le_mono.
Qed.

Theorem Rplus_nonneg_pos : forall n m : R, 0 <= n -> 0 < m -> 0 < n + m.
Proof.
intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_lt_mono.
Qed.

Theorem Rplus_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n + m.
Proof.
intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_mono.
Qed.

Theorem Rle_le_minus : forall n m : R, n <= m <-> 0 <= m - n.
Proof.
intros n m. rewrite (@Rplus_le_mono_r n m (- n)).
setoid_replace (n + - n) with 0 by ring.
now setoid_replace (m + - n) with (m - n) by ring.
Qed.

Theorem Rlt_lt_minus : forall n m : R, n < m <-> 0 < m - n.
Proof.
intros n m. rewrite (@Rplus_lt_mono_r n m (- n)).
setoid_replace (n + - n) with 0 by ring.
now setoid_replace (m + - n) with (m - n) by ring.
Qed.

Theorem Ropp_lt_mono : forall n m : R, n < m <-> - m < - n.
Proof.
intros n m. split; intro H.
apply -> (@Rplus_lt_mono_l n m (- n - m)) in H.
setoid_replace (- n - m + n) with (- m) in H by ring.
now setoid_replace (- n - m + m) with (- n) in H by ring.
apply -> (@Rplus_lt_mono_l (- m) (- n) (n + m)) in H.
setoid_replace (n + m + - m) with n in H by ring.
now setoid_replace (n + m + - n) with m in H by ring.
Qed.

Theorem Ropp_pos_neg : forall n : R, 0 < - n <-> n < 0.
Proof.
intro n; rewrite (Ropp_lt_mono n 0). now setoid_replace (- 0) with 0 by ring.
Qed.

(* Times and order *)

Theorem Rtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m.
Proof sor.(SORtimes_pos_pos).

Theorem Rtimes_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n * m.
Proof.
intros n m H1 H2.
le_elim H1. le_elim H2.
le_less; now apply Rtimes_pos_pos.
rewrite <- H2; rewrite Rtimes_0_r; le_equal.
rewrite <- H1; rewrite Rtimes_0_l; le_equal.
Qed.

Theorem Rtimes_pos_neg : forall n m : R, 0 < n -> m < 0 -> n * m < 0.
Proof.
intros n m H1 H2. apply -> Ropp_pos_neg.
setoid_replace (- (n * m)) with (n * (- m)) by ring.
apply Rtimes_pos_pos. assumption. now apply <- Ropp_pos_neg.
Qed.

Theorem Rtimes_neg_neg : forall n m : R, n < 0 -> m < 0 -> 0 < n * m.
Proof.
intros n m H1 H2.
setoid_replace (n * m) with ((- n) * (- m)) by ring.
apply Rtimes_pos_pos; now apply <- Ropp_pos_neg.
Qed.

Theorem Rtimes_square_nonneg : forall n : R, 0 <= n * n.
Proof.
intro n; destruct (Rlt_trichotomy 0 n) as [H | [H | H]].
le_less; now apply Rtimes_pos_pos.
rewrite <- H, Rtimes_0_l; le_equal.
le_less; now apply Rtimes_neg_neg.
Qed.

Theorem Rtimes_neq_0 : forall n m : R, n ~= 0 /\ m ~= 0 -> n * m ~= 0.
Proof.
intros n m [H1 H2].
destruct (Rlt_trichotomy n 0) as [H3 | [H3 | H3]];
destruct (Rlt_trichotomy m 0) as [H4 | [H4 | H4]];
try (false_hyp H3 H1); try (false_hyp H4 H2).
apply Rneq_symm. apply Rlt_neq. now apply Rtimes_neg_neg.
apply Rlt_neq. rewrite Rtimes_comm. now apply Rtimes_pos_neg.
apply Rlt_neq. now apply Rtimes_pos_neg.
apply Rneq_symm. apply Rlt_neq. now apply Rtimes_pos_pos.
Qed.

(* The following theorems are used to build a morphism from Z to R and
prove its properties in ZCoeff.v. They are not used in RingMicromega.v. *)

(* Surprisingly, multilication is needed to prove the following theorem *)

Theorem Ropp_neg_pos : forall n : R, - n < 0 <-> 0 < n.
Proof.
intro n; setoid_replace n with (- - n) by ring. rewrite Ropp_pos_neg.
now setoid_replace (- - n) with n by ring.
Qed.

Theorem Rlt_0_1 : 0 < 1.
Proof.
apply <- Rlt_le_neq. split.
setoid_replace 1 with (1 * 1) by ring. apply Rtimes_square_nonneg.
apply Rneq_0_1.
Qed.

Theorem Rlt_succ_r : forall n : R, n < 1 + n.
Proof.
intro n. rewrite <- (Rplus_0_l n); setoid_replace (1 + (0 + n)) with (1 + n) by ring.
apply -> Rplus_lt_mono_r. apply Rlt_0_1.
Qed.

Theorem Rlt_lt_succ : forall n m : R, n < m -> n < 1 + m.
Proof.
intros n m H; apply Rlt_trans with m. assumption. apply Rlt_succ_r.
Qed.

(*Theorem Rtimes_lt_mono_pos_l : forall n m p : R, 0 < p -> n < m -> p * n < p * m.
Proof.
intros n m p H1 H2. apply <- Rlt_lt_minus.
setoid_replace (p * m - p * n) with (p * (m - n)) by ring.
apply Rtimes_pos_pos. assumption. now apply -> Rlt_lt_minus.
Qed.*)

End STRICT_ORDERED_RING.