(** A library of relation operators defining sequences of transitions
  and useful properties about them. *)

(** This file includes code drawn from the Coq development of the
    paper:
    Trace-relating compiler correctness and secure compilation.
    Carmine Abate, Roberto Blanco, Ștefan Ciobâcă, Adrien Durier,
    Deepak Garg, Cătălin Hriţcu, Marco Patrignani, Éric Tanter,
    and Jérémy Thibault. ESOP 2020.
    The Coq development is available at
    https://github.com/secure-compilation/different_traces.
    We modify and adjust some definitions to match our conventions.
*)

Require Import Classical ClassicalEpsilon.
From Coq Require Import String ZArith List Streams.
Require Import Integers.
Require Import Program.Equality.
Import ListNotations.
Set Implicit Arguments.

(* We model the external world state as containing the next input to
provide the program, the next global state to step to after providing
an input, and a function to produce the next global state after
receiving an output. *)
CoInductive global_state : Type :=
| global_state_with_input (z : Z) (n : global_state) (f : Z -> global_state).

(* Provide an input for the program to take *)
Definition take_input (g : global_state) : Z * global_state :=
  match g with
  | global_state_with_input z n _ =>
    (z, n)
  end.

(* Receive an output from the program and generate a new global state *)
Definition produce_output (g : global_state) (n : Z) : global_state :=
  match g with
  | global_state_with_input _ _ f => f n
  end.

(* events: input or output an integer, or interrupt *)
Inductive event : Type :=
| ev_input : Z -> event
| ev_output : Z -> event
| ev_intr : event.

(* trace of events during execution of program *)
Definition trace := list event.
Definition inftrace := Stream event.

Section SEQUENCES.

(* the type of states *)
Variable A: Type.

(* the transition relation, from one state to the next, optionally emitting an event *)
Variable R: A -> option event -> A -> Prop.

(** ** Finite sequences of transitions *)

(** Zero, one or several transitions: reflexive, transitive closure of [R]. *)

Inductive star: A -> trace -> A -> Prop :=
  | star_refl: forall a,
      star a [] a
  | star_step: forall a b c t,
      R a None b -> star b t c -> star a t c
  | star_step_ev: forall a b c e t,
      R a (Some e) b -> star b t c -> star a (e :: t) c.

Lemma star_one:
  forall (a b: A), R a None b -> star a [] b.
Proof.
  eauto using star.
Qed.

Lemma star_one_ev:
  forall (a b: A) e, R a (Some e) b -> star a [e] b.
Proof.
  eauto using star.
Qed.

Lemma star_trans:
  forall (a b: A) t1 t2, star a t1 b -> forall c, star b t2 c -> star a (t1 ++ t2) c.
Proof.
  induction 1; eauto using star.
Qed.

Lemma star_trans_nil:
  forall (a b: A), star a nil b -> forall c, star b nil c -> star a nil c.
Proof.
  intros.
  replace ([]:trace) with (([] ++ []):trace); eauto using star_trans.
Qed.

Lemma star_int:
  forall a c t, star a t c -> forall t' t'', t = t' ++ t'' -> exists b, star a t' b.
Proof.
  induction 1; intros.
  - exists a. symmetry in H; destruct (app_eq_nil _ _ H). rewrite H0; econstructor.
  - destruct (IHstar _ _ H1) as (b0 & ?). exists b0; econstructor; eauto.
  - destruct t'.
    + exists a; econstructor.
    + rewrite <- app_comm_cons in H1.
      inversion H1; rewrite H3 in *; rewrite H4 in *.
      destruct (IHstar t' t'') as (b0 & ?); try easy.
      exists b0; eapply star_step_ev; eauto.
Qed.

(** One or several transitions: transitive closure of [R]. *)

Inductive plus: A -> trace -> A -> Prop :=
  | plus_left: forall a b c t,
      R a None b -> star b t c -> plus a t c
  | plus_left_ev: forall a b c e t,
      R a (Some e) b -> star b t c -> plus a (e :: t) c.

Lemma plus_one:
  forall a b, R a None b -> plus a [] b.
Proof.
  eauto using star, plus.
Qed.

Lemma plus_one_ev:
  forall a b e, R a (Some e) b -> plus a [e] b.
Proof.
  eauto using star, plus.
Qed.

Lemma plus_star:
  forall a b t,
  plus a t b -> star a t b.
Proof.
  intros. inversion H; eauto using star.
Qed.

Lemma plus_star_trans:
  forall a b c t1 t2, plus a t1 b -> star b t2 c -> plus a (t1 ++ t2) c.
Proof.
  intros. inversion H; eauto using plus, star_trans.
Qed.

Lemma star_plus_trans:
  forall a b c t1 t2, star a t1 b -> plus b t2 c -> plus a (t1 ++ t2) c.
Proof.
  intros. inversion H0; inversion H; eauto using plus, star, star_trans.
Qed.

Lemma plus_right:
  forall a b c t, star a t b -> R b None c -> plus a t c.
Proof.
  intros. replace t with (t ++ []) by auto using app_nil_r.
  eauto using star_plus_trans, plus_one, plus_one_ev.
Qed.

Lemma plus_right_ev:
  forall a b c t e, star a t b -> R b (Some e) c -> plus a (t ++ [e]) c.
Proof.
  eauto using star_plus_trans, plus_one, plus_one_ev.
Qed.

Lemma star_inv : forall a t b,
    star a t b ->
    (a = b /\ t = []) \/ plus a t b.
Proof.
  intros; inversion H; subst;
    try solve [left; auto];
    right; [eapply plus_left | eapply plus_left_ev]; eauto.
Qed.

(** No transitions from a state. *)

Definition irred (a: A) : Prop := forall b eo, ~(R a eo b).

(** ** Infinite sequences of transitions *)

Definition all_seq_inf (a: A) : Prop :=
  forall t b, star a t b -> exists eopt c, R b eopt c.

CoInductive infseq: A -> inftrace -> Prop :=
| infseq_step: forall a b t,
    R a None b -> infseq b t -> infseq a t
| infseq_step_ev: forall a e b t,
    R a (Some e) b -> infseq b t -> infseq a (Cons e t).

Definition cons_to_itr (eopt : option event) (t : inftrace) : inftrace :=
  match eopt with
  | Some e => Cons e t
  | None => t
  end.

Fixpoint app_to_itr (t : trace) (it : inftrace) :=
  match t with
  | nil => it
  | e :: t' => Cons e (app_to_itr t' it)
  end.

(* Adapted from different traces paper ResourceExhaustion/Sequences.v *)
CoInductive infseq_N : A -> nat -> inftrace -> Prop :=
| infseq_N_star : forall a b n1 n2 l s,
    n2 < n1 ->
    star a l b ->
    infseq_N b n2 s ->
    infseq_N a n1 (app_to_itr l s)
| infseq_N_plus : forall a b n1 n2 l s,
    plus a l b ->
    infseq_N b n2 s ->
    infseq_N a n1 (app_to_itr l s).

Lemma infseq_N_inv : forall n s a,
    infseq_N a n s ->
    exists eo, exists s', exists n', exists a',
            R a eo a' /\ infseq_N a' n' s' /\ cons_to_itr eo s' = s.
Proof.
  intros n. pattern n.
  eapply well_founded_ind with (R := lt).
  apply PeanoNat.Nat.lt_wf_0.
  intros x H s a H0.
  inversion H0; subst; clear H0.
  - inversion H2; subst; clear H2.
    + apply H with n2. now apply H1.
      apply H3.
    + exists None. exists (app_to_itr l s0). exists x. exists b0.
      repeat split; eauto.
      eapply infseq_N_star; eauto.
    + exists (Some e). exists (app_to_itr t s0). exists x. exists b0.
      repeat split; eauto.
      eapply infseq_N_star; eauto.
  - inversion H1; subst; clear H1.
    + exists None, (app_to_itr l s0), n2, b0.
      repeat split; eauto.
      inversion H3; subst; clear H3.
      assumption.
      eapply infseq_N_plus; eauto.
      econstructor; eauto.
      eapply infseq_N_plus; eauto.
      eapply plus_left_ev; eauto.
    + exists (Some e), (app_to_itr t s0), n2, b0.
      repeat split; eauto.
      inversion H3; subst; clear H3.
      assumption.
      eapply infseq_N_plus; eauto.
      econstructor; eauto.
      eapply infseq_N_plus; eauto.
      eapply plus_left_ev; eauto.
Qed.

Lemma infseq_N_infseq :
  forall a s n, infseq_N a n s -> infseq a s.
Proof.
  cofix Hfix.
  intros a s n H.
  destruct (infseq_N_inv H) as [l [s' [n' [a' [HR [Hinf Heq]]]]]].
  subst. destruct l.
  - apply infseq_step_ev with (b := a').
    eauto. eapply Hfix; eauto.
  - apply infseq_step with (b := a').
    eauto. eapply Hfix; eauto.
Qed.

Lemma infseq_infseq_N :
  forall a n s, infseq a s -> infseq_N a n s.
Proof.
  cofix Hfix.
  intros a n s H.
  inversion H; subst.
  - replace s with (app_to_itr [] s) by auto.
    eapply infseq_N_plus with (n2 := 0).
    replace [] with ((nil:trace) ++ []) by now rewrite app_nil_r.
    econstructor. eauto. econstructor.
    eapply Hfix. eauto.
  - replace (Cons e t) with (app_to_itr [e] t) by auto.
    eapply infseq_N_plus with (n2 := 0).
    replace [] with ((nil:trace) ++ []) by now rewrite app_nil_r.
    eapply plus_left_ev. eauto. cbn; econstructor.
    eapply Hfix. eauto.
Qed.

Lemma app_to_itr_app_distrib: forall t t' it,
    app_to_itr t (app_to_itr t' it) = app_to_itr (t ++ t') it.
Proof.
  induction t; cbn; auto. intros. now rewrite IHt.
Qed.

Lemma star_infseq_trans: forall a t b it,
    star a t b -> infseq b it -> infseq a (app_to_itr t it).
Proof.
  induction 1; intros.
  - now cbn.
  - eapply infseq_step; eauto.
  - eapply infseq_step_ev; eauto.
Qed.

Lemma infseq_coinduction_principle:
  forall (X: A -> inftrace -> Prop),
  (forall a t, X a t -> exists b eo t', R a eo b /\ X b t' /\ t = cons_to_itr eo t') ->
  forall a t, X a t -> infseq a t.
Proof.
  intros X P. cofix COINDHYP; intros.
  destruct (P a t H) as [b [eo [t' [HR [HX Happ]]]]].
  destruct eo; cbn in Happ; subst t.
  - apply infseq_step_ev with b; auto.
  - apply infseq_step with b; auto.
Qed.

Lemma infseq_coinduction_principle_2:
  forall (X: A -> inftrace -> Prop),
  (forall a t, X a t -> exists b t' t'', plus a t' b /\ X b t'' /\ t = app_to_itr t' t'') ->
  forall a t, X a t -> infseq a t.
Proof.
  intros.
  apply infseq_coinduction_principle with
      (X := fun a t => exists b t' t'', star a t' b /\ X b t'' /\ t = app_to_itr t' t'').
  - intros.
    destruct H1 as [b [t' [t'' [STAR [Xb Ht0]]]]].
    inversion STAR; subst; try solve [ eauto 20 ].
    destruct (H b t'' Xb) as [c [t'0 [t''0 [PLUS [Xc Ht'0]]]]].
    inversion PLUS; subst; eauto 20.
  - exists a, [], t; split; auto using star_refl.
Qed.

(* Silent divergence *)
CoInductive infseq_silent : A -> Prop :=
| infseq_silent_step :
    forall a b, R a None b -> infseq_silent b -> infseq_silent a.

Remark cycle_infseq_silent:
  forall a, R a None a -> infseq_silent a.
Proof.
  intros. cofix CIH. apply infseq_silent_step with a. auto. apply CIH.
Qed.

Lemma infseq_silent_coinduction_principle:
  forall (X: A -> Prop),
  (forall a, X a -> exists b, R a None b /\ X b) ->
  forall a, X a -> infseq_silent a.
Proof.
  intros X P. cofix COINDHYP; intros.
  destruct (P a H) as [b [HR HX]].
  econstructor; eauto.
Qed.

Lemma infseq_silent_coinduction_principle_2:
  forall (X: A -> Prop),
  (forall a, X a -> exists b, plus a [] b /\ X b) ->
  forall a, X a -> infseq_silent a.
Proof.
  intros.
  apply infseq_silent_coinduction_principle with
      (X := fun a => exists b, star a [] b /\ X b).
  - intros.
    destruct H1 as [b [STAR Xb]].
    inversion STAR; subst; try solve [ eauto 20 ].
    destruct (H b Xb) as [c [PLUS Xc]].
    inversion PLUS; subst; eauto 20.
  - exists a; split; eauto using star.
Qed.

Lemma infseq_silent_implies_infseq :
  forall a t, infseq_silent a -> infseq a t.
Proof.
  cofix CIH.
  intros a t H.
  inversion H; subst.
  replace t with (app_to_itr [] t) by reflexivity.
  econstructor; eauto.
Qed.

Lemma infseq_silent_coind :
  forall P a t, (infseq a t -> P a) ->
           (infseq_silent a -> P a).
Proof.
  auto using infseq_silent_implies_infseq.
Qed.

Lemma infseq_silent_if_all_silent_inf:
  forall a,
    (forall t b, star a t b -> exists c, R b None c) ->
    infseq_silent a.
Proof.
  cofix CIH; intros.
  destruct (H [] a) as [b H']; try constructor.
  econstructor; eauto.
  apply CIH. eauto using star_step.
Qed.

Definition diverges_silently (a : A) (t : trace) :=
  exists b, star a t b /\ infseq_silent b.

(* Diverges with infinite sequence of events (i.e. reacts) *)
CoInductive infseq_with_inftrace : A -> inftrace -> Prop :=
| infseq_with_inftrace_plus: forall a t b it,
    plus a t b -> t <> [] ->
    infseq_with_inftrace b it ->
    infseq_with_inftrace a (app_to_itr t it).

Lemma infseq_with_inftrace_coinduction_principle:
  forall (X: A -> inftrace -> Prop),
  (forall a t, X a t -> exists b t' t'', plus a t' b /\ X b t'' /\ t = app_to_itr t' t'' /\ t' <> []) ->
  forall a t, X a t -> infseq_with_inftrace a t.
Proof.
  intros X P. cofix CIH; intros.
  destruct (P a t H) as (b & t' & t'' & Hplus & HX & Happ & Ht').
  rewrite Happ; econstructor; eauto.
Qed.

Lemma star_infseq_with_inftrace: forall (a b : A) (t : trace) (it : inftrace),
    star a t b -> infseq_with_inftrace b it ->
    infseq_with_inftrace a (app_to_itr t it).
Proof.
  intros. inversion H0; subst.
  assert (plus a (t ++ t0) b0) by eauto using star_plus_trans.
  rewrite app_to_itr_app_distrib.
  econstructor; eauto.
  intuition. destruct (app_eq_nil _ _ H5); congruence.
Qed.

Lemma infseq_with_inftrace_implies_infseq : forall a it,
    infseq_with_inftrace a it ->
    infseq a it.
Proof.
  assert (forall a n s, infseq_with_inftrace a s -> infseq_N a n s).
  {
    cofix Hfix.
    intros a n s H.
    inversion H; subst.
    destruct t as [| e l]; try congruence.
    replace (app_to_itr (e :: l) it) with (app_to_itr ([e] ++ l) it) in H by reflexivity.
    inversion H0; subst; clear H0.
    - eapply infseq_N_plus.
      + eapply plus_left; eauto.
      + eapply Hfix; eauto.
    - eapply infseq_N_plus.
      + eapply plus_left_ev; eauto.
      + eapply Hfix; eauto.
  }
  intros s a H0.
  eapply infseq_N_infseq.
  eapply H.
  eassumption.
  Unshelve.
  all: exact 0.
Qed.

CoInductive stream' :=
| scons' : forall (t : trace) (s : stream'), t <> [] -> stream'.

Program Definition split_inftrace' (t : trace) (s: stream') (NE: t <> []): event * stream' :=
  match t with
  | nil => _
  | e :: nil => (e, s)
  | e :: t' => (e, @scons' t' s _)
  end.
Next Obligation.
  destruct t'; congruence.
Qed.

CoFixpoint stream_of_stream' (s': stream') : inftrace :=
  match s' with
  | @scons' t T'' NOTEMPTY =>
    let (e, tl) := @split_inftrace' t T'' NOTEMPTY in
    Cons e (stream_of_stream' tl)
  end.

Remark unroll_stream':
  forall T, T = match T with @scons' t T' NE => @scons' t T' NE end.
Proof.
  intros. destruct T; auto.
Qed.

Lemma stream_stream'_app:
  forall t T NE,
    stream_of_stream' (@scons' t T NE) = app_to_itr t (stream_of_stream' T).
Proof.
  induction t.
  intros. elim NE. auto.
  intros. simpl.
  rewrite (unfold_Stream (stream_of_stream' (@scons' (a :: t) T NE))).
  simpl. destruct t. auto.
  simpl. f_equal. apply IHt.
Qed.

Section REACTS.
Variable a : A.
Hypothesis reacts:
  forall t b, star a t b ->
           exists t' c, plus b t' c /\ t' <> [].

Lemma reacts':
  forall t b, star a t b ->
           { c & { t' : trace | plus b t' c /\ t' <> [] } }.
Proof.
  intros.
  destruct (constructive_indefinite_description _ (reacts H)) as [t' H'].
  destruct (constructive_indefinite_description _ H') as [c [Hplus Ht']].
  exists c; exists t'; auto.
Qed.

Lemma not_nil_nil : (@nil event) <> [] -> False.
Proof.
  congruence.
Qed.

CoFixpoint build_stream' t b (ST: star a t b) : @stream' :=
  match (reacts' ST) with
  | existT _ s2 (exist _ t2 (conj A B)) =>
    @scons' t2 (build_stream' (plus_star (star_plus_trans ST A))) B
  end.

Lemma reacts_forever_reactive_rec:
  forall t b (ST : star a t b),
    infseq_with_inftrace b (stream_of_stream' (build_stream' ST)).
Proof.
  cofix COINDHYP; intros.
  rewrite (unroll_stream' (build_stream' ST)).
  simpl.
  destruct (reacts' ST) as [s2 [t2 [H1 H2]]].
  rewrite stream_stream'_app.
  econstructor. eassumption. auto. apply COINDHYP.
Qed.

Lemma reacts_forever_reactive:
  exists it, infseq_with_inftrace a it.
Proof.
  exists (stream_of_stream' (build_stream' (star_refl _))).
  apply reacts_forever_reactive_rec.
Qed.
End REACTS.

(* Every state either terminates on an irreducible state, emits a
finite trace then diverges silently, or diverges with an infinite
sequence of events. *)
Lemma infseq_or_finseq: forall a,
    (exists t b, star a t b /\ irred b) \/
    (exists t, diverges_silently a t) \/
    (exists it, infseq_with_inftrace a it).
Proof.
  intros.
  destruct (classic (forall t b, star a t b -> exists eo c, R b eo c)).
  - destruct (classic (exists t b, star a t b /\ (forall t' c, star b t' c -> exists d, R c None d))).
    + right; left.  destruct H0 as (t & b & Htb & Hc).
      exists t; unfold diverges_silently; exists b; split; eauto.
      now apply infseq_silent_if_all_silent_inf.
    + right; right. eapply reacts_forever_reactive. intros.
      generalize (not_ex_all_not _ _ H0 t). intro; clear H0.
      generalize (not_ex_all_not _ _ H2 b). intro; clear H2.
      destruct (not_and_or _ _ H0); try contradiction.
      destruct (not_all_ex_not _ _ H2) as [t' C]; clear H0.
      destruct (not_all_ex_not _ _ C) as [c D]; clear C.
      destruct (imply_to_and _ _ D) as [E F]; clear D.
      destruct (H (t ++ t') c) as [eo [d G]]. eapply star_trans; eauto.
      destruct eo.
      * exists (t' ++ [e]), d; split; eauto using plus_star_trans, plus_right_ev.
        intuition. destruct (app_eq_nil _ _ H0); subst; congruence.
      * exists (t'), d; split; eauto using plus_right.
  - left. apply not_all_ex_not in H. destruct H as (t & P).
    apply not_all_ex_not in P. destruct P as (b & P).
    generalize (imply_to_and _ _ P). intros [U V].
    exists t, b; split. auto.
    red; intros; red; intros. elim V. exists eo, b0; auto.
Qed.

(** ** Determinism properties for functional transition relations. *)

(** A transition relation is functional if every state can transition to at most
  one other state. *)

Hypothesis R_functional:
  forall a b c eo1 eo2, R a eo1 b -> R a eo2 c -> b = c /\ eo1 = eo2.

(** Uniqueness of finite transition sequences. *)

Lemma star_star_inv:
  forall a b t1, star a t1 b -> forall c t2, star a t2 c ->
                                  (exists t, star b t c /\ t2 = t1 ++ t)
                                  \/ (exists t, star c t b /\ t1 = t2 ++ t).
Proof.
  induction 1; intros.
- left. eexists; eauto.
- inversion H1; subst.
  + right. eauto using star.
  + assert (b = b0) by (eapply R_functional; eauto). subst b0.
    apply IHstar; auto.
  + apply (R_functional H) in H2. destruct H2. discriminate.
- inversion H1; subst.
  + right. eauto using star.
  + apply (R_functional H) in H2. destruct H2. discriminate.
  + assert (b = b0) by (eapply R_functional; eauto). subst b0.
    assert (e = e0).
    { specialize (R_functional H H2). destruct R_functional; injection H5; auto. }
    subst e0.
    apply IHstar in H3. destruct H3.
    * left. destruct H3. exists x. rewrite <- app_comm_cons.
      destruct H3. split; try easy. rewrite H4; congruence.
    * right. destruct H3. exists x. rewrite <- app_comm_cons.
      destruct H3. split; try easy. rewrite H4; congruence.
Qed.

Lemma finseq_unique:
  forall a b b' t t',
  star a t b -> irred b ->
  star a t' b' -> irred b' ->
  b = b' /\ t = t'.
Proof.
  intros. destruct (star_star_inv H H1).
  - destruct H3. destruct H3. inversion H3; subst; try elim (H0 _ _ H5).
    split; try rewrite app_nil_r; auto.
  - destruct H3. destruct H3. inversion H3; subst; try elim (H2 _ _ H5).
    split; try rewrite app_nil_r; auto.
Qed.

(** A state cannot both diverge and terminate on an irreducible state. *)

Lemma infseq_star_inv:
  forall a b t t', star a t' b -> infseq a t -> exists t'', infseq b t'' /\ t = app_to_itr t' t''.
Proof.
  intros until 1. generalize dependent t. dependent induction H; intros.
  - eauto.
  - inversion H1; subst.
    + assert (b = b0) by (eapply R_functional; eauto). subst b0.
      apply IHstar; auto.
    + assert (None = Some e) by (eapply R_functional; eauto). inversion H4.
  - inversion H1; subst.
    + assert (None = Some e) by (eapply R_functional; eauto). inversion H4.
    + assert (b = b0) by (eapply R_functional; eauto). subst b0.
      assert (e = e0) by (specialize (R_functional H H2); destruct R_functional; congruence). subst e0.
      apply IHstar in H3. destruct H3 as [t'' H3]. exists t''.
      destruct H3. split; eauto. cbn. now rewrite H4.
Qed.

Lemma infseq_finseq_excl:
  forall a t b t',
  star a t b -> irred b -> infseq a t' -> False.
Proof.
  intros.
  assert (exists t'', infseq b t'' /\ t' = app_to_itr t t'') by (eapply infseq_star_inv; eauto).
  destruct H2 as [t'' [H2 H2']]. inversion H2; subst; now apply H0 in H3.
Qed.

Lemma infseq_silent_star_inv:
  forall a b t, star a t b -> infseq_silent a -> infseq_silent b.
Proof.
  intros until 1. dependent induction H; intros.
  - eauto.
  - inversion H1; subst.
    assert (b = b0) by (eapply R_functional; eauto). subst b0.
    apply IHstar; auto.
  - inversion H1; subst.
    assert (None = Some e) by (eapply R_functional; eauto); congruence.
Qed.

Lemma infseq_silent_star_inv':
  forall a b t, star a t b -> infseq_silent a -> t = [].
Proof.
  intros until 1. dependent induction H; intros.
  - eauto.
  - apply IHstar. eapply infseq_silent_star_inv; eauto.
    eapply star_step. eapply H. eapply star_refl.
  - inversion H1; subst.
    assert (None = Some e) by (eapply R_functional; eauto); congruence.
Qed.

Lemma infseq_silent_finseq_excl:
  forall a t b,
  star a t b -> irred b -> infseq_silent a -> False.
Proof.
  intros.
  assert (infseq_silent b) by (eapply infseq_silent_star_inv; eauto).
  inversion H2; subst; now apply H0 in H3.
Qed.

Lemma diverges_silently_finseq_excl:
  forall a t b t',
    star a t b -> irred b -> diverges_silently a t' -> False.
Proof.
  intros. unfold diverges_silently in H1. destruct H1 as (b' & ? & ?).
  apply star_star_inv with (b := b) (t1 := t) in H1; auto.
  destruct H1.
  - destruct H1 as (t0 & Hstar & Happ).
    unfold irred in H0. inversion Hstar; subst; try (now apply H0 in H1).
    inversion H2; subst. now apply H0 in H1.
  - destruct H1 as (t0 & Hstar & Happ).
    assert (infseq_silent b) by (eapply infseq_silent_star_inv; eauto).
    inversion H1; subst; now apply H0 in H3.
Qed.

Lemma infseq_with_inftrace_inv : forall a t1 b,
    star a t1 b ->
    forall c t2 it1 it2,
      star a t2 c ->
      t1 <> [] -> t2 <> [] ->
      infseq_with_inftrace b it1 ->
      infseq_with_inftrace c it2 ->
      exists a', exists t, exists it1', exists it2',
              t <> [] /\
              infseq_with_inftrace a' it1' /\ infseq_with_inftrace a' it2' /\
              app_to_itr t1 it1 = app_to_itr t it1' /\
              app_to_itr t2 it2 = app_to_itr t it2'.
Proof.
  induction 1; intros; try congruence.
  - inversion H1; subst; try congruence.
    + assert (b = b0 /\ None = None) as [? _] by eauto using R_functional; subst.
      eapply IHstar; eauto.
    + assert (b = b0 /\ None = Some e) as [? ?] by eauto using R_functional; congruence.
  - inversion H1; subst; try congruence.
    + assert (b = b0 /\ Some e = None) as [? ?] by eauto using R_functional; congruence.
    + assert (b = b0 /\ Some e = Some e0) as [? ?] by eauto using R_functional.
      inversion H9; subst.
      exists b0. exists [e0]. exists (app_to_itr t it1). exists (app_to_itr t0 it2).
      repeat split; try congruence; eauto using star_infseq_with_inftrace.
Qed.

Lemma star_infseq_with_inftrace_inv : forall a t b,
    star a t b ->
    forall it, infseq_with_inftrace a it ->
          exists it', infseq_with_inftrace b it' /\ it = app_to_itr t it'.
Proof.
  induction 1; intros.
  - eexists; cbn; eauto.
  - inversion H1; subst; clear H1.
    inversion H2; subst; clear H2.
    + assert (b1 = b) by (now eapply R_functional; eassumption); subst.
      specialize (IHstar (app_to_itr t0 it0)).
      eapply IHstar. eapply star_inv in H5. destruct H5; try (destruct H2; congruence).
      econstructor; eauto.
    + assert (b = b1 /\ None = Some e) as [? ?] by eauto using R_functional; congruence.
  - inversion H1; subst; clear H1.
    inversion H2; subst; clear H2.
    + assert (b = b1 /\ Some e = None) as [? ?] by eauto using R_functional; congruence.
    + assert (b1 = b /\ Some e0 = Some e) as [? ?] by eauto using R_functional; inversion H6; subst.
      eapply star_infseq_with_inftrace in H5; eauto. apply IHstar in H5.
      destruct H5 as (it' & ? & ?).
      exists it'; split; auto. cbn. rewrite H5; auto.
Qed.

Lemma infseq_with_inftrace_star_inv'_oneev:
  forall a e it, infseq_with_inftrace a (Cons e it) -> exists b, star a [e] b.
Proof.
  intros. inversion H; subst. destruct t; try congruence.
  cbn in H0. inversion H0; subst.
  inversion H1; subst.
  - replace (e :: t) with ([e] ++ t) in H5 by auto.
    apply star_int with (t' := [e]) (t'' := t) in H5; auto.
    destruct H5 as (b' & ?). exists b'; eapply star_step; eauto.
  - exists b0. eapply star_step_ev; eauto. eapply star_refl.
Qed.

Lemma infseq_with_inftrace_star_inv':
  forall t it' it, it = app_to_itr t it' -> forall a, infseq_with_inftrace a it -> exists b, star a t b.
Proof.
  induction t; intros.
  - exists a; constructor.
  - cbn in H. pose proof H0. rewrite H in H1.
    apply infseq_with_inftrace_star_inv'_oneev in H1. destruct H1 as (b' & ?).
    pose proof H1. eapply star_infseq_with_inftrace_inv in H2; eauto.
    destruct H2 as (it'' & ? & ?). cbn in H3.
    assert (it'' = app_to_itr t it').
    { rewrite H3 in H. inversion H; now subst. }
    specialize (IHt _ _ H4 _ H2). destruct IHt as (b & ?).
    exists b. replace (a :: t) with ([a] ++ t) by auto. eapply star_trans; eauto.
Qed.

Lemma infseq_with_inftrace_star_inv:
  forall a it, infseq_with_inftrace a it -> forall t it', it = app_to_itr t it' -> exists b, star a t b.
Proof.
  eauto using infseq_with_inftrace_star_inv'.
Qed.

Lemma diverges_with_inftrace_finseq_excl:
  forall a t b it,
    star a t b -> irred b -> infseq_with_inftrace a it -> False.
Proof.
  intros.
  eapply infseq_with_inftrace_implies_infseq in H1.
  eapply infseq_finseq_excl; eauto.
Qed.

Lemma infseq_silent_with_inftrace_excl:
  forall a : A, infseq_silent a -> forall it' : inftrace, infseq_with_inftrace a it' -> False.
Proof.
  intros. inversion H0; subst.
  apply plus_star in H1.
  apply infseq_silent_star_inv' in H1; eauto.
Qed.

Lemma diverges_silently_with_inftrace_excl:
  forall a t it,
    diverges_silently a t -> infseq_with_inftrace a it -> False.
Proof.
  intros. unfold diverges_silently in *. destruct H as (b & ? & ?).
  inversion H0; subst.
  eapply star_infseq_with_inftrace_inv in H; eauto.
  destruct H as (b'' & ? & ?).
  eapply infseq_silent_with_inftrace_excl; eauto.
Qed.

CoInductive stream_eq' : inftrace -> inftrace -> Prop :=
  eq'_scons : forall l s1 s2,
    l <> [] -> stream_eq' s1 s2 ->
    stream_eq' (app_to_itr l s1) (app_to_itr l s2).

Lemma deterministic_infseq_with_inftrace': forall a t t',
    infseq_with_inftrace a t -> infseq_with_inftrace a t' -> stream_eq' t t'.
Proof.
  cofix CIH; intros.
  inversion H; inversion H0; subst.
  pose proof (infseq_with_inftrace_inv).
  apply plus_star in H1. apply plus_star in H6.
  specialize (H4 _ _ _ H1 _ _ _ _ H6 H2 H7 H3 H8).
  destruct H4 as [a' [l1 [s1' [s2' [H11 [H12 [H13 [H14 H15]]]]]]]]; auto.
  rewrite H14; rewrite H15.
  econstructor; eauto.
Qed.

Lemma stream_eq'_EqSt : forall it1 it2, stream_eq' it1 it2 -> EqSt it1 it2.
Proof.
  cofix Hfix; intros.
  inversion H; subst; clear H.
  destruct l. congruence.
  simpl.
  destruct l. simpl. constructor. cbn; auto. apply Hfix; auto.
  constructor. cbn; auto.  apply Hfix. constructor. congruence.
  assumption.
Qed.

Lemma deterministic_infseq_with_inftrace:
  forall a t,
    infseq_with_inftrace a t ->
    forall t',
      infseq_with_inftrace a t' ->
      EqSt t t'.
Proof.
  eauto using deterministic_infseq_with_inftrace', stream_eq'_EqSt.
Qed.

End SEQUENCES.


(*** Flattening and mapping ***)

Require Import Arith.
Require Import List.
Require Import Ott.ott_list_core.
Require Import Ott.ott_list_support.
Require Import Ott.ott_list_base.

Section Flat_map.
Variables A B C : Type.
Implicit Types x : A.
Implicit Types y : B.
Implicit Types l xs : list A.
Implicit Types ys : list B.
Implicit Types xss : list (list A).
Implicit Types yss : list (list B).
Implicit Types f : A -> B.
Implicit Types g : B -> C.
Implicit Types F : A -> list B.
Implicit Types G : B -> list C.
Set Implicit Arguments.

Lemma std_eq_flat_map :
  forall F l, List.flat_map F l = flat_map F l.
Proof. induction l; simpl; congruence. Qed.

Lemma length_flat_map :
  forall F l,
    length (flat_map F l) = fold_right plus 0 (map (fun x => length (F x)) l).
Proof. induction l; simpl; autorewrite with lists; congruence. Qed.

Lemma flat_map_app :
  forall F l l', flat_map F (l ++ l') = flat_map F l ++ flat_map F l'.
Proof. intros; induction l; simpl; autorewrite with lists; congruence. Qed.

Lemma flat_map_map :
  forall f G l, flat_map G (map f l) = flat_map (compose G f) l.
Proof.
  intros; induction l; simpl; autorewrite with lists;
    unfold compose in *; congruence.
Qed.

Lemma map_flat_map :
  forall F g l, map g (flat_map F l) = flat_map (compose (map g) F) l.
Proof.
  intros; induction l; simpl; autorewrite with lists;
    unfold compose in *; congruence.
Qed.

Lemma flat_map_identity : forall l, flat_map (fun x => x::nil) l = l.
Proof. induction l; simpl; congruence. Qed.

Lemma flat_map_extensionality :
  forall F F' l, (forall x, F x = F' x) -> flat_map F l = flat_map F' l.
Proof. intros; induction l; simpl; try rewrite H; congruence. Qed.

Lemma flat_map_rev :
  forall F l, flat_map F (rev l) = rev (flat_map (compose (@rev _) F) l).
Proof.
  intros; induction l; simpl. reflexivity.
  unfold compose in *; autorewrite with lists;
    rewrite flat_map_app; simpl; autorewrite with lists. congruence.
Qed.

Definition flatten := flat_map (fun xs => xs).
Lemma unfold_flatten : flatten = flat_map (fun xs => xs).
Proof refl_equal _.

Lemma In_flat_map_intro :
  forall F l x y,
    In x l -> In y (F x) -> In y (flat_map F l).
Proof.
  intros; induction l; simpl in *; destruct H.
  subst; auto with datatypes. auto with datatypes.
Qed.

Lemma In_flat_map_elim :
  forall F l y,
    In y (flat_map F l) ->
    exists x, In x l /\ In y (F x).
Proof.
  intros; induction l; simpl in * . solve [elim H].
  destruct (in_app_or _ _ _ H). subst; eauto with datatypes. firstorder.
Qed.

End Flat_map.

Hint Rewrite std_eq_flat_map
             length_flat_map flat_map_app flat_map_map map_flat_map
             flat_map_identity flat_map_extensionality
             flat_map_rev
             unfold_flatten
             : lists.
Hint Resolve In_flat_map_intro In_flat_map_elim : lists.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** * This module proves the validity of
    - well-founded recursion (also known as course of values)
    - well-founded induction
    from a well-founded ordering on a given set *)

Set Implicit Arguments.

Require Import Notations.
Require Import Logic.
Require Import Datatypes.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Init.Wf.

Section Well_founded.

 Variable A : Type.
 Variable R : A -> A -> Prop.

 Hypothesis Rwf : well_founded R.

 Section FixPoint.

  Variable P : A -> Type.
  Variable F : forall x:A, (forall y:A, R y x -> P y) -> P x.

  (** Proof that [well_founded_induction] satisfies the fixpoint equation.
      It requires an extra property of the functional *)

  Variable EQ : forall a, P a -> P a -> Prop.
  Variable Equiv: forall a: A, Equivalence (@EQ a).

  Hypothesis
    F_ext :
      forall (x:A) (f g:forall y:A, R y x -> P y),
        (forall (y:A) (p:R y x), EQ (f y p) (g y p)) -> EQ (F f) (F g).

  Lemma Fix_F_inv : forall (x:A) (r s:Acc R x), EQ (Fix_F P F r) (Fix_F P F s).
  Proof.
   intro x; induction (Rwf x); intros.
   rewrite <- (Fix_F_eq P F r); rewrite <- (Fix_F_eq P F s); intros.
   apply F_ext; auto.
  Qed.

  Lemma Fix_eq : forall x:A, EQ (Fix Rwf P F x) (F (fun (y:A) (p:R y x) => Fix Rwf P F y)).
  Proof.
   intro x; unfold Fix.
   rewrite <- Fix_F_eq.
   apply F_ext; intros.
   apply Fix_F_inv.
  Qed.

 End FixPoint.

End Well_founded.


Definition teq_shift_dbselect :=
fun (n i j : nat) (eqT gtT ltT : Term) =>
nat_ind
  (fun i0 : nat =>
   forall j0 : nat,
   shift n (dbselect i0 j0 eqT gtT ltT) = dbselect i0 j0 (shift n eqT) (shift n gtT) (shift n ltT))
  (fun j0 : nat =>
   match
     j0 as n0
     return
       (shift n (dbselect 0 n0 eqT gtT ltT) = dbselect 0 n0 (shift n eqT) (shift n gtT) (shift n ltT))
   with
   | 0 => eq_refl
   | S j1 => eq_refl
   end)
  (fun (i0 : nat)
     (IHi : forall j0 : nat,
            shift n (dbselect i0 j0 eqT gtT ltT) =
            dbselect i0 j0 (shift n eqT) (shift n gtT) (shift n ltT)) (j0 : nat) =>
   match
     j0 as n0
     return
       (shift n (dbselect (S i0) n0 eqT gtT ltT) =
        dbselect (S i0) n0 (shift n eqT) (shift n gtT) (shift n ltT))
   with
   | 0 => eq_refl
   | S j1 => IHi j1
   end) i j
     : forall (n i j : nat) (eqT gtT ltT : Term),
       shift n (dbselect i j eqT gtT ltT) = dbselect i j (shift n eqT) (shift n gtT) (shift n ltT).


Require Import ssreflect ssrfun ssrnat ssrbool seq eqtype.
Require Import OtDef ListTools Ssromega Tree Basics ArithAux Commons.

Section RichTextOTDefinition.

Import Equality.

Context {X : eqType} (C : Type) {otX : OTBase X C} {ipX : OTInv _ _ otX} {otcX : OTComp otX}.

Inductive jcmd : Type :=
  | JInsert of nat & seq (tree X)
  | JRemove of nat & seq (tree X)
  | JUnite of nat & X & seq (tree X)
  | JFlat of nat & (tree X)
  | JOpenRoot of nat & jcmd
  | JEditLabel of C.

(* fix unite nop (force it to be non-empty) *)
Fixpoint jinterp (cmd : jcmd) (m : tree X) : option (tree X) :=
match m with | Node x xs =>
 match cmd with
  | JInsert i es => NodeW x (ins i es xs)
  | JRemove i es => NodeW x (rm i es xs)
  | JUnite i y es => if es is [::] then Some (Node x xs) else
   if rm i es xs is Some xs' then NodeW x (ins i [:: Node y es] xs') else None
  | JFlat i (Node z zs) =>
   if nth i xs is Some (Node y ys) then
    if (zs == ys) && (y == z) then NodeW x (oins i ys (rm i [:: Node y ys] xs))
    else None else None
  | JOpenRoot i cmd' => if nth i xs is Some x' then NodeW x (rplc i (jinterp cmd' x') xs) else None
  | JEditLabel cmd => if @interp X C otX cmd x is Some x' then Some (Node x' xs) else None
 end
end.

Fixpoint jinv (cmd : jcmd) :=
match cmd with
  | JInsert n l => JRemove n l
  | JRemove n l => if l is [::] then JInsert 0 [::] else JInsert n l
  | JUnite n x l => if l is [::] then JInsert 0 [::] else JFlat n (Node x l)
  | JFlat n (Node x l) => if l is [::] then JInsert n [:: Node x [::]] else JUnite n x l
  | JOpenRoot n c   => JOpenRoot n (jinv c)
  | JEditLabel c    => JEditLabel (inv c)
end.

Definition tr_ins (len : nat) (n1 n2 : nat) :=
 if (n1 < n2) then n1 else n1 + len.

Definition tr_rem (len : nat) (n1 n2 : nat) :=
 if (n1 < n2) then Some n1 else if (n1 >= n2 + len) then Some (n1 - len) else None.

Definition tr_uni (len : nat) (n1 n2 : nat) :=
 if (n1 < n2) then Some n1 else if (n1 >= n2 + len) then Some (n1 - len + 1) else None.

Definition openroot_in (cmd : seq (tree X) -> jcmd) n1 l1 n2 tc2 :=
  match tr_rem (size l1) n2 n1 with
    None => let i := n2 - n1 in
    if nth i l1 is Some x' then
      match rplc i (jinterp tc2 x') l1 with
        | Some l1' => [:: cmd l1']
        | _ => [:: (* unused *)]
      end
    else [:: (* unused *)]
    | _ => [:: cmd l1]
  end.

Fixpoint jit (op1 op2 : jcmd) (flag : bool) : seq jcmd :=
match op1, op2 with
 | JEditLabel c1, JEditLabel c2 => map JEditLabel  (it c1 c2 flag)
 | _, JEditLabel _ | JEditLabel _, _ => [:: op1]

 | JOpenRoot n1 tc1, JOpenRoot n2 tc2 =>
   if n1 == n2 then map (JOpenRoot n1) (jit tc1 tc2 flag) else [:: op1]

 | JRemove n1 l1, JOpenRoot n2 tc2 => openroot_in (JRemove n1) n1 l1 n2 tc2
 | JOpenRoot n1 tc1, JRemove n2 l2 =>
   match tr_rem (size l2) n1 n2 with
    | Some n1' => [:: JOpenRoot n1' tc1]
    | None     => nil
   end

 | JUnite n1 x1 l1, JOpenRoot n2 tc2 => openroot_in (JUnite n1 x1) n1 l1 n2 tc2
 | JOpenRoot n1 tc1, JUnite n2 _ l2 =>
   match tr_uni (size l2) n1 n2 with
    | Some n1' => [:: JOpenRoot n1' tc1]
    | None => [:: JOpenRoot n2 (JOpenRoot (n1 - n2) tc1)]
   end

 | JFlat n1 (Node x1 l1), JOpenRoot n2 tc2 =>
   (* is it really unnecessary to check nth here? *)
   if (n1 == n2) then
    match jinterp tc2 (Node x1 l1) with
     | Some t1' => [:: JFlat n1 t1']
     | None => [:: (* unused *)]
    end
   else [:: op1]
 | JOpenRoot n1 tc1, JFlat n2 (Node x2 l2) =>
   if (n1 < n2) then [:: op1]
   else if (n2 < n1) then [:: JOpenRoot (n1 + size l2 - 1) tc1]
    else match tc1 with
      | JOpenRoot n' tc' => [:: JOpenRoot (n' + n2) tc']
      | JEditLabel c' => [::]
      | JInsert n' l' => [:: JInsert (n' + n2) l']
      | JRemove n' l' => [:: JRemove (n' + n2) l']
      | JUnite n' x' l' => [:: JUnite (n' + n2) x' l']
      | JFlat n' l' => [:: JFlat (n' + n2) l']
     end

 | _, JOpenRoot _ _ => [:: op1]

 | JOpenRoot n1 tc1, JInsert n2 l2 => [:: JOpenRoot (tr_ins (size l2) n1 n2) tc1]

 | JInsert n1 l1, JInsert n2 l2 =>
  if (n1 == n2) then (if flag then [:: op1] else [:: JInsert (n1 + size l2) l1])
                else [:: JInsert (tr_ins (size l2) n1 n2) l1]

 | JInsert n1 l1, JRemove n2 l2 => if l2 is [::] then [:: op1] else
   let len := size l2 in
    if (n1 <= n2) then [:: op1] else
      if (n1 >= n2 + len) then [:: JInsert (n1 - len) l1] else [::]
 | JRemove n1 l1, JInsert n2 l2 =>
   let (len1, len2) := (size l1, size l2) in
    if (n1 + len1 <= n2) then [:: op1]
      else if (n2 <= n1) then [:: JRemove (n1 + len2) l1]
      else match ins (n2 - n1) l2 l1 with
           | Some l1' => [:: JRemove n1 l1']
           | None => [:: op1] end (* <- this branch is unused *)

 | JInsert n1 l1, JUnite n2 x2 l2 =>
   if l2 is [::] then
     if n2 <= n1 then [:: JInsert n1.+1 l1] else [:: op1]
   else if (n1 <= n2) then [:: op1]
   else if (n1 >= n2 + size l2) then [:: JInsert (n1 - size l2 + 1) l1]
   else [:: JOpenRoot n2 (JInsert (n1 - n2) l1)]
 | JUnite n1 x1 l1, JInsert n2 l2 =>
   if l1 is [::] then if n1 <= n2 then [:: op1] else [:: JUnite (n1 + size l2) x1 l2]
   else if (n2 >= n1 + size l1) then [:: op1]
   else if (n2 <= n1) then [:: JUnite (n1 + size l2) x1 l1]
   else if (ins (n2 - n1) l2 l1) is Some zs then [:: JUnite n1 x1 zs] else [:: (* unused *)]

 | JInsert n1 l1, JFlat n2 (Node x2 l2) =>
   if (n1 <= n2) then [:: op1] else [:: JInsert (n1 + (size l2) - 1) l1]
 | JFlat n1 l1, JInsert n2 l2 =>
   if (n1 < n2) then [:: op1] else [:: JFlat (n1 + size l2) l1]

 | JRemove n1 l1, JRemove n2 l2 =>
   let (len1, len2) := (size l1, size l2) in
   interval_interval_case n1 len1 n2 len2 (mkIIChoice (seq jcmd)
     [:: op1]
     [:: JRemove (n1 - len2) l1]
     [::]
     [:: JRemove n1 (rotr (n2 - n1) (drop len2 (rot (n2 - n1) l1)))]
     [::]
     [:: JRemove n2 (drop (n2 + len2 - n1) l1)]
     [:: JRemove n1 (take (n2 - n1) l1)])

 | JRemove n1 l1, JUnite n2 x2 l2 =>
   let (len1, len2) := (size l1, size l2) in
   if l1 is [::] then [::]
   else if l2 is [::] then [::]
    else let united := (oins (n2 - n1) [:: Node x2 l2] (rm (n2 - n1) l2 l1)) in
    interval_interval_case n1 len1 n2 len2 (mkIIChoice (seq jcmd)
      [:: op1]
      [:: JRemove (n1 - len2).+1 l1]
      (if united is Some l1' then [::JRemove n1 l1'] else [:: (* unused *)])
      (if united is Some l1' then [::JRemove n1 l1'] else [:: (* unused *)])
      [:: JOpenRoot n2 (JRemove (n1 - n2) l1)]
      [:: JOpenRoot n2 (JRemove (n1-n2) (take (len2 + n2 - n1) l1)); JRemove (n2.+1) (drop (len2 + n2 - n1) l1) ]
      [:: JRemove n1 (take (n2 - n1) l1); JOpenRoot n1 (JRemove 0 (drop (n2 - n1) l1))])
  | JUnite n1 x1 l1, JRemove n2 l2 =>
    let (len1, len2) := (size l1, size l2) in
    if l2 is [::] then [::op1]
    else if l1 is [::] then [::] else
    interval_interval_case n1 len1 n2 len2 (mkIIChoice _
      [:: op1]
      [:: JUnite (n1 - len2) x1 l1]
      [::]
      [:: JUnite n1 x1 (rotr (n2 - n1) (drop len2 (rot (n2 - n1) l1)))]
      [::]
      [:: JUnite n2 x1 (drop (n2 + len2 - n1) l1)]
      [:: JUnite n1 x1 (take (n2 - n1) l1)])

  | JRemove n1 l1, JFlat n2 (Node x l2) =>
    if l1 is [::] then [::]
    else if (n1 + size l1 <= n2) then [:: op1]
    else if (n1 > n2) then [:: JRemove (n1 + size l2 - 1) l1]
    else if rm (n2 - n1) [:: Node x l2] l1 is Some ws then
         if ins (n2 - n1) l2 ws is Some zs then
         (if zs is nil then [::] else [:: JRemove n1 zs]) else [:: (* unused *) ] else [:: (* unused *)]
  | JFlat n1 l1, JRemove n2 l2 =>
    if l2 is [::] then [:: op1]
    else if (n1 < n2) then [:: op1] else
    if (n1 >= n2 + size l2) then [:: JFlat (n1 - size l2) l1]
    else [::]

  | JUnite n1 x1 l1, JUnite n2 x2 l2 =>
    let (len1, len2) := (size l1, size l2) in
    interval_interval_case n1 len1 n2 len2 (mkIIChoice _
      [:: op1]
      [:: JUnite (n1 - len2 + 1) x1 l1]
      (if ~~flag then [:: JUnite n1 x1 [:: Node x2 l2]]
       else [:: JOpenRoot n1 (JUnite 0 x1 l2)])
      (if rm (n2 - n1) l2 l1 is Some l1' then
         if ins (n2 - n1) [:: Node x2 l2] l1' is Some l1'' then
           [:: JUnite n1 x1 l1''] else (* unused *) [::] else [::])
      [:: JOpenRoot n2 (JUnite (n1 - n2) x1 l1)]
      (if flag then [:: JFlat n2 (Node x2 l2); op1] else [::])
      (if flag then [:: JFlat n2 (Node x2 l2); op1] else [::]))

  | JUnite n1 x1 l1, JFlat n2 (Node x2 l2) =>
    if (n2 >= n1 + size l1) then [:: op1]
    else if (n2 < n1) then [:: JUnite (n1 + size l2 -1) x1 l1]
    else if rm (n2 - n1) [:: Node x2 l2] l1 is Some ws then
         if ins (n2 - n1) l2 ws is Some zs then
         if zs is [::] then [:: JInsert n1 [:: Node x1 [::]]] else [:: JUnite n1 x1 zs]
         else [:: (* unused *) ] else [:: (* unused *)]
  | JFlat n1 l1, JUnite n2 x2 l2 =>
    match tr_uni (size l2) n1 n2 with
     | Some n1' => [:: JFlat n1' l1]
     | None => [:: JOpenRoot n2 (JFlat (n1 - n2) l1)]
    end

  | JFlat n1 l1, JFlat n2 (Node x2 l2) =>
    if (n1 < n2) then [:: op1]
    else if (n1 == n2) then [::]
    else [:: JFlat (n1 + size l2 - 1) l1]
end.

Fixpoint nonempty_op (t : jcmd) : bool :=
match t with
 | (JEditLabel c) => true
 | (JRemove _ l) => l != nil
 | (JInsert _ l) => l != nil
 | (JUnite _ _ l) => l != nil
 | (JFlat _ l) => true
 | (JOpenRoot _ c) => nonempty_op c
end.

Lemma nonempty_map n l: all nonempty_op [seq JOpenRoot n i | i <- l] = all nonempty_op l.
by elim: l => [|l ls] //= ->. Qed.

Lemma ins_nonempty {Z : eqType} n a2 l1 l2 (l1' : seq Z):
ins n (a2 :: l2) l1 = Some l1' -> l1' != nil.
by elim: n l1 => [l1 [] <- |n IHn [|a l] // /wcons_some [] x [] _ ->]. Qed.

Lemma rplc_nonempty {Z : eqType} n t (l1 : seq Z) b:
 l1 != nil -> rplc n t l1 = Some b -> b != nil.
elim: n l1 => [|n IHn] [|a l1] // _ /=.
 + by case: t => [t|] //= [] <-.
 + by move => /wcons_some [] x [] _ ->. Qed.

Lemma rm0 {Z : eqType} (l : seq Z): rm 0 [::] l = Some l. by case: l. Qed.
(* TODO: Show that the result of transformation of two
         nonempty operations is a composite of nonempty operations *)

Theorem nonempty_it op1 op2 f: nonempty_op op1 -> nonempty_op op2 -> all nonempty_op (jit op1 op2 f).
 elim: op1 op2 => [n1 l1|n1 l1|n1 x1 l1|n1 [x1 l1]|n1 c1 IHc1|c1]
                  [n2 l2|n2 l2|n2 x2 l2|n2 [x2 l2]|n2 c2|c2] //=; eauto;
 try by rewrite ?andbT.
 + (* 1/24 *) by move: (n1 == n2) f => [] [] //=; rewrite andbT.
 + (* 2/24 *) by move: l2 (n1 <= n2) => [|a2 l2] [] //=; try case (_ <= _) => //=; rewrite andbT.
 + (* 3/24 *) by move: l2 (n1 <= n2) => [|a2 l2] [] //=; try case (_ <= _) => //=; rewrite andbT.
 + (* 4/24 *) by move: (n1 <= n2) => [] //=; rewrite ?andbT.
 + (* 5/24 *) move A0: (_ <= _) => [] //=.
  + by rewrite andbT.
  + move A1: (_ <= _) => [] //=. by rewrite ?andbT.
    case A2: (ins _ _ _) => [a|] //=; rewrite ?andbT => //.
    by move: l2 A2 => [|a2 l2] // /ins_nonempty.
 + (* 6/24 TODO: *) case: (interval_cases_analysisP _ _ _ _ _) => //=; rewrite andbT //.
  + rewrite -[rotr _ _ == _]size_eq0 /rotr size_rot size_drop size_rot. case: eqP => //=.
    - move=> -> _. rewrite eq_sym leq_add2l => H [] // H'. move/andP: (conj H' H).
      rewrite -ltn_neqAle -subn_gt0 lt0n //.
    - move/eqP. move=> A B. move/andP:(conj A B). rewrite -ltn_neqAle -subn_gt0 => H.
      move/(leq_sub2r (size l2)). rewrite -addnBA // subnn addn0.
      move/(leq_sub2r n1). rewrite subnAC addnC -addnBA // subnn addn0 -lt0n => /(leq_trans H) //.
  + admit.
  + admit.
 + (* 7/24 TODO: *) admit.
 + (* 8/24 *)
    by move A0: (_ <= _) l1 => [] [|a1 l1'] //=;
    move A1: (_ <= _) => []; case A2: (n2  - n1) => [|n] // _ _;
    try case: (_ == _) => [] //; case: (rm _ _ _) => // [] // a;
    rewrite -?cons_wcons; case: (ins _ _ _) => [[]|].
 + (* 9/24 *) rewrite /openroot_in.
   case: (tr_rem _ _ _) => [] //=; rewrite ?andbT //.
   case: (nth _ _) => [a|] //. case A0: (rplc _ _ _) => [b|] //=.
   rewrite ?andbT. by move: A0 => /rplc_nonempty A0 /A0.
 + (* 10/24 *) repeat (move: (_ <= _) => []); move: l1 l2 => [|a1 l1] [|a2 l2] //=;
   move A0: (ins _ _ _) => [a|] // _ _ /=; move: A0 => /ins_nonempty; by rewrite ?andbT.
 + (* 11/24 TODO *) admit.
 + (* 12/24 TODO *) admit.
 + (* 13/24 *) repeat (move: (_ <= _) => [] //=); try by rewrite ?andbT;
    move A0: (rm _ _ _) => [a|] //; move A1: (ins _ _ _) => [[|b bl]|] //=.
    by rewrite ?andbT. by rewrite ?andbT.
 + (* 14/24 same as 9/24 *) rewrite /openroot_in.
   case: (tr_rem _ _ _) => [] //=; rewrite ?andbT //.
   case: (nth _ _) => [a|] //. case A0: (rplc _ _ _) => [b|] //=.
   rewrite ?andbT. by move: A0 => /rplc_nonempty A0 /A0.
 + (* 15/24 *) by case: (n1 < n2).
 + (* 16/24 *) case: l2 (n1 < n2) => [|a2 l2] [] _ _ //=; case: (_ <= _) => //=.
 + (* 17/24 *) case: (tr_uni _ _ _) => [_|] //=.
 + (* 18/24 *) case: (_ < _) (_ == _) => [] [] //=.
 + (* 19/24 *) by case: (_ == _) => [] //=; case: (jinterp _ _) => [_|] /=.
 + (* 20/24 *) by case: (tr_rem _ _ _) => [_|] //=; rewrite andbT.
 + (* 21/24 *) by case: (tr_uni _ _ _) => [_|] //=; rewrite andbT.
 + (* 22/24 *) move: (n1 < n2) (n2 < n1) => [] [] //= {IHc1}; try by rewrite andbT.
               by case: c1 => //= _ l l'; rewrite andbT.
 + (* 23/24 *) case: (n1 == n2).
  - by move /(IHc1 c2) => A /A; rewrite nonempty_map.
  - by rewrite /= andbT.
 + (* 24/24 *) by elim: (it c1 c2 f) => [] //=. Qed.

Fixpoint jcmdsi cmd : nat :=
match cmd with
 | (JEditLabel c) => @cmdsi X C otX otcX c
 | (JUnite _ _ _) => 1
 | (JInsert  _ _) => 1
 | (JOpenRoot _ c) => jcmdsi c
 | _ => 0
end.

Fixpoint jcmdsz cmd : nat :=
match cmd with
 | (JEditLabel c) => @cmdsz X C otX otcX c
 | (JRemove _ t) => weights t
 | (JInsert _ t) => weights t
 | (JOpenRoot _ c) => jcmdsz c
 | _ => 1
end.

Definition jsz := foldl addn 0 \o map jcmdsz.
Definition jsi := foldl addn 0 \o map jcmdsi.
Definition jcomputability := computability jit jsz jsi.

Ltac comp_unfold := rewrite /jcomputability /computability /flip /jit ?/tr_uni ?/openroot_in ?/tr_rem.

(* TODO: This lemma is true only for nonempty operations *)
(* Lemma jsz_nondg : forall cmd, 0 < jcmdsz cmd.
by elim=> //=; exact: sz_nondg. Qed. *)

Section WeightLemmata.

Lemma weights_ins l1: forall (n : nat) (l : seq (tree X)) r,
  ins n l1 l = Some r -> weights r = weights l1 + weights l.
elim => [l r|n] /=.
 + by case => <-; rewrite weights_app.
 + move => IHn [] // a l r /wcons_some [] x [] /IHn A1 ->.
   by rewrite ?weights_cons addnA (addnC (weights _)) -addnA A1. Qed.

Lemma weights_rm (l1 : seq (tree X)) l2 l3 n: rm n l2 l1 = Some l3 ->
 weights l3 + weights l2 = weights l1.
elim: n l1 l2 l3 => [|n IHn] //.
 + move => l1 l2 l3 => /rm_eq <-. by rewrite weights_app addnC.
 + case => [|a1 l1] /= [|a2 l2] l3 //; try by case => <-.
  + move => /wcons_some [] x [] /IHn; rewrite ?weights_cons => <- ->.
    by rewrite weights_cons ?addnA. Qed.

Lemma weights_Node (x : X) l: weights [:: Node x l] = weights l + 1.
by rewrite {1}/weights /= weight_Node addn0. Qed.

Lemma weights_rplc {n} {t : tree X} {l l1 b}: nth n l = Some l1 ->
rplc n (Some t) l = Some b -> weights b + weight l1 = weight t + weights l.
elim: n l b => [|n IHn] /= [|a l] // b.
 + move => [] -> [] <-. rewrite ?weights_cons. ssromega.
 + move => A0 /wcons_some [] x [] /(IHn _ _ A0) A1 ->; rewrite ?weights_cons. ssromega. Qed.

End WeightLemmata.

Lemma ins_rm_corr {l1 n1 l2 n2}:
   jcomputability (JInsert n1 l1) (JRemove n2 l2).
Proof.  comp_unfold => _. case: l2 => [|l2 l2s] /=.
 - rewrite addn0 [n2 <= n1]leqNgt [n1 <= n2]leqNgt; case: (ltngtP n1 n2) => /=;
   rewrite /jsz /jsi /= ?add0n ?addn0; eauto.
 - case: (int_ptP n2 (size l2s) n1) => /=; try (case A1: ins => [r_ins|] /=);
   rewrite ?leqnn ?leqnSn; eauto; rewrite /jsz /jsi /= ?add0n ?addn0 => _ _; split => //; eauto.
   - by move: A1 => /weights_ins ->.
   - by apply /leq_addl. Qed.

Lemma ins_uni_corr {n1 l1 n2 x2 l2}: jcomputability (JInsert n1 l1) (JUnite n2 x2 l2).
comp_unfold => _. case: l2 => [|l2 l2s] /=.
+ case: (n2 <= n1); rewrite /jsz /jsi /=; nat_norm; eauto.
+ case: (n1 <= n2); case: (n2 + (size l2s).+1 <= n1);
  rewrite /jsz /jsi /=; try (case: (ins _ _ _)); nat_norm; eauto. Qed.

Lemma ins_flat_corr {n1 l1 n2 x2 l2}:
  jcomputability (JInsert n1 l1) (JFlat n2 (Node x2 l2)).
Proof. comp_unfold; rewrite [n1 <= n2]leqNgt => _.
 case: ltngtP => //=; rewrite ?leqnn ?leqnSn; intuition. Qed.

Lemma L0: forall n (l1 l2 : seq (tree_eqType X)),
  weights (rotr n (drop (size l1) (rot n l2))) <= weights l2.
by elim => [|n IHn] l1 l2 /=; rewrite ?weights_rotr ?weights_rot;
 [set j := rot 0 l2 | set j := rot (n.+1) l2];
 move: (weights_drop (size l1) j); rewrite ?weights_rot. Qed.

Lemma rm_rm_corr {n1 l1 n2 l2}:
   jcomputability (JRemove n1 l1) (JRemove n2 l2).
Proof. comp_unfold => _.
 case: (interval_interval_case_analP);
 rewrite /jsz /jsi /= ?addn0 ?add0n; eauto;
 move => _ _; try move => _; split => //;
 try (split; [done| left; split]) => //;
 (try apply leq_add); (try apply weights_drop); (try apply weights_take);
 [rewrite -ltnS -addnS; apply ltn_addl; rewrite ltnS| |
  rewrite addnC -ltnS -addnS; apply ltn_addl; rewrite ltnS |]; apply L0. Qed.

Lemma L1 (l : tree X): weights [:: l] = weight l.
by rewrite /weights /= addn0. Qed.

Lemma L2 n (l : seq (tree X)): weights (take n l) + weights (drop n l) = weights l.
elim: n l => [|n IHn] [|a l] //=. by rewrite ?weights_cons -addnA (IHn l). Qed.

Lemma rm_uni_corr {n1 l1 n2 x2 l2}:
  jcomputability (JRemove n1 l1) (JUnite n2 x2 l2).
Proof. comp_unfold.
 case: (interval_interval_case_analP) => /=;
 move: l1 l2 => [|l1 l1s] [|l2 l2s]; try (by simpl; eauto);
 move => _ _ _; try move => _;
 try (move: (l1 :: l1s) (l2 :: l2s) => l1' l2';
        case A0: (rm _ _ _) => /= [z|]; try case A1: (ins _ _) => [z2|] //=);
 rewrite /jsz /jsi /= ?addn0 ?add0n; eauto;
 (try by move: A0 => /weights_rm <-; move: A1 => /weights_ins ->; rewrite weights_Node;
   split;[ssromega| split;[|right]]);
 [move: ((size l2s).+1 + n2 - n1) => [|n] /=| move: (n2 - n1) => [|n] /=]; eauto;
   rewrite ?weights_cons -?addnA ?addnS addn0 L2 addn0; eauto. Qed.

Lemma rm_flat_corr {n1 l1 n2 x2 l2}:
  jcomputability (JRemove n1 l1) (JFlat n2 (Node x2 l2)).
Proof. comp_unfold => _; case: (int_pt_incP n1 (size l1) n2);
case: l1 => [|a1 l1]; try by (rewrite /jsz /jsi /=; nat_norm; eauto).
case: (n2 - n1) => [|d].
 + simpl. case A0: (a1 == Node x2 l2) => /= _ _; eauto.
   move: A0 => /eqP ->. rewrite rm_id. case A0: (l2 ++ l1) => [|a l]; eauto.
   move: A0 => <-; rewrite /jsz /jsi /= weights_app weights_cons weight_Node; nat_norm.
   split; try split; try done; try left; by elim: (addn _ _) => [] //.
+  move A0: (rm _ _ _) => [[|w ws]|]; try move A1: (ins _ _ _) => [[|z zs]|];
   try by rewrite /jsz /jsi /= ?add0n ?addn0; eauto.
   move: A0 => /weights_rm A0. move: A1 => /weights_ins A1.
   rewrite /jsz /jsi /= ?add0n ?addn0 A1 -A0 weights_Node; intuition.
   ssromega. left. split => //. ssromega. Qed.

Lemma weights_interp {a b c} {l : seq (tree X)} {n}:
nth n l = Some a -> rplc n (jinterp c a) l = Some b ->
   weights b <= (jcmdsz c) + weights l /\ (weights b <= weights l \/ (0 < jcmdsi c)).
elim: c l a n b => [n1 l1|n1 l1 |n1 s l1| n1 t|n1 j IH| c] /= l a n b A0.
 + case: a A0 => [x xs]. move A0: (NodeW _ _) => [[x2 l2]|] //=.
  + move: A0 => /nodew_some [] _ /weights_ins A0 A1 /(weights_rplc A1).
    rewrite ?weight_Node A0 => A2. split. ssromega. by right.
  + by rewrite rplc_none_none.
 + case: a A0 => [x xs]. move A0: (NodeW _ _) => [[x2 l2]|] //=.
  + move: A0 => /nodew_some [] _ /weights_rm A0 A1 /(weights_rplc A1).
    rewrite ?weight_Node -A0 => A2. split. ssromega. left. ssromega.
  + by rewrite rplc_none_none.
 + case: a A0 l1 => [x xs] A0 [|a1 l1] A1.
  + move: (weights_rplc A0 A1) => A2. split. ssromega. by right.
  + move A2: (rm _ _ _) A1 => [xs'|]; try move A3: (NodeW _ _) => [[x2 l2]|] //=;
    try by rewrite rplc_none_none. move => A4.
    move: (weights_rplc A0 A4). move: A3 => /nodew_some [] -> /weights_ins.
    move: A2 => /weights_rm. rewrite weights_Node ?weight_Node => <- ->. split. ssromega. by right.
 + case: a A0 t => [x xs] A0 [z zs]. move A1: (nth _ _) => [[y ys]|];
   try move A22: (_ && _) => [/andP [/eqP A21 /eqP]|]; try move A3: (rm _ _ _) => [a|] /=;
   try move A4: (ins _ _ _) => [c|] /=; try by rewrite rplc_none_none.
   move => /(weights_rplc A0). move: A4 => /weights_ins. move: A3 => /weights_rm.
   rewrite ?weights_Node ?weight_Node => <- -> A2. split; try left; ssromega.
 + case: a A0 => [t l0] A0; case A1: (nth _ _ ) => [x'|];
   try move A2: (rplc n1 _ _) => [l1|] /=; try move => /(weights_rplc A0);
   try move: (IH _ _ _ _ A1 A2) => [] IH0 IH1; try (case A3: (jinterp _ _) A2 => [t1|]);
   try by rewrite ?rplc_none_none. rewrite ?weight_Node. move /(weights_rplc A1) => H0 H1.
   split. ssromega. move: IH1 => [H2|]. left. ssromega. by right.
 + case: a A0 => t1 l1 A1. case: (interp c t1) => [a /(weights_rplc A1)|].
   rewrite ?weight_Node => A2. have: (weights b = weights l) by ssromega.
   move => ->. split. ssromega. left. done. by rewrite rplc_none_none. Qed.

Lemma rm_or_corr {n1 l1 n2 c2} :
  jcomputability (JRemove n1 l1) (JOpenRoot n2 c2).
Proof. comp_unfold; rewrite /tr_rem /openroot_in /tr_rem.
 case: (int_pt_incP n1 (size l1) n2) => /=; eauto;
 case A0: nth => [a|]; eauto.
 case A1: (rplc _ _ _) => [b|]; eauto.
 move => _ _ _. rewrite /jsz /=; nat_norm.
 move: (weights_interp A0 A1) => [H0 H1].
 split. by rewrite addnC. split. done. by case: H1; [left|right]. Qed.

Lemma uni_uni_corr {n1 x1 l1 n2 x2 l2} :
  jcomputability (JUnite n1 x1 l1) (JUnite n2 x2 l2).
Proof. comp_unfold => srv. case: (interval_interval_case_analP) => /=; case: srv => /=; try (by intuition);
 case: rm => [?|]; try (by intuition); case: ins => [?|]; try (by intuition). Qed.

Lemma  uni_flat_corr {n1 x1 l1 n2 x2 l2}:
  jcomputability (JUnite n1 x1 l1) (JFlat n2 (Node x2 l2)).
Proof. comp_unfold.
 case: (int_pt_incP n1 (size l1) n2) => /=; try (by intuition).
 case: rm => [?|]; try (case: ins => [[|??]|]); by intuition. Qed.

Lemma uni_or_corr {n1 x1 l1 n2 c2}:
  jcomputability (JUnite n1 x1 l1) (JOpenRoot n2 c2).
Proof. comp_unfold.
 case: (int_pt_incP n1 (size l1) n2) => /=; try (by intuition).
 case: nth => [?|]; try (case: rplc => [?|]); by intuition. Qed.

Lemma flat_flat_corr {n1 x1 l1 n2 x2 l2}:
  jcomputability (JFlat n1 (Node x1 l1)) (JFlat n2 (Node x2 l2)).
Proof. comp_unfold => _. rewrite eq_sym.
case: (ltngtP n2 n1) => /=; by intuition. Qed.

Lemma flat_or_corr {n1 x1 l1 n2 c2}:
  jcomputability (JFlat n1 (Node x1 l1)) (JOpenRoot n2 c2).
Proof. comp_unfold => _. case: (ltngtP n1 n2) => /=; try (by intuition).
case: c2 => [n' l'|n' l'|n' x' l'|n' [x' l']|n' c'|c1']; case: jinterp => [?|] /=; by intuition. Qed.

Lemma or_or_corr {n1 c1 n2 c2}:
 (forall op2, jcomputability c1 op2) -> jcomputability (JOpenRoot n1 c1) (JOpenRoot n2 c2).
Proof. move=> IH. rewrite /jcomputability /computability /jsz /jsi /flip => /=; rewrite eq_sym.
 case: (n2 == n1) => /= srv; try (by intuition).
 move: (IH c2). rewrite /jcomputability /computability /jsz /jsi /flip => /(_ srv) /= [] H1 [] H2 H3.
 split. rewrite -!map_comp. exact: H1.
 split. by rewrite -!map_comp. rewrite -!map_comp. case: H3 => H3. by left. right. done. Qed.

Lemma el_el_corr {c1 c2}:
  jcomputability (JEditLabel c1) (JEditLabel c2).
Proof.
 comp_unfold; rewrite /jsz /jsi /comp => srv.
 move: (@comp_corr X C otX otcX c1 c2 srv). by rewrite /flip /si /sz -?map_comp. Qed.

Lemma ins_ins_corr {n1 l1 n2 l2} :
  jcomputability (JInsert n1 l1) (JInsert n2 l2).
Proof. by comp_unfold; rewrite eq_sym => srv; case: eqP => H; case: srv => /=; rewrite ?leqnn; intuition. Qed.

Ltac symm1 := rewrite [jsi _ + jsi _]addnC [jsz _ + jsz _]addnC (and_comm (jsz _ <= _))
                      [(jsi ([:: _])) + _]addnC [(jsz ([:: _])) + _]addnC.
Ltac symm2 := rewrite [jsi _ + jsi _]addnC [jsi [:: _] + jsi [:: _]]addnC
                      [jsz _ + jsz _] addnC [jsz [:: _] + jsz [:: _]]addnC
                      (and_comm (jsz _ <= jsz [:: _])).

(*TODO: Fix holes in the proof *)
Theorem jcomp_corr: forall (op1 op2 : jcmd),
  jcomputability op1 op2.
Proof. elim => [n1 l1|n1 l1|n1 x1 l1|n1 [x1 l1]|n1 c1 IHc1|c1]
               [n2 l2|n2 l2|n2 x2 l2|n2 [x2 l2]|n2 c2|c2] srv;
         try (simpl; by comp_unfold; nat_norm; intuition).
  + exact: ins_ins_corr.
  + exact: ins_rm_corr.
  + exact: ins_uni_corr.
  + exact: ins_flat_corr.
  + symm1; exact: ins_rm_corr.
  + exact: rm_rm_corr.
  + exact: rm_uni_corr.
  + exact: rm_flat_corr.
  + exact: rm_or_corr.
  + symm1; exact: ins_uni_corr.
  + symm1; exact: rm_uni_corr.
  + exact: uni_uni_corr.
  + exact: uni_flat_corr.
  + exact: uni_or_corr.
  + symm1; exact: ins_flat_corr.
  + symm1; exact: rm_flat_corr.
  + symm1; exact: uni_flat_corr.
  + exact: flat_flat_corr.
  + exact: flat_or_corr.
  + symm2; exact: rm_or_corr.
  + symm2; exact: uni_or_corr.
  + symm2; exact: flat_or_corr.
  + exact: or_or_corr.
  + exact: el_el_corr. Qed.

Theorem jip1 : forall op m mr, jinterp op m = Some mr -> jinterp (jinv op) mr = (Some m).
Proof. elim => [n1 l1|n1 l1|n1 x1 l1|n1 [x1 l1]|n1 c1 IHc1|c1] [x xs] [rx rxs] //=.
 + by move/nodew_some => []-> /rm_ins_id ->.
 + move/nodew_some => [] ->; case: l1 => [|x1 l1] /=.
  - by rewrite rm_id => [] [] -> /=.
  - by move/ins_rm_id => /(_ (ltn0Sn _)) ->.
 + case: l1 => [|l1 l1s] //=.
   case Hrm: rm => [r_rm|//] /nodew_some [] -> H; move:(H).
   move/ins_some_nth_in => /(_ 0 (ltn0Sn _)). rewrite addn0 => -> /=; rewrite ?eq_refl orm_some /=.
   apply/nodew_some; split => //. move/rm_ins_id: H ->.  by move/ins_rm_id: Hrm => /(_ (ltn0Sn _)).
 + case: l1 => [|l1 l1s] //; case: nth => [r_nth|] //; case: r_nth => [z zs];
   case: eqP =>// <- /=; case: eqP => // <- /nodew_some [] ->; case Hrm: rm => [r_rm|] //=.
  - move=> /ins_id <-. move: Hrm => /ins_rm_id => Hrm. by rewrite Hrm.
   by move/rm_ins_id ->; move/ins_rm_id: Hrm => /(_ (ltn0Sn _)) ->.
 + case Hnth: nth => [r_nth|]// /nodew_some [] <-. case Hjint: jinterp => [r_jint|]; try by rewrite rplc_none_none.
   move=> Hrplc.  move/rplc_nth_eq:(Hrplc) ->.
   by rewrite (IHc1 _ _ Hjint) -Hnth orplc_some -Hrplc orplc_some rplc_rplcC_eq /= (rplc_nth_id' _ _ _ Hnth).
 + case Hinterp: interp => [?|] // [] <- <-.
   by move: (@ip1 _ _ _ ipX _ _ _ Hinterp) ->. Qed.

Instance jOT : OTBase (tree X) jcmd := {interp := jinterp; it := jit}.
(*TODO: Prove commutation *)
admit. Defined.

(*TODO: Restrict to nonempty operations *)
Instance jInv : OTInv (tree X) jcmd jOT := {inv := jinv; ip1 := jip1}.
Instance jCompOT : OTComp jOT := {cmdsz := jcmdsz; cmdsi := jcmdsi; (*sz_nondg := jsz_nondg; *) comp_corr := jcomp_corr}.
Admitted.

End RichTextOTDefinition.

Implicit Arguments JEditLabel [[C] [X]].
Implicit Arguments JInsert [[C] [X]].
Implicit Arguments JRemove [[C] [X]].
Implicit Arguments JUnite [[C] [X]].
Implicit Arguments JFlat [[C] [X]].
Implicit Arguments JOpenRoot [[C] [X]].


Require Import Iron.Language.SystemF2Effect.Value.Relation.TyJudge.

(* Uniqueness of typing.
   Checking an expression always returns a unique type an effect. *)
Lemma typex_unique
 :  forall ke te se sp x t1 e1 t2 e2
 ,  TypeX  ke te se sp x t1 e1
 -> TypeX  ke te se sp x t2 e2
 -> t1 = t2 /\ e1 = e2.
Proof.
 intros. gen ke te se sp t1 e1 t2 e2.
 induction x using exp_mutind with
  (PV := fun v1 => forall ke te se sp t1 t1'
      ,  TypeV ke te se sp v1 t1
      -> TypeV ke te se sp v1 t1'
      -> t1 = t1');
  intros;
   try (solve [inverts_type; try congruence]);
   inverts_type; auto.

 - Case "VLam".
   spec IHx H9 H10.
   burn.

 - Case "VLAM".
   spec IHx H8 H7.
   burn.

 - Case "XVal".
   spec IHx H6 H5.
   burn.

 - Case "XLet".
   spec IHx1 H11 H13.
   spec IHx2 H12 H14.
   rip.

 - Case "XApp".
   spec IHx  H7  H6.
   spec IHx0 H10 H11.
   subst. inverts IHx. auto.

 - Case "VAPP".
   spec IHx H7 H6.
   inverts IHx. auto.

 - Case "XOp1".
   spec IHx H10 H11.
   subst.
   rip; congruence.

 - Case "XPrivate".
   spec IHx H8 H10.
   rip; congruence.

 - Case "XExtend".
   spec IHx H11 H13.
   rip; congruence.

 - Case "XAlloc".
   spec IHx H10 H11.
   subst. burn.

 - Case "XRead".
   spec IHx H10 H11.
   inverts IHx. auto.
Qed.


Definition dbselect_spec_lt :=
fun (i j : nat) (eqT gtT ltT : Term) =>
nat_ind (fun j0 : nat => forall i0 : nat, i0 < j0 -> dbselect i0 j0 eqT gtT ltT = ltT)
  (fun (i0 : nat) (H : i0 < 0) =>
   match i0 as n return (n < 0 -> dbselect n 0 eqT gtT ltT = ltT) with
   | 0 =>
       fun H0 : 0 < 0 =>
       let H1 : 0 = 0 -> eqT = ltT :=
         match H0 in (_ <= n) return (n = 0 -> eqT = ltT) with
         | le_n _ =>
             fun H1 : 1 = 0 =>
             (fun H2 : 1 = 0 =>
              let H3 : False :=
                eq_ind 1 (fun e : nat => match e with
                                         | 0 => False
                                         | S _ => True
                                         end) I 0 H2 in
              False_ind (eqT = ltT) H3) H1
         | le_S _ m H1 =>
             fun H2 : S m = 0 =>
             (fun H3 : S m = 0 =>
              let H4 : False :=
                eq_ind (S m) (fun e : nat => match e with
                                             | 0 => False
                                             | S _ => True
                                             end) I 0 H3 in
              False_ind (1 <= m -> eqT = ltT) H4) H2 H1
         end in
       H1 eq_refl
   | S i1 =>
       fun H0 : S i1 < 0 =>
       let H1 : 0 = 0 -> gtT = ltT :=
         match H0 in (_ <= n) return (n = 0 -> gtT = ltT) with
         | le_n _ =>
             fun H1 : S (S i1) = 0 =>
             (fun H2 : S (S i1) = 0 =>
              let H3 : False :=
                eq_ind (S (S i1)) (fun e : nat => match e with
                                                  | 0 => False
                                                  | S _ => True
                                                  end) I 0 H2 in
              False_ind (gtT = ltT) H3) H1
         | le_S _ m H1 =>
             fun H2 : S m = 0 =>
             (fun H3 : S m = 0 =>
              let H4 : False :=
                eq_ind (S m) (fun e : nat => match e with
                                             | 0 => False
                                             | S _ => True
                                             end) I 0 H3 in
              False_ind (S (S i1) <= m -> gtT = ltT) H4) H2 H1
         end in
       H1 eq_refl
   end H)
  (fun (j0 : nat) (IHj : forall i0 : nat, i0 < j0 -> dbselect i0 j0 eqT gtT ltT = ltT)
     (i0 : nat) (H : i0 < S j0) =>
   match i0 as n return (n < S j0 -> dbselect n (S j0) eqT gtT ltT = ltT) with
   | 0 => fun _ : 0 < S j0 => eq_refl
   | S i1 => fun H0 : S i1 < S j0 => IHj i1 (le_S_n (S i1) j0 H0)
   end H) j i
     : forall (i j : nat) (eqT gtT ltT : Term), i < j -> dbselect i j eqT gtT ltT = ltT.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Import WfExtensionality.

Lemma subtype_sel_equ_sel_upp_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_equ x1 L1 T1') ->
                  forall T2 x2 L2 T2', T2 = (t_sel_upp x2 L2 T2') ->
                                  subtype T1 T2 = orb (andb (eq_var x1 x2)
                                                            (eq_label L1 L2))
                                                      (subtype T1' T2).
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Basic_Cons.Terminal.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.
From Categories Require Import NatTrans.NatTrans NatTrans.Func_Cat.
From Categories Require Import Basic_Cons.Terminal.
From Categories Require Import PreSheaf.PreSheaf.

Section Initial.
  Context (C : Category).

  (** The initial element of the category of presheaves. *)
  Program Definition PSh_Init_Func : Functor (C^op) Type_Cat :=
    {|
      FO := fun _ => (Empty : Type)
    |}.

  Local Hint Resolve NatTrans_eq_simplify : core.
  Local Hint Extern 1 => progress cbn in * : core.

  (** The functor that maps to the empty type in coq is the terminal object of
      presheaves. *)
  Program Instance PSh_Initial : (𝟘_ (PShCat C))%object :=
    {|
      terminal := PSh_Init_Func;
      t_morph := fun u => {|Trans := fun x y => _ |}
    |}.

End Initial.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e221m3_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.ProofIrrelevance.
Require Import Program.

Require Import LensLaws.Isomorphism.
Require Import LensLaws.Functor.

Module Zip.

Parameter F : Set -> Set.

(** Shape *)
Parameter Sh : Set.

(** Index *)
Parameter Ix : Sh -> Set.

(** Container *)
Definition C (A : Set) : Set := sigT (fun (s : Sh) => Ix s -> A).

(** Iso *)
Parameter iso : forall (X : Set), Iso (F X) (C X).

Definition fmapF {A B : Set} (f : A -> B) (x : F A) : F B.
Proof.
  apply (isoFrom (iso B)).
  apply (isoTo (iso A)) in x.
  destruct x as [s ia].
  exists s. intros i.
  apply f. apply ia. exact i. Defined.

(** [F] is a functor. *)
Theorem functorF : IsFunctor F.
Proof.
  apply (@MkFunctor F (@fmapF)).

  - intros A.
    extensionality x.
    unfold fmapF. unfold isoFrom. unfold isoTo.
    destruct (iso A).
    unfold IsInverse in *.
    rewrite (i x) at 2.
    f_equal.
    destruct (f x).
    f_equal.

  - intros A B C' f g.
    extensionality x.
    unfold fmapF. unfold isoFrom. unfold isoTo.
    destruct (iso A) as [fwdA bwdA HA HA'].
    destruct (iso C') as [fwdC bwdC HC HC'].
    destruct (iso B) as [fwdB bwdB HB HB'].
    rewrite <- HB'.
    f_equal. destruct (fwdA x). trivial. Defined.

(** Let us have some operation [zip]. *)
Parameter zip : forall (A B : Set) (x : F A) (y : F B), F (A * B).

(*
Parameter Naturality : forall (A B C D : Set) (x : F A) (y : F B) (f : A -> C) (g : B -> D),
  zip (fmapF f x) (fmapF g y) =
  fmapF (fun (xy : A * B) => let (x', y') := xy in (f x', g y')) (zip x y).
*)

(**
We can define a binary action on [Sh] using given [zip].
[M] stands for monoidal.
*)
Definition M (s z : Sh) : Sh.
Proof.
  set (cx := fun (i : Ix s) => tt).
  set (cy := fun (i : Ix z) => tt).

  set (fx := isoFrom (iso ()) (@existT Sh _ s cx)).
  set (fy := isoFrom (iso ()) (@existT Sh _ z cy)).

  set (fxy := zip fx fy).
  set (cxy := isoTo (iso _) fxy).

  destruct cxy as [sz _].
  exact sz. Defined.

(** If [zip] behaves idempotently, then [M] is idempotent too. *)
Lemma Idempotency :
  (forall (A : Set) (xs : F A), zip xs xs = fmapF (fun x => (x, x)) xs) ->
  (forall (s : Sh), M s s = s).
Proof.
  intros H s.
  unfold M.

  (** we use assumption immediately *)
  rewrite H.

  (** rest is mechanic *)
  unfold fmapF; unfold isoTo; unfold isoFrom.

  destruct (iso (() * ())) as [fwdP bwdP HP HP'].
  rewrite <- HP'.
  destruct (iso ()) as [fwdU bwdU HU HU'].
  rewrite  <- HU'.

  reflexivity. Qed.

End Zip.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e383m421_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Export
        FJ.Base.Notations
	OrderedTypeEx
        FMapAVL
        FMapFacts.

(* Definition of finite maps for defining class tables and typing environments *)

Module M := FMapAVL.Make (Nat_as_OT).
Module P := WProperties_fun Nat_as_OT M.
Module F := P.F.

Definition Map := M.t.

Definition keys {A : Type}(m : Map A) :=
 M.fold (fun k _ ac => k :: ac) m nil.

Definition values {A : Type}(m : Map A) := M.fold (fun _ v ac => v :: ac) m nil.

Definition MapsToDec {A : Type}
  : forall n (m : Map A), {C | M.MapsTo n C m} + {~ M.In n m}.
  refine (fun n m =>
            match M.find n m as r
                  return M.find n m = r -> {C | M.MapsTo n C m} + {~ M.In n m} with
            | None => fun _ => !!
            | Some x => fun _ => [|| x ||]
            end (eq_refl (M.find n m))).
  apply F.find_mapsto_iff ; auto.
  intro H.
  apply F.in_find_iff in H ; try contradiction.
Defined.


(** * Coequalizer **)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Generalizable All Variables.

Set Primitive Projections.
Set Universe Polymorphism.

Require Import COC.Base.Main.

Class IsCoequalizer (C: Category)(X Y: C)(f g: C X Y)
      (Coeq: C)
      (coeq: C Y Coeq)
      (univ: forall {Z: C}{h: C Y Z},
          h \o f == h \o g -> C Coeq Z) :=
  {
    coequalize: coeq \o f == coeq \o g;

    coequalizer_universality: forall Z (h: C Y Z)(Heq: h \o f == h \o g),
        (univ Heq) \o coeq == h;

    coequalizer_uniqueness: forall Z (h: C Y Z)(Heq: h \o f == h \o g)(u: C Coeq Z),
          u \o coeq == h -> u == univ Heq
  }.

Structure Coequalizer (C: Category)(X Y: C)(f g: C X Y) :=
  {
    coequalizer_obj: C;
    coequalizer_map:> C Y coequalizer_obj;
    coequalizer_univ: forall (Z: C)(h:C Y Z), h \o f == h \o g -> C coequalizer_obj Z;

    coequalizer_prf:> IsCoequalizer coequalizer_map coequalizer_univ
  }.
Existing Instance coequalizer_prf.

Notation "[ 'Coequalizer' 'of' f , g 'by' univ 'with' map 'to' Coeq 'in' C ]" :=
  (@Build_Coequalizer C _ _ f g Coeq map univ _).
Notation "[ 'Coequalizer' 'of' f , g 'by' univ 'with' map ]" :=
  [Coequalizer of f,g by univ with map to _ in _].
Notation "[ 'Coequalizer' 'by' univ 'with' map ]" :=
  [Coequalizer of _,_ by univ with map].
Notation "[ 'Coequalizer' 'by' univ ]" := [Coequalizer by univ with _].

Lemma coequalizer_univ_subst
      (C: Category)(X Y: C)(f g: C X Y)
      (coeq: Coequalizer f g)
      (Z: C)(h h': C Y Z)
      (Heq: h \o f == h \o g)
      (Heq': h' \o f == h' \o g):
  h == h' ->
  coequalizer_univ coeq Heq == coequalizer_univ coeq Heq'.
Proof.
  intros Heqh.
  apply coequalizer_uniqueness; symmetry; rewrite <- Heqh.
  now rewrite coequalizer_universality.
Qed.

(** Isomorphic **)
Lemma coequalizer_isomorphic:
  forall (C: Category)(X Y: C)(f g: C X Y)
         (eq eq': Coequalizer f g),
    coequalizer_obj eq === coequalizer_obj eq' in C.
Proof.
  intros; simpl; unfold isomorphic.
  exists (coequalizer_univ eq (coequalize (IsCoequalizer:=eq'))),  (coequalizer_univ eq' (coequalize (IsCoequalizer:=eq))); split.
  - rewrite (coequalizer_uniqueness (coequalize (IsCoequalizer:=eq)) (u:=Id (coequalizer_obj eq))); [| now rewrite cat_comp_id_cod].
    apply coequalizer_uniqueness.
    now rewrite cat_comp_assoc, !coequalizer_universality.
  - rewrite (coequalizer_uniqueness (coequalize (IsCoequalizer:=eq')) (u:=Id (coequalizer_obj eq'))); [| now rewrite cat_comp_id_cod].
    apply coequalizer_uniqueness.
    now rewrite cat_comp_assoc, !coequalizer_universality.
Qed.

(** Example **)
(** Coequalizer of Setoids **)
Class IsRelation (X: Setoid)(R: X -> X -> Prop) :=
  {
    relation_proper:> Proper ((== in X) ==> (== in X) ==> iff) R
  }.

Structure Relation (X: Setoid) :=
  {
    relation_rel:> X -> X -> Prop;
    relation_prf:> IsRelation X relation_rel
  }.
Existing Instance relation_prf.
Notation "[ 'Rel' 'by' rel 'on' X ]" := (@Build_Relation X rel _).

Inductive EquivClosure (A: Setoid)(R: Relation A): A -> A -> Prop :=
| eqcl_base: forall a b, R a b -> EquivClosure R a b
| eqcl_refl: forall a b: A, a == b -> EquivClosure R a b
| eqcl_sym: forall a b: A, EquivClosure R a b -> EquivClosure R b a
| eqcl_trans: forall a b c, EquivClosure R a b -> EquivClosure R b c -> EquivClosure R a c.

Program Instance EquivClosure_Equivalence (A: Setoid)(R: Relation A)
  : Equivalence (EquivClosure R).
Next Obligation.
  now intros x; apply eqcl_refl.
Qed.
Next Obligation.
  now intros x y; apply eqcl_sym.
Qed.
Next Obligation.
  now intros x y z; apply eqcl_trans.
Qed.

Program Definition EqCl (X: Setoid)(R: Relation X) :=
  [Rel by EquivClosure R on X].
Next Obligation.
  split; intros.
  - revert y y0 H H0.
    induction H1; intros.
    + apply eqcl_base.
      now rewrite <- H0, <- H1.
    + rewrite H0, H1 in H.
      now apply eqcl_refl.
    + now apply eqcl_sym, IHEquivClosure.
    + apply eqcl_trans with b.
      * now apply IHEquivClosure1.
      * now apply IHEquivClosure2.
  - rename x into y, y into x, x0 into y0, y0 into x0.
    revert y y0 H H0.
    induction H1; intros.
    + apply eqcl_base.
      now rewrite H0, H1.
    + rewrite <- H0, <- H1 in H.
      now apply eqcl_refl.
    + now apply eqcl_sym, IHEquivClosure.
    + apply eqcl_trans with b.
      * now apply IHEquivClosure1.
      * now apply IHEquivClosure2.
Qed.

Program Definition QuotientSetoid (X: Setoid)(R: Relation X)
        (Heq: Equivalence R) :=
  [Setoid by R on X].

Inductive coequalize_pair (X Y: Setoid)(f g: Map X Y): Y -> Y -> Prop :=
| coequalize_pair_def: forall (x: X)(y y': Y),
    f x == y -> g x == y' ->
    coequalize_pair f g y y'.

Program Definition coequalize_pair_relation (X Y: Setoid)(f g: Map X Y) :=
  [Rel by coequalize_pair f g on Y].
Next Obligation.
  split; intros.
  - destruct H1.
    apply coequalize_pair_def with x.
    + now rewrite H in H1.
    + now rewrite H0 in H2.
  - destruct H1.
    apply coequalize_pair_def with x1.
    + now rewrite H.
    + now rewrite H0.
Qed.

Program Definition coequalizer_of_Setoids (X Y: Setoid)(f g: Map X Y) :=
  [Coequalizer of f, g
    by (fun z h H => [ y :-> h y])
   with [y :-> y]
   to QuotientSetoid (EqCl (coequalize_pair_relation f g)) (EquivClosure_Equivalence Y (coequalize_pair_relation f g))
     in Setoids].
Next Obligation.
  intros y y' Heq.
  now apply eqcl_refl.
Qed.
Next Obligation.
  intros y y' Hr.
  induction Hr.
  - destruct H0.
    rewrite <- H0, <- H1.
    now rewrite (H x).
  - now rewrite H0.
  - now symmetry.
  - now transitivity (h b).
Qed.
Next Obligation.
  now apply eqcl_base, coequalize_pair_def with x.
Qed.


From ITree Require Import
     Indexed.Sum
     Core.Subevent.

From Coq Require Import
     Logic.Eqdep
     Program.Equality
     Vector.

From CTree Require Import
     CTree
     Misc.Vectors
     Interp.Par
     Interp.Fold
     Take
     Eq.

Set Implicit Arguments.

Import CTreeNotations VectorNotations.
Local Open Scope ctree_scope.

Section RR.
  Context {E C: Type -> Type} {X: Type} {HasTau: B1 -< C}.

  (*| Schedule [m] processes in round-robin.
      [m] is the total length of the vector
      [i] counts in reverse m .. 0
      [j] counts from 0 .. m,
      in every step [i + j = m] is invariant.
  Equations rr'' (m: nat) (i j: nat) (H: m = i + j) (x: id j) (v: vec (S i) (ctree E C X)):
    ctree (E +' parE m) C (vec (S i) (ctree E C X)) by wf i :=
    @rr'' _ 0 j _ _ (h :: []) :=      (* j = m /\ i = 0 *)
      (p <- preempt (eq_rec_r (fun m => id m) x H) 1 h;;
       Ret [p]
      );
    @rr'' _ (S i') j _ _ (h :: ts) := (* S i' + j = m *)
      (p <- preempt (eq_rec_r (fun m => id m) (Fin.R (S i') x) _) 1 h ;;
       ps <- @rr'' m i' (S j) _ (FS x) ts ;;
       Ret (p :: ps)
      ).
   *)

  (*| Map [preempt i 1] over a vector [v] -- inductive |*)
  Notation rr' v := (Vector.rectS (fun n _ => ctree (E +' parE) C (vec (S n) (ctree E C X)))
                                  (fun h => x <- preempt 0 1 h ;; Ret [x])
                                  (fun h n t ts => x <- preempt (S n) 1 h ;; xs <- ts ;; Ret (x :: xs)) v).

  (*| Guarded coinduction of [rr'] |*)
  Definition rr {n}: vec (S n) (ctree E C X) -> ctree (E +' parE) C X :=
    cofix F v :=
      v' <- rr' v ;; Guard (F v').

  Lemma unfold_rr {n}: forall (v: vec (S n) (ctree E C X)),
      rr v  ≅  v' <- rr' v ;; Guard (rr v').
  Proof. intros; step; cbn; auto. Qed.

  Lemma unfold_0_rr: forall (h: ctree E C X),
      rr [h] ≅ x <- preempt 0 1 h ;; Guard (rr [x]).
  Proof.
    intros.
    rewrite unfold_rr.
    cbn.
    rewrite bind_bind.
    upto_bind_eq.
    now rewrite bind_ret_l.
  Qed.

  Lemma unfold_Sn_rr {n}:
    forall (h: ctree E C X) (ts: vec (S n) (ctree E C X)),
      rr (h :: ts) ≅
         (x <- preempt (S n) 1 h ;;
          xs <- rr' ts ;;
          Guard (rr (x :: xs))).
  Proof.
    destruct n; intros; rewrite unfold_rr.
    - repeat dependent destruction ts.
      cbn.
      rewrite !bind_bind.
      upto_bind_eq.
      rewrite !bind_bind.
      upto_bind_eq.
      now rewrite !bind_ret_l.
    - do 2 dependent destruction ts.
      simpl.
      repeat (rewrite !bind_bind; upto_bind_eq).
      rewrite !bind_ret_l.
      reflexivity.
  Qed.

End RR.

(* Fair parallel composition *)
(*| Fair parallel operator, warning: not associative |*)
(*| A || B -> br (A^* ; B) (B^*; A) *) (* (A || B) || C == A || (B || C) *)
Definition fair{E C X}`{B1 -< C}`{B2 -< C}`{BN -< C} :
  ctree E C X -> ctree E C X -> ctree (E +' parE) C X :=
  cofix R (P : ctree E C X) (Q : ctree E C X) :=
    brD2
      (n <- branch false (branchN) ;;
       p <- preempt 0 n P ;;
       q <- preempt 1 1 Q ;;
       R p q)
      (n <- branch false (branchN) ;;
       q <- preempt 1 n Q ;;
       p <- preempt 0 1 P ;;
       R p q).

Notation fair_ P Q :=
  (brD2
      (n <- branch false (branchN) ;;
       p <- preempt 0 n P ;;
       q <- preempt 1 1 Q ;;
       fair p q)
      (n <- branch false (branchN) ;;
       q <- preempt 1 n Q ;;
       p <- preempt 0 1 P ;;
       fair p q)
   ).

Lemma unfold_fair {E C X}`{B1 -< C}`{B2 -< C}`{BN -< C}:
  forall (a: ctree E C X) (b: ctree E C X),
    (fair a b) ≅ (fair_ a b).
Proof. intros; step; cbn; auto. Qed.

From CTree Require Import Logic.Ctl.
Import CtlNotations.
Local Open Scope ctl_scope.

Section FairFacts.
  Context {E C: Type -> Type}{ST: Type}{HasStuck: B0 -< C} {HasTau: B1 -< C}
          {he: Handler E ST}.

  #[local] Instance Handler_parplus{hp: Handler parE nat}:
    Handler (E+'parE) (ST*nat) :=
    {|
      hfold _ ef x '(s,t) :=
      match ef with
      | inl1 e => (he.(hfold) e x s, t)
      | inr1 f => (s, hp.(hfold) f x t)
      end
    |}.

  Lemma rr_is_fair:
    forall (n: nat) (v: vec (S n) (ctree E C void)) l,
      <( rr v, l |= AG (AF (now (fun '(_, x) => n = x))) )>.
    Proof.
      Opaque Take.take.
      coinduction R CIH.
      induction n; intros; econstructor.
      - (* i = 1, AF *)
        repeat dependent destruction v. (* v = [h] *)
        rewrite unfold_0_rr,
          unfold_Sn_preempt,
          bind_bind.
        apply ctl_af_ax; right; unfold ax; cbn; intros * TR.
        eapply trans_trigger_inv in TR as ([] & ? & ->).
        now apply MatchA.
      - (* i = 1, { AG } *)
        do 2 dependent destruction v. (* v = h :: ts *)
        intros.
        rewrite unfold_0_rr,
          unfold_Sn_preempt,
          bind_trigger,
          bind_vis in H.
        apply trans_vis_inv in H as ([] & ? & ->).
        step; econstructor.
        + now apply MatchA.
        + intros.
          (* Magic induction incantation *)
          unfold trans, transR in H0; cbn in H0.
          remember (observe t') as obst'.
          remember (observe t'0) as obst'0.
          revert t'0 Heqobst'0  t' Heqobst' h H.
          induction H0; try contradiction; intros; cbn in t', t'0; subst.
          * eapply IHtrans_; auto.
            rewrite (ctree_eta t') in H.
            rewrite <- Heqobst' in H.
            desobs h; try contradiction.
            -- rewrite bind_vis in H; step in H; inv H.
            -- destruct vis; rewrite bind_br in H.
               ++ step in H; inv H.
               ++ apply equ_br_invT in H as H1.
                  destruct H1 as (-> & _).
                  apply equ_br_invE in H as (-> & ?).
                  rewrite H.
                  instantiate (1:= BrD _ _).
                  cbn.
                  Fail rewrite (ctree_eta (k0 x)). (* why this fails? *)
                  admit.
          * rewrite (ctree_eta t') in H0.
            rewrite <- Heqobst' in H0.
            desobs h; try contradiction.
            -- rewrite bind_vis in H0; step in H0; inv H0.
            -- destruct vis; rewrite bind_br in H0.
               ++ apply equ_br_invT in H0 as H1.
                  destruct H1 as (-> & _).
                  apply equ_br_invE in H0 as (-> & ?).
                  apply observe_equ_eq in Heqobst'0.
                  rewrite <- Heqobst'0 in *; clear t'0 Heqobst'0.
                  rewrite <- H, H0.
                  rewrite unfold_0_take,
                    translate_ret,
                    bind_ret_l,
                    ctl_t_ag_af_guard.
                  apply CIH.
               ++ step in H0; inv H0.
          * apply observe_equ_eq in Heqobst'0.
            rewrite <- Heqobst'0 in *; clear t'0 Heqobst'0.
            rewrite (ctree_eta t') in H0.
            rewrite <- Heqobst' in H0.
            rewrite <- H.
            desobs h; try contradiction.
            -- rewrite bind_vis in H0.
               apply equ_vis_invT in H0 as H1; subst.
               apply equ_vis_invE in H0 as (-> & ?).
               rewrite H0.
               rewrite unfold_0_take,
                    translate_ret,
                    bind_ret_l,
                    ctl_t_ag_af_guard.
               apply CIH.
            -- destruct vis; rewrite bind_br in H0; step in H0; inv H0.
      - (* i = S n, AF *)
        dependent destruction v.
        rewrite unfold_Sn_rr,
          unfold_Sn_preempt,
          bind_bind.
        apply ctl_af_ax; right; unfold ax; cbn; intros * TR.
        eapply trans_trigger_inv in TR as ([] & ? & ->).
        now apply MatchA.
      - (* i = S n, { AG } *)
        do 2 dependent destruction v. (* v = h :: ts *)
        intros.
        rewrite unfold_Sn_rr,
          unfold_Sn_preempt,
          bind_trigger,
          bind_vis in H.
        apply trans_vis_inv in H as ([] & ? & ->).
        step; econstructor.
        + now apply MatchA.
        + intros.
          (* Magic induction incantation *)
          unfold trans, transR in H0; cbn in H0.
          remember (observe t') as obst'.
          remember (observe t'0) as obst'0.
          revert t'0 Heqobst'0  t' Heqobst' h H.
          induction H0; try contradiction; intros; cbn in t', t'0; subst.
          * eapply IHtrans_; auto.
            rewrite (ctree_eta t') in H.
            rewrite <- Heqobst' in H.
            desobs h; try contradiction.
            -- rewrite bind_vis in H; step in H; inv H.
            -- destruct vis; rewrite bind_br in H.
               ++ step in H; inv H.
               ++ apply equ_br_invT in H as H1.
                  destruct H1 as (-> & _).
                  apply equ_br_invE in H as (-> & ?).
                  rewrite H.
                  instantiate (1:= BrD _ _).
                  cbn.
                  Fail rewrite (ctree_eta (k0 x)). (* why this fails? *)
                  admit.
          * rewrite (ctree_eta t') in H0.
            rewrite <- Heqobst' in H0.
            desobs h; try contradiction.
            -- rewrite bind_vis in H0; step in H0; inv H0.
            -- destruct vis; rewrite bind_br in H0.
               ++ apply equ_br_invT in H0 as H1.
                  destruct H1 as (-> & _).
                  apply equ_br_invE in H0 as (-> & ?).
                  apply observe_equ_eq in Heqobst'0.
                  rewrite <- Heqobst'0 in *; clear t'0 Heqobst'0.
                  rewrite <- H, H0; clear H H0.
                  rewrite unfold_0_take,
                    translate_ret,
                    bind_ret_l.
                  dependent destruction v; cbn.
                  ** rewrite bind_bind,
                       unfold_Sn_preempt,
                       bind_trigger,
                       bind_vis.
                     desobs h0; try contradiction.
                     ---
                     admit.
                  ** admit.
               ++ step in H0; inv H0.
          * apply observe_equ_eq in Heqobst'0.
            rewrite <- Heqobst'0 in *; clear t'0 Heqobst'0.
            rewrite (ctree_eta t') in H0.
            rewrite <- Heqobst' in H0.
            rewrite <- H.
            desobs h; try contradiction.
            -- rewrite bind_vis in H0.
               apply equ_vis_invT in H0 as H1; subst.
               apply equ_vis_invE in H0 as (-> & ?).
               rewrite H0.
               rewrite unfold_0_take,
                    translate_ret,
                 bind_ret_l.
               cbn.
               admit.
            -- destruct vis; rewrite bind_br in H0; step in H0; inv H0.
    Admitted.
  End FairFacts.


  Inductive term : Set :=
    | Srt : sort -> term
    | Ref : nat -> term
    | Abs : term -> term -> term
    | App : term -> term -> term
    | Prod : term -> term -> term.

  (* Variable bindings and free variables *)

  Inductive subt_bind (T M : term) : term -> Prop :=
    | Bsbt_abs : subt_bind T M (Abs T M)
    | Bsbt_prod : subt_bind T M (Prod T M).

  Inductive subt_nobind (m : term) : term -> Prop :=
    | Nbsbt_abs : forall n : term, subt_nobind m (Abs m n)
    | Nbsbt_app_l : forall v : term, subt_nobind m (App m v)
    | Nbsbt_app_r : forall u : term, subt_nobind m (App u m)
    | Nbsbt_prod : forall n : term, subt_nobind m (Prod m n).

  Hint Resolve Bsbt_abs Bsbt_prod Nbsbt_abs Nbsbt_app_l Nbsbt_app_r
    Nbsbt_prod: pts.

  Inductive free_db : nat -> term -> Prop :=
    | Db_srt : forall (n : nat) (s : sort), free_db n (Srt s)
    | Db_ref : forall k n : nat, k > n -> free_db k (Ref n)
    | Db_abs :
        forall (k : nat) (A M : term),
        free_db k A -> free_db (S k) M -> free_db k (Abs A M)
    | Db_app :
        forall (k : nat) (u v : term),
        free_db k u -> free_db k v -> free_db k (App u v)
    | Db_prod :
        forall (k : nat) (A B : term),
        free_db k A -> free_db (S k) B -> free_db k (Prod A B).

  Hint Resolve Db_srt Db_ref Db_abs Db_app Db_prod: pts.

  (* Relocation and substitution *)

  Fixpoint lift_rec (n : nat) (t : term) {struct t} :
   nat -> term :=
    fun k =>
    match t with
    | Srt s => Srt s
    | Ref i =>
        Ref match le_gt_dec k i with
            | left _ => n + i
            | right _ => i
            end
    | Abs a m => Abs (lift_rec n a k) (lift_rec n m (S k))
    | App u v => App (lift_rec n u k) (lift_rec n v k)
    | Prod a b => Prod (lift_rec n a k) (lift_rec n b (S k))
    end.

  Definition lift (n : nat) (N : term) := lift_rec n N 0.

  Fixpoint subst_rec (ts t : term) {struct t} : nat -> term :=
    fun k =>
    match t with
    | Srt s => Srt s
    | Ref i =>
        match lt_eq_lt_dec k i with
        | inleft (left _) => Ref (pred i)
        | inleft (right _) => lift k ts
        | inright _ => Ref i
        end
    | Abs a m => Abs (subst_rec ts a k) (subst_rec ts m (S k))
    | App u v => App (subst_rec ts u k) (subst_rec ts v k)
    | Prod a b => Prod (subst_rec ts a k) (subst_rec ts b (S k))
    end.

  Definition subst (N M : term) := subst_rec N M 0.

  Theorem lift_naif : forall (n : nat) (t : term), {u : term | u = lift n t}.
intros; exists (lift n t); trivial.
Qed.

  Theorem subst_naif : forall u v : term, {t : term | t = subst u v}.
intros; exists (subst u v); trivial.
Qed.

  Lemma lift_ref_ge :
   forall k n p : nat, p <= n -> lift_rec k (Ref n) p = Ref (k + n).
Proof.
intros; simpl in |- *.
elim (le_gt_dec p n); auto with arith.
intro; absurd (p <= n); auto with arith.
Qed.

  Lemma lift_ref_lt :
   forall k n p : nat, p > n -> lift_rec k (Ref n) p = Ref n.
Proof.
intros; simpl in |- *.
elim (le_gt_dec p n); auto with arith.
intro; absurd (p <= n); auto with arith.
Qed.

  Lemma subst_ref_lt :
   forall (u : term) (n k : nat), k > n -> subst_rec u (Ref n) k = Ref n.
Proof.
simpl in |- *; intros.
elim (lt_eq_lt_dec k n); intros; auto with arith.
elim a; intros.
absurd (k <= n); auto with arith.

inversion_clear b in H.
elim gt_irrefl with n; auto with arith.
Qed.

  Lemma subst_ref_gt :
   forall (u : term) (n k : nat),
   n > k -> subst_rec u (Ref n) k = Ref (pred n).
Proof.
simpl in |- *; intros.
elim (lt_eq_lt_dec k n); intros.
elim a; intros; auto with arith.
inversion_clear b in H.
elim gt_irrefl with n; auto with arith.

absurd (k <= n); auto with arith.
Qed.

  Lemma subst_ref_eq :
   forall (u : term) (n : nat), subst_rec u (Ref n) n = lift n u.
Proof.
intros; simpl in |- *.
elim (lt_eq_lt_dec n n); intros.
elim a; intros; auto with arith.
elim lt_irrefl with n; auto with arith.

elim gt_irrefl with n; auto with arith.
Qed.

  Lemma lift_rec0 : forall (M : term) (k : nat), lift_rec 0 M k = M.
Proof.
simple induction M; simpl in |- *; intros; auto with arith.
elim (le_gt_dec k n); auto with arith.

rewrite H; rewrite H0; auto with arith.

rewrite H; rewrite H0; auto with arith.

rewrite H; rewrite H0; auto with arith.
Qed.

  Lemma lift0 : forall M : term, lift 0 M = M.
Proof fun M : term => lift_rec0 M 0.

  Lemma simpl_lift_rec :
   forall (M : term) (n k p i : nat),
   i <= k + n ->
   k <= i -> lift_rec p (lift_rec n M k) i = lift_rec (p + n) M k.
Proof.
simple induction M; simpl in |- *; intros; auto with arith.
elim (le_gt_dec k n); intros.
elim (le_gt_dec i (n0 + n)); intros.
rewrite plus_assoc; auto with arith.

absurd (i <= n0 + n); auto with arith.
rewrite plus_comm.
apply le_trans with (k + n0); auto with arith.

elim (le_gt_dec i n); intros; auto with arith.
absurd (k <= n); auto with arith.
apply le_trans with i; auto with arith.

rewrite H; auto with arith; rewrite H0; simpl in |- *; auto with arith.

rewrite H; auto with arith; rewrite H0; simpl in |- *; auto with arith.

rewrite H; auto with arith; rewrite H0; simpl in |- *; auto with arith.
Qed.

  Lemma simpl_lift :
   forall (M : term) (n : nat), lift (S n) M = lift 1 (lift n M).
Proof.
intros; unfold lift in |- *.
rewrite simpl_lift_rec; auto with arith.
Qed.

  Lemma permute_lift_rec :
   forall (M : term) (n k p i : nat),
   i <= k ->
   lift_rec p (lift_rec n M k) i = lift_rec n (lift_rec p M i) (p + k).
Proof.
simple induction M; intros; auto with arith.
unfold lift_rec at 2 4 in |- *.
elim (le_gt_dec k n); elim (le_gt_dec i n); intros.
rewrite lift_ref_ge; auto with arith.
rewrite lift_ref_ge; auto with arith.
elim plus_assoc_reverse with p n0 n.
elim plus_assoc_reverse with n0 p n.
elim plus_comm with p n0; auto with arith.

apply le_trans with n; auto with arith.

absurd (i <= n); auto with arith.
apply le_trans with k; auto with arith.

rewrite lift_ref_ge; auto with arith.
rewrite lift_ref_lt; auto with arith.

rewrite lift_ref_lt; auto with arith.
rewrite lift_ref_lt; auto with arith.
apply le_gt_trans with k; auto with arith.

simpl in |- *.
rewrite H; auto with arith; rewrite H0; auto with arith.
rewrite plus_n_Sm; auto with arith.

simpl in |- *.
rewrite H; auto with arith; rewrite H0; auto with arith.

simpl in |- *.
rewrite H; auto with arith; rewrite H0; auto with arith.
rewrite plus_n_Sm; auto with arith.
Qed.

  Lemma permute_lift :
   forall (M : term) (k : nat),
   lift 1 (lift_rec 1 M k) = lift_rec 1 (lift 1 M) (S k).
Proof fun (M : term) (k : nat) => permute_lift_rec M 1 k 1 0 (le_O_n k).

  Lemma simpl_subst_rec :
   forall (N M : term) (n p k : nat),
   p <= n + k ->
   k <= p -> subst_rec N (lift_rec (S n) M k) p = lift_rec n M k.
Proof.
simple induction M; intros; auto with arith.
unfold lift_rec in |- *.
elim (le_gt_dec k n); intros.
rewrite subst_ref_gt; auto with arith.
red in |- *; red in |- *.
apply le_trans with (S (n0 + k)); simpl in |- *; auto with arith.

rewrite subst_ref_lt; auto with arith.
apply le_gt_trans with k; auto with arith.

simpl in |- *.
rewrite H; auto with arith; rewrite H0; auto with arith.
elim plus_n_Sm with n k; auto with arith.

simpl in |- *.
rewrite H; auto with arith; rewrite H0; auto with arith.

simpl in |- *.
rewrite H; auto with arith; rewrite H0; auto with arith.
elim plus_n_Sm with n k; auto with arith.
Qed.

  Lemma simpl_subst :
   forall (N M : term) (n p : nat),
   p <= n -> subst_rec N (lift (S n) M) p = lift n M.
Proof.
intros; unfold lift in |- *.
apply simpl_subst_rec; auto with arith.
Qed.

  Lemma commut_lift_subst_rec :
   forall (M N : term) (n p k : nat),
   k <= p ->
   lift_rec n (subst_rec N M p) k = subst_rec N (lift_rec n M k) (n + p).
Proof.
simple induction M; intros; auto with arith.
unfold subst_rec at 1, lift_rec at 2 in |- *.
elim (lt_eq_lt_dec p n); elim (le_gt_dec k n); intros.
elim a0.
case n; intros.
inversion_clear a1.

unfold pred in |- *.
rewrite lift_ref_ge; auto with arith.
rewrite subst_ref_gt; auto with arith.
elim plus_n_Sm with n0 n1; auto with arith.

apply le_trans with p; auto with arith.

simple induction 1.
rewrite subst_ref_eq.
unfold lift in |- *.
rewrite simpl_lift_rec; auto with arith.

absurd (k <= n); auto with arith.
apply le_trans with p; auto with arith.
elim a; auto with arith.
simple induction 1; auto with arith.

rewrite lift_ref_ge; auto with arith.
rewrite subst_ref_lt; auto with arith.

rewrite lift_ref_lt; auto with arith.
rewrite subst_ref_lt; auto with arith.
apply le_gt_trans with p; auto with arith.

simpl in |- *.
rewrite plus_n_Sm.
rewrite H; auto with arith; rewrite H0; auto with arith.

simpl in |- *; rewrite H; auto with arith; rewrite H0; auto with arith.

simpl in |- *; rewrite plus_n_Sm.
rewrite H; auto with arith; rewrite H0; auto with arith.
Qed.

  Lemma commut_lift_subst :
   forall (M N : term) (k : nat),
   subst_rec N (lift 1 M) (S k) = lift 1 (subst_rec N M k).
Proof.
intros; unfold lift in |- *.
rewrite commut_lift_subst_rec; auto with arith.
Qed.

  Lemma distr_lift_subst_rec :
   forall (M N : term) (n p k : nat),
   lift_rec n (subst_rec N M p) (p + k) =
   subst_rec (lift_rec n N k) (lift_rec n M (S (p + k))) p.
Proof.
simple induction M; intros; auto with arith.
unfold subst_rec at 1 in |- *.
elim (lt_eq_lt_dec p n); intro.
elim a.
case n; intros.
inversion_clear a0.

unfold pred, lift_rec at 1 in |- *.
elim (le_gt_dec (p + k) n1); intro.
rewrite lift_ref_ge; auto with arith.
elim plus_n_Sm with n0 n1.
rewrite subst_ref_gt; auto with arith.
red in |- *; red in |- *; apply le_n_S.
apply le_trans with (n0 + (p + k)); auto with arith.
apply le_trans with (p + k); auto with arith.

rewrite lift_ref_lt; auto with arith.
rewrite subst_ref_gt; auto with arith.

simple induction 1.
unfold lift in |- *.
rewrite <- permute_lift_rec; auto with arith.
rewrite lift_ref_lt; auto with arith.
rewrite subst_ref_eq; auto with arith.

rewrite lift_ref_lt; auto with arith.
rewrite lift_ref_lt; auto with arith.
rewrite subst_ref_lt; auto with arith.

simpl in |- *; replace (S (p + k)) with (S p + k); auto with arith.
rewrite H; rewrite H0; auto with arith.

simpl in |- *; rewrite H; rewrite H0; auto with arith.

simpl in |- *; replace (S (p + k)) with (S p + k); auto with arith.
rewrite H; rewrite H0; auto with arith.
Qed.

  Lemma distr_lift_subst :
   forall (M N : term) (n k : nat),
   lift_rec n (subst N M) k = subst (lift_rec n N k) (lift_rec n M (S k)).
Proof fun (M N : term) (n : nat) => distr_lift_subst_rec M N n 0.

  Lemma distr_subst_rec :
   forall (M N P : term) (n p : nat),
   subst_rec P (subst_rec N M p) (p + n) =
   subst_rec (subst_rec P N n) (subst_rec P M (S (p + n))) p.
Proof.
simple induction M; auto with arith; intros.
unfold subst_rec at 2 in |- *.
elim (lt_eq_lt_dec p n); intro.
elim a.
case n; intros.
inversion_clear a0.

unfold pred, subst_rec at 1 in |- *.
elim (lt_eq_lt_dec (p + n0) n1); intro.
elim a1.
case n1; intros.
inversion_clear a2.

rewrite subst_ref_gt; auto with arith.
rewrite subst_ref_gt; auto with arith.
apply gt_le_trans with (p + n0); auto with arith.

simple induction 1.
rewrite subst_ref_eq; auto with arith.
rewrite simpl_subst; auto with arith.

rewrite subst_ref_lt; auto with arith.
rewrite subst_ref_gt; auto with arith.

simple induction 1.
rewrite subst_ref_lt; auto with arith.
rewrite subst_ref_eq.
unfold lift in |- *.
rewrite commut_lift_subst_rec; auto with arith.

do 3 (rewrite subst_ref_lt; auto with arith).

simpl in |- *; replace (S (p + n)) with (S p + n); auto with arith.
rewrite H; auto with arith; rewrite H0; auto with arith.

simpl in |- *; rewrite H; rewrite H0; auto with arith.

simpl in |- *; replace (S (p + n)) with (S p + n); auto with arith.
rewrite H; rewrite H0; auto with arith.
Qed.

  Lemma distr_subst :
   forall (P N M : term) (k : nat),
   subst_rec P (subst N M) k = subst (subst_rec P N k) (subst_rec P M (S k)).
Proof fun (P N M : term) (k : nat) => distr_subst_rec M N P k 0.