Require Import Tapl.LambdaSub.Base.
Require Import Tapl.LambdaSub.Exp.
Require Import Tapl.LambdaSub.Subst.
Require Import Tapl.LambdaSub.Typing.

(* Progress: Every well-typed term is either a value or can take a step. *)
Theorem progress : forall t T,
    nil ⊢ t ∈ T ->
    value t ∨ exists t', t --> t'.
Proof with auto.
  intros.
  remember nil as G.
  induction H; subst.
  - (* If ⊢ t was derived from the variable rule, this is a contradiction since there are no free variables in the empty context. *)
    exfalso. apply get_nil in H...
  - (* If ⊢ t was derived from the abstraction rule, t is a value, so we're done. *)
    left; split... apply wf_abs. eauto.
  - (* By our inductive hypothesis, t1 is either a value, or it can step to t1'.
       If it can step, then we just follow st_app1. If it is a value, then t2 is either a value or it can step to t2'.
       If it can step to t2', then we just follow st_app2. If t2 is a value, then since by the canonical arrow lemma, t1 must be an abstraction, so we can follow st_appAbs. *)
    right.
    pose proof (IHhas_type1 eq_refl).
    pose proof (IHhas_type2 eq_refl).
    destruct H1.
    + destruct H2.
      * pose proof (canonical_forms_arrow nil t1 T1 T2 H H1).
        destruct H3 as [S [t' H3]]. subst.
        exists (substX 0 t2 t')...
      * destruct H2 as [t2' H2].
        exists (tm_app t1 t2')...
    + destruct H1 as [t1' H1]. exists (tm_app t1' t2)...
  - (* If ⊢ t was derived from the unit rule, t is a value. *)
    left; split; unfold closed...
  - apply IHhas_type...
Qed.

(* Preservation: If t has type T and steps to t', then t' also has type T. *)

Lemma typing_inversion_abs : forall Γ S1 t T,
  Γ ⊢ (tm_abs S1 t) ∈ T →
  ∃ S2, ty_arrow S1 S2 <: T ∧ (S1 :: Γ) ⊢ t ∈ S2.
Proof.
  intros.
  remember (tm_abs S1 t) as s.
  induction H; inversion Heqs; subst; intros; try solve_by_invert.
  - exists T2; auto.
  - destruct IHhas_type as [S2 [Hsub Hty]]. reflexivity.
    exists S2. eauto.
Qed.

Lemma abs_arrow : forall Γ S1 s2 T1 T2,
  Γ ⊢ (tm_abs S1 s2) ∈ ty_arrow T1 T2 →
  T1 <: S1 ∧ (S1 :: Γ) ⊢ s2 ∈ T2.
Proof.
  intros.
  apply typing_inversion_abs in H.
  destruct H as [S2 [H1 H2]].
  apply inversion_arrow in H1 as [S3 [S4 [H3 [H4 H5]]]].
  inversion H3; subst. eauto.
Qed.

Theorem preservation : forall t t' T,
    t --> t' ->
    nil ⊢ t ∈ T ->
    nil ⊢ t' ∈ T.
Proof with eauto.
  intros.
  generalize dependent t'.
  remember nil as Γ.
  induction H0; intros; subst.
  - exfalso. apply get_nil in H...
  - inversion H.
  - inversion H; subst...
    + assert (H' := H0_).
      apply abs_arrow in H0_ as [HT1 HT2].
      eapply subst_preserves_typing with T...
  - inversion H.
  - apply Ty_Sub with S...
Qed.

(* Type safety: If t has type T, then it never reaches a stuck state. *)
Definition stuck (t : term) := ¬ value t ∧ ¬ exists t', t --> t'.

Theorem soundness : ∀ t t' T,
  nil ⊢ t ∈ T →
  t -->* t' →
  ¬ (stuck t).
Proof with eauto.
  intros.
  unfold stuck.
  induction H0; unfold not; intros [HA HB].
  - apply progress in H. destruct H as [vt | [t' Ht]]...
  - apply (preservation a b T) in H...
Qed.


Require Export prosa.analysis.facts.model.service_of_jobs.
Require Export prosa.analysis.facts.preemption.rtc_threshold.job_preemptable.
Require Export prosa.analysis.abstract.definitions.

(** * Run-to-Completion Threshold of a job *)
(** In this module, we provide a sufficient condition under which a job
    receives enough service to become non-preemptive. *)
(** Previously we defined the notion of run-to-completion threshold (see file
   abstract.run_to_completion_threshold.v). Run-to-completion threshold is the
   amount of service after which a job cannot be preempted until its completion.
   In this section we prove that if cumulative interference inside a busy interval
   is bounded by a certain constant then a job executes long enough to reach its
   run-to-completion threshold and become non-preemptive. *)
Section AbstractRTARunToCompletionThreshold.

  (** Consider any type of tasks ... *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.

  (**  ... and any type of jobs associated with these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** In addition, we assume existence of a function
     mapping jobs to their preemption points. *)
  Context `{JobPreemptable Job}.

  (** Consider any kind of uni-service ideal processor state model. *)
  Context {PState : Type}.
  Context `{ProcessorState Job PState}.
  Hypothesis H_ideal_progress_proc_model : ideal_progress_proc_model PState.
  Hypothesis H_unit_service_proc_model : unit_service_proc_model PState.

  (** Consider any arrival sequence with consistent arrivals ... *)
  Variable arr_seq : arrival_sequence Job.
  Hypothesis H_arrival_times_are_consistent : consistent_arrival_times arr_seq.

  (** ... and any schedule of this arrival sequence. *)
  Variable sched : schedule PState.

  (** Assume that the job costs are no larger than the task costs. *)
  Hypothesis H_jobs_respect_taskset_costs : arrivals_have_valid_job_costs arr_seq.

  (** Let [tsk] be any task that is to be analyzed. *)
  Variable tsk : Task.

  (** Assume we are provided with abstract functions for interference and interfering workload. *)
  Variable interference : Job -> instant -> bool.
  Variable interfering_workload : Job -> instant -> duration.

  (** For simplicity, let's define some local names. *)
  Let work_conserving := work_conserving arr_seq sched tsk.
  Let cumul_interference := cumul_interference interference.
  Let cumul_interfering_workload := cumul_interfering_workload interfering_workload.
  Let busy_interval := busy_interval sched interference interfering_workload.

  (** We assume that the schedule is work-conserving. *)
  Hypothesis H_work_conserving: work_conserving interference interfering_workload.

  (** Let [j] be any job of task [tsk] with positive cost. *)
  Variable j : Job.
  Hypothesis H_j_arrives : arrives_in arr_seq j.
  Hypothesis H_job_of_tsk : job_task j = tsk.
  Hypothesis H_job_cost_positive : job_cost_positive j.

  (** Next, consider any busy interval <<[t1, t2)>> of job [j]. *)
  Variable t1 t2 : instant.
  Hypothesis H_busy_interval : busy_interval j t1 t2.

  (** First, we prove that job [j] completes by the end of the busy interval.
     Note that the busy interval contains the execution of job j, in addition
     time instant t2 is a quiet time. Thus by the definition of a quiet time
     the job should be completed before time t2. *)
  Lemma job_completes_within_busy_interval:
    completed_by sched j t2.
  Proof.
    move: (H_busy_interval) => [[/andP [_ LT] [_ _]] [_ QT2]].
    unfold pending, has_arrived in QT2.
    move: QT2; rewrite  /pending negb_and; move => /orP [QT2|QT2].
    { by move: QT2 => /negP QT2; exfalso; apply QT2, ltnW. }
      by rewrite Bool.negb_involutive in QT2.
  Qed.

  (** In this section we show that the cumulative interference is a complement to
     the total time where job [j] is scheduled inside the busy interval. *)
  Section InterferenceIsComplement.

    (** Consider any sub-interval <<[t, t + delta)>> inside the busy interval [t1, t2). *)
    Variables (t : instant) (delta : duration).
    Hypothesis H_greater_than_or_equal : t1 <= t.
    Hypothesis H_less_or_equal: t + delta <= t2.

    (** We prove that sum of cumulative service and cumulative interference
       in the interval <<[t, t + delta)>> is equal to delta. *)
    Lemma interference_is_complement_to_schedule:
      service_during sched j t (t + delta) + cumul_interference j t (t + delta) = delta.
    Proof.
      rewrite /service_during /cumul_interference/service_at.
      rewrite -big_split //=.
      rewrite -{2}(sum_of_ones t delta).
      rewrite big_nat [in RHS]big_nat.
      apply: eq_bigr=> x /andP[Lo Hi].
      move: (H_work_conserving j t1 t2 x) => Workj.
      feed_n 5 Workj; try done.
      { by apply/andP; split; eapply leq_trans; eauto 2. }
      destruct interference.
      - replace (service_in _ _) with 0; auto; symmetry.
        apply no_service_not_scheduled; auto.
        now apply/negP; intros SCHED; apply Workj in SCHED; apply SCHED.
      - replace (service_in _ _) with 1; auto; symmetry.
        apply/eqP; rewrite eqn_leq; apply/andP; split.
        + apply H_unit_service_proc_model.
        + now apply H_ideal_progress_proc_model, Workj.
    Qed.

  End InterferenceIsComplement.

  (** In this section, we prove a sufficient condition under which job [j] receives enough service. *)
  Section InterferenceBoundedImpliesEnoughService.

    (** Let progress_of_job be the desired service of job j. *)
    Variable progress_of_job : duration.
    Hypothesis H_progress_le_job_cost : progress_of_job <= job_cost j.

    (** Assume that for some delta, the sum of desired progress and cumulative
       interference is bounded by delta (i.e., the supply). *)
    Variable delta : duration.
    Hypothesis H_total_workload_is_bounded:
      progress_of_job + cumul_interference j t1 (t1 + delta) <= delta.

    (** Then, it must be the case that the job has received no less service than progress_of_job. *)
    Theorem j_receives_at_least_run_to_completion_threshold:
      service sched j (t1 + delta) >= progress_of_job.
    Proof.
      case NEQ: (t1 + delta <= t2); last first.
      { intros.
        have L8 := job_completes_within_busy_interval.
        apply leq_trans with (job_cost j); first by done.
        rewrite /service.
        rewrite -(service_during_cat _ _ _ t2).
        apply leq_trans with (service_during sched j 0 t2); [by done | by rewrite leq_addr].
          by apply/andP; split; last (apply negbT in NEQ; apply ltnW; rewrite ltnNge).
      }
      {  move: H_total_workload_is_bounded => BOUND.
         apply subh3 in BOUND.
         apply leq_trans with (delta - cumul_interference j t1 (t1 + delta)); first by done.
         apply leq_trans with (service_during sched j t1 (t1 + delta)).
         { rewrite -{1}[delta](interference_is_complement_to_schedule t1) //.
           rewrite -addnBA // subnn addn0 //.
         }
         { rewrite /service -[X in _ <= X](service_during_cat _ _ _ t1).
           rewrite leq_addl //.
             by apply/andP; split; last rewrite leq_addr.
         }
      }
    Qed.

  End InterferenceBoundedImpliesEnoughService.

  (** In this section we prove a simple lemma about completion of
     a job after is reaches run-to-completion threshold. *)
  Section CompletionOfJobAfterRunToCompletionThreshold.

    (** Assume that completed jobs do not execute ... *)
    Hypothesis H_completed_jobs_dont_execute:
      completed_jobs_dont_execute sched.

    (** .. and the preemption model is valid. *)
    Hypothesis H_valid_preemption_model:
      valid_preemption_model arr_seq sched.

    (** Then, job [j] must complete in [job_cost j - job_run_to_completion_threshold j] time
       units after it reaches run-to-completion threshold. *)
    Lemma job_completes_after_reaching_run_to_completion_threshold:
      forall t,
        job_run_to_completion_threshold j <= service sched j t ->
        completed_by sched j (t + (job_cost j - job_run_to_completion_threshold j)).
    Proof.
      move => t ES.
      set (job_cost j - job_run_to_completion_threshold j) as job_last.
      have LSNP := @job_nonpreemptive_after_run_to_completion_threshold
                     Job H2 H3 _ _ arr_seq sched _ j _ t.
      apply negbNE; apply/negP; intros CONTR.
      have SCHED: forall t', t <= t' <= t + job_last -> scheduled_at sched j t'.
      { move => t' /andP [GE LT].
        rewrite -[t'](@subnKC t) //.
        eapply LSNP; eauto 2; first by rewrite leq_addr.
        rewrite subnKC //.
        apply/negP; intros COMPL.
        move: CONTR => /negP Temp; apply: Temp.
        apply completion_monotonic with (t0 := t'); try done.
      }
      have SERV: job_last + 1 <= \sum_(t <= t' < t + (job_last + 1)) service_at sched j t'.
      { rewrite -{1}[job_last + 1]addn0  -{2}(subnn t) addnBA // addnC.
        rewrite -{1}[_+_-_]addn0 -[_+_-_]mul1n -iter_addn -big_const_nat.
        rewrite big_nat_cond [in X in _ <= X]big_nat_cond.
        rewrite leq_sum //.
        move => t' /andP [NEQ _].
        apply H_ideal_progress_proc_model; apply SCHED.
          by rewrite addn1 addnS ltnS in NEQ.
      }
      eapply service_at_most_cost with (j0 := j) (t0 := t + job_last.+1) in H_completed_jobs_dont_execute; auto.
      move: H_completed_jobs_dont_execute; rewrite leqNgt; move => /negP T; apply: T.
      rewrite /service -(service_during_cat _ _ _ t); last by (apply/andP; split; last rewrite leq_addr).
      apply leq_trans with (job_run_to_completion_threshold j + service_during sched j t (t + job_last.+1));
        last by rewrite leq_add2r.
      apply leq_trans with  (job_run_to_completion_threshold j + job_last.+1); last by rewrite leq_add2l /service_during -addn1.
        by rewrite addnS ltnS subnKC //; eapply job_run_to_completion_threshold_le_job_cost; eauto.
    Qed.

  End CompletionOfJobAfterRunToCompletionThreshold.

End AbstractRTARunToCompletionThreshold.


(*
 * Definition of Graham's number and facts about Knuth "up-arrow" notation.
 *)

From Coq Require Import
  Program.Wf.
From FunProofs.Lib Require Import
  Util.

Definition lex_order (xs ys : nat * nat) :=
  let '(x1, x2) := xs in let '(y1, y2) := ys in
  x1 < y1 \/ (x1 = y1 /\ x2 < y2).

Lemma lex_order_wf : well_founded lex_order.
Proof.
  intros [a b]; pattern a, b; apply lt_wf_double_rec; clear a b; intros.
  constructor; intros [] [| []]; subst; auto.
Defined.

Lemma sub_1_lt n : n <> 0 -> n - 1 < n.
Proof.
  induction n; intros; [easy |].
  cbn; destruct n; constructor.
Defined.

Definition up' (b : nat) : (nat * nat) -> nat.
Proof.
  unshelve refine (Fix lex_order_wf (fun _ => nat)
    (fun (args : nat * nat)
         (up' : forall args', lex_order args' args -> nat) =>
       let n := fst args in let p := snd args in
       if Nat.eq_dec n O then b * p
       else if Nat.eq_dec p O then 1
       else up' (n - 1, (up' (n, p - 1) _)) _));
    destruct args as []; subst n p; cbn in *; auto using sub_1_lt.
Defined.
Definition up n b p : nat := up' b (n, p).

Notation "b '^{' n '}' p" := (up n b p) (at level 30, right associativity).

Lemma up_0_mul b p : b ^{0} p = b * p.
Proof. auto. Qed.

Lemma up_pow_0_1 n b : b ^{S n} 0 = 1.
Proof. destruct n; auto. Qed.

Lemma up_unroll n b p : b ^{S n} (S p) = b ^{n} b ^{S n} p.
Proof.
  remember (up _ _ (up _ _ _)) as rhs.
  unfold up, up'; rewrite Init.Wf.Fix_eq.
  - repeat fold (up' b); cbn [fst snd].
    repeat (destruct (Nat.eq_dec _ _); [easy |]).
    subst rhs; unfold up; repeat f_equal; lia.
  - intros [] **; repeat (destruct Nat.eq_dec; auto).
    cbn; rewrite !H; auto.
Qed.

Corollary up_1_pow b p : b ^{1} p = b ^ p.
Proof.
  induction p; auto.
  rewrite up_unroll, up_0_mul, IHp; auto.
Qed.

Corollary up_pow_1_base n : forall b, b ^{n} 1 = b.
Proof.
  induction n; intros.
  - rewrite up_0_mul, Nat.mul_1_r; auto.
  - rewrite up_unroll, up_pow_0_1; auto.
Qed.

Corollary up_1_1 p : forall n, 1 ^{S n} p = 1.
Proof.
  induction p; intros.
  - rewrite up_pow_0_1; auto.
  - rewrite up_unroll, IHp, up_pow_1_base; auto.
Qed.

Corollary up_2_2_4 n : 2 ^{n} 2 = 4.
Proof.
  induction n; auto.
  rewrite !up_unroll, up_pow_0_1, up_pow_1_base; auto.
Qed.

Definition strict_increase (min : nat) (f : nat -> nat) :=
  forall n n', min < n < n' -> f n < f n'.

Definition strict_increase_1 (min : nat) (f : nat -> nat) :=
  forall n, min < n -> f n < f (S n).

Definition abundant (min : nat) (f : nat -> nat) :=
  forall n, min < n -> n < f n.

Lemma strict_increase_iff min f : strict_increase_1 min f <-> strict_increase min f.
Proof.
  unfold strict_increase, strict_increase_1; split; intros Hstrict **.
  - induction n'; [easy |].
    assert (n < n' \/ n = n') as [] by lia; subst; [| eapply Hstrict; lia].
    etransitivity; [eapply IHn'; lia |]; eapply Hstrict; lia.
  - apply Hstrict; lia.
Qed.

Lemma strict_increase_pos min f :
  strict_increase min f -> min < f (S min) -> forall n, min < n -> min < f n.
Proof.
  intros Hstrict Hf1; induction n; intros; try easy.
  assert (min < n \/ n = min) as [|] by lia; subst; auto.
  etransitivity; [eapply IHn; eauto |].
  eapply Hstrict; lia.
Qed.

Section Composition.
  Variables (f g : nat -> nat) (b : nat).
  Hypotheses (b_min : 1 < b) (f_min : 1 < f 1).
  Hypotheses (f_strict : strict_increase 0 f) (f_abundant : abundant 0 f).
  Hypotheses (g_base : g 1 = b) (g_succ : forall n, g (S n) = f (g n)).

  Lemma strict_abundant_comp_pos n : 0 < n -> 0 < g n.
  Proof.
    induction n as [| []]; intros; [easy | |].
    - rewrite g_base; lia.
    - rewrite g_succ; apply strict_increase_pos; auto; lia.
  Qed.

  Lemma strict_abundant_comp_strict : strict_increase 0 g.
  Proof.
    rewrite <- strict_increase_iff; hnf; intros.
    rewrite g_succ; apply f_abundant, strict_abundant_comp_pos; auto.
  Qed.

  Lemma strict_abundant_comp_abundant : abundant 0 g.
  Proof.
    hnf; induction n as [| []]; intros; [easy | |].
    - rewrite g_base; auto.
    - enough (g (S n) < g (S (S n))) by lia.
      eapply strict_abundant_comp_strict with (n := S n); lia.
  Qed.
End Composition.

Section UpPowStrictAbundant.
  Variable (b : nat).
  Hypothesis (b_min : 1 < b).
  Notation f := (fun n p => b ^{n} p) (only parsing).

  Let mul_strict : strict_increase 0 (f 0).
  Proof. hnf; intros; apply Nat.mul_lt_mono_pos_l; auto; lia. Qed.

  Let mul_abundant : abundant 0 (f 0).
  Proof.
    hnf; intros.
    rewrite <- (Nat.mul_1_l n) at 1.
    apply Nat.mul_lt_mono_pos_r; lia.
  Qed.

  Corollary up_pow_strict_abundant n : strict_increase 0 (f n) /\ abundant 0 (f n).
  Proof.
    induction n; auto using mul_strict, mul_abundant; destruct IHn; split.
    - eapply strict_abundant_comp_strict with (f := fun p => b ^{n} p) (b := b);
        eauto using up_unroll.
      rewrite up_pow_1_base; auto.
    - eapply strict_abundant_comp_abundant with (f := fun p => b ^{n} p) (b := b);
        eauto using up_unroll.
      rewrite up_pow_1_base; auto.
  Qed.
End UpPowStrictAbundant.

Section UpBaseStrict.
  Corollary up_pos b n p : 0 < (S b) ^{S n} p.
  Proof.
    destruct b; [rewrite up_1_1; auto |].
    destruct p; [rewrite up_pow_0_1; auto |].
    apply strict_increase_pos; auto; try lia.
    - eapply up_pow_strict_abundant; lia.
    - rewrite up_pow_1_base; lia.
  Qed.

  Corollary up_base_strict n : forall p, 0 < p -> strict_increase 0 (fun b => b ^{n} p).
  Proof.
    induction n; intros * Hp; hnf; intros n' n'' **.
    - apply Nat.mul_lt_mono_pos_r; lia.
    - induction p; [easy |].
      assert (0 < p \/ p = 0) as [|] by lia; subst.
      + rewrite !up_unroll.
        destruct n'; [easy |].
        etransitivity; [eapply IHn; eauto using up_pos |].
        eapply up_pow_strict_abundant; eauto using up_pos; lia.
      + rewrite !up_pow_1_base; lia.
  Qed.
End UpBaseStrict.

Section UpDegreeStrict.
  Corollary up_degree_strict p b : 0 < p -> strict_increase 2 (fun n => b ^{n} p).
  Proof.
    intros Hp; rewrite <- strict_increase_iff; hnf; intros.
    revert p b Hp; induction n; intros; try lia.
    destruct p; try easy.
    rewrite !up_unroll.
  Admitted.
End UpDegreeStrict.

(* Lemma up_pow_add : forall b p p' n, *)
(*   (b ^{n} p) ^{n} p' < b ^{n} (p + p'). *)
(* Proof. *)
(* Admitted. *)

Fixpoint graham_aux n :=
  match n with
  | O => 4
  | S n' => 3 ^{graham_aux n'} 3
  end.
Definition graham_num := graham_aux 64.


From Undecidability.L Require Export Util.L_facts.
From Undecidability.L.Tactics Require Import LClos.
Require Import ZArith. (* ? *)
Require Import FunInd.

(* *** Reflexted closure calculus *)
(* This moduel provides definitions of an symbolic simplifier for reflected L-terms used in Lbeta *)

Open Scope LClos.

Inductive rTerm : Type :=
| rVar (x : nat) : rTerm
| rApp (s : rTerm) (t : rTerm) : rTerm
| rLam (s : rTerm)
| rConst (x : nat) : rTerm
| rRho (s : rTerm).

Coercion rApp : rTerm >-> Funclass.

Definition denoteTerm (phi : nat -> term) :rTerm->term :=
  fix denoteTerm s :=
    match s with
    | rVar n => var n
    | rApp s t=> app (denoteTerm s) (denoteTerm t)
    | rLam s => lam (denoteTerm s)
    | rConst n => phi n
    | rRho s => rho (denoteTerm s)
    end.

Definition Proc phi := forall (n:nat) , proc (phi n).

Definition rClosed phi s:= Proc phi /\ closed (denoteTerm phi s).

Definition rPow phi n s t :=
  denoteTerm phi s >(n) denoteTerm phi t.

Lemma rReduceIntro phi l s t : Proc phi -> rClosed phi s -> rClosed phi t -> denoteTerm phi s >(l) denoteTerm phi t -> rPow phi l s t.
Proof.
  unfold rPow;tauto.
Qed.

Inductive rComp : Type :=
| rCompVar (x:nat)
| rCompApp (s : rComp) (t : rComp) : rComp
| rCompClos (s : rTerm) (A : list rComp) : rComp.

Coercion rCompApp : rComp >-> Funclass.

Definition denoteComp (phi : nat -> term) :rComp -> Comp:=
  fix denoteComp s :=
    match s with
    | rCompVar x => CompVar x
    | rCompApp s t => (denoteComp s) (denoteComp t)
    | rCompClos s A => CompClos (denoteTerm phi s) (map denoteComp A)
    end.

Fixpoint rSubstList (s:rTerm) (x:nat) (A: list rTerm): rTerm :=
  match s with
  | rVar n => if Dec ( n < x )then rVar n else nth (n-x) A (rVar n)
  | rApp s t => (rSubstList s x A) (rSubstList t x A)
  | rLam s => rLam (rSubstList s (S x) A)
  | rRho s => rRho (rSubstList s (S x) A)
  | rConst x => rConst x
  end.

Fixpoint rDeClos (s:rComp) : rTerm :=
  match s with
  | rCompVar x => rVar x
  | rCompApp s t => (rDeClos s) (rDeClos t)
  | rCompClos s A => rSubstList s 0 (map rDeClos A)
  end.

Definition rComp_ind_deep'
           (P : rComp -> Prop)
           (Pl : list rComp -> Prop)
           (IHVar : forall x : nat, P (rCompVar x))
           (IHApp : forall s : rComp, P s -> forall t : rComp, P t -> P (s t))
           (IHClos : forall (s : rTerm) (A : list rComp),
               Pl A -> P (rCompClos s A))
           (IHNil : Pl nil)
           (IHCons : forall (a:rComp) (A : list rComp),
               P a -> Pl A -> Pl (a::A))
           (x:rComp) : P x :=
  (fix f c : P c:=
     match c with
     | rCompVar x => IHVar x
     | rCompApp s t => IHApp s (f s) t (f t)
     | rCompClos s A => IHClos s A
                              ((fix g A : Pl A :=
                                  match A with
                                    [] => IHNil
                                  | a::A => IHCons a A (f a) (g A)
                                  end) A)
     end) x
.

Definition rComp_ind_deep
           (P : rComp -> Prop)
           (IHVar : forall x : nat, P (rCompVar x))
           (IHApp : forall s : rComp, P s -> forall t : rComp, P t -> P (s t))
           (IHClos : forall (s : rTerm) (A : list rComp),
               (forall a, a el A -> P a) -> P (rCompClos s A)) : forall x, P x.
Proof.
  apply rComp_ind_deep' with (Pl:=fun A => (forall a, a el A -> P a)); [auto..|easy|].
  -intros. inv H1;auto.
Qed.

Definition rValidComp phi s := Proc phi /\validComp (denoteComp phi s).

Lemma rSubstList_correct phi s x A: Proc phi -> denoteTerm phi (rSubstList s x A) = substList (denoteTerm phi s) x (map (denoteTerm phi) A).
Proof.
  revert x. induction s; intros;simpl.
  - decide (x < x0); decide (x0 > x); try lia ;intuition (try congruence);simpl.
    now rewrite <-map_nth with (f:= denoteTerm phi).
  -now rewrite IHs1,IHs2.
  -now rewrite IHs.
  -rewrite substList_closed. auto. apply H.
  -rewrite IHs. 2:tauto. reflexivity.
Qed.

Lemma map_ext' : forall (A B : Type) (f g : A -> B) (l:list A),
    (forall a : A, a el l -> f a = g a) ->  map f l = map g l.
Proof.
  intros. induction l.
  -reflexivity.
  -simpl. rewrite H;auto using in_eq, in_cons. f_equal. apply IHl. intros. apply H.
   auto using in_eq, in_cons.
Qed.

Lemma denoteTerm_correct phi s: Proc phi -> deClos (denoteComp phi s) = denoteTerm phi (rDeClos s).
Proof.
  intros pp. unfold denoteComp, rDeClos. pattern s. apply rComp_ind_deep;intros;simpl;try congruence.
  -rewrite rSubstList_correct;auto. f_equal.
   rewrite !map_map. now apply map_ext'.
Qed.

Definition rCompBeta s t :=
  match s,t with
  |rCompClos (rLam ls) A,rCompClos (rLam lt) B => Some (rCompClos ls (t::A))
  |rCompClos (rLam ls) A,rCompClos (rConst x) B => Some (rCompClos ls (t::A))
  |rCompClos (rLam ls) A,rCompClos (rRho lt) B => Some (rCompClos ls (t::A))
  |_,_ => None
  end.

Definition rCompAppCount :=
  fun (j : nat) (u v : nat * rComp) => let (l, u0) := u in let (k, v0) := v in (j + (l + k), u0 v0).

Fixpoint rCompSeval' n (u : nat*rComp) : (nat *rComp)*bool:=
  match n with
    S n =>
    match u with
    | (l, rCompApp s t) =>
      match rCompSeval' n (0,s),rCompSeval' n (0,t) with
        (i, s',true),(j, t',true) =>
        match rCompBeta s' t' with
          Some u => rCompSeval' n ((S l)+(i+j),u)
        | None => ((l+(i+j),s' t'),false)
        end
      | ((i,s'),_),((j,t'),_) => ((l+(i+j),s' t'),false)
      end
    | (l, rCompClos (rApp s t) A ) =>
      rCompSeval' n (l, rCompApp (rCompClos s A) (rCompClos t A))
    | (l , rCompClos (rVar x) A )=> (l,nth x A (rCompVar x),true)
    | (l, rCompClos (rConst x) A )=> (u,true)
    | (l, rCompVar x ) => (u,true)
    | (l, rCompClos (rLam _) A) => (u,true)
    | (l, rCompClos (rRho _) A) => (u,true)
    end
  | 0 => (u,true)
  end.

Definition rCompSeval n u : (nat*rComp):=
  (fst (rCompSeval' n u)).

Lemma rCompBeta_sound phi (s t u: rComp) : Proc phi -> rCompBeta s t = Some u -> denoteComp phi (s t) >[(1)] denoteComp phi u.
Proof with simpl in *;try congruence;auto.
  intros pp eq. destruct s... destruct s... destruct t... destruct s0; inv eq...
  -constructor. apply pp.
  -constructor. eexists. reflexivity.
Qed.

Functional Scheme rCompSeval'_ind := Induction for rCompSeval' Sort Prop.

Lemma rCompSeval_sound n phi s l:
  Proc phi -> let (k,t) := rCompSeval n (l,s) in k >= l /\ denoteComp phi s >[(k-l)] denoteComp phi t.
Proof with (repeat inv_validComp;repeat (eassumption || constructor || intuition idtac || lia || subst ; eauto using star || rewrite Nat.sub_diag in * || rewrite Nat.sub_0_r in *||cbn in * )).
  intros. unfold rCompSeval.
  pose (p:= (l,s)).
  change (let (k, t) := fst (rCompSeval' n p) in k >= fst p /\denoteComp phi  (snd p) >[(k-(fst p))] denoteComp phi t).
  generalize p. clear l s p. intros p.
  functional induction (rCompSeval' n p); intros;cbn...
  -rewrite e2,e5 in *...  eapply rCompBeta_sound in e8;try eauto. destruct (rCompSeval' _ (S _,_ ));destruct p... eapply (CPow_trans (t:= denoteComp phi (s' t')))...
  -rewrite e2,e5 in *...  eapply (CPow_trans (t:= denoteComp phi (s' t')))...
  -rewrite e2,e5 in *...  eapply (CPow_trans (t:= denoteComp phi (s' t')))...
  -rewrite e2,e5 in *...  eapply (CPow_trans (t:= denoteComp phi (s' t')))...
  -rewrite <- map_nth...
  -repeat destruct (rCompSeval' _ _)... destruct p... eapply CPow_trans...
Qed.

Lemma rCompBeta_rValidComp s t u phi : rValidComp phi s -> rValidComp phi t -> rCompBeta s t = Some u -> rValidComp phi u.
Proof with repeat (congruence || subst || simpl in * || intuition ).
  unfold rValidComp in *. intros vs vt eq. assert (pp:Proc phi)by (inv vs;auto). split;auto.  unfold rCompBeta in eq. destruct s... destruct s... destruct t... destruct s0...
  -inv eq. inv H0; inv H2. constructor... rewrite map_length in *. now inv H7.
  -inv eq. inv H0; inv H2. constructor...
   +destruct (pp x) as [_ H']. inv H'. now rewrite H0.
   +rewrite map_length in *. now inv H7.
  -inv eq. inv H0; inv H2. constructor...
   +rewrite map_length in *. now inv H7.
   +rewrite map_length in *. now inv H7.
Qed.

Lemma rCompSeval_rValidComp n s phi k : Proc phi -> rValidComp phi s -> rValidComp phi (snd (rCompSeval n (k,s))).
Proof with repeat (eapply validCompApp ||apply validCompClos || congruence || subst || simpl in * || intuition).
  intros P. unfold rCompSeval. revert s k. induction n; intros s k [? vs];(split;[auto|])... destruct s;try now  inv vs;cbn...
  -inv vs. assert (IHn1 := IHn s1 0 ). assert (IHn2 := IHn s2 0).
   unfold snd,fst in *. do 2 destruct ((rCompSeval' n (_,_)))... destruct p,p0... unfold rValidComp in *. destruct b,b0... destruct (rCompBeta r r0) eqn:eq;unfold rValidComp in *.
   +apply IHn... eapply rCompBeta_rValidComp;eauto;  unfold rValidComp in *...
   +idtac...
  -unfold rValidComp in *. inv vs. destruct s;simpl...
   +rewrite <- map_nth. apply H2. apply nth_In. now inv H4.
   +apply IHn;auto. simpl in *. split;auto. inv H4. repeat constructor...
Qed.

Lemma rClosed_valid s phi : Proc phi -> (rClosed phi s <-> rValidComp phi (rCompClos s [])).
Proof.
  intros pp. unfold rClosed. unfold rValidComp. rewrite closed_dcl. split;intros H.
  -repeat constructor;simpl;intuition;apply H0.
  -inv H. inv H1. now tauto.
Qed.

Lemma expandDenote phi s: Proc phi -> denoteTerm phi s = deClos (denoteComp phi (rCompClos s [])).
Proof.
  intros pp. rewrite (denoteTerm_correct _ pp). simpl. rewrite rSubstList_correct;auto. simpl. now rewrite substList_nil.
Qed.

Lemma rDeClos_reduce  phi s: Proc phi -> rValidComp phi s -> deClos (denoteComp phi s) = deClos (denoteComp phi (rCompClos (rDeClos s) [])).
Proof.
  intros pp vc. simpl. rewrite <- denoteTerm_correct;auto. now rewrite substList_nil.
Qed.

Lemma rDeClos_rValidComp phi s: Proc phi -> rValidComp phi s -> rValidComp phi (rCompClos (rDeClos s) []).
Proof with repeat (eauto || congruence || subst || simpl in * || intuition).
  intros pp [? H]. unfold rValidComp in *. split;try tauto.  simpl. apply deClos_valComp in H. apply validComp_closed. now rewrite <- denoteTerm_correct.
Qed.

Lemma rStandardize n phi s : Proc phi -> rClosed phi s -> let (l,s') := (rCompSeval n (0,rCompClos s [])) in  rPow phi l s (rDeClos s').
Proof with eauto.
  intros pp cl. unfold rPow. rewrite rClosed_valid in *;auto. assert (cl': rValidComp phi (snd (rCompSeval n (0,rCompClos s [])))).
  -apply rCompSeval_rValidComp;auto.
  - destruct rCompSeval eqn:eq1. rewrite !expandDenote;auto.  specialize (rCompSeval_sound n (rCompClos s []) 0 pp);intros  H. rewrite eq1 in H.
    destruct H as [_ H]. rewrite Nat.sub_0_r in H. rewrite <- rDeClos_reduce... apply deClos_correct... destruct cl...
Qed.

Lemma rStandardizeUsePow n phi s:
  Proc phi -> rClosed phi s ->
  let (l,s') := (rCompSeval n (0,rCompClos s [])) in denoteTerm phi s >(l) denoteTerm phi (rDeClos s').
Proof.
  apply rStandardize.
Qed.

Lemma rStandardizeUse n phi s:
  Proc phi -> rClosed phi s ->
  let (l,s') := (rCompSeval n (0,rCompClos s [])) in denoteTerm phi s >* denoteTerm phi (rDeClos s').
Proof.
  intros a b.
  specialize (rStandardizeUsePow n a b). destruct (rCompSeval _ _). rewrite star_pow. firstorder.
Qed.

Fixpoint rClosed_decb' n u : bool:=
  match u with
  | rApp s t => andb (rClosed_decb' n s) (rClosed_decb' n t)
  | rVar x => negb (leb n x)
  | rConst x => true
  | rLam s =>rClosed_decb' (S n) s
  | rRho s =>rClosed_decb' (S n) s
  end.

Lemma rClosed_decb'_correct s phi n: Proc phi -> rClosed_decb' n s = true -> bound n (denoteTerm phi s).
Proof.
  intros pp. revert n. induction s;intros n eq;simpl in *.
  -rewrite Bool.negb_true_iff in eq. apply leb_complete_conv in eq. now constructor.
  -rewrite Bool.andb_true_iff in eq. constructor; intuition.
  -constructor. auto.
  -apply bound_ge with (k:=0);[|lia]. rewrite <- closed_dcl. apply pp.
  -unfold rho,r.
   repeat (eapply dclApp||eapply dcllam||eapply dclvar).
   all:try lia. eauto.
Qed.

Definition rClosed_decb s:= rClosed_decb' 0 s.

Lemma rClosed_decb_correct phi s : Proc phi -> rClosed_decb s = true -> rClosed phi s.
Proof.
  intros. hnf;split;[auto|]. rewrite closed_dcl. apply rClosed_decb'_correct;auto.
Qed.

(* Facts about denote *)

Definition liftPhi Vars n:=nth n Vars I.

Arguments liftPhi Vars n/.

Lemma liftPhi_correct Vars: (forall s, s el Vars -> proc s) -> Proc (liftPhi Vars).
Proof.
  intros H n. unfold liftPhi. destruct (nth_in_or_default n Vars I) as [?|eq].
  -now apply H.
  -rewrite eq. cbv. split.  auto. eexists. eauto.
Qed.

Fixpoint benchTerm x : rTerm :=
  match x with
    0 => (rLam (rVar 0))
  | S x => (rLam (benchTerm x)) (rLam (rVar 0))
  end.

Close Scope LClos.


Set Warnings "-notation-overridden".

Require Import Coq.Program.Basics.
Require Import Coq.Lists.List.

From Equations Require Import Equations.
Unset Equations With Funext.

Require Import Category.Lib.
Require Import Category.Theory.

Require Import Embed.Theory.Utils.
Require Import Embed.Theory.Btree.
Require Import Embed.Theory.Btree.Functor.
Require Import Embed.Theory.Btree.Monad.

Generalizable All Variables.
Set Universe Polymorphism.
Set Nested Proofs Allowed.

Equations num_leaves {A} (xs : @btree A) : nat :=
num_leaves (bnil _) := S O ;
num_leaves (bcons x y) := num_leaves x + num_leaves y.
Global Transparent num_leaves.

Lemma num_leaves_positive {A} (xs : @btree A) : ~(num_leaves xs = O).
Proof.
revert xs.
fix num_leaves_positive 1.
destruct xs.

rewrite num_leaves_equation_1.
auto.

rewrite num_leaves_equation_2.
intro.
pose (Plus.plus_is_O (num_leaves xs1) (num_leaves xs2) H).
destruct a.
exact (num_leaves_positive xs1 H0).
Qed.

Lemma num_leaves_fmap {A B} {f : A -> B} (xs : @btree A) : num_leaves (fmap f xs) = num_leaves xs.
Proof.
revert xs.
fix num_leaves_fmap 1.
destruct xs.

rewrite fmap_btree_equation_1.
repeat (rewrite num_leaves_equation_1).
reflexivity.

rewrite fmap_btree_equation_2.
repeat (rewrite num_leaves_equation_2).

refine (nat_plus_eq _ _).

exact (num_leaves_fmap _).

exact (num_leaves_fmap _).
Qed.

Equations leaves {A} (xs : @btree A) : list A :=
leaves (bnil x) := cons x nil ;
leaves (bcons x y) := leaves x ++ leaves y.

Fixpoint leaves_fmap {A B} (f : A -> B) (xs : @btree A) :
  leaves (fmap_btree f xs) = List.map f (leaves xs).
destruct xs.

rewrite fmap_btree_equation_1.
repeat (rewrite leaves_equation_1).
reflexivity.

rewrite fmap_btree_equation_2.
repeat (rewrite leaves_equation_2).
rewrite map_app.

refine (list_app_eq _ _).

exact (leaves_fmap _ _ _ _).

exact (leaves_fmap _ _ _ _).
Qed.

Lemma eq_num_leaves {A} (xs : @btree A) : length (leaves xs) = num_leaves xs.
Proof.
revert xs.
fix eq_num_leaves 1.
destruct xs.

rewrite leaves_equation_1.
rewrite num_leaves_equation_1.
unfold length.
reflexivity.

rewrite leaves_equation_2.
rewrite num_leaves_equation_2.
rewrite app_length.
refine (nat_plus_eq _ _).

exact (eq_num_leaves _).

exact (eq_num_leaves _).
Qed.

Local Open Scope nat_scope.

(* lemma for zip_btree *)
Lemma num_leaves_bcons_length_l {A B} {x y : @btree A} {ys : list B} : num_leaves (bcons x y) = length ys
  -> num_leaves x <= length ys.
intro.
rewrite num_leaves_equation_2 in H.
rewrite <- H.
exact (Plus.le_plus_l _ _).
Qed.

Definition num_leaves_firstn {A B} {x y : @btree A} {zs : list B} (pf : num_leaves (bcons x y) = length zs) :
  num_leaves x = length (firstn (num_leaves x) zs) := eq_sym
    (firstn_length_le zs (num_leaves_bcons_length_l pf)).

Definition num_leaves_skipn {A B} {x y : @btree A} {zs : list B} (pf : num_leaves (bcons x y) = length zs) :
   num_leaves y = length (skipn (num_leaves x) zs) := eq_sym
        (eq_trans
          (skipn_length (num_leaves x) zs)
          (eq_sym
            (Minus.plus_minus (length zs) (num_leaves x) (num_leaves y) (eq_sym pf))
          )
        ).

(* list_num_leaves xs = sum (map num_leaves xs) *)
Equations list_num_leaves {A} (xs : list (@btree A)) : nat :=
list_num_leaves nil := O ;
list_num_leaves (cons y ys) := num_leaves y + list_num_leaves ys.

Lemma eq_num_leaves_list_num_leaves {A} (xs : @btree A) : num_leaves xs = list_num_leaves (cons xs nil).
Proof.
rewrite list_num_leaves_equation_2.
rewrite list_num_leaves_equation_1.
auto.
Qed.

Lemma list_num_leaves_cons_positive {A} (x : @btree A) (xs : list (@btree A)) :
  list_num_leaves (x :: xs) <> 0%nat.
Proof.
revert xs; revert x.
fix list_num_leaves_cons_positive 2.
destruct xs.

rewrite <- eq_num_leaves_list_num_leaves.
exact (num_leaves_positive _).

rewrite list_num_leaves_equation_2.
intro.
refine (list_num_leaves_cons_positive b xs _).
pose (Plus.plus_is_O _ _ H).
destruct a.
exact H1.
Qed.

Lemma list_num_leaves_map_fmap {A B} {xs : list (@btree A)} (f : A → B) :
  list_num_leaves (List.map (fmap[btree_Functor] f) xs) = list_num_leaves xs.
Proof.
revert xs.
fix list_num_leaves_map_fmap 1.
destruct xs.

simpl.
reflexivity.

unfold List.map.
repeat (rewrite list_num_leaves_equation_2).
refine (nat_plus_eq _ _).

exact (num_leaves_fmap _).

exact (list_num_leaves_map_fmap xs).
Qed.

Equations total : list nat -> nat :=
total nil := 0%nat;
total (cons x xs) := x + total xs.

Fixpoint total_app (xs ys : list nat) :
  total (xs ++ ys) = (total xs + total ys)%nat.
destruct xs.
{
  reflexivity.
}
{
  rewrite total_equation_2.
  simpl.
  rewrite total_equation_2.
  rewrite <- PeanoNat.Nat.add_assoc.
  f_equal.
  exact (total_app _ _).
}
Qed.

Fixpoint list_num_leaves_total {A : Type} (xs : list (@btree A)) :
  list_num_leaves xs = total (map num_leaves xs).
destruct xs.
{
  rewrite list_num_leaves_equation_1.
  simpl.
  rewrite total_equation_1.
  reflexivity.
}
{
  rewrite list_num_leaves_equation_2.
  simpl.
  rewrite total_equation_2.
  rewrite (list_num_leaves_total A xs).
  reflexivity.
}
Qed.

(* Local Open Scope nat_scope. *)
Lemma list_num_leaves_app {A} (xs ys : list (@btree A)) :
  (list_num_leaves xs + list_num_leaves ys)%nat = list_num_leaves (xs ++ ys).
do 3 (rewrite list_num_leaves_total).
rewrite map_app.
rewrite total_app.
reflexivity.
Qed.

Fixpoint num_leaves_join {A} (xs : @btree (@btree A)) :
  num_leaves (join_btree xs) = list_num_leaves (leaves xs).
destruct xs.

rewrite join_btree_equation_1.
rewrite leaves_equation_1.
rewrite list_num_leaves_equation_2.
rewrite list_num_leaves_equation_1.
exact (plus_n_O _).

rewrite join_btree_equation_2.
rewrite leaves_equation_2.
rewrite num_leaves_equation_2.
rewrite <- list_num_leaves_app.
refine (nat_plus_eq _ _).

exact (num_leaves_join _ _).

exact (num_leaves_join _ _).
Qed.

Local Open Scope nat_scope.
Definition list_num_leaves_firstn {A B} {z : @btree A} {zs : list (@btree A)} {ws : list B}
  (pf : list_num_leaves (z :: zs) = length ws) :
    num_leaves z = length (firstn (num_leaves z) ws) := eq_sym
  (firstn_length_le
    ws
    (eq_rect (num_leaves z + list_num_leaves zs) (fun w => num_leaves z <= w) (Plus.le_plus_l (num_leaves z) (list_num_leaves zs)) (length ws) (eq_trans (eq_sym (list_num_leaves_equation_2 A z zs)) pf))
  ).
Local Close Scope nat_scope.

Definition list_num_leaves_skipn {A B} {z : @btree A} {zs : list (@btree A)} {ws : list B}
  (pf : list_num_leaves (z :: zs) = length ws) :
    list_num_leaves zs = length (skipn (num_leaves z) ws) := eq_sym
  (eq_trans
    (skipn_length (num_leaves z) ws)
    (eq_sym
      (Minus.plus_minus (length ws) (num_leaves z) (list_num_leaves zs) (eq_sym pf))
    )
  ).


Require Import VST.msl.Extensionality.

Class NatDed (A: Type) := mkNatDed {
  andp: A -> A -> A;
  orp: A -> A -> A;
  exp: forall {T:Type}, (T -> A) -> A;
  allp: forall {T:Type}, (T -> A) -> A;
  imp: A -> A -> A;
  prop: Prop -> A;
  derives: A -> A -> Prop;
  pred_ext: forall P Q, derives P Q -> derives Q P -> P=Q;
  derives_refl: forall P, derives P P;
  derives_trans: forall P Q R, derives P Q -> derives Q R -> derives P R;
  TT := prop True;
  FF := prop False;
  andp_right:  forall X P Q:A, derives X P -> derives X Q -> derives X (andp P Q);
  andp_left1:  forall P Q R:A, derives P R -> derives (andp P Q) R;
  andp_left2:  forall P Q R:A, derives Q R -> derives (andp P Q) R;
  orp_left: forall P Q R, derives P R -> derives Q R -> derives (orp P Q) R;
  orp_right1: forall P Q R, derives P Q -> derives P (orp Q R);
  orp_right2: forall P Q R, derives P R -> derives P (orp Q R);
  exp_right: forall {B: Type} (x:B) (P: A) (Q: B -> A),
                        derives P (Q x) -> derives P (exp Q);
  exp_left: forall {B: Type} (P: B -> A) (Q: A),
                      (forall x, derives (P x) Q) -> derives (exp P) Q;
  allp_left: forall {B}(P: B -> A) x Q, derives (P x) Q -> derives (allp P) Q;
  allp_right: forall {B}(P: A) (Q: B -> A),  (forall v, derives P (Q v)) -> derives P (allp Q);
  imp_andp_adjoint: forall P Q R, derives (andp P Q) R <-> derives P (imp Q R);
  prop_left: forall (P: Prop) Q, (P -> derives TT Q) -> derives (prop P) Q;
  prop_right: forall (P: Prop) Q, P -> derives Q (prop P);
  prop_imp_prop_left: forall (P Q: Prop), derives (imp (prop P) (prop Q)) (prop (P -> Q));
  allp_prop_left: forall {B: Type} (P: B -> Prop), derives (allp (fun b => prop (P b))) (prop (forall b, P b))
(* not_prop_right: forall (P: A) (Q: Prop), (Q -> derives P FF) -> derives P (prop (not Q)) *)
}.

Program Instance LiftNatDed (A B: Type) {ND: NatDed B} : NatDed (A -> B) :=
 mkNatDed (A -> B)
    (*andp*) (fun P Q x => andp (P x) (Q x))
    (*orp*) (fun P Q x => orp (P x) (Q x))
    (*exp*) (fun {T} (F: T -> A -> B) (a: A) => exp (fun x => F x a))
    (*allp*) (fun {T} (F: T -> A -> B) (a: A) => allp (fun x => F x a))
    (*imp*) (fun P Q x => imp (P x) (Q x))
    (*prop*) (fun P x => prop P)
    (*derives*) (fun P Q => forall x, derives (P x) (Q x))
     _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _.
Next Obligation.
 intros; extensionality x; apply pred_ext; auto.
Defined.
Next Obligation.
 intros; apply derives_refl.
Defined.
Next Obligation.
 intros; eapply derives_trans; eauto.
Defined.
Next Obligation.
 intros; eapply andp_right; eauto.
Defined.
Next Obligation.
 intros; eapply andp_left1; eauto.
Defined.
Next Obligation.
 intros; eapply andp_left2; eauto.
Defined.
Next Obligation.
 intros; eapply orp_left; eauto.
Defined.
Next Obligation.
 intros; eapply orp_right1; eauto.
Defined.
Next Obligation.
 intros; eapply orp_right2; eauto.
Defined.
Next Obligation.
 intros; eapply exp_right; eauto.
Defined.
Next Obligation.
 intros; eapply exp_left; eauto.
Defined.
Next Obligation.
 intros; eapply allp_left; eauto.
Defined.
Next Obligation.
 intros; eapply allp_right; eauto.
Defined.
Next Obligation.
 intros; split; intros;  eapply imp_andp_adjoint; eauto.
Defined.
Next Obligation.
 intros; eapply prop_left; eauto.
Defined.
Next Obligation.
 intros; eapply prop_right; eauto.
Defined.
Next Obligation.
 intros; eapply prop_imp_prop_left; eauto.
Defined.
Next Obligation.
 intros; eapply allp_prop_left; eauto.
Defined.

Delimit Scope logic with logic.
Local Open Scope logic.
Notation "P '|--' Q" := (derives P Q) (at level 80, no associativity).
Notation "'EX'  x ':' T ',' P " := (exp (fun x:T => P%logic)) (at level 65, x at level 99) : logic.
Notation "'ALL'  x ':' T  ',' P " := (allp (fun x:T => P%logic)) (at level 65, x at level 99) : logic.
Infix "||" := orp (at level 50, left associativity) : logic.
Infix "&&" := andp (at level 40, left associativity) : logic.
Notation "P '-->' Q" := (imp P Q) (at level 55, right associativity) : logic.
Notation "P '<-->' Q" := (andp (imp P Q) (imp Q P)) (at level 57, no associativity) : logic.
Notation "'!!' e" := (prop e) (at level 25) : logic.

Class SepLog (A: Type) {ND: NatDed A} := mkSepLog {
  emp: A;
  sepcon: A -> A -> A;
  wand: A -> A -> A;
  ewand: A -> A -> A;
  sepcon_assoc: forall P Q R, sepcon (sepcon P Q) R = sepcon P (sepcon Q R);
  sepcon_comm:  forall P Q, sepcon P Q = sepcon Q P;
  wand_sepcon_adjoint: forall (P Q R: A),  (sepcon P Q |-- R) <-> (P |-- wand Q R);
  sepcon_andp_prop: forall P Q R, sepcon P (!!Q && R) = !!Q && (sepcon P R);
  sepcon_derives: forall P P' Q Q' : A, P |-- P' -> Q |-- Q' -> sepcon P Q |-- sepcon P' Q';
  ewand_sepcon: forall (P Q R : A),  ewand (sepcon P Q) R = ewand P (ewand Q R);
  ewand_TT_sepcon: forall (P Q R: A),
                         andp (sepcon P Q) (ewand R TT) |--
                               sepcon (andp P (ewand R TT)) (andp Q (ewand R TT));
  exclude_elsewhere: forall P Q: A, sepcon P Q |-- sepcon (andp P (ewand Q TT)) Q;
  ewand_conflict: forall P Q R, sepcon P Q |-- FF -> andp P (ewand Q R) |-- FF
}.

Notation "P '*' Q" := (sepcon P Q) : logic.
Notation "P '-*' Q" := (wand P Q) (at level 60, right associativity) : logic.

Instance LiftSepLog (A B: Type) {NB: NatDed B}{SB: SepLog B} : SepLog (A -> B).
 apply (mkSepLog (A -> B) _ (fun rho => emp)
            (fun P Q rho => P rho * Q rho) (fun P Q rho => P rho -* Q rho)
            (fun P Q rho => ewand (P rho) (Q rho))).
 (* sepcon_assoc *) intros; extensionality rho; apply sepcon_assoc.
 (* sepcon_comm *) intros; extensionality rho; apply sepcon_comm.
 intros.  split. simpl. intuition.
    apply wand_sepcon_adjoint. auto.
    intro. intro rho.     apply <- wand_sepcon_adjoint; auto.
 simpl; intros. extensionality x. apply sepcon_andp_prop.
 simpl; intros; apply sepcon_derives; auto.
 simpl; intros; extensionality x; apply ewand_sepcon.
 simpl; intros; eapply ewand_TT_sepcon.
 simpl; intros; eapply exclude_elsewhere.
 simpl; intros; eapply ewand_conflict; eauto.
Defined.

Class ClassicalSep  (A: Type) {ND: NatDed A}{SL: SepLog A} := mkCS {
   sepcon_emp: forall P, P * emp = P
}.

Instance LiftClassicalSep (A B: Type)  {NB: NatDed B}{SB: SepLog B}{CB: ClassicalSep B} :
        ClassicalSep (A -> B).
 apply mkCS.
 intros. extensionality x. simpl. apply sepcon_emp.
Qed.

Definition  extensible {A}{ND: NatDed A}{SL: SepLog A}(P:A) := sepcon P TT |-- P.

Class IntuitionisticSep (A: Type) {ND: NatDed A}{SL: SepLog A} := mkIS {
   all_extensible: forall P, extensible P
}.

Instance LiftIntuitionisticSep (A B: Type)  {NB: NatDed B}{SB: SepLog B}{IB: IntuitionisticSep B} :
        IntuitionisticSep (A -> B).
 apply mkIS.
 intros. intro. simpl. apply all_extensible.
Qed.

Class Indir (A: Type) {ND: NatDed A} := mkIndir {
  later: A -> A;
  now_later: forall P: A, P |-- later P;
  later_K: forall P Q, later (P --> Q) |-- later P --> later Q;
  later_allp: forall T (F: T -> A),  later (allp F) = ALL x:T, later (F x);
  later_exp: forall T (F: T-> A), EX x:T, later (F x) |-- later (exp F);
  later_exp': forall T (any:T) F, later (exp F) = EX x:T, later (F x);
  later_exp'': forall T F, later (exp F) |-- (EX x:T, later (F x)) || later FF;
  later_imp: forall P Q,  later(P --> Q) = later P --> later Q;
  later_prop: forall PP: Prop, later (!! PP) |-- !! PP || later FF;
  loeb: forall P,   later P |-- P ->  TT |-- P
}.

Notation "'|>' e" := (later e) (at level 30, right associativity): logic.

Instance LiftIndir (A: Type) (B: Type)  {NB: NatDed B}{IXB: Indir B} :
         @Indir (A -> B) (LiftNatDed A B).
 apply (mkIndir _ _ (fun P rho => later (P rho))); intros; simpl in *; intros.
 apply now_later.
 apply later_K.
 simpl; intros. extensionality rho. apply later_allp.
 simpl; intros. apply later_exp.
 simpl; intros. extensionality rho. apply later_exp'; auto.
 simpl; intros. apply later_exp''.
 simpl; intros. extensionality rho. apply later_imp.
 simpl; intros. apply later_prop.
 simpl; intros. apply loeb; auto.
Defined.

Class SepIndir (A: Type) {NA: NatDed A}{SA: SepLog A}{IA: Indir A} := mkSepIndir {
  later_sepcon: forall P Q, |> (P * Q) = |>P * |>Q;
  later_wand: forall P Q, |> (P -* Q) = |>P -* |>Q;
  later_ewand: forall P Q, |> (ewand P Q) = ewand (|>P) (|>Q)
}.

Instance LiftSepIndir  (A: Type) (B: Type)  {NB: NatDed B} {SB: SepLog B}{IB: Indir B}{SIB: SepIndir B} :
     @SepIndir (A -> B) (LiftNatDed A B) (LiftSepLog A B) (LiftIndir A B).
 constructor.
 intros; simpl. extensionality rho.  apply later_sepcon.
 intros; simpl. extensionality rho.  apply later_wand.
 intros; simpl. extensionality rho.  apply later_ewand.
Defined.

Class CorableSepLog (A: Type) {ND: NatDed A}{SL: SepLog A}:= mkCorableSepLog {
  corable: A -> Prop;
  corable_prop: forall P, corable (!! P);
  corable_andp: forall P Q, corable P -> corable Q -> corable (P && Q);
  corable_orp: forall P Q, corable P -> corable Q -> corable (P || Q);
  corable_imp: forall P Q, corable P -> corable Q -> corable (P --> Q);
  corable_allp: forall {B: Type} (P:  B -> A), (forall b, corable (P b)) -> corable (allp P);
  corable_exp: forall {B: Type} (P:  B -> A), (forall b, corable (P b)) -> corable (exp P);
  corable_sepcon: forall P Q, corable P -> corable Q -> corable (P * Q);
  corable_wand: forall P Q, corable P -> corable Q -> corable (P -* Q);
  corable_andp_sepcon1: forall P Q R, corable P ->  (P && Q) * R = P && (Q * R)
}.

Instance LiftCorableSepLog (A: Type) (B: Type) {NB: NatDed B} {SB: SepLog B} {CSL: CorableSepLog B} : @CorableSepLog (A -> B) (LiftNatDed A B) (LiftSepLog A B).
  apply (@mkCorableSepLog _ _ _ (fun P => forall b, corable (P b))); intros; simpl in *; intros.
  + apply corable_prop.
  + apply corable_andp; auto.
  + apply corable_orp; auto.
  + apply corable_imp; auto.
  + apply corable_allp; auto.
  + apply corable_exp; auto.
  + apply corable_sepcon; auto.
  + apply corable_wand; auto.
  + extensionality b.
    apply corable_andp_sepcon1; auto.
Defined.

Class CorableIndir (A: Type) {ND: NatDed A}{SL: SepLog A}{CSL: CorableSepLog A}{ID: Indir A} :=
  corable_later: forall P, corable P -> corable (|> P).

Instance LiftCorableIndir (A: Type) (B: Type) {NB: NatDed B} {SB: SepLog B} {CSL: CorableSepLog B} {ID: Indir B} {CI: CorableIndir B}: @CorableIndir (A -> B) (LiftNatDed A B) (LiftSepLog A B) (LiftCorableSepLog A B) (LiftIndir A B).
  unfold CorableIndir; simpl; intros.
  apply corable_later; auto.
Defined.

Lemma orp_comm: forall {A: Type} `{NatDed A} (P Q: A), P || Q = Q || P.
Proof.
  intros.
  apply pred_ext.
  + apply orp_left; [apply orp_right2 | apply orp_right1]; apply derives_refl.
  + apply orp_left; [apply orp_right2 | apply orp_right1]; apply derives_refl.
Qed.


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Confluence, boundedness, length preserving transformations
  - Modules AddFreshLoop: add rules LXR <-> L'YR' where Y is fresh
  - Module DerivableRule: add derivable rule / removing redundant rule
  - Module DerivableRule': add rule that is derivable with a prefix
  - Module Reordering: change order, duplicate rules
*)

Require Import Relation_Operators Operators_Properties List Lia PeanoNat.
Import ListNotations.

Require Import Undecidability.StackMachines.SMN.
From Undecidability.StackMachines.Util Require Import Facts List_facts SMN_facts.

Require Import ssreflect ssrbool ssrfun.

Set Default Proof Using "Type".
Set Default Goal Selector "!".

Local Definition rt_rt1n := @clos_rt_rt1n_iff Config.
Local Definition rt_rtn1 := @clos_rt_rtn1_iff Config.
Local Definition app_norm := (@app_assoc', @app_nil_l, @app_nil_r).
Local Arguments rt_trans {A R x y z}.

Module AddFreshLoop.
Section Reduction.
  Variables (M : SMN) (L R L' R': list Symbol) (X Y: State).
  Variable confluent_M : confluent M.
  Arguments confluent_M {X Y1 Y2}.
  Variable length_preserving_M : length_preserving M.
  Variable XY_neq : X <> Y.
  Variable Y_fresh : Forall (fun '((_, _, x), (_, _, y)) => x <> Y /\ y <> Y) M.
  Variable lp_XY : length (L++R) = length (L'++R') /\ 1 <= length (L++R).

  Definition M' : SMN :=
    [((L, R, X), (L', R', Y)); ((L', R', Y), (L, R, X))] ++ M.

  Definition get_state (c: Config) := match c with (_, _, x) => x end.

  Definition valid_state (x: State) := x <> Y.

  Lemma step_fresh_l {l r x} : step M' (l, r, Y) x ->
    x = (L ++ skipn (length L') l, R ++ skipn (length R') r, X).
  Proof using lp_XY Y_fresh XY_neq.
    move Hy: (l, r, Y) => y Hyx. case: Hyx Hy => > + [] *.
    subst. rewrite /M' in_app_iff. move=> [[|[|]]|].
    - move=> [] *. by congruence.
    - move=> [] *. subst. by rewrite ?skipn_app ?Nat.sub_diag ?skipn_all.
    - done.
    - have := Y_fresh. rewrite Forall_forall. by move=> H /H [].
  Qed.

  Lemma step_fresh_r {l r x} : step M' x (l, r, Y) ->
    x = (L ++ skipn (length L') l, R ++ skipn (length R') r, X).
  Proof using lp_XY Y_fresh XY_neq.
    move Hy: (l, r, Y) => y Hyx. case: Hyx Hy => > + [] *.
    subst. rewrite /M' in_app_iff. move=> [[|[|]]|].
    - move=> [] *. subst. by rewrite ?skipn_app ?Nat.sub_diag ?skipn_all.
    - move=> [] *. by congruence.
    - done.
    - have := Y_fresh. rewrite Forall_forall. by move=> H /H [].
  Qed.

  Lemma simulation {n x y} : reachable_n M' n x y ->
    valid_state (get_state x) -> valid_state (get_state y) -> reachable_n M n x y.
  Proof using lp_XY Y_fresh XY_neq.
    elim: n x y; first by (move=> > /reachable_0E -> *; apply: rn_refl).
    move=> n IH x y /reachable_SnE [|]; first by (move=> -> *; apply: rn_refl).
    move=> [z1]. have : {get_state z1 = Y} + {get_state z1 <> Y} by decide equality. case; first last.
    {
      move=> Hz1 [Hxz1] /IH {}IH Hx ?. apply: rn_step; last by apply: IH.
      move: Hxz1 Hx Hz1 => /step_app. case; last done.
      case=> > [|[|]]; move=> [] /= *; by congruence.
    }
    move: n IH => [|n] IH; first by (move=> ? [_ /reachable_0E ?]; congruence).
    move=> + [+ /reachable_SnE H]. case: H; first by congruence.
    move=> [z2] [+]. move: z1 => [[l1 r1] z1] /= + + ?. subst z1.
    move: x z2 => [[l r] x] [[l2 r2] z2].
    move=> /step_fresh_l [] ? ? ? + /step_fresh_r [] => *. subst.
    apply: (reachable_n_monotone (m := S n)); first by lia.
    apply: IH; [|done|done].
    apply: reachable_n_monotone; last by eassumption. by lia.
  Qed.

  Lemma simulation' {x y} : reachable M' x y ->
    valid_state (get_state x) -> valid_state (get_state y) -> reachable M x y.
  Proof using lp_XY Y_fresh XY_neq.
    by move /reachable_to_reachable_n => [?] /simulation H /H => {}H /H /reachable_n_to_reachable.
  Qed.

  Lemma inverse_simulation {n x y} : reachable_n M n x y -> reachable_n M' n x y.
  Proof. move=> ?. apply: reachable_n_incl; last by eassumption. by apply: incl_appr. Qed.

  Lemma inverse_simulation' {x y} : reachable M x y -> reachable M' x y.
  Proof. move=> ?. apply: reachable_incl; last by eassumption. by apply: incl_appr. Qed.

  Lemma continue {x y} : reachable M' x y -> valid_state (get_state x) ->
    exists z, reachable M' y z /\ valid_state (get_state z).
  Proof using lp_XY Y_fresh XY_neq.
    have : {get_state y = Y} + {get_state y <> Y} by decide equality. case; first last.
    { move=> *. eexists. by constructor; first by apply: rt_refl. }
    move=> Hy. move /rt_rtn1 => Hxy. case: Hxy Hy; first by congruence.
    move=> ? ? /step_app. case; first last.
    { case=> >. have := Y_fresh. rewrite Forall_forall => H /H /= []. by congruence. }
    case=> v w > /= [|[|]]; [| by congruence | done].
    move=> [] <- <- <- <- <- <- _ _ _. exists (L ++ v, R ++ w, X).
    constructor; last done. apply: rt_step. apply: transition. right. by left.
  Qed.

  Lemma synchronize_step {x y} : step M' x y ->
    exists z, reachable_n M' 1 x z /\ reachable_n M' 1 z y /\ valid_state (get_state z).
  Proof using lp_XY Y_fresh XY_neq.
    move=> /[dup] [[]] >. rewrite /M' in_app_iff -/M'.
    move=> [[|[|]]|].
    - move=> [] <- <- <- <- <- <- ?. eexists.
      constructor; first by apply: rn_refl.
      by constructor; first by (apply: rn_step; [by eassumption | by apply: rn_refl]).
    - move=> [] <- <- <- <- <- <- ?. eexists.
      constructor; first by (apply: rn_step; [by eassumption | by apply: rn_refl]).
      by constructor; first by apply: rn_refl.
    - done.
    - have := Y_fresh. rewrite Forall_forall => H /H [? ?] ?. eexists.
      constructor; first by apply: rn_refl.
      by constructor; first by (apply: rn_step; [by eassumption | by apply: rn_refl]).
  Qed.

  Lemma synchronize {x y} : reachable M' x y ->
    exists z1 z2, reachable_n M' 1 x z1 /\ reachable_n M' 1 z2 y /\ reachable M z1 z2.
  Proof using lp_XY Y_fresh XY_neq.
    move /rt_rt1n. case.
    { exists x, x. constructor; first by apply: rn_refl.
      constructor; first by apply: rn_refl. by apply: rt_refl. }
    move=> ? ? + /rt_rt1n /rt_rtn1 Hz1y. case: Hz1y.
    { move /synchronize_step => [z] [? [? ?]]. exists z, z.
      constructor; first done. constructor; first done. by apply: rt_refl. }
    move=> ? ? /synchronize_step => [[z2]] [/reachable_n_to_reachable ? [? ?]].
    move=> /rt_rtn1 ? /synchronize_step => [[z1]] [? [/reachable_n_to_reachable ? ?]]. exists z1, z2.
    constructor; first done. constructor; first done.
    apply: simulation'; [| done | done].
    apply: rt_trans; first by eassumption.
    by apply: rt_trans; first by eassumption.
  Qed.

  Lemma confluent_valid_M' {x y1 y2} : valid_state (get_state x) ->
    reachable M' x y1 -> reachable M' x y2 ->
    exists z : Config, reachable M' y1 z /\ reachable M' y2 z.
  Proof using confluent_M lp_XY Y_fresh XY_neq.
    move=> Hx Hxy1 Hxy2. move: (Hxy1) => /continue => /(_ Hx). move=> [z1 [Hy1z1 ?]].
    move: (Hxy2) => /continue => /(_ Hx). move=> [z2 [Hy2z2 ?]].
    have Hxz1 : reachable M x z1.
    { apply: simulation'; [| done | done]. by apply: rt_trans; last by eassumption. }
    have Hxz2 : reachable M x z2.
    { apply: simulation'; [| done | done]. by apply: rt_trans; last by eassumption. }
    have [? [? ?]]:= confluent_M Hxz1 Hxz2. eexists.
    constructor; (apply: rt_trans; first by eassumption); apply: inverse_simulation'; by eassumption.
  Qed.

  Theorem confluent_M' : confluent M'.
  Proof using confluent_M lp_XY Y_fresh XY_neq.
    move=> x y1 y2.
    have : {get_state x = Y} + {get_state x <> Y} by decide equality. case; first last.
    { move=> *. apply: confluent_valid_M'; by eassumption. }
    move=> Hx /rt_rt1n Hxy1. case: Hxy1 Hx.
    { move=> *. eexists. constructor; first by eassumption. by apply: rt_refl. }
    move=> {}y1 y1' + + + /rt_rt1n Hxy2. case: Hxy2.
    - move=> ? /rt_rt1n ? ?.
      eexists. constructor; first by apply: rt_refl.
      apply: rt_trans; last by eassumption. by apply: rt_step.
    - move=> {}y2 y2'. move: x y1 y2 => [[l r] x] [[l1 r1] y1] [[l2 r2] y2].
      move=> + + + + /= Hx. subst x.
      move=> /step_fresh_l [] ? ? ? + /step_fresh_l [] ? ? ?. subst.
      move=> /rt_rt1n H1 /rt_rt1n H2.
      by apply: confluent_valid_M'; [| by eassumption | by eassumption].
  Qed.

  Lemma bounded_M' NM : bounded M NM -> bounded M' (NM * (1 + length M') * (1 + length M') * 4).
  Proof using lp_XY Y_fresh XY_neq.
    move=> bounded_M. move=> x.
    have [Lx [HLx H2Lx]] := next_n_configs M' 1 [x].
    have [L2x [HL2x H2L2x]] := concat_reachable Lx bounded_M.
    have [L3x [HL3x H2L3x]] := next_n_configs M' 1 L2x.
    exists L3x. constructor.
    - move=> ? /synchronize => [[z1]] [z2] [/HLx] /(_ ltac:(by left)).
      by move /HL2x => H [+ /H /HL3x {}H] => /H.
    - suff : length L2x <= NM * (1 + length M') * 2 by
        move: H2L3x => /=; clear; nia.
      move: H2Lx H2L2x => /=. clear. by nia.
  Qed.

  Lemma bounded_M NM' : bounded M' NM' -> bounded M NM'.
  Proof.
    move=> bounded_M' x. have [Lx [HLx ?]] := bounded_M' x. exists Lx.
    constructor; last done. by move=> ? /inverse_simulation' /HLx.
  Qed.

  Theorem boundedness : (exists NM, bounded M NM) <-> (exists NM', bounded M' NM').
  Proof using lp_XY Y_fresh XY_neq.
    constructor; move=> [? ?]; eexists; [by apply: bounded_M' | by apply: bounded_M].
  Qed.

  Lemma length_preserving_M' : length_preserving M'.
  Proof using length_preserving_M lp_XY Y_fresh XY_neq.
    move=> >. rewrite /M' in_app_iff. move=> [[|[|]]|].
    - move=> [] *. by subst.
    - move: lp_XY => [? ?] [] *. subst. constructor; [done | by lia].
    - done.
    - by move /length_preserving_M.
  Qed.

  Lemma step_fresh_rI l r l' r' y: reachable M (L ++ l, R ++ r, X) (l', r', y) -> reachable M' (L' ++ l, R' ++ r, Y) (l', r', y).
  Proof using lp_XY.
    move=> ?. apply: rt_trans; first last.
    - apply: reachable_incl; last by eassumption. move=> ? ?. by firstorder done.
    - apply: rt_step. apply: transition. by firstorder done.
  Qed.

  Lemma step_fresh_lI l r l' r' x: reachable M (l, r, x) (L ++ l', R ++ r', X) -> reachable M' (l, r, x) (L' ++ l', R' ++ r', Y) .
  Proof using lp_XY.
    move=> ?. apply: rt_trans.
    - apply: reachable_incl; last by eassumption. move=> ? ?. by firstorder done.
    - apply: rt_step. apply: transition. by firstorder done.
  Qed.

End Reduction.
End AddFreshLoop.

Module DerivableRule.
Section Reduction.
  Variables (M : SMN) (L R L' R': list Symbol) (X Y: State).
  Variable derivable : reachable M (L, R, X) (L', R', Y).
  Variable non_nil : 1 <= length (L ++ R).

  Definition M' : SMN := [((L, R, X), (L', R', Y))] ++ M.

  Lemma simulation {x y} : reachable M' x y <-> reachable M x y.
  Proof using derivable.
    clear non_nil. constructor; last by (apply: reachable_incl; apply /incl_appr).
    elim.
    - move=> ? ?. case=> >. rewrite /M' in_app_iff. case.
      * case; last done.
        move=> [] *. subst. by apply: reachable_stack_app.
      * move=> ?. apply: rt_step. by apply: transition.
    - move=> *. by apply: rt_refl.
    - move=> *. apply: rt_trans; by eassumption.
  Qed.

  Lemma confluence : confluent M' <-> confluent M.
  Proof using derivable.
    constructor.
    - move=> HM' ? ? ? /simulation H1 /simulation H2.
      have [z [? ?]] := HM' _ _ _ H1 H2. exists z.
      constructor; by apply /simulation.
    - move=> HM ? ? ? /simulation H1 /simulation H2.
      have [z [? ?]] := HM _ _ _ H1 H2. exists z.
      constructor; by apply /simulation.
  Qed.

  Theorem boundedness : (exists NM, bounded M NM) <-> (exists NM', bounded M' NM').
  Proof using derivable.
    constructor.
    - move=> [NM] HM. exists NM => x. have [Lx [HLx ?]]:= HM x.
      exists Lx. constructor; last done.
      by move=> ? /simulation /HLx.
    - move=> [NM'] HM'. exists NM' => x. have [Lx [HLx ?]]:= HM' x.
      exists Lx. constructor; last done.
      by move=> ? /simulation /HLx.
  Qed.

  Lemma length_preservation : length_preserving M' <-> length_preserving M.
  Proof using non_nil derivable.
    constructor; first by (apply: length_preserving_incl; right).
    move=> HM >. rewrite /M' in_app_iff. case; last by move /HM.
    case; last done. move=> [] *. subst.
    move: (derivable) => /(length_preservingP HM). case; last done.
    move=> [] *. by subst.
  Qed.

  Lemma step_neq {l r x l' r' y} :
    X <> x \/ Y <> y -> step M' (l, r, x) (l', r', y) -> step M (l, r, x) (l', r', y).
  Proof.
    move Hx': (l, r, x) => x'. move Hy': (l', r', y) => y' H Hx'y'.
    case: Hx'y' Hx' Hy' H => > /= [].
    - move=> ? ? ? [?|?]; by congruence.
    - move /transition => + ? ? ?. by apply.
  Qed.

End Reduction.
End DerivableRule.

Module DerivableRule'.
Section Reduction.
  Variables (M : SMN) (R R': list Symbol) (A: Symbol) (X Y: State).
  Variable confluent_M : confluent M.
  Variable length_preserving_M : length_preserving M.
  Variable derivable : reachable M ([A], R, X) ([A], R', Y).
  Variable non_nil : 1 <= length R.

  Variable XY_neq : X <> Y.
  Variable unique_step_l : forall l r y, step M (l, r, X) y -> l = [A] ++ skipn 1 l.
  Variable unique_step_l' : forall l' r' y, step M y (l', r', X) -> l' = [A] ++ skipn 1 l'.

  Definition M' : SMN := [(([], R, X), ([], R', Y))] ++ M.

  Lemma unique_step_M'l' {l' r' y} : step M' y (l', r', X) -> l' = [A] ++ skipn 1 l'.
  Proof using unique_step_l' unique_step_l derivable XY_neq.
    move Hx: (l', r', X) => x Hyx. case: Hyx Hx.
    move=> v w >. rewrite /M' in_app_iff.
    case; first by (case; [by congruence | done]).
    move /transition => /(_ v w) + [] *. subst.
    by move /unique_step_l'.
  Qed.

  Lemma simulation {x y z} : step M' x y -> reachable M' y z -> reachable M y z.
  Proof using unique_step_l' unique_step_l derivable XY_neq.
    move=> Hxy. move /rt_rtn1. elim; first by apply: rt_refl.
    move=> y' {}z Hy'z. case: Hy'z.
    move=> v w >. rewrite /M' in_app_iff. case; first last.
    { move /transition => *.
      apply: rt_trans; first by eassumption. by apply: rt_step. }
    case; last done.
    (* case last step was the new rule *)
    move=> [] <- <- <- <- <- <-. rewrite -/M'.
    clear y'. move Hy': ([] ++ v, R ++ w, X) => y' Hyy'.
    case: Hyy' Hy' Hxy.
    { move=> <- /= /unique_step_M'l' -> _. by apply: reachable_stack_app. }
    move=> {}y' {}z + + ?. subst z.
    move=> /= /unique_step_M'l' -> *. apply: rt_trans; first by eassumption.
    by apply: reachable_stack_app.
  Qed.

  Lemma inverse_simulation {x y} : reachable M x y -> reachable M' x y.
  Proof. apply: reachable_incl. by right. Qed.

  Lemma bounded_M' NM : bounded M NM -> bounded M' (1 + NM * length M').
  Proof using unique_step_l' unique_step_l derivable XY_neq non_nil.
    move=> bounded_M x.
    have [ys [Hys H'ys]] := next_configs M' x.
    have [L [HL H'L]] := concat_reachable ys bounded_M.
    exists ([x] ++ L). constructor; first last.
    { move: H'ys H'L. rewrite app_length /=. by nia. }
    move=> ? /rt_rt1n Hxz. rewrite in_app_iff.
    case: Hxz Hys; first by (move=> *; left; left).
    move=> ? ? Hxy + Hys.
    move: Hxy (Hxy) => /Hys ? /simulation Hyz /rt_rt1n ?.
    right. apply: HL; [by eassumption | by apply: Hyz].
  Qed.

  Lemma bounded_M NM' : bounded M' NM' -> bounded M NM'.
  Proof.
    move=> bounded_M' x. have [L [HL ?]] := bounded_M' x. exists L.
    constructor; last done. by move=> ? /inverse_simulation /HL.
  Qed.

  Theorem boundedness : (exists NM, bounded M NM) <-> (exists NM', bounded M' NM').
  Proof using unique_step_l' unique_step_l derivable XY_neq non_nil.
    constructor; move=> [? ?]; eexists; [by apply: bounded_M' | by apply: bounded_M].
  Qed.

  Lemma length_preserving_M' : length_preserving M'.
  Proof using unique_step_l' unique_step_l derivable XY_neq non_nil length_preserving_M.
    move=> >. rewrite /M' in_app_iff. case; last by move /length_preserving_M.
    case; last done. move=> [] *. subst. move=> /=. constructor; last done.
    have /length_preservingP := derivable. move /(_ length_preserving_M).
    case; first by congruence.
    rewrite ?app_length /=. by lia.
  Qed.

  Lemma confluent_M' : confluent M'.
  Proof using unique_step_l' unique_step_l derivable XY_neq confluent_M.
    move=> ? ? ? /rt_rt1n + /rt_rt1n. case.
    { move=> /rt_rt1n ?. eexists. constructor; first by eassumption.
      by apply: rt_refl. }
    move=> ? ? Hxy1 /rt_rt1n Hy1z1 Hxy2. case: Hxy2 Hxy1.
    { move=> ?. eexists. constructor; first by apply: rt_refl.
      apply: rt_trans; last by eassumption. by apply: rt_step. }
    move=> ? ? Hxy2 /rt_rt1n Hy2z2 Hxy1.
    move: Hy1z1 Hy2z2 => /simulation => /(_ _ Hxy1) Hy1z1 /simulation => /(_ _ Hxy2) Hy2z2.
    case: Hxy1 Hxy2 Hy1z1 Hy2z2 => v1 w1 >.
    rewrite /M' in_app_iff -/M'. case.
    - case; last done.
      (* case y1 is taken by new rule *)
      move=> [] <- <- <- <- <- <- /=.
      move Hx: (v1, R ++ w1, X) => x Hxy2. case: Hxy2 Hx => v2 w2 >.
      rewrite /M' in_app_iff -/M'. case.
        (* case y1 and y2 are taken by new rule *)
      { case; last done.
        move=> [] <- <- <- <- <- <- [] <- /app_inv_head <- /=.
        move=> /confluent_M => H /H => [[? [? ?]]].
        eexists. constructor; apply: inverse_simulation; by eassumption. }
      (* case y1 is taken by new rule, y2 is taken in M *)
      move /transition => /(_ v2 w2) + H. rewrite -H.
      move=> Hxy2. move: Hxy2 (Hxy2) => /unique_step_l ->.
      move=> /(@rt_step Config) /(@rt_trans Config) => {}H + /H.
      have /reachable_stack_app := derivable.
      move=> /(_ (skipn 1 v1) w1) /(@rt_trans Config) => {}H /H.
      move=> /confluent_M => {}H /H [? [? ?]].
      eexists. constructor; apply: inverse_simulation; by eassumption.
      (* case y1 is taken in M *)
    - move /transition => /(_ v1 w1) Hxy2.
      move Hx: (c in step M' c _) => ? Hxy1. case: Hxy1 Hx Hxy2.
      move=> v2 w2 >. rewrite /M' in_app_iff -/M'. case.
      { case; last done.
        (* case y2 is taken by new rule, y1 is taken in M *)
        move=> [] <- <- <- <- <- <- /= ->.
        move=> Hxy1. move: Hxy1 (Hxy1) => /unique_step_l ->.
        move=> /(@rt_step Config) /(@rt_trans Config) => {}H /H Hxz1.
        have /reachable_stack_app := derivable.
        move=> /(_ (skipn 1 v2) w2) /(@rt_trans Config) => {}H /H.
        move: Hxz1=> /confluent_M {}H /H [? [? ?]].
        eexists. constructor; apply: inverse_simulation; by eassumption. }
      (* case y1 and y2 are taken in M *)
      move /transition => /(_ v2 w2) + ->.
      move=> /(@rt_step Config) /(@rt_trans Config) => {}H + + /H.
      move=> /(@rt_step Config) /(@rt_trans Config) => {}H /H.
      move=> /confluent_M => {}H /H [? [? ?]].
      eexists. constructor; apply: inverse_simulation; by eassumption.
  Qed.

End Reduction.
End DerivableRule'.

Module Reordering.
Section Reduction.
  Variables (M1 M2 : SMN) (L R L' R': list Symbol) (X Y: State).

  Definition M : SMN := M1 ++ (((L, R, X), (L', R', Y)) ::  M2).
  Definition M' : SMN := [((L, R, X), (L', R', Y))] ++ M1 ++ M2.

  Lemma simulation {x y} : reachable M' x y <-> reachable M x y.
  Proof.
    constructor; apply: reachable_incl=> ?; rewrite /M /M' ?in_app_iff /=; by firstorder done.
  Qed.

  Lemma confluence : confluent M' <-> confluent M.
  Proof.
    constructor; apply: confluent_incl; rewrite /M /M' => ?; rewrite /= ?in_app_iff /=; by firstorder done.
  Qed.

  Lemma boundedness' {n} : bounded M' n <-> bounded M n.
  Proof.
    constructor.
    - move=> HM' x. have [Lx [HLx ?]]:= HM' x.
      exists Lx. constructor; last done.
      by move=> ? /simulation /HLx.
    - move=> HM x. have [Lx [HLx ?]]:= HM x.
      exists Lx. constructor; last done.
      by move=> ? /simulation /HLx.
  Qed.

  Theorem boundedness : (exists NM, bounded M NM) <-> (exists NM', bounded M' NM').
  Proof. by constructor; move=> [? ?]; eexists; apply /boundedness'. Qed.

  Lemma length_preservation : length_preserving M' <-> length_preserving M.
  Proof.
    rewrite /M' /M.
    constructor; apply: length_preserving_incl; move=> ?; rewrite ?in_app_iff /=; by firstorder done.
  Qed.

  Lemma simulation_step {x y} : step M' x y <-> step M x y.
  Proof.
    constructor; apply: step_incl=> ?; rewrite /M /M' ?in_app_iff /=; by firstorder done.
  Qed.

End Reduction.
End Reordering.

Module Transform.

Definition basic (op: Instruction) : bool :=
  match op with
  | (([], [a], _), ([b], [], _)) => true
  | (([a], [], _), ([], [b], _)) => true
  | _ => false
  end.

Definition weight_Instruction (op: Instruction) : nat :=
  if basic op then 0 else
    match op with
    | ((l, r, _), (l', _, _)) => 1 + length (l ++ l' ++ l ++ r)
    end.

Definition weight (M: SMN) : nat :=
  fold_right (fun op w => w + weight_Instruction op) 0 M.

Fixpoint fresh_State (M: SMN) : State :=
  match M with
  | [] => 1
  | ((_, _, x), (_, _, y)) :: M => 1 + x + y + fresh_State M
  end.

Lemma fresh_StateP {M: SMN} {l r x l' r' y} :
  In ((l, r, x), (l', r', y)) M -> x < fresh_State M /\ y < fresh_State M.
Proof.
  elim: M; first done.
  move=> [[[l1 r1] x1] [[l2 r2] x2]] M IH /= [|].
  - move=>  [] *. subst. by lia.
  - move /IH. by lia.
Qed.

Lemma fresh_StateP' (M: SMN) :
  Forall (fun '((_, _, x), (_, _, y)) => x <> fresh_State M /\ y <> fresh_State M) M.
Proof.
  rewrite Forall_forall. move=> [[[l1 r1] x1] [[l2 r2] x2]] /fresh_StateP. by lia.
Qed.

Lemma weight_split op M1 M2 : weight (M1 ++ op :: M2) = weight_Instruction op + weight (M1 ++ M2).
Proof.
  elim: M1.
  - move=> /=. by lia.
  - move=> op1 M1 /= ->. by lia.
Qed.

Lemma minimize_weight_lhs {M: SMN} {a l r l' r' x y} :
  In (a :: l, r, x, (l', r', y)) M ->
  weight_Instruction (a :: l, r, x, (l', r', y)) <> 0 ->
  confluent M -> length_preserving M ->
  { M' : SMN | weight M' < weight M /\
    (confluent M' /\ length_preserving M' /\ ((exists NM, bounded M NM) <-> (exists NM', bounded M' NM'))) }.
Proof.
  move=> HM Hop confluent_M lp_M.
  pose z := fresh_State M.
  pose M1 := AddFreshLoop.M' M [a] [] [] [a] x z.
  pose M2 := DerivableRule.M' M1 l (a::r) l' r' z y.
  have : In (a :: l, r, x, (l', r', y)) M2.
  { rewrite /M2 /M1 /AddFreshLoop.M' /DerivableRule.M' ?in_app_iff.
    move: HM. clear. by firstorder done. }
  move /in_split_informative => /(_ ltac:(by do 5 (decide equality))) => [[[M21 M22] HM2]].
  pose M3 := Reordering.M' M21 M22 (a :: l) r l' r' x y.
  pose M4 := DerivableRule.M' (M21 ++ M22) (a::l) r l' r' x y.
  have ? : x <> z by (move: HM => /fresh_StateP; subst z; lia).
  have ? : y <> z by (move: HM => /fresh_StateP; subst z; lia).
  (* lzar -> l'yr' is derivable *)
  have ? : reachable M1 (l, a :: r, z) (l', r', y).
  { apply: AddFreshLoop.step_fresh_rI; first by (move=> /=; lia).
    apply: rt_step. move: HM => /transition => /(_ [] []). by rewrite ?app_norm. }
  (* alxr -> l'yr' is redundant *)
  have ? : reachable (M21 ++ M22) (a :: l, r, x) (l', r', y).
  { apply: (rt_trans (y := (l, a :: r, z))); apply: rt_step;
      (apply: (@DerivableRule.step_neq _ (a :: l) r l' r' x y); first by [left | right]);
      apply /Reordering.simulation_step; rewrite /Reordering.M -HM2 /M2.
    - apply: (stepI l r [a] [] [] [a] x z);
        [done | done | clear; by firstorder done ].
    - apply: (stepI [] [] l (a :: r) l' r' z y);
        [by rewrite ?app_norm | by rewrite ?app_norm | clear; by firstorder done ]. }
  exists (M21 ++ M22). constructor; [| constructor; [| constructor]].
  - suff: weight M2 < weight M + (weight_Instruction (a :: l, r, x, (l', r', y))).
    { rewrite HM2 weight_split. move: (weight_Instruction _) (weight _). by lia. }
    move: Hop. rewrite /M2 /DerivableRule.M' /= /weight_Instruction.
    case: (basic (a :: l, r, x, (l', r', y))); first by lia.
    move=> _. case: (basic (l, a :: r, z, (l', r', y))).
    { rewrite /= ?app_length. by lia. }
    rewrite /= ?app_length /= ?app_length. by lia.
  - apply /DerivableRule.confluence; first by eassumption.
    apply /Reordering.confluence. rewrite /Reordering.M -HM2.
    apply /DerivableRule.confluence; first by eassumption.
    apply: AddFreshLoop.confluent_M'; [done | done | by apply: fresh_StateP' | by move=> /=; lia ].
  - apply /DerivableRule.length_preservation;
      [by eassumption | rewrite app_length /=; lia | ].
    apply /Reordering.length_preservation. rewrite /Reordering.M -HM2.
    apply /DerivableRule.length_preservation;
      [by eassumption | rewrite app_length /=; lia | ].
    apply: AddFreshLoop.length_preserving_M'; [done | done | by apply: fresh_StateP' | by move=> /=; lia ].
  - rewrite (DerivableRule.boundedness (M21 ++ M22)); first by eassumption.
    rewrite -(Reordering.boundedness M21 M22).
    rewrite /Reordering.M -HM2.
    rewrite -(DerivableRule.boundedness); first by eassumption.
    rewrite -(AddFreshLoop.boundedness); [done | by apply: fresh_StateP' | by move=> /=; lia | done ].
Qed.

Lemma minimize_weight_rhs {M: SMN} {a r l' r' x y} :
  In (([], r, x), (a :: l', r', y)) M ->
  weight_Instruction (([], r, x), (a :: l', r', y)) <> 0 ->
  confluent M -> length_preserving M ->
  { M' : SMN | weight M' < weight M /\ (confluent M' /\ length_preserving M' /\ ((exists NM, bounded M NM) <-> (exists NM', bounded M' NM'))) }.
Proof.
  move=> HM Hop confluent_M lp_M.
  pose z := fresh_State M.
  pose M1 := AddFreshLoop.M' M [a] [] [] [a] y z.
  pose M2 := DerivableRule.M' M1 [] r l' (a::r') x z.
  have : In ([], r, x, (a :: l', r', y)) M2.
  { rewrite /M2 /M1 /AddFreshLoop.M' /DerivableRule.M' ?in_app_iff.
    move: HM. clear. by firstorder done. }
  move /in_split_informative => /(_ ltac:(by do 5 (decide equality))) => [[[M21 M22] HM2]].
  pose M3 := Reordering.M' M21 M22 [] r (a::l') r' x y.
  pose M4 := DerivableRule.M' (M21 ++ M22) [] r (a::l') r' x y.
  have ? : x <> z by  (move: HM => /fresh_StateP; subst z; lia).
  have ? : y <> z by  (move: HM => /fresh_StateP; subst z; lia).
  (* xr -> l'zar' is derivable *)
  have ? : reachable M1 ([], r, x) (l', a::r', z).
  { apply: AddFreshLoop.step_fresh_lI; first by (move=> /=; lia).
    apply: rt_step. move: HM => /transition => /(_ [] []). by rewrite ?app_norm. }
  (* xr -> al'yr' is redundant *)
  have ? : reachable (M21 ++ M22) ([], r, x) (a :: l', r', y).
  { apply: (rt_trans (y := (l', a :: r', z))); apply: rt_step;
      (apply: (@DerivableRule.step_neq _ [] r (a::l') r' x y); first by [left | right]);
      apply /Reordering.simulation_step; rewrite /Reordering.M -HM2 /M2.
    - apply: (stepI [] [] [] r l' (a :: r') x z);
        [by rewrite ?app_norm | by rewrite ?app_norm | clear; by firstorder done ].
    - apply: (stepI l' r' [] [a] [a] [] z y);
        [done | done | clear; by firstorder done]. }
  exists (M21 ++ M22). constructor; [| constructor; [| constructor]].
  - suff: weight M2 < weight M + (weight_Instruction ([], r, x, (a::l', r', y))).
    { rewrite HM2 weight_split. move: (weight_Instruction _) (weight _). by lia. }
    move: Hop. rewrite /M2 /DerivableRule.M' /= /weight_Instruction.
    case: (basic ([], r, x, (a :: l', r', y))); first by lia.
    move=> _. case: (basic ([], r, x, (l', a :: r', z))).
    { rewrite /= ?app_length. by lia. }
    rewrite /= ?app_length /= ?app_length. by lia.
  - apply /DerivableRule.confluence; first by eassumption.
    apply /Reordering.confluence. rewrite /Reordering.M -HM2.
    apply /DerivableRule.confluence; first by eassumption.
    apply: AddFreshLoop.confluent_M'; [done | done | by apply: fresh_StateP' | by move=> /=; lia ].
  - apply /DerivableRule.length_preservation; [by eassumption | move: HM => /lp_M; by lia | ].
    apply /Reordering.length_preservation. rewrite /Reordering.M -HM2.
    apply /DerivableRule.length_preservation; [by eassumption | move: HM => /lp_M; by lia | ].
    apply: AddFreshLoop.length_preserving_M'; [done | done | by apply: fresh_StateP' | by move=> /=; lia ].
  - rewrite (DerivableRule.boundedness (M21 ++ M22)); first by eassumption.
    rewrite -(Reordering.boundedness M21 M22).
    rewrite /Reordering.M -HM2.
    rewrite -(DerivableRule.boundedness); first by eassumption.
    rewrite -(AddFreshLoop.boundedness); [done | by apply: fresh_StateP' | by move=> /=; lia | done ].
Qed.

Lemma minimize_weight_short {M: SMN} {a b x y} :
  In (([], [a], x), ([], [b], y)) M ->
  confluent M -> length_preserving M ->
  { M' : SMN | weight M' < weight M /\ (confluent M' /\ length_preserving M' /\ ((exists NM, bounded M NM) <-> (exists NM', bounded M' NM'))) }.
Proof.
  move=> HM confluent_M lp_M.
  pose z := fresh_State M.
  pose M1 := AddFreshLoop.M' M [] [a] [a] [] x z.
  pose M2 := DerivableRule.M' M1 [a] [] [] [b] z y.
  have : In ([], [a], x, ([], [b], y)) M2.
  { rewrite /M2 /M1 /AddFreshLoop.M' /DerivableRule.M' ?in_app_iff.
    move: HM. clear. by firstorder done. }
  move /in_split_informative => /(_ ltac:(by do 5 (decide equality))) => [[[M21 M22] HM2]].
  pose M3 := Reordering.M' M21 M22 [] [a] [] [b] x y.
  pose M4 := DerivableRule.M' (M21 ++ M22) [] [a] [] [b] x y.
  have ? : x <> z by (move: HM => /fresh_StateP; subst z; lia).
  have ? : y <> z by (move: HM => /fresh_StateP; subst z; lia).
  (* az -> yb is derivable *)
  have ? : reachable M1 ([a], [], z) ([], [b], y).
  { apply: AddFreshLoop.step_fresh_rI; first by (move=> /=; lia).
    apply: rt_step. move: HM => /transition => /(_ [] []). by rewrite ?app_norm. }
  (* alxr -> l'yr' is redundant *)
  have ? : reachable (M21 ++ M22) ([], [a], x) ([], [b], y).
  { apply: (rt_trans (y := ([a], [], z))); apply: rt_step;
      (apply: (@DerivableRule.step_neq _ [] [a] [] [b] x y); first by [left | right]);
      apply /Reordering.simulation_step; rewrite /Reordering.M -HM2 /M2.
    - apply: (stepI [] [] [] [a] [a] [] x z);
        [done | done | clear; by firstorder done].
    - apply: (stepI [] [] [a] [] [] [b] z y);
        [done | done | clear; by firstorder done]. }
  exists (M21 ++ M22). constructor; [| constructor; [| constructor]].
  - suff: weight M2 < weight M + (weight_Instruction ([], [a], x, ([], [b], y))).
    { rewrite HM2 weight_split. move: (weight_Instruction _) (weight _). by lia. }
    rewrite /weight_Instruction /basic.
    rewrite /M2 /DerivableRule.M' /= /weight_Instruction /=. by lia.
  - apply /DerivableRule.confluence; first by eassumption.
    apply /Reordering.confluence. rewrite /Reordering.M -HM2.
    apply /DerivableRule.confluence; first by eassumption.
    apply: AddFreshLoop.confluent_M'; [done | done | by apply: fresh_StateP' | by move=> /=; lia ].
  - apply /DerivableRule.length_preservation; [by eassumption | move=> /=; by lia | ].
    apply /Reordering.length_preservation. rewrite /Reordering.M -HM2.
    apply /DerivableRule.length_preservation; [by eassumption | move=> /=; by lia | ].
    apply: AddFreshLoop.length_preserving_M'; [done | done | by apply: fresh_StateP' | by move=> /=; lia ].
  - rewrite (DerivableRule.boundedness (M21 ++ M22)); first by eassumption.
    rewrite -(Reordering.boundedness M21 M22).
    rewrite /Reordering.M -HM2.
    rewrite -(DerivableRule.boundedness); first by eassumption.
    rewrite -(AddFreshLoop.boundedness); [done | by apply: fresh_StateP' | by move=> /=; lia | done].
Qed.

Lemma minimize_weight_length {M: SMN} {a r b r' x y} :
  In (([], a :: r, x), ([], b :: r', y)) M ->
  weight_Instruction (([], a :: r, x), ([], b :: r', y)) <> 0 ->
  1 <= length r ->
  confluent M -> length_preserving M ->
  { M' : SMN | weight M' < weight M /\ (confluent M' /\ length_preserving M' /\ ((exists NM, bounded M NM) <-> (exists NM', bounded M' NM'))) }.
Proof.
  move=> HM Hop Hr confluent_M lp_M.
  pose z1 := fresh_State M.
  pose M1 := AddFreshLoop.M' M [] [a] [a] [] x z1.
  pose z2 := fresh_State M1.
  pose M2 := AddFreshLoop.M' M1 [] [b] [a] [] y z2.
  pose M3 := DerivableRule'.M' M2 r r' z1 z2.
  have : In ([], a :: r, x, ([], b :: r', y)) M3.
  { rewrite /M3 /M2 /M1 /AddFreshLoop.M' /DerivableRule'.M' ?in_app_iff.
    move: HM. clear. by firstorder done. }
  move /in_split_informative => /(_ ltac:(by do 5 (decide equality))) => [[[M31 M32] HM3]].
  pose M4 := Reordering.M' M31 M32 [] (a::r) [] (b::r') x y.
  pose M5 := DerivableRule.M' (M31 ++ M32) [] (a::r) [] (b::r') x y.
  have ? : x <> z1 by (move: HM => /fresh_StateP; subst z1; lia).
  have ? : y <> z1 by (move: HM => /fresh_StateP; subst z1; lia).
  have [? ?] : x <> z2 /\ y <> z2.
  { have /fresh_StateP : In ([], a :: r, x, ([], b :: r', y)) M1.
    { rewrite /M1 /AddFreshLoop.M' ?in_app_iff. by right. }
    unfold z2; lia. }
  have ? : z1 <> z2.
  { have /fresh_StateP : In ([], [a], x, ([a], [], z1)) M1.
    { rewrite /M1 /AddFreshLoop.M' ?in_app_iff. left. by left. }
    unfold z2; lia. }

  (* az1r -> az2r' is derivable *)
  have ? : reachable M2 ([a], r, z1) ([a], r', z2).
  { apply: AddFreshLoop.step_fresh_lI; first by (move=> /=; lia).
    apply: AddFreshLoop.step_fresh_rI; first by (move=> /=; lia).
    apply: rt_step. move: HM => /transition => /(_ [] []). by rewrite ?app_norm. }
  (* xar -> ybr' is redundant *)
  have ? : reachable (M31 ++ M32) ([], a::r, x) ([], b :: r', y).
  { apply: (rt_trans (y := ([a], r, z1))); [| apply: (rt_trans (y := ([a], r', z2)))]; apply: rt_step;
      (apply: (@DerivableRule.step_neq _ [] (a :: r) [] (b :: r') x y); first by [left | right]);
      apply /Reordering.simulation_step; rewrite /Reordering.M -HM3 /M3.
    - apply: (stepI [] r [] [a] [a] [] x z1);
        [done | done | clear; by firstorder done].
    - apply: (stepI [a] [] [] r [] r' z1 z2);
        [by rewrite ?app_norm | by rewrite ?app_norm | clear; by firstorder done].
    - apply: (stepI [] r' [a] [] [] [b] z2 y);
        [done | done | clear; by firstorder done]. }
  (* z1 is only exited with a on the left stack *)
  have ? : forall l'' r'' z , step M2 (l'', r'', z1) z -> l'' = [a] ++ skipn 1 l''.
  { move=> l'' r'' z. move HZ1: (l'', r'', z1) => Z1 HZ1z. case: HZ1z HZ1.
    move=> >. rewrite /M2 /AddFreshLoop.M' /M1 /AddFreshLoop.M' ?in_app_iff. case.
    { case; [by congruence | case; [by congruence | done]]. }
    case.
    - case; first by congruence.
      case; last done.
      move=> + [] *. move=> [] *. by subst.
    - move /fresh_StateP=> ? [] *. subst z1. by lia. }
  (* z1 is only entered with a on the left stack *)
  have ? : forall l'' r'' z , step M2 z (l'', r'', z1) -> l'' = [a] ++ skipn 1 l''.
  { move=> l'' r'' z. move HZ1: (l'', r'', z1) => Z1 HZ1z. case: HZ1z HZ1.
    move=> >. rewrite /M2 /AddFreshLoop.M' /M1 /AddFreshLoop.M' ?in_app_iff. case.
    { case; [by congruence | case; [by congruence | done]]. }
    case; [case|].
    - move=> + [] * => [[]] *. by subst.
    - case; [by congruence | done].
    - move /fresh_StateP=> ? [] *. subst z1. by lia. }
  exists (M31 ++ M32). constructor; [| constructor; [| constructor]].
  - suff: weight M3 < weight M + (weight_Instruction ([], (a::r), x, ([], (b::r'), y))).
    { rewrite HM3 weight_split. move: (weight_Instruction _) (weight _). by lia. }
    move: Hop.
    rewrite /M3 /DerivableRule.M' /= /weight_Instruction.
    case: (basic ([], a :: r, x, ([], b :: r', y))); first by lia.
    move=> _. case: (basic ([], r, z1, ([], r', z2))).
    { rewrite /= ?app_length. by lia. }
    rewrite /= ?app_length /= ?app_length. by lia.
  - apply /DerivableRule.confluence; first by eassumption.
    apply /Reordering.confluence. rewrite /Reordering.M -HM3.
    apply /DerivableRule'.confluent_M'; [| by eassumption | done | done | done ].
    apply: AddFreshLoop.confluent_M'; [ | done | by apply: fresh_StateP' | by move=> /=; lia ].
    apply: AddFreshLoop.confluent_M'; [ done | done | by apply: fresh_StateP' | by move=> /=; lia ].
  - apply /DerivableRule.length_preservation; [by eassumption | move=> /=; by lia | ].
    apply /Reordering.length_preservation. rewrite /Reordering.M -HM3.
    apply /DerivableRule'.length_preserving_M'; [| by eassumption | done | done | done | done ].
    apply: AddFreshLoop.length_preserving_M'; [ | done | by apply: fresh_StateP' | by move=> /=; lia ].
    apply: AddFreshLoop.length_preserving_M'; [ done | done | by apply: fresh_StateP' | by move=> /=; lia ].
  - rewrite (DerivableRule.boundedness (M31 ++ M32)); first by eassumption.
    rewrite -(Reordering.boundedness M31 M32).
    rewrite /Reordering.M -HM3.
    rewrite -(DerivableRule'.boundedness); [ by eassumption | done | done | done | done | ].
    rewrite -(AddFreshLoop.boundedness); [ done | by apply: fresh_StateP' | by move=> /=; lia | ].
    rewrite -(AddFreshLoop.boundedness); [ done | by apply: fresh_StateP' | by move=> /=; lia | done ].
Qed.

Lemma overweight_Instruction {M} : weight M <> 0 -> { op | In op M /\ weight_Instruction op <> 0 }.
Proof.
  elim: M; first done.
  move=> op M IH /=. have [-> ? |] : { weight M = 0 } + { weight M <> 0 } by decide equality.
  - exists op. constructor; [by left | done].
  - move /IH => [op' [? ?]] _. exists op'. constructor; [by right | done].
Qed.

(* from any confluent and length preserving SMN construct a boundedness-equivalent, confluent, length preserving SMN with only rules of weight 0 *)
Theorem minimize_weight (M: SMN) :
  confluent M -> length_preserving M ->
  { M' : SMN | weight M' = 0 /\ (confluent M' /\ length_preserving M' /\ ((exists NM, bounded M NM) <-> (exists NM', bounded M' NM'))) }.
Proof.
  elim /(measure_rect weight): M => M IH confluent_M lp_M.
  have [? |] : {weight M = 0} + {weight M <> 0} by decide equality.
  { exists M. by firstorder done. }
  move /overweight_Instruction => [[[[l r] x] [[l' r'] y]] []].
  move: l => [|a l]; first last.
  { (* reduce lhs l size *)
    move /minimize_weight_lhs => H /H => /(_ confluent_M lp_M) => [[M' [? [? [? ?]]]]].
    case: (IH M'); [ done | done | done |].
    move=> M'' [? [? [? HM'']]]. exists M''.
    constructor; [done | constructor; [ done | constructor; [done | by rewrite -HM'']]]. }
  move: l' => [|a l']; first last.
  { (* reduce rhs l size *)
    move /minimize_weight_rhs => H /H => /(_ confluent_M lp_M) => [[M' [? [? [? ?]]]]].
    case: (IH M'); [ done | done | done |].
    move=> M'' [? [? [? HM'']]]. exists M''.
    constructor; [done | constructor; [ done | constructor; [done | by rewrite -HM'']]]. }
  move: r => [|a r]; first by (move /lp_M => /=; lia).
  move: r' => [|b r']; first by (move /lp_M => /=; lia).
  move: r => [|a' r].
    (* replace rules xa -> yb *)
  - move: r' => [|? ?]; last by (move /lp_M => /=; lia).
    move=> + _ => /minimize_weight_short => /(_ confluent_M lp_M) => [[M' [? [? [? ?]]]]].
    case: (IH M'); [ done | done | done |]. move=> M'' [? [? [? HM'']]]. exists M''.
    constructor; [done | constructor; [ done | constructor; [done | by rewrite -HM'']]].
    (* reduce overall size of rule xr -> yr' *)
  - have : 1 <= length (a' :: r) by (move=> /=; lia).
    move: (a' :: r) => {}r.
    move /minimize_weight_length => H /H => {}H /H => /(_ confluent_M lp_M) => [[M' [? [? [? ?]]]]].
    case: (IH M'); [ done | done | done |]. move=> M'' [? [? [? HM'']]]. exists M''.
    constructor; [done | constructor; [ done | constructor; [done | by rewrite -HM'']]].
Qed.

End Transform.

(* basic instructions are of shape xa -> by or ax -> yb *)
Inductive basic : Instruction -> Prop :=
  | basic_r a b x y : basic (([], [a], x), ([b], [], y))
  | basic_l a b x y : basic (([a], [], x), ([], [b], y)).

(* from any confluent and length preserving SMN construct a boundedness-equivalent, confluent, SMN with only basic instructions *)
Theorem construct_basic_SMN (M: SMN) :
  confluent M -> length_preserving M ->
  { M' : SMN | Forall basic M' /\ (confluent M' /\ ((exists NM, bounded M NM) <-> (exists NM', bounded M' NM'))) }.
Proof.
  move /Transform.minimize_weight => H /H => [[M']] [HM'] [? [_ ?]].
  exists M'. constructor; last by constructor.
  apply /Forall_forall => op /(@in_split Instruction) => [[?]] [? ?]. subst M'.
  move: HM'. rewrite Transform.weight_split => ?.
  have : Transform.weight_Instruction op = 0 by lia. clear.
  rewrite /Transform.weight_Instruction.
  case Hop: (Transform.basic op); last by move: op Hop => [[[l r] ?] [[l' r'] ?]].
  move: op Hop => [[[l r] ?] [[l' r'] ?]] /=.
  move: l r l' r' => [|a [|? ?]] [|b [|? ?]] [|a' [|? ?]] [|b' [|? ?]] *; by [| apply: basic_r | apply: basic_l].
Qed.