Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibFun LibProd LibContainer
     LibSet LibRelation LibPer LibMonoid.
Local Notation path := rtclosure.
From iris_time.union_find.math Require Import LibNatExtra LibIter InverseNatNat
     Ackermann InverseAckermann MiscArith TLCBuffer
     UnionFind01Data UnionFind03Link UnionFind04Compress
     UnionFind05IteratedCompression UnionFind11Rank UnionFind13RankLink
     UnionFind14RankCompress UnionFind21Parent UnionFind22ParentEvolution
     UnionFind23Evolution UnionFind24Pleasant UnionFind41Potential
     UnionFind42PotentialCompress.

(* -------------------------------------------------------------------------- *)

(* We now study how level, index, and potential evolve over time. *)

(* -------------------------------------------------------------------------- *)

Section R.

Variable r : nat.
Hypothesis r_geq_1: 1 <= r.

Notation alphar := (alphar r).
Notation rankr := (rankr r).
Notation prek := (prek r).
Notation k := (k r).
Notation i := (i r).
Notation phi := (phi r).
Notation Phi := (Phi r).

Section StudyOfEvolution.

Variable  V    : Type.
Variable  D    : set V.
Variables F F' : binary V.
Variables K K' : V -> nat.

Hypothesis is_rdsf_F : is_rdsf D F K.
Hypothesis ev  : evolution D F K F' K'.

(* -------------------------------------------------------------------------- *)

Section NonRoot.

(* Now, let us study a vertex [v], which we assume already has a parent. *)

Variable v : V.
Hypothesis v_has_a_parent: ~ is_root F v.

(* -------------------------------------------------------------------------- *)

(* [rankr v] remains constant. *)

Lemma non_root_has_constant_rankr:
  rankr K v = rankr K' v.
Proof using ev v_has_a_parent.
  unfold rankr.
  forwards: non_root_has_constant_rank; eauto.
Qed.

(* [rankr (p v)] grows. *)

Lemma rankrpv_grows:
  rankr K (p F v) <= rankr K' (p F' v).
Proof using is_rdsf_F ev v_has_a_parent.
  unfold rankr. eapply plus_le_plus.
  eauto using Kpv_grows.
Qed.

(* -------------------------------------------------------------------------- *)

(* Because [rankr v] is constant while [rankr (p v)] may grow, [k v] can only
   grow. *)

Lemma kv_grows:
  k F K v <= k F' K' v.
Proof using is_rdsf_F ev v_has_a_parent r_geq_1.
  unfold k, prek, defk.
  eapply plus_le_plus.
  forwards f: non_root_has_constant_rankr; eauto.
  rewrite <- f.
  eapply betaf_monotonic; eauto using rankrpv_grows with k monotonic.
Qed.

(* -------------------------------------------------------------------------- *)

(* As long as [k v] remains constant, [i v] can only grow. *)

Lemma iv_grows_if_kv_constant:
  k F K v = k F' K' v ->
  i F K v <= i F' K' v.
Proof using is_rdsf_F ev v_has_a_parent.
  clear r_geq_1.
  introv h. unfold i.
  assert (h': prek F K v = prek F' K' v). { unfold k in h. lia. }
  rewrite <- h'.
  forwards f: non_root_has_constant_rankr; eauto.
  rewrite <- f.
  eapply betaf_monotonic; eauto using rankrpv_grows with i.
Qed.

(* -------------------------------------------------------------------------- *)

(* The potential of [v] cannot increase. (Lemma 4.5 on pages 18-19.) *)

Lemma phiv_cannot_increase_nonroot:
  phi F' K' v <= phi F K v.
Proof using is_rdsf_F ev v_has_a_parent r_geq_1.
  intros.
  assert (hK: rankr K v = rankr K' v). { eauto using non_root_has_constant_rankr. }
  assert (hR: ~ is_root F' v). { eauto using non_root_forever. }
  (* For [phi F K v], we are in case 2 or 3. *)
  tests hc : (alphar (rankr K v) = alphar (rankr K (p F v))).
  (* Case 2. *)
  { forwards hphi: phi_case_2 F; eauto. rewrite hphi. clear hphi.
    (* For [phi F' K' v], we are in case 2 or 3. *)
    tests hc' : (alphar (rankr K' v) = alphar (rankr K' (p F' v))).
    (* Case 2. *)
    (* This is the non-trivial case. *)
    { forwards hphi: phi_case_2 F'; eauto. rewrite hphi. clear hphi.
      eapply plus_le_plus.
      rewrite <- hK.
      eapply lexpo_cannot_increase.
      { eauto using i_le_rank. }
      { eauto using kv_grows. }
      { rewrite hK. rewrite hc'. eauto using k_lt_alphar, is_rdsf_evolution. }
      { exact iv_grows_if_kv_constant. }
    }
    (* Case 3. Immediate, since the new potential (i.e., the left-hand side of
       the inequality) is zero. *)
    { forwards hphi: phi_case_3 F'; eauto. rewrite hphi. clear hphi.
      lia. }
  }
  (* Case 3. *)
  { forwards hphi: phi_case_3 F; eauto. rewrite hphi. clear hphi.
    forwards: alphar_rankr_grows_along_edges_corollary; eauto.
    (* For [phi F' K' v], we must be in case 3 too. *)
    assert (alphar (rankr K' v) < alphar (rankr K' (p F' v))).
    { rewrite <- hK.
      eapply Nat.lt_le_trans. eauto.
      eapply alphar_monotonic. eauto. eauto using rankrpv_grows. }
    rewrite phi_case_3 by solve [ eauto | lia ].
    (* Thus, the potential was zero and remains zero. *)
    eauto.
  }
Qed.

End NonRoot.

(* -------------------------------------------------------------------------- *)

(* Let [v] be an arbitrary vertex (possibly a root). If its rank is preserved,
   then its potential cannot increase. *)

Lemma phiv_cannot_increase:
  forall v,
  rankr K v = rankr K' v ->
  phi F' K' v <= phi F K v.
Proof using is_rdsf_F ev r_geq_1.
  introv h. tests : (is_root F v).
  { (* Case: [v] is a root. The fact that the rank of [v] does not change
       is sufficient to prove that its potential cannot increase. *)
    rewrite (@phi_case_1 _ _ F K) by assumption.
    rewrite phi_upper_bound.
    rewrite h.
    eauto. }
  { (* Case: [v] is not a root. *)
    eauto using phiv_cannot_increase_nonroot. }
Qed.

End StudyOfEvolution.

(* -------------------------------------------------------------------------- *)

(* The increase of the potential [Phi] during a link is at most 2. This is
   Lemma 4.7 on page 19. The formal proof follows roughly the paper proof,
   except we find it necessary to make certain case analyses explicit. *)

Lemma potential_increase_during_link_preliminary:
  forall V D F K K' (x y : V),
  is_rdsf D F K ->
  x <> y ->
  x \in D ->
  y \in D ->
  is_root F x ->
  is_root F y ->
  (* In this lemma, we consider only the following two cases. It is easy
     to later argue that, by symmetry, this covers all cases. *)
  K x < K y /\ K' = K \/
  K x = K y /\ K' = fupdate K y (1 + K y) ->
  (* The following hypothesis is redundant, but it is convenient to require it. *)
  evolution D F K (link F x y) K' ->
  (* The conclusion. *)
  Phi D (link F x y) K' <= Phi D F K + 2.

Proof using r_geq_1.
  intros. unfold Phi.

  (* Either the rank of [y] remains the same, or it increases by one,
     and in that case, [x] and [y] initially have the same rank. We
     fully distinguish these two cases, as the first one is trivial. *)
  branches; unpack.

  (* Case: the rank of [y] is unchanged. In fact, every rank is unchanged. *)
  { subst K'.
    (* We do not even need the two-credit slack. *)
    match goal with |- ?a <= ?a' + _ => cut (a <= a'); [ lia | ] end.
    (* Every rank is unchanged, so no potential can increase. Easy. *)
    eapply fold_pointwise; eauto with finite typeclass_instances.
    eauto using phiv_cannot_increase.
  }

  (* Case: the rank of [y] is increased by one, and [x] and [y] initially have
     the same rank. Then, the potential of [y] may increase, but the potential
     of [x] decreases, and this compensates (up to a two-credit slack) for the
     increase in the potential of [y]. *)

  assert (hKx: rankr K x = rankr K y).
  { unfold rankr. lia. }
  assert (hK'y: rankr K' y = rankr K y + 1).
  { unfold rankr. subst K'. rewrite fupdate_eq by eauto. case_if; lia. }

  (* [is_rdsf] is preserved. Proving this is a bit painful, due to the way
     things are set up. We must do some house-keeping before we can apply
     the lemma [is_rdsf_link]. *)
  assert (is_rdsf D (link F x y) K').
  { assert (hF: link F x y = link_by_rank_F F K y x).
    { unfold link_by_rank_F. cases_if.
      false. unfold rankr in *. lia.
      reflexivity. }
    assert (hK: K' = link_by_rank_K K y x).
    { unfold link_by_rank_K. cases_if. eauto. }
    rewrite hF. rewrite hK.
    eauto using is_rdsf_link.
  }

  (* Set [y] and [x] aside. *)
  do 2 rewrite (@fold_isolate _ D y) by eauto with finite typeclass_instances.
  simpl.
  do 2 try rewrite (@fold_isolate _ (D \-- y) x);
   try solve [ eauto with finite typeclass_instances | rew_set in * ].
  simpl.
  (* Divide the goal into two subgoals. First, the total potential of all
     vertices other than [x] and [y] cannot increase. Second, the total
     potential of [x] and [y] increases by at most two. *)
  match goal with |- ?p + (?q + ?r) <= ?p' + (?q' + ?r') + ?a =>
    cut (r <= r' /\ p + q <= p' + q' + a); [ lia | split ]
  end.

  (* Subgoal 1: the vertices other than [x] and [y]. Again, their rank is
     unchanged, so their potential cannot increase. Easy. *)
  { eapply fold_pointwise; eauto with finite typeclass_instances. intros v ?.
    assert (rankr K v = rankr K' v).
    { unfold rankr. subst K'. rewrite fupdate_neq. auto. rew_set in *. tauto. }
    eauto using phiv_cannot_increase.
  }

  (* Subgoal 2: examine how the total potential of [x] and [y] evolves.
     This is the non-trivial part of this proof. *)

  (* The rank of [x] has not changed. *)
  assert (hK'x: rankr K x = rankr K' x).
  { subst K'. unfold rankr. rewrite fupdate_neq; eauto. }

  (* The parent of [x] is now [y]. *)
  forwards hpx: link_sets_parent F K x y; eauto using is_root_link.

  (* The (new) level and index of [x] are at least 1. *)
  assert (hkx: 1 <= k (link F x y) K' x).
  { unfold k. lia. }
  assert (hix: 1 <= i (link F x y) K' x).
  { eauto using i_ge_1, x_no_longer_a_root. }

  (* The vertex [y] is a root, both before and after the link. Thus, the potential
     of [y] before and after the link is as follows. *)
  forwards h: phi_case_1 r F K y; eauto. rewrite h. clear h.
  forwards h: phi_case_1 r (link F x y) K' y; eauto using is_root_link. rewrite h. clear h.

  (* The vertex [x] was a root before the link. Its potential before the link is as follows. *)
  forwards h: phi_case_1 r F K x; eauto. rewrite h. clear h.
  (* After the link, [x] is no longer a root. After the link, the rank of [x] is strictly
     less than the rank of [y]. Yet, we don't know whether the images of these ranks through
     [alphar] are equal or distinct. Thus, we don't know whether we are in case 2 or 3. A
     case analysis appears to be necessary; indeed, if we attempt to treat these two cases
     together, the fact that the subtraction of [i] is known to be safe only in case 2
     seems to become a problem. This case analysis does not explicitly appear in Alstrup et
     al.'s paper. *)
  tests hranks: (alphar (rankr K' x) = alphar (rankr K' y)).

  (* We are in case 2. The new potential of [x] is as follows. *)
  { forwards h: phi_case_2 r (link F x y) K' x; eauto using x_no_longer_a_root. congruence. rewrite h. clear h.
    (* The subtractions are safe. *)
    forwards: phi_case_2_safe_k r (link F x y) K' x; try rewrite hpx; eauto using x_no_longer_a_root.
    forwards: phi_case_2_safe_i r (link F x y) K' x; try rewrite hpx; eauto using x_no_longer_a_root.
    (* Simplify. *)
    rewrite <- hK'x in *. clear hK'x.
    rewrite hKx in *. clear hKx.
    rewrite hK'y in *. clear hK'y.
    rewrite <- hranks in *. clear hranks.
    (* Conclude via low-level arithmetic reasoning.
       We do not even need the two-credit slack in this case. *)
    eapply random_arithmetic_lemma_01; eauto.
  }

  (* We are in case 3. The new potential of [x] is zero. *)
  { forwards h: phi_case_3 r (link F x y) K' x; try rewrite hpx; eauto using x_no_longer_a_root. rewrite h. clear h.
    (* Simplify. *)
    rewrite <- hK'x in *. clear hK'x.
    rewrite hKx in *. clear hKx.
    rewrite hK'y in *. clear hK'y.
    (* Exploit [alphar (n + 1) <= alphar n + 1]. *)
    rewrite alphar_grows_one_by_one by eauto.
    (* Conclude via low-level arithmetic reasoning.
       This is where we need the two-credit slack. *)
    eapply random_arithmetic_lemma_02. eapply alphar_positive.
  }

Qed.

(* PUBLIC *)
Lemma potential_increase_during_link:
  forall V D F F' K K' (x y : V),
  is_rdsf D F K ->
  x <> y ->
  x \in D ->
  y \in D ->
  is_root F x ->
  is_root F y ->
  F' = link_by_rank_F F K x y ->
  K' = link_by_rank_K K x y ->
  Phi D F' K' <= Phi D F K + 2.
Proof using r_geq_1.
  intros.
  assert (evolution D F K F' K').
  { subst. eauto with evolution. }
  subst.
  unfold link_by_rank_F, link_by_rank_K in *.
  three_ways (K x) (K y);
  eapply potential_increase_during_link_preliminary;
    eauto with lia.
Qed.

(* -------------------------------------------------------------------------- *)

(* Instantiate the theory of [UnionFind24Pleasant]. *)

(* The predicate [top_part] corresponds to the ``top part of the path''
   mentioned in the proof of Lemma 4.11. *)

Definition top_part V z F K (x : V) :=
  is_repr F x z /\
  alphar (rankr K x) = alphar (rankr K z).

Definition pleasant V z F K (x : V) :=
  pleasant (top_part z) (@k V) F K x.

Definition displeasure V z F K (x : V) :=
  displeasure (top_part z) (@k V) F K x.

(* The predicate [top_part] is hereditary. *)

Lemma top_part_hereditary:
  forall V D F K (x y z : V),
  @is_rdsf V D F K ->
  top_part z F K x ->
  F x y ->
  top_part z F K y.
Proof using r_geq_1.
  unfold top_part. intros. unpack.
  (* The representative of [y], the parent of [x], must be [z]. So, there
     is a path from [y] to [z]. *)
  assert (path F y z).
  { eauto using path_from_parent_to_repr_F with is_dsf. }
  split.
  { eauto using is_repr_is_root with is_repr. }
  (* Because [alphar . rankr] is constant all the way from [x] to [z],
     [x] and its parent have the same image through this function. *)
  assert (alphar (rankr K x) <= alphar (rankr K y)).
  { eauto using alphar_rankr_grows_along_a_path with rtclosure. }
  assert (alphar (rankr K y) <= alphar (rankr K z)).
  { eauto using alphar_rankr_grows_along_a_path. }
  lia.
Qed.

(* One step of path compression at [x] does not affect the ``top part
   of the path'' above [x]. *)

Lemma compress_preserves_top_part_above_y:
  forall V D F K x y z,
  @is_rdsf V D F K ->
  F x y ->
  path F y z ->
  forall v z',
  (* note: we allow [z'] and [z] to be distinct; this makes life easier down the road *)
  top_part z' F K v ->
  top_part z' (compress F x z) K v.
Proof using.
  unfold top_part. intros. unpack. split; eauto.
  { eauto using compress_preserves_is_repr_direct with is_dsf. }
Qed.

(* This result bounds the number of vertices in the top part of the path
   which are unpleasant (i.e., whose potential does not decrease). *)

(* The proof of Lemma 4.11 says this is a strict inequality. This is
   true. Here, we do not exploit the fact that a level is at least 1,
   which is why we end up establishing a large inequality. *)

Lemma bounded_displeasure_alstrup:
  forall V D F K,
  @is_rdsf V D F K ->
  forall x z,
  top_part z F K x ->
  displeasure z F K x <= alphar (rankr K z).
Proof using r_geq_1.
  intros.
  eapply bounded_displeasure_preliminary_2.
  { eauto. }
  { eauto using top_part_hereditary. }
  { intros y hTopLevel hNonRoot.
    (* There is an edge from [y] to its parent. *)
    forwards: parent_spec. eauto.
    (* The parent of [y] satisfies [top_part], too. Which implies
       that its [alphar . rankr] is equal to that of [z]. *)
    forwards [ ? hrpy ]: top_part_hereditary; eauto.
    rewrite <- hrpy. clear hrpy.
    (* The result follows. *)
    eauto using k_lt_alphar. }
  { assumption. }
Qed.

(* -------------------------------------------------------------------------- *)

(* During a path compression step at [x], the vertex [x] is the only one whose
   potential changes. So, if the potential of [x] decreases, then the total
   potential [Phi] decreases as well. *)

Lemma from_phi_to_Phi:
  forall V (D : set V) F K,
  is_rdsf D F K ->
  forall x z,
  ~ is_root F x ->
  is_repr F x z ->
  phi (compress F x z) K x < phi F K x ->
  Phi D (compress F x z) K < Phi D F K.
Proof using r_geq_1.
  intros.
  assert (x \in D).
  { eauto with confined is_dsf. }
  (* Set [x] aside. *)
  unfold Phi.
  do 2 rewrite (@fold_isolate _ D x) by eauto with finite typeclass_instances.
  simpl.
  (* Treat [x] on the one hand, and the other vertices on the other hand. *)
  match goal with |- ?p + ?q < ?p' + ?q' =>
    cut (p < p' /\ q <= q'); [ lia | split ]
  end.
  { assumption. }
  { eapply fold_pointwise; eauto with finite typeclass_instances.
    eauto using phiv_cannot_increase, compress_evolution, pleasant_non_root. }
Qed.

(* -------------------------------------------------------------------------- *)

(* If [alphar . rankr] is constant all the way from [x] to its root [z],
   then a pleasant path compression step at [x] causes the potential of
   [x] to decrease. This is Lemma 4.10 in Alstrup et al.'s paper. *)

Lemma pleasant_phi:
  forall V (D : set V) F K,
  is_rdsf D F K ->
  forall x z,
  pleasant z F K x ->
  is_repr F x z ->
  phi (compress F x z) K x < phi F K x.
Proof using r_geq_1.
  introv ? (hTopLevel & hNonRoot & hY) ?.
  destruct hTopLevel.
  destruct hY as [ y ? ]. unpack.
  (* The representative of the parent of [x] must be [z]. So, there is
     a path from the parent of [x] to [z]. *)
  assert (path F (p F x) z).
  { eauto using path_from_parent_to_repr. }
  (* Because [alphar . rankr] is constant all the way from [x] to [z],
     [x] and its parent have the same image through this function. *)
  assert (alphar (rankr K x) <= alphar (rankr K (p F x))).
  { eauto using alphar_rankr_grows_along_edges. }
  assert (alphar (rankr K (p F x)) <= alphar (rankr K z)).
  { eauto using alphar_rankr_grows_along_a_path. }
  assert (alphar (rankr K x) = alphar (rankr K (p F x))).
  { lia. }
  (* Hence, before compression, the potential of [x] is given by case 2. *)
  forwards h: phi_case_2 r F K x; eauto. rewrite h. clear h.
  (* No rank changes during compression. Hence, after compression, the
     potential of [x] is also given by case 2. *)
  assert (hxpx: alphar (rankr K x) = alphar (rankr K (p (compress F x z) x))).
  { erewrite compress_changes_parent_of_x_to_z by eauto. lia. }
  rewrite phi_case_2 by eauto using compress_preserves_roots_converse.
  (* Simplify, and apply a low-level arithmetic lemma. *)
  eapply plus_lt_plus.
  forwards: compress_evolution x; eauto.
  eapply lexpo_cannot_increase_and_decreases_if. (* yay! *)
  { eauto using i_le_rank. }
  { eauto using i_ge_1, is_rdsf_evolution, non_root_forever with lia. }
  { eauto using i_le_rank, is_rdsf_evolution, non_root_forever with lia. }
  { eauto using kv_grows. }
  { rewrite hxpx.
    eauto using k_lt_alphar, is_rdsf_evolution, non_root_forever with lia. }
  { eauto using iv_grows_if_kv_constant. }
  { eauto using prove_lexpo_decreases, kv_grows, kx_ky_compress. }
Qed.

(* During an arbitrary path compression step, the total potential [Phi] cannot
   increase. *)

Lemma arbitrary_Phi:
  forall V (D : set V) F K,
  is_rdsf D F K ->
  forall x y z,
  F x y ->
  path F y z ->
  Phi D (compress F x z) K <= Phi D F K.
Proof using r_geq_1.
  intros. unfold Phi.
  eapply fold_pointwise; eauto with finite typeclass_instances.
  eauto using phiv_cannot_increase with evolution.
Qed.

(* -------------------------------------------------------------------------- *)

(* We now evaluate the amortized cost of path compression in the ``top part''
   of the path. *)

Lemma amortized_cost_fw_ipc_top_part_inductive:
  forall V F x l F',
  @fw_ipc V F x l F' ->
  forall D K z,
  is_rdsf D F K ->
  top_part z F K x ->
  Phi D F' K + l <= Phi D F K + displeasure z F K x.
Proof using r_geq_1.
  unfold displeasure.
  induction 1; intros.

  (* FWIPCBase *)
  { lia. }

  (* FWIPCStep *)
  (* At this point, we unfortunately have two names for [z], so we must
     first argue that they are the same vertex. *)
  match goal with h: top_part ?z' _ _ _ |- _ =>
    assert (z' = z); [ destruct h | subst z' ]
  end.
  { eapply is_repr_is_equiv_is_repr_bis; eauto with is_dsf.
    eauto using path_is_equiv with rtclosure is_dsf. }

  (* Argue that compression does not affect the displeasure of [y]. This
     seems obvious, but is in fact non-trivial, as we must check that it
     affects neither the function [k] nor the predicate [top_part]. *)
  forwards: compress_preserves_displeasure_of_y (top_part z) x y z;
  eauto using is_repr_path, (@compress_preserves_k_above_y r),
              compress_preserves_top_part_above_y.

  (* Use the induction hypothesis. *)
  forwards: IHfw_ipc;
    eauto using is_rdsf_compress, is_repr_path,
                compress_preserves_top_part_above_y, top_part_hereditary.

  (* Now, perform case analysis. *)
  tests : (pleasant z F K x); unfold pleasant in *.

  { (* Case: [x] is pleasant. Then, path compression at [x] frees up one unit
       of potential, which pays for this step. The induction hypothesis does
       the rest. *)
    erewrite displeasure_parent_if_pleasant by eauto.
    forwards: from_phi_to_Phi x;
      eauto 8 using pleasant_phi, a_root_has_no_parent_contrapositive
               with is_dsf is_repr is_equiv.
    lia. }

  { (* Case: [x] is unpleasant. Then, we pay for this path compression step
       out of the [k] credits that we explicitly request from the client. *)
    erewrite displeasure_parent_if_unpleasant by eauto.
    forwards: arbitrary_Phi; eauto using is_repr_path.
    lia. }

Qed.

(* A corollary. *)

Lemma amortized_cost_fw_ipc_top_part:
  forall V D F K x z l F',
  @fw_ipc V F x l F' ->
  is_rdsf D F K ->
  top_part z F K x ->
  Phi D F' K + l <= Phi D F K + alphar (rankr K z).
Proof using r_geq_1.
  intros.
  rewrite amortized_cost_fw_ipc_top_part_inductive by eauto.
  rewrite bounded_displeasure_alstrup by eauto.
  reflexivity.
Qed.

(* -------------------------------------------------------------------------- *)

(* Say [x] is ``easy'' if [alphar . rankr] is NOT constant all the way from [x]
   to its root [z], but maps [x] and its parent to the same value. In this case,
   a path compression step at [x] causes the potential of [x] to decrease. This
   is Lemma 4.9 in Alstrup et al.'s paper. *)

Lemma easy_phi:
  forall V (D : set V) F K,
  is_rdsf D F K ->
  forall x,
  ~ is_root F x ->
  forall z,
  is_repr F x z ->
  alphar (rankr K x) = alphar (rankr K (p F x)) ->
  alphar (rankr K (p F x)) < alphar (rankr K z) ->
  phi (compress F x z) K x < phi F K x.
Proof using r_geq_1.
  intros.
  (* The representative of the parent of [x] must be [z]. So, there is
     a path from the parent of [x] to [z]. *)
  assert (path F (p F x) z).
  { eauto using path_from_parent_to_repr. }
  (* Before compression, the potential of [x] is given by case 2. Hence,
     it is non-zero. *)
  forwards h: phi_case_2_lower_bound r F K x; eauto.
  (* After compression, the parent of [x] is [z], so the potential of [x]
     is given by case 3. Hence, it is zero. *)
  assert (alphar (rankr K x) <> alphar (rankr K (p (compress F x z) x))).
  { erewrite compress_changes_parent_of_x_to_z by eauto. lia. }
  rewrite phi_case_3 by eauto using compress_preserves_roots_converse.
  (* The result follows. *)
  lia.
Qed.

(* -------------------------------------------------------------------------- *)

(* The following result covers the so-called ``bottom part'' of the path.
   It combines Lemma 4.8 and the ``bottom part'' of Lemma 4.10, and calls
   the previous result [amortized_cost_fw_ipc_top_part] when it reaches
   the ``top part'' of the path. *)

Lemma amortized_cost_fw_ipc_bottom_part:
  forall V F x l F',
  @fw_ipc V F x l F' ->
  forall D K z,
  is_rdsf D F K ->
  is_repr F x z ->
  Phi D F' K + l <= Phi D F K + 2 * alphar (rankr K z) - alphar (rankr K x).
Proof using r_geq_1.
  induction 1; intros.

  (* FWIPCBase *)
  {
    (* [x] is [z]. *)
    assert (x = z).
    { eauto using a_path_out_of_a_root_is_trivial, is_repr_path. }
    subst z.
    (* The result follows, quite trivially. *)
    lia.
  }

  (* FWIPCStep *)

  (* At this point, we unfortunately have two names for [z], so we must
     first argue that they are the same vertex. *)
  match goal with h: is_repr _ x ?z' |- _ =>
    assert (z' = z); [ | subst z' ]
  end.
  { eapply is_repr_is_equiv_is_repr_bis; eauto with is_dsf.
    eauto using path_is_equiv with rtclosure is_dsf. }

  (* The parent of [x] is [y]. *)
  assert (hpx: p F x = y).
  { eauto using parent_unique. }

  (* The function [alphar . rankr] grows along the path from [x] to [z]. *)
  assert (alphar (rankr K x) <= alphar (rankr K z)).
  { eauto using alphar_rankr_grows_along_a_path, is_repr_path. }

  (* Perform case analysis: are [x] and [z] at the same height? *)
  tests: (alphar (rankr K x) = alphar (rankr K z)).

  (* Case: yes, [x] and [z] are at the same height. This means [x] is in
     fact in the top part of the path. *)
  {
    assert (top_part z F K x).
    { split; eauto. }
    (* The previous analysis applies. *)
    forwards: amortized_cost_fw_ipc_top_part x; eauto with fw_ipc.
    (* The result follows. *)
    lia.
  }

  (* Case: no, [x] and [z] are at different heights. *)

  (* Use the induction hypothesis. *)
  forwards: IHfw_ipc;
    eauto using is_rdsf_compress, is_repr_path,
                compress_preserves_is_repr_direct with is_dsf.

  (* Perform case analysis: are [x] and its parent at the same height? *)
  tests: (alphar (rankr K x) = alphar (rankr K (p F x))).

  (* Case: [x] is easy. *)
  {
    (* Path compression at [x] frees up one unit of potential, which
       pays for this step. *)
    forwards: from_phi_to_Phi x;
      eauto 8 using easy_phi, a_root_has_no_parent_contrapositive with lia.
    rewrite hpx in *.
    lia.
  }

  (* Case: [x] is not easy. *)
  {
    forwards: arbitrary_Phi; eauto using is_repr_path.
    rewrite hpx in *.
    (* In that case, [alphar . rankr] at [y] is one more than at [x],
       which pays for this step. *)
    assert (alphar (rankr K x) <= alphar (rankr K y)).
    { eauto using alphar_rankr_grows_along_a_path with rtclosure. }
    lia.
  }

Qed.

(* As a corollary, we obtain the amortized cost of iterated path compression,
   in a formulation based on [fw_ipc]. *)

Lemma amortized_cost_fw_ipc:
  forall V F x l F',
  @fw_ipc V F x l F' ->
  forall D K z,
  is_rdsf D F K ->
  is_repr F x z ->
  Phi D F' K + l < Phi D F K + 2 * alphar (rankr K z).
Proof using r_geq_1.
  intros.
  forwards: amortized_cost_fw_ipc_bottom_part; eauto.
  assert (alphar (rankr K x) > 0). { eauto using alphar_positive. }
  assert (alphar (rankr K z) > 0). { eauto using alphar_positive. }
  lia.
Qed.

(* -------------------------------------------------------------------------- *)

(* This corollary combines [ipc_defined], [amortized_cost_fw_ipc], and
   [bw_ipc_fw_ipc], so as to obtain the amortized cost of iterated path
   compression, in a variant based on [bw_ipc], and in a form where the [ipc]
   predicate appears as part of the conclusion (not as a hypothesis). *)

(* PUBLIC *)
Lemma amortized_cost_of_iterated_path_compression_local:
  forall V D F K x,
  @is_rdsf V D F K ->
  x \in D ->
  exists l F' z,
  is_repr F x z /\
  bw_ipc F x l F' /\
  Phi D F' K + l < Phi D F K + 2 * alphar (rankr K z).
Proof using r_geq_1.
  intros.
  forwards (l&F'&?): ipc_defined x. eauto with is_dsf.
  forwards (z&?): is_dsf_defined_is_repr x. eauto with is_dsf.
  exists l F' z. splits;
  eauto using amortized_cost_fw_ipc, bw_ipc_fw_ipc with is_dsf.
Qed.

(* A simplified version, where we bound the rankr of [z] by the cardinality of
   [D], plus [r - 1]. *)

(* PUBLIC *)
Lemma amortized_cost_of_iterated_path_compression_global:
  forall V D F K x,
  @is_rdsf V D F K ->
  x \in D ->
  exists l F',
  bw_ipc F x l F' /\
  Phi D F' K + l < Phi D F K + 2 * alphar (card D + (r - 1)).
Proof using r_geq_1.
  intros.
  forwards (l&F'&z&?): amortized_cost_of_iterated_path_compression_local; eauto. unpack.
  exists l F'. splits; eauto.
  assert (K z <= log2 (card D)).
  { eapply rank_is_logarithmic;
    eauto 6 using is_equiv_in_D_direct, path_is_equiv, is_repr_path with is_dsf. }
  assert (1 <= card D).
  { eapply card_ge_one; eauto with finite. }
  assert (K z < card D).
  { forwards: log2_lt_n (card D); eauto. lia. }
  assert (rankr K z <= card D + (r - 1)).
  { unfold rankr. lia. }
  assert (alphar (rankr K z) <= alphar (card D + (r - 1))).
  { eapply alphar_monotonic; eauto. }
  lia.
Qed.

End R.

(* A further simplified version, where we take [r] to be 1. *)

(* PUBLIC *)
Lemma amortized_cost_of_iterated_path_compression_simplified:
  forall V D F K x,
  @is_rdsf V D F K ->
  x \in D ->
  exists l F',
  bw_ipc F x l F' /\
  Phi 1 D F' K + l <= Phi 1 D F K + 2 * alpha (card D) + 3.
Proof using.
  intros.
  forwards (l&F'&?&hb): amortized_cost_of_iterated_path_compression_global; eauto.
  exists l F'. splits; eauto.
  replace (card D + (1 - 1)) with (card D) in hb by lia.
  unfold alphar, prealphar, defalphar in hb.
  assert (f: alpha (card D + 1) <= alpha (card D) + 1).
  { eauto using alpha_grows_one_by_one. }
  lia.
Qed.


Require Import String.
Require Import Names.
Require Import Arith.
Require Import Functors.

Open Scope string_scope.

Section Type_Test_Section.
  (* Type Testing, of course. *)
  Definition D := AType.

  Definition tex1' : DType D := tnat' _. (* Nat *)
  Definition tex1 := proj1_sig tex1'.

  Eval compute in ("Evaluating 'tnat == tnat' as an 'TNat.").
  Eval compute in (eq_DType D tex1 tex1').

End Type_Test_Section.

Section Test_Section.

  Definition E := Arith.

  Definition ex_1 : Names.Exp E :=
    (add' _ (lit' _ 1) (lit' _ 2)).
  Definition ex_2  : Names.Exp E :=
    (add' _ (lit' _ 5) (lit' _ 0)).
  Definition ex_3  : Names.Exp E :=
      (add' _ ex_1 ex_2).

  Definition test_typeof e :=
    match (typeof D E e) with
      | Some t1 => DTypePrint _ (proj1_sig t1)
      | None => "Type Error!"
    end.

  Eval compute in ("The type of '1 + 2' should be tnat.").
  Eval compute in (test_typeof (proj1_sig ex_1)).
  Eval compute in ("The type of '145 + 2346' should be tnat.").
  Eval compute in (test_typeof (proj1_sig ex_2)).
  Eval compute in ("The type of '(1 + 2) + (5 + 0)' should be tnat.").
  Eval compute in (test_typeof (proj1_sig ex_3)).

  Eval compute in (ExpPrint E (proj1_sig ex_1)).
  Eval compute in (ExpPrint E (proj1_sig ex_2)).
  Eval compute in (ExpPrint E (proj1_sig ex_3)).

  Definition V := StuckValue :+: BotValue :+: NatValue.

  Eval compute in ("Evaluating '1 + 2'").
  Eval compute in (ValuePrint V (proj1_sig (eval V E (proj1_sig ex_1) nil))).
  Eval compute in ("Evaluating '5 + 0'").
  Eval compute in (ValuePrint V (proj1_sig (eval V E (proj1_sig ex_2) nil))).
  Eval compute in ("Evaluating '(1 + 2) + (5 + 0)'").
  Eval compute in (ValuePrint V (proj1_sig (eval V E (proj1_sig ex_3) nil))).

  Definition WFV := (WFValue_VI D V).

  Lemma soundness : forall (e : Exp E),
    forall T, typeof D E (proj1_sig e) = Some T ->
      WFValueC D V WFV (eval V E (proj1_sig e) nil) T.
  Proof.
    intro; eapply eval_Soundness; eauto with typeclass_instances.
  Qed.

  Eval compute in ("Type Soundness for Arith Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import MuRec LNat LOptions LProd Lists.
From Undecidability Require Import FOL.DecidableEnumerable FOL.Reductions.

Inductive is_computable {A} {t : TT A} (a : A) : Prop :=
  C : computable a -> is_computable a.

Notation enumerates f p := (forall x, p x <-> exists n : nat, f n = Some x).

Definition L_decidable {X} `{registered X} (P : X -> Prop) :=
  exists f : X -> bool, is_computable f /\ forall x, P x <-> f x = true.

Definition L_enumerable {X} `{registered X} (p : X -> Prop) :=
  exists f : nat -> option X, is_computable f /\ (enumerates f p).

Definition L_recognisable {X} `{registered X} (p : X -> Prop) :=
  exists s : term, forall x, p x <-> converges (s (enc x)).

Section L_enum_rec.

  Variable X : Type.
  Context `{registered X}.
  Variable (p : X -> Prop).

  Hypotheses (f : nat -> option X) (c_f : computable f) (H_f : enumerates f p).
  Hypotheses (d : X -> X -> bool) (c_d : computable d) (H_d : forall x y, reflect (x = y) (d x y)).

  Definition test := (fun x n => match f n with Some y => d x y | None => false end).

  Instance term_test : computable test.
  Proof.
    extract.
  Qed.

  Lemma proc_test (x : X) :
    proc (λ y, !!(ext test) !!(enc x) y).
  Proof.
    cbn. Lproc.
  Qed.

  Lemma L_enumerable_recognisable :
    L_recognisable p.
  Proof.
    exists (λ x, !!mu (λ y, !!(ext test) x y)).
    intros. split; intros.
    - eapply H_f in H0 as [n H0].
      edestruct (mu_complete (proc_test x)) with (n := n).
      + intros. exists (test x n0). cbn. Lsimpl.
      + cbn. Lsimpl. unfold test. rewrite H0. Lsimpl. destruct (H_d x x); intuition.
      + exists (ext x0). split; try Lproc.
        cbn. Lsimpl. now rewrite H1.
    - destruct H0 as (v & ? & ?).
      edestruct (mu_sound (proc_test x)) with (v := v) as (n & ? & ? & _).
      + intros. exists (test x n). cbn. Lsimpl.
      + Lproc.
      + rewrite <- H0. symmetry. cbn. Lsimpl.
      + subst. eapply H_f. exists n.
        assert ((λ y, !! (ext test) !! (enc x) y) !!(ext n) == ext (test x n)).
        cbn. Lsimpl. rewrite H2 in *.
        eapply unique_normal_forms in H3; try Lproc.
        eapply inj_enc in H3.
        unfold test in H3. destruct (f n); inv H3.
        destruct (H_d x x0); firstorder.
  Qed.

End L_enum_rec.

Definition L_nat := (fix f n := match n with 0 => [0] | S n => f n ++ [S n] end)%list.

Instance term_L_nat : computable L_nat.
Proof.
  extract.
Qed.

Definition T_nat_nat := Eval cbn in @L_T (nat * nat) _.

Definition pair' : nat * nat -> nat * nat := fun '(x,y) => (x,y).

Instance term_pair' : computable pair'.
Proof.
  extract.
Qed.

Instance term_T_nat_nat : computable T_nat_nat.
Proof.
  change (computable
    (fix T_prod (n : nat) : list (nat * nat) :=
       match n with
       | 0 => [(0, 0)]
       | S n0 =>
           (T_prod n0 ++ map pair' (L_nat n0 × L_nat n0))%list
       end)).
  extract.
Qed.

Instance term_R_nat_nat : computable R_nat_nat.
Proof.
  change (computable (fun n : nat => nthe n (T_nat_nat n))).
  extract.
Qed.

Definition lenumerates {X} L (p : X -> Prop) :=
  cumulative L /\ (forall x : X, p x <-> (exists m : nat, x el L m)).

Definition L_enum {X} `{registered X} (p : X -> Prop) :=
  exists L, is_computable L /\ lenumerates L p.

Instance term_ofNat X `{registered X} :
  computable (@ofNat X).
Proof.
  extract.
Qed.

Lemma projection X Y {HX : registered X} {HY : registered Y} (p : X * Y -> Prop) :
  L_enumerable p -> L_enumerable (fun x => exists y, p (x,y)).
Proof.
  intros (f & [cf] & ?).
  exists (fun n => match f n with Some (x, y) => Some x | None => None end).
  split.
  - econstructor. extract.
  - intros; split.
    + intros [y ?]. eapply H in H0 as [n]. exists n. now rewrite H0.
    + intros [n ?]. destruct (f n) as [ [] | ] eqn:E; inv H0.
      exists y. eapply H. eauto.
Qed.

Lemma L_enumerable_ext X `{registered X} p q : L_enumerable p -> (forall x : X, p x <-> q x) -> L_enumerable q.
Proof.
  intros (f & cf & Hf) He. exists f; split; eauto.
  intros ?. rewrite <- He. eapply Hf.
Qed.

Lemma L_enumerable_enum {X} `{registered X} (p : X -> Prop) :
  L_enum p -> L_enumerable p.
Proof.
  intros (f & [cf] & Hf).
  exists (@ofNat X f). split.
  - econstructor. extract.
  - destruct Hf as [CX HX].
    intros. rewrite HX.
    + split; intros [n].
      * eapply In_nth_error in H0 as [m].
        destruct (pairs_retract (m, n)) as [k]. exists k. unfold ofNat. now rewrite H1.
      * unfold ofNat in *. destruct R_nat_nat as [ [] | ].
        eapply nth_error_In in H0. eauto. inv H0.
Qed.

Lemma L_enumerable_halt {X} `{registered X} (p : X -> Prop) :
  L_decidable (X := X * X) (fun '(x,y) => x = y) ->
  L_enumerable p -> p ⪯ converges.
Proof.
  intros (d & [c_d] & H_d) (f & [c_f] & H_f).
  edestruct L_enumerable_recognisable with (p := p) (d := fun x y => d (x,y)) (f := f); eauto.
  - extract.
  - intros. specialize (H_d (x,y)). destruct (d (x,y)); intuition.
  - now exists (fun x0 => x (enc x0)).
Qed.


Require Import Lia.
Require Import ssreflect ssrbool ssrfun.
Require Import Arith.
Require Import List.
Import Nat.
Import ListNotations.

Require Import Lists.Streams.

Load util.

(** Auxiliary definitions **)

Fixpoint prependListStream {A} (xs:list A) ys :=
  match xs with
  | [] => ys
  | x::xr => Cons x (prependListStream xr ys)
  end.

Inductive ne_list (A:Type) : Type :=
| ne_single (a:A)
| ne_cons   (a:A) (xs:ne_list A).
Arguments ne_single {A}.
Arguments ne_cons {A}.

Definition prependNeListStream {A} (xs:ne_list A) ys :=
  (cofix prepend (xs : ne_list A) :=
  match xs with
  | ne_single x => Cons x ys
  | ne_cons x xr => Cons x (prepend xr)
  end) xs.

CoFixpoint concat_list {A} (f:nat -> ne_list A) n :=
  (prependNeListStream (f n) (concat_list f (S n))).

Definition to_ne_list {X} (xs:list X) (Hne:xs<>nil) : ne_list X.
Proof.
  induction xs.
  - congruence.
  - destruct xs.
    + exact (ne_single a).
    + refine (ne_cons a (IHxs _)).
    congruence.
Defined.

(** Main definitions **)

Definition period := [1;2;3;4;3;2].

CoFixpoint seq := prependListStream period seq.
CoFixpoint seq2 := Cons 1 (Cons 2 (Cons 3 (Cons 4 (Cons 3 (Cons 2 seq2))))).

Definition offset r :=
  match r with
  |  0 =>  0
  |  1 =>  0
  |  2 =>  1
  |  3 =>  2
  |  4 =>  3
  |  5 =>  4
  |  6 =>  6
  |  7 =>  9
  |  8 => 11
  |  9 => 15
  | 10 => 18
  | 11 => 22
  | 12 => 27
  | 13 => 32
  | 14 => 37
  | _ => 0
  end.

Definition extra r :=
    match r with
    |  0 => []
    |  1 => [1]
    |  2 => [2]
    |  3 => [3]
    |  4 => [4]
    |  5 => [3;2]
    |  6 => [1;2;3]
    |  7 => [4;3]
    |  8 => [2;1;2;3]
    |  9 => [4;3;2]
    | 10 => [1;2;3;4]
    | 11 => [3;2;1;2;3]
    | 12 => [4;3;2;1;2]
    | 13 => [3;4;3;2;1]
    | 14 => [2;3;4;3;2]
    | _ => []
  end.

Definition qrseq (q:nat) (r:nat) : (list nat) * (list nat) :=
    (
      concat(repeat (rotate (offset r) period) q),
      extra r
    ).

Definition n_to_seq (n:nat) :=
  let (qseq,rseq) := qrseq (n/15) (n mod 15) in
  qseq ++ rseq.

Ltac solve_eqst_const :=
  match goal with
  | |- EqSt (Cons ?A ?B) (Cons ?C ?D) =>
      constructor;[auto|cbn [tl]]
  | _ => fail
  end.

(** Auxiliary proofs **)

Goal EqSt seq seq2.
Proof.
  cofix CIH.
  do 6 constructor;trivial.
Qed.

Lemma prepend_app {X} (xs ys:list X) s:
  prependListStream (xs++ys) s =
  prependListStream (xs) (prependListStream ys s).
Proof.
  induction xs;cbn.
  - reflexivity.
  - now rewrite IHxs.
Qed.

Lemma prepend_list_ne_list X (xs:list X) H S:
  prependListStream xs S =
  prependNeListStream (to_ne_list xs H) S.
Proof.
  induction xs as [|x [|y xs] IH].
  - congruence.
  - rewrite (unfold_Stream (prependNeListStream _ _));cbn.
    reflexivity.
  - cbn [prependListStream].
    rewrite (unfold_Stream (prependNeListStream _ _)).
    cbn. f_equal. apply IH.
Qed.

Lemma concat_list_unfold_list X f H n:
  let g n := @to_ne_list X (f n) (H n) in
  concat_list g n =
  prependListStream (f n) (concat_list g (S n)).
Proof.
  cbn.
  rewrite (unfold_Stream (concat_list _ _)).
  unfold concat_list at 1.
  fold (@concat_list X).
  rewrite prepend_list_ne_list.
  setoid_rewrite (unfold_Stream (prependNeListStream _ _)) at 2.
  reflexivity.
Qed.

(** Main proofs **)

Lemma qrseq_spec q r (Hr:r<15):
  let (ps,rs) := qrseq q r in
  sum ps = 15 * q /\
  sum rs = r.
Proof.
  destruct qrseq as [ps rs] eqn:H.
  revert H.
  do 15 try (destruct r as [|r]).
  16: lia.
  all: cbn;injection 1 as <- <-.
  all: rewrite repeat_sum;cbn;split;lia.
Qed.

Definition n_to_seq_spec (n:nat) :
  n>0 ->
  let xs := n_to_seq n in
  sum xs = n /\ xs <> nil.
Proof.
  intros H0.
  assert(15 <> 0) as H15 by lia.
  pose proof(Nat.div_mod n 15 H15) as Hn.
  pose proof(Nat.mod_upper_bound n 15 H15) as Hr.
  unfold n_to_seq.
  remember (n/15) as q.
  remember (n mod 15) as r.
  pose proof(@qrseq_spec q r Hr) as H.
  destruct (@qrseq q r) as [qseq rseq] eqn: Hseq.
  destruct H as [Hqseq Hrseq].
  split.
  - now rewrite sum_app Hqseq Hrseq Hn.
  - destruct n;[lia|].
    do 15 try (destruct r as [|r]).
    16: lia.
    all: cbn in Hseq;injection Hseq as <- <-.
    2-15: now apply app_not_nil_r.
    assert(q>0) by lia.
    destruct q;[lia|].
    cbn;congruence.
Defined.

Lemma prependPeriod s:
EqSt s seq ->
EqSt (prependListStream period s) seq.
Proof.
  intros H.
  rewrite (unfold_Stream seq).
  do 6 constructor;[reflexivity|].
  apply H.
Qed.

Lemma prependRepeatPeriod n s:
EqSt s seq ->
EqSt (prependListStream (concat (repeat period n)) s) seq.
Proof.
  intros H.
  induction n.
  - apply H.
  - cbn [repeat concat].
    rewrite prepend_app.
    apply prependPeriod, IHn.
Qed.

Lemma prependPeriodSeq:
  prependListStream period seq = seq.
Proof.
  setoid_rewrite (unfold_Stream seq) at 2.
  now cbn.
Qed.

Definition n_to_ne_seq (n:nat) : ne_list nat.
Proof.
  apply (to_ne_list (n_to_seq (S n))).
  pose proof (n_to_seq_spec (S n)) as [_ H].
  1: {
    induction n.
    - do 2 constructor.
    - constructor;apply IHn.
  }
  exact H.
Defined.

Lemma seq_eq_k n k:
  k < 15 ->
  (S n) mod 15 = k ->
  EqSt (concat_list n_to_ne_seq (S n)) (prependListStream (drop (offset (S k) mod length period) period) seq) ->
  EqSt (concat_list n_to_ne_seq n) (prependListStream (drop (offset k mod length period) period) seq).
Proof.
  intros Hk Hr IH.
  rewrite concat_list_unfold_list.
  (* rewrite (unfold_Stream (concat_list _ _)). *)
  cbn [concat_list].
  unfold n_to_seq.
  rewrite Hr.
  cbn [qrseq].
  (* cbn offset period *)
  remember (_ / 15) as q.
  pose proof prependPeriodSeq as HP.
  cbn in HP.
  destruct q.
  - cbn [repeat concat app].

    do 15 try destruct k as [|k].
    all:
    try(
    cbn [offset extra skipn length period];
    vm_compute (_ mod 6);
    cbn [drop period];
    cbn [prependListStream];

    rewrite (unfold_Stream seq);cbn [seq];
    cbn [prependListStream period];
    first [
      rewrite <- unfold_Stream |
      (cbn [prependListStream period];
      repeat solve_eqst_const)
    ];

    cbn [length period offset] in IH;
    vm_compute (_ mod 6) in IH;
    cbn [period drop offset] in IH;
    repeat rewrite prependPeriodSeq in IH;
    repeat rewrite HP in IH;
    repeat rewrite prependPeriodSeq;
    repeat rewrite HP;
    apply IH
    ).
  - rewrite repeat_rotate.

    do 15 try destruct k as [|k].

    all:
    cbn [offset extra skipn length period];
    vm_compute (_ mod 6);
    cbn [drop period];
      repeat rewrite prepend_app;
    cbn [prependListStream];

    rewrite (unfold_Stream seq);cbn [seq];
    cbn [prependListStream period];
    first [
      rewrite <- unfold_Stream |
      (cbn [prependListStream period];
      repeat solve_eqst_const)
    ];

    cbn [length period offset] in IH;
    vm_compute (_ mod 6) in IH;
    cbn [period drop offset] in IH;
    repeat rewrite prependPeriodSeq in IH;
    repeat rewrite HP in IH;
    repeat rewrite prependPeriodSeq;
    repeat rewrite HP;

      apply prependRepeatPeriod;
      cbn [take period];

      rewrite (unfold_Stream seq);cbn [seq];
      rewrite (unfold_Stream seq);cbn [seq];
      cbn [prependListStream period];
      first [
        rewrite <- unfold_Stream |
        (cbn [prependListStream period];
        repeat solve_eqst_const)
      ];

      repeat rewrite prependPeriodSeq in IH;
      repeat rewrite HP in IH;
      repeat rewrite prependPeriodSeq;
      repeat rewrite HP;
      apply IH.
Defined.

Lemma seq_eq_large_step n:
  S n mod 15 = 1 ->
  EqSt (concat_list n_to_ne_seq (15 + n)) seq ->
  EqSt (concat_list n_to_ne_seq n) seq.
Proof.
  intros Hn CIH.
  assert(15<>0) as H0 by lia.
  pose proof (@local_mod_add (S n) 15 1 H0 Hn) as Hmod.

  pose proof (@seq_eq_k n 1) as Hk.
  rewrite prependPeriodSeq in Hk.
  apply Hk;[lia|auto|].
  clear Hk.

  do 13 (apply seq_eq_k;[lia|shelve|]).
  Unshelve.
  shelve.
  - apply (Hmod 1);lia.
  - apply (Hmod 2);lia.
  - apply (Hmod 3);lia.
  - apply (Hmod 4);lia.
  - apply (Hmod 5);lia.
  - apply (Hmod 6);lia.
  - apply (Hmod 7);lia.
  - apply (Hmod 8);lia.
  - apply (Hmod 9);lia.
  - apply (Hmod 10);lia.
  - apply (Hmod 11);lia.
  - apply (Hmod 12);lia.
  - apply (Hmod 13);lia.
  Unshelve.

  match goal with
  | [ |- context G[concat_list _ ?N] ] =>
  replace N with (14+n) by reflexivity
  end.
  remember (14+n) as m.
  vm_compute (_ mod _).
  cbn [drop].
  rewrite prependPeriodSeq.

  pose proof (@seq_eq_k m 0) as Hk.
  rewrite prependPeriodSeq in Hk.
  apply Hk;[lia| | ].
  1: {
    subst.
    change (S (14+n)) with (14+S n).
    rewrite (add_mod _ _ _ H0) Hn.
    setoid_rewrite mod_small at 2;[|lia].
    now rewrite (mod_same _ H0).
  }
  clear Hk.
  subst.
  apply CIH.
Defined.

Unset Guard Checking.

(* we will apply the cofix to "concat_list _ n+15"
  so it is okay but Coq does not know it
*)

Lemma seq_eq n:
  S n mod 15 = 1 ->
  EqSt (concat_list n_to_ne_seq n) seq.
Proof.
  (* unfold concat_list. *)
  revert n.
  cofix CIH.
  intros n H.
  apply seq_eq_large_step.
  1: apply H.
  apply CIH.

  change (S (15+n)) with (15+(S n)).
  assert(15<>0) as H0 by congruence.
  rewrite (add_mod _ _ _ H0) H.
  now rewrite (mod_same _ H0).
Qed.

Set Guard Checking.

Corollary full_seq: EqSt (concat_list n_to_ne_seq 0) seq.
Proof.
  apply seq_eq.
  rewrite mod_small;lia.
Qed.


Require Export PredMonad.Ordered8.OrderedType.

(***
 *** The monad typeclass
 ***)

Class MonadOps M `{OTypeF M} : Type :=
  { returnM : forall {A} `{OType A}, A -o> M A _ _;
    bindM : forall {A B} `{OType A} `{OType B},
        M A _ _ -o> (A -o> M B _ _) -o> M B _ _ }.

Class Monad M `{MonadOps M} : Prop :=
  {
    monad_return_bind :
      forall A B `{OType A} `{OType B} (f: A -o> M B _ _) x,
        bindM @o@ (returnM @o@ x) @o@ f =o= f @o@ x;

    monad_bind_return :
      forall A `{OType A} m,
        bindM @o@ m @o@ returnM =o= m;

    monad_assoc :
      forall A B C `{OType A} `{OType B} `{OType C}
             m (f: A -o> M B _ _) (g: B -o> M C _ _),
        bindM @o@ (bindM @o@ m @o@ f) @o@ g
        =o=
        bindM @o@ m @o@ (ofun (fun x => bindM @o@ (f @o@ x) @o@ g));
  }.

(* Helpful bind notation *)
Notation "'do' x <- m1 ; m2" :=
  (bindM @o@ m1 @o@ (ofun (fun x => m2))) (at level 60, right associativity).

(* Add the monad laws to the OT rewrite set *)
Hint Rewrite @monad_return_bind @monad_bind_return @monad_assoc : OT.

(***
 *** The Identity Monad
 ***)

Definition Identity A `{OType A} := A.

Instance OTRelationF_Identity : OTRelationF Identity :=
  fun _ R _ => R.

Instance OTypeF_Identity : OTypeF Identity :=
  fun _ _ ot => ot.

Instance IdMonad_MonadOps : MonadOps Identity :=
  { returnM := fun A _ _ => ofun (fun x => x);
    bindM := fun A B _ _ _ _ =>
               ofun (fun m => ofun (fun (f:A -o> B) => f @o@ m)) }.

Instance IdMonad : Monad Identity.
Proof.
  econstructor; intros; simpl; reflexivity.
Qed.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(* *************************************************************************

          Buchberger : equality over polynomials, definition of Peq

          Laurent Thery March 1997 (revised April 2001)

  ************************************************************************** *)

From Coq Require Export Relation_Definitions List.
From Coq Require Import Arith Compare_dec.
From Buchberger Require Export CoefStructure OrderStructure POrder Monomials Term.

Set Default Proof Using "Type".

Section Peq.
Load hCoefStructure.
Load hOrderStructure.
Load hOrder.

Definition size := length (A:=Term A n).

Definition sizel m := match m with
                      | (l1, l2) => size l1 + size l2
                      end.

Definition lessP m1 m2 := sizel m1 < sizel m2.

Local Hint Unfold lessP : core.

Lemma wf_lessP : well_founded lessP.
Proof.
red in |- *.
cut (forall (m : nat) a, sizel a < m -> Acc lessP a).
intros H' a.
apply H' with (m := S (sizel a)); auto.
intros m; elim m; clear m.
intros a H; inversion H.
intros m H' a H'0.
apply Acc_intro.
intros y H'1; apply H'.
unfold lessP in H'1.
apply Nat.lt_le_trans with (sizel a); auto with arith.
Qed.

Local Hint Resolve wf_lessP : core.

Theorem pX_inj :
 forall (n1 n2 : Term A n) l1 l2, n1 = n2 -> l1 = l2 -> pX n1 l1 = pX n2 l2.
Proof.
intros n1 n2 l1 l2 H' H'0; rewrite H'0; rewrite H'; auto.
Qed.

Local Hint Resolve pX_inj : core.

Lemma pX_invl : forall (a b : Term A n) p q, pX a p = pX b q -> a = b.
Proof.
intros a b p q H'; inversion H'; auto.
Qed.

Local Hint Unfold pX : core.

Lemma pX_invr : forall p q (a b : Term A n), pX a p = pX b q -> p = q.
Proof.
unfold pX, pX in |- *.
intros p q a b H'; inversion H'; auto.
Qed.

Theorem canonicalpO : canonical A0 eqA ltM (pO A n).
Proof.
split; auto.
apply olistO.
red in |- *; simpl in |- *; auto.
Qed.

Theorem canonicalp1 :
 forall a,
 ~ zeroP (A:=A) A0 eqA (n:=n) a -> canonical A0 eqA ltM (pX a (pO A n)).
Proof.
intros a H; split; simpl in |- *; auto.
red in |- *; simpl in |- *; apply Relation_Operators_compat.d_one.
Qed.

Local Hint Resolve canonicalp1 canonical0 : core.

Inductive eqP : list (Term A n) -> list (Term A n) -> Prop :=
  | eqP0 : eqP (pO A n) (pO A n)
  | eqpP1 :
      forall ma mb p q,
      eqTerm (A:=A) eqA (n:=n) ma mb -> eqP p q -> eqP (pX ma p) (pX mb q).

Local Hint Resolve eqP0 eqpP1 : core.

Theorem eqp_refl : reflexive _ eqP.
Proof using plusA multA minusA invA divA cs A1 A0.
red in |- *.
intros x; elim x; auto.
intros a l H; change (eqP (pX a l) (pX a l)) in |- *; apply eqpP1; auto.
Qed.

Theorem eqp_sym : symmetric _ eqP.
Proof using plusA multA minusA invA divA cs A1 A0.
red in |- *.
intros x y H'; elim H'; auto.
intros ma mb p q H H0 H1.
apply eqpP1; auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Lemma eqp_inv1 : forall p, eqP (pO A n) p -> p = pO A n.
Proof.
unfold pO in |- *; intros p H'; inversion H'; auto.
Qed.

Theorem eqp_inv2 : forall p, eqP p (pO A n) -> p = pO A n.
Proof.
unfold pO in |- *; intros p H'; inversion H'; auto.
Qed.

Theorem eqp_inv3l :
 forall a b p q, eqP (pX a p) (pX b q) -> eqTerm (A:=A) eqA (n:=n) a b.
Proof.
intros a b p q H'; simple inversion H'; auto.
unfold pO in H0; inversion H0.
rewrite (pX_invl ma a p0 p); auto; rewrite (pX_invl mb b q0 q); auto.
Qed.

Theorem eqp_inv3r : forall a b p q, eqP (pX a p) (pX b q) -> eqP p q.
Proof.
intros a b p q H'; simple inversion H'; auto.
unfold pO in H0; inversion H0.
rewrite (pX_invr p0 p ma a); auto; rewrite (pX_invr q0 q mb b); auto.
Qed.

Theorem eqp_trans : transitive _ eqP.
Proof using plusA multA minusA invA divA cs A1 A0.
red in |- *.
intros x; elim x; auto.
intros y z H'; inversion_clear H'.
intros H'0; inversion_clear H'0; auto.
intros a l H' y z H'0; inversion_clear H'0.
intros H4; inversion_clear H4.
change (eqP (pX a l) (pX mb0 q0)) in |- *; apply eqpP1; eauto.
apply (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n) with (y := mb); auto.
Qed.

Local Hint Resolve eqp_refl : core.

Let eqTerm_imp_eqT := eqTerm_imp_eqT A eqA n.

Theorem ltP_refl_pX :
 forall (a : Term A n) (p : list (Term A n)),
 canonical A0 eqA ltM (pX a p) -> ltP (A:=A) (n:=n) ltM p (pX a p).
Proof using plusA os multA minusA invA divA cs A1.
intros a p; case p; auto.
intros a0 l H'.
apply ltP_trans with (y := pX a (pO A n)); auto.
change (ltP (A:=A) (n:=n) ltM (pX a0 l) (pX a (pO A n))) in |- *.
apply ltP_hd; auto.
apply (canonical_pX_order A A0) with (eqA := eqA) (l := l); auto.
apply ltP_tl; auto.
change (ltP (A:=A) (n:=n) ltM (pO A n) (pX a0 l)) in |- *; apply ltPO.
Qed.

Theorem eqp_eqTerm :
 forall a b p q, eqP (pX a p) (pX b q) -> eqTerm (A:=A) eqA (n:=n) a b.
Proof.
intros a b p q H'; inversion_clear H'; trivial.
Qed.

Theorem ltp_eqp_comp :
 forall p q r s,
 ltP (A:=A) (n:=n) ltM p q ->
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM q -> eqP p r -> eqP q s -> ltP (A:=A) (n:=n) ltM r s.
Proof.
intros p q r s H'; generalize r s; elim H'; clear r s H'; auto.
intros x p0 r s H H0 H1; inversion H1.
intros H4; inversion H4; apply ltPO.
intros x y p0 q0 H r s H0 H1 H2 H3; inversion_clear H2; try discriminate;
 inversion_clear H3; try discriminate; auto.
apply ltP_hd.
apply ltT_eqTl with (a := y); auto.
apply ltT_eqTr with (a := x); auto.
intros x y p0 q0 H H0 H1 r s H2 H3 H4 H5; inversion_clear H4;
 try discriminate; inversion_clear H5; try discriminate.
apply ltP_tl; auto.
apply (eqT_trans A n) with (y := y); auto.
apply (eqT_trans A n) with (y := x); auto.
apply (eqT_sym A n); auto.
apply H1; auto.
apply canonical_imp_canonical with (a := x); auto.
apply canonical_imp_canonical with (a := y); auto.
Qed.

Theorem eqp_imp_canonical :
 forall p q, eqP p q -> canonical A0 eqA ltM p -> canonical A0 eqA ltM q.
Proof using plusA multA minusA invA eqA_dec divA cs A1.
intros p q H'; elim H'; auto.
intros ma mb p0 q0 H'0 H'1 H'2 H'3.
apply canonical_pX_eqT with (a := ma); auto.
apply ltP_pX_canonical; auto.
apply H'2.
apply canonical_imp_canonical with (a := ma); auto.
apply (canonical_nzeroP A A0 eqA n ltM ma p0); auto.
apply ltp_eqp_comp with (p := p0) (q := pX ma (pO A n)); auto.
apply canonical_pX_ltP with (1 := H'3).
apply canonical_imp_canonical with (a := ma); auto.
apply canonicalp1; auto.
apply (canonical_nzeroP A A0 eqA n ltM ma p0); auto.
apply nzeroP_comp_eqTerm with (1 := cs) (a := ma); auto.
apply (canonical_nzeroP A A0 eqA n ltM ma p0); auto.
Qed.

Definition sizel3
 (m : list (Term A n) * (list (Term A n) * list (Term A n))) :=
  match m with
  | (l1, (l2, l3)) => size l1 + (size l2 + size l3)
  end.

Definition lessP3
 (m1 m2 : list (Term A n) * (list (Term A n) * list (Term A n))) :=
  sizel3 m1 < sizel3 m2.

Lemma wf_lessP3 : well_founded lessP3.
Proof.
red in |- *.
cut (forall (m : nat) a, sizel3 a < m -> Acc lessP3 a).
intros H' a.
apply H' with (m := S (sizel3 a)); auto.
intros m; elim m; clear m.
intros a H; inversion H.
intros p H' a H'0; apply Acc_intro.
intros y H'1; apply H'.
unfold lessP in H'1; apply Nat.lt_le_trans with (sizel3 a); auto with arith.
Qed.

Local Hint Resolve wf_lessP3 : core.

Set Implicit Arguments.
Unset Strict Implicit.

Definition eqPf :
  forall pq, {eqP (fst pq) (snd pq)} + {~ eqP (fst pq) (snd pq)}.
intros pq; pattern pq in |- *;
 apply well_founded_induction with (R := lessP) (1 := wf_lessP);
 clear pq.
intros pq; case pq; simpl in |- *; clear pq.
intros p; case p; clear p.
intros q; case q; clear q.
intros H'; left; constructor.
intros b q H'; right; red in |- *; intros H'0; inversion H'0.
intros a p q; case q; clear q.
intros H'; right; red in |- *; intros H'0; inversion H'0.
intros b q Rec; case (eqTerm_dec _ _ eqA_dec n a b); simpl in Rec;
 intros eqTerm0.
case (Rec (p, q)); unfold lessP in |- *; simpl in |- *; auto with arith.
intros H'; left; auto.
change (eqP (pX a p) (pX b q)) in |- *; auto.
intros H'; right; red in |- *; intros H'0.
apply H'.
apply eqp_inv3r with (a := a) (b := b); auto.
right; red in |- *; intros H'.
apply eqTerm0.
apply eqp_eqTerm with (p := p) (q := q); auto.
Defined.

Definition seqP : poly A0 eqA ltM -> poly A0 eqA ltM -> Prop.
intros sp1 sp2; case sp1; case sp2.
intros p1 H'1 p2 H'2; exact (eqP p1 p2).
Defined.

Set Strict Implicit.
Unset Implicit Arguments.

Definition seqp_dec : forall p q : poly A0 eqA ltM, {seqP p q} + {~ seqP p q}.
intros p q; case p; case q; simpl in |- *.
intros x H' x0 H'0.
apply (eqPf (x, x0)).
Defined.

Theorem seqp_refl : reflexive (poly A0 eqA ltM) seqP.
Proof using plusA multA minusA invA divA cs A1.
red in |- *.
intros p; case p; simpl in |- *.
intros x H'.
apply eqp_refl.
Qed.

Theorem seqp_sym : symmetric (poly A0 eqA ltM) seqP.
Proof using plusA multA minusA invA divA cs A1.
red in |- *.
intros p q; case p; case q; simpl in |- *.
intros x H' x0 H'0 H'1.
apply eqp_sym; auto.
Qed.

Theorem seqp_trans : transitive (poly A0 eqA ltM) seqP.
Proof using plusA multA minusA invA divA cs A1.
red in |- *.
intros p q r; case p; case q; case r; simpl in |- *.
intros x H' x0 H'0 x1 H'1 H'2 H'3.
apply eqp_trans with (y := x0); auto.
Qed.

End Peq.