From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path.
From Coq Require Import Eqdep Relation_Operators.
From pcm Require Import pred prelude ordtype finmap pcm unionmap heap.
From DiSeL Require Import Freshness State EqTypeX Protocols Worlds NetworkSem.
From DiSeL Require Import Rely Actions Injection Process Always.
From DiSeL Require Import HoareTriples InferenceRules InductiveInv While.
From DiSeL Require Import CalculatorProtocol CalculatorInvariant.
From DiSeL Require Import CalculatorClientLib CalculatorServerLib.
From DiSeL Require Import DelegatingCalculatorServer SimpleCalculatorServers.

Export CalculatorProtocol.

Section CalculatorApp.

Definition l1 := 1.
Definition l2 := 2.
Lemma lab_dis : l2 != l1. Proof. by []. Qed.

Definition f args :=
  match args with
  | x::y::_ => Some (x + y)
  | _ => None
  end.

Definition prec (args : input) :=
  if args is x::y::_ then true else false.

Lemma prec_valid :
  forall i, prec i -> exists v, f i = Some v.
Proof. by move=>i; case: i=>//=x; case=>//y _ _; eexists _. Qed.

(* Two overlapping calculator systems *)
(* System 1: one server, one client *)
Definition cs1 := [::1].
Definition cls1 := [::2].

(* System 2: one server, one client *)
Definition cs2 := [::3].
Definition cls2 := [::1].

Notation nodes1 := (cs1 ++ cls1).
Notation nodes2 := (cs2 ++ cls2).
Lemma Huniq1 : uniq nodes1. Proof. by []. Qed.
Lemma Huniq2 : uniq nodes2. Proof. by []. Qed.

(* Protocol I'm a server in *)
Notation cal1 := (cal_with_inv l1 f prec cs1 cls1).
Notation cal2 := (cal_with_inv l2 f prec cs2 cls2).

Notation W1 := (mkWorld cal1).
Notation W2 := (mkWorld cal2).

(* Composite world *)
Definition V := W1 \+ W2.
Lemma validV : valid V.
Proof.
rewrite /V; apply/andP=>/=.
split; first by rewrite validPtUn/= validPt/= domPt inE/=.
by rewrite unitR valid_unit.
Qed.

(* This server node *)
Definition sv : nid := 1.
Definition cl : nid := 2.
(* It's a server in protocol cal1 *)
Lemma  Hs1 : sv \in cs1. Proof. by []. Qed.
(* It's a client in protocol cal2 *)
Lemma  Hc2 : sv \in cls2. Proof. by []. Qed.
Lemma Hc1 : cl \in cls1. Proof. by []. Qed.
(* Delegate server *)
Definition sd := 3.
Lemma Hs2 : sd \in cs2. Proof. by []. Qed.

Notation loc i k := (getLocal sv (getStatelet i k)).
Notation loc1 i := (loc i l1).
Notation loc2 i := (loc i l2).

(****************************************************)
(***********        Initial state     ***************)
(****************************************************)

Definition init_loc := st :-> ([::] : reqs).

Definition init_dstate1 := sv \\-> init_loc \+ cl \\-> init_loc.
Definition init_dstate2 := sv \\-> init_loc \+ sd \\-> init_loc.

Lemma valid_init_dstate1 : valid init_dstate1.
Proof.
case: validUn=>//=;
do?[case: validUn=>//; do?[rewrite ?validPt/=//]|by rewrite validPt/=].
by move=>k; rewrite !domPt !inE/==>/eqP<-/eqP.
Qed.

Lemma valid_init_dstate2 : valid init_dstate2.
Proof.
case: validUn=>//=;
do?[case: validUn=>//; do?[rewrite ?validPt/=//]|by rewrite validPt/=].
by move=>k; rewrite !domPt !inE/==>/eqP<-/eqP.
Qed.

Notation init_dstatelet1 := (DStatelet init_dstate1 Unit).
Notation init_dstatelet2 := (DStatelet init_dstate2 Unit).

Definition init_state : state :=
  l1 \\-> init_dstatelet1 \+ l2 \\-> init_dstatelet2.

Lemma validI : valid init_state.
Proof.
case: validUn=>//=; do?[case: validUn=>//;
  do?[rewrite ?gen_validPt/=//]|by rewrite validPt/=];
  by move=>k; rewrite !domPt !inE/==>/eqP<-/eqP.
Qed.

Lemma coh1': calcoh prec cs1 cls1 init_dstatelet1 /\
             CalcInv l1 f prec cs1 cls1 init_dstatelet1.
Proof.
split; last by move=>?????????/=/esym/unitbP/=; rewrite um_unitbPtUn.
split=>//; rewrite ?valid_init_dstate1//.
- split; first by rewrite valid_unit.
  by move=>m ms; rewrite find0E.
- move=>z; rewrite /=/init_dstate1 domUn !inE/= valid_init_dstate1/=.
  by rewrite !domPt !inE !(eq_sym z).
move=>n/=; rewrite inE=>/orP; case=>//=.
- move/eqP=>->/=; exists [::]=>/=.
  rewrite /getLocal/init_dstate1/= findUnL?valid_init_dstate1//.
  by rewrite domPt/= findPt/=.
rewrite inE=>/eqP=>->; exists [::]=>/=.
rewrite /getLocal/init_dstate1/= findUnL?valid_init_dstate1//.
by rewrite domPt/= findPt.
Qed.

Lemma coh1 : l1 \\-> init_dstatelet1 \In Coh W1.
Proof.
split=>//.
- apply/andP; split; last by rewrite valid_unit.
  by rewrite ?validPt.
- by rewrite validPt/=.
- by apply: hook_complete_unit.
- by move=>z; rewrite !domPt !inE/=.
move=>k; case B: (l1==k); last first.
- have X: (k \notin dom W1.1).
    by rewrite /init_state/W1/=!domPt !inE/=; move/negbT: B.
  by rewrite /getProtocol /getStatelet/= ?findPt2 eq_sym !B/=.
move/eqP:B=>B; subst k; rewrite prEq/getStatelet/init_state findPt/=.
exact: coh1'.
Qed.

Lemma coh2' : calcoh prec cs2 cls2 init_dstatelet2 /\
              CalcInv l2 f prec cs2 cls2 init_dstatelet2.
Proof.
split; last by move=>?????????/=/esym/unitbP/=; rewrite um_unitbPtUn.
split=>//; rewrite ?valid_init_dstate2//.
- split; first by rewrite valid_unit.
  by move=>m ms; rewrite find0E//.
- move=>z; rewrite /=/init_dstate2 domUn !inE/= valid_init_dstate2//=.
  by rewrite !domPt !inE !(eq_sym z) orbC.
move=>n/=; rewrite inE=>/orP; case=>//=.
- move/eqP=>->/=; exists [::]=>/=.
  rewrite /getLocal/init_dstate2/= findUnL?valid_init_dstate2//.
  by rewrite domPt/= findPt/=.
rewrite inE=>/eqP=>->; exists [::]=>/=.
rewrite /getLocal/init_dstate2/= findUnL?valid_init_dstate2//.
by rewrite domPt/= findPt.
Qed.

Lemma coh2 : l2 \\-> init_dstatelet2 \In Coh W2.
Proof.
split.
- apply/andP; split; last by rewrite valid_unit.
  by rewrite ?validPt.
- by rewrite validPt/=.
- by apply: hook_complete_unit.
- by move=>z; rewrite !domPt !inE/=.
move=>k; case B: (l2==k); last first.
- have X: (k \notin dom W2.1).
    by rewrite /init_state/W2/=!domPt !inE/=; move/negbT: B.
  by rewrite /getProtocol /getStatelet/= ?findPt2 eq_sym !B/=.
move/eqP:B=>B; subst k; rewrite prEq/getStatelet/init_state findPt/=.
exact: coh2'.
Qed.

Lemma init_coh : init_state \In Coh V.
Proof.
split=>//; first by apply: validV.
- by apply: validI.
- rewrite /V/=/init_state/==>z.
- by move=>???; rewrite domUn !inE/= dom0 andbC.
- rewrite /V/init_state=>z; rewrite !domUn !inE; case/andP:validV=>->_/=.
  by rewrite validI/= !domPt.
move=>k; case B: ((l1 == k) || (l2 == k)); last first.
- have X: (k \notin dom V.1).
  + by rewrite /V domUn inE/= !domPt!inE/= B andbC.
  rewrite /getProtocol /getStatelet/=.
  case: dom_find (X)=>//->_/=; rewrite /init_state.
  case/negbT/norP: B=>/negbTE N1/negbTE N2.
  rewrite findUnL; rewrite ?validI// domPt inE N1.
  rewrite findPt2 eq_sym N1/=.
  by rewrite findPt2 eq_sym N2/=.
case/andP: validV=>V1 V2.
case/orP:B=>/eqP Z; subst k;
rewrite /getProtocol/V findUnL/= ?V1 ?domPt ?inE/= ?findPt;
rewrite /getStatelet ?findUnL/= ?validI// ?domPt ?inE/= ?findPt;
[by case: coh1'|by case coh2'].
Qed.

(****************************************************)
(***********    Runnable programs     ***************)
(****************************************************)

Definition client_input :=
  [:: [::1; 2]; [::3; 4]; [::5; 6]; [::7; 8]; [::9; 10]].

Definition compute_input := compute_list_f l1 f prec cs1 cls1 cl Hc1 sv.

(* [C] A simple client, evaluating a serives of requests *)
Program Definition client_run (u : unit) :
  DHT [cl, V]
   (fun i => network_rely V cl init_state i,
   fun (res : seq (input * nat)) m =>
     [/\ all (fun e => f e.1 == Some e.2) res &
      client_input = map fst res]) :=
  Do (uinject (compute_input client_input)).

Next Obligation.
rewrite -(unitR V)/V.
have V: valid (W1 \+ W2 \+ Unit) by rewrite unitR validV.
apply: (injectL V); do?[apply: hook_complete_unit | apply: hooks_consistent_unit].
by move=>??????; rewrite dom0.
Qed.

Next Obligation.
move=>i/=R.
have X: injects W1 V Unit.
- move: (@injectL W1 W2 Unit)=>/=; rewrite !unitR =>H.
  apply: H=>//; do? [by apply: hook_complete0].
  + by rewrite -[Unit]unitR; move: validV.
  by move=>l _=>????; rewrite dom0.
case: (rely_ext X coh1 R)=>i1[j1][Z]C'; subst i.
apply: inject_rule=>//.
apply: call_rule=>C1{C'}/=; last by move=>m[H1]H2 H3.
have E: (getStatelet i1 l1) = (getStatelet (i1 \+ j1) l1).
- by rewrite (locProjL (proj2 (rely_coh R)) _ C1)=>//; rewrite /W1 domPt.
rewrite E (rely_loc' _ R)/getLocal/=/getStatelet/=.
rewrite findUnL ?validI// domPt inE eqxx findPt/=.
by rewrite /init_dstate1 findUnR?valid_init_dstate1// domPt/= findPt/=.
Qed.

(* [S1] Delegating server, serving the client's needs *)
Definition delegating_server (u : unit) :=
  delegating_server_loop l1 l2 lab_dis f prec cs1 cls1 cs2 cls2 sv
                         Hs1 Hc2 sd Hs2.

Program Definition server1_run (u : unit) :
  DHT [sv, V]
   (fun i => network_rely V sv init_state i,
   fun (res : unit) m => False) :=
  Do (delegating_server u).
Next Obligation.
move=>i/=R; apply: call_rule=>C1//=.
rewrite (rely_loc' _ R)/getLocal/=/getStatelet/=.
rewrite findUnL ?validI ?valid_init_dstate1//.
rewrite domPt inE eqxx findPt/=.
rewrite findUnR ?validI ?valid_init_dstate1//=.
rewrite domPt inE/= findPt/=; split=>//.
rewrite -(rely_loc _ R)/=/getStatelet findUnR ?validI ?valid_init_dstate1//=.
rewrite domPt inE/= findPt/= /init_dstate2/=.
rewrite findUnL ?validI ?valid_init_dstate2//.
by rewrite domPt inE/= findPt/= /init_dstate2/=.
Qed.

(* [S2] A memoizing server, serving as a delegate *)

Definition secondary_server (u : unit) :=
  with_inv (ii l2 f prec cs2 cls2)
           (memoizing_server l2 f prec prec_valid cs2 cls2 sd Hs2).

Program Definition server2_run (u : unit) :
  DHT [sd, V]
   (fun i => network_rely V sd init_state i,
    fun (res : unit) m => False) :=
  Do _ (@inject sd W2 V Unit _ _ (secondary_server u);; ret _ _ tt).

Next Obligation.
rewrite -(unitR V)/V.
have V: valid (W1 \+ W2 \+ Unit) by rewrite unitR validV.
apply: (injectR V); do?[apply: hook_complete_unit | apply: hooks_consistent_unit].
by move=>??????; rewrite dom0.
Qed.

Next Obligation.
move=>i/=R; apply: step.
rewrite /init_state joinC.

have X: injects W2 V Unit.
- move: (@injectL W2 W1 Unit)=>/=; rewrite !unitR=>H.
  rewrite /V joinC;apply: H=>//; do? [by apply: hook_complete0].
  + by rewrite joinC -[Unit]unitR; move: validV.
  by move=>l _=>????; rewrite dom0.
rewrite /V joinC in R X; rewrite /init_state [l1 \\->_ \+ _]joinC in R.
case: (rely_ext X coh2 R)=>j1[i1][Z]C'; subst i.
apply: inject_rule=>//=.
apply: with_inv_rule; apply:call_rule=>//_.
have E: (getStatelet j1 l2) = (getStatelet (j1 \+ i1) l2).
- by rewrite (locProjL (proj2 (rely_coh R)) _ C')=>//; rewrite /W1 domPt.
rewrite E (rely_loc' _ R)/getLocal/=/getStatelet/=.
rewrite findUnL ?validI//; last by rewrite joinC validI.
rewrite domPt/= findPt/=.
by rewrite /init_dstate2 findUnL ?valid_init_dstate2 ?domPt/= ?findPt.
Qed.

End CalculatorApp.

(***************************************************)
(* Now all three programs run in the same world!   *)
(***************************************************)

Definition c_runner (u : unit) := client_run u.
Definition s_runner1 (u : unit) := server1_run u.
Definition s_runner2 (u : unit) := server2_run u.


Require Import Rel.Definitions.
Require Import Rel.BasicFacts.
Require Import Rel.Compat_weaken_X.
Require Import Util.Subset.
Require Import Lang.BindingsFacts.
Require Import Lang.Static.
Set Implicit Arguments.

Section section_ccompat_tm_down.
Context (EV HV : Set).
Context (Ξ : XEnv EV HV).
Context (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig).
Context (ρ₁ ρ₂ : HV → hd0) (ρ : HV → IRel 𝓣_Sig).
Context (X : var).
Context (T : ty EV HV ∅) (𝓔 : eff EV HV ∅).

Hint Resolve postfix_refl.
Hint Rewrite in_singleton.

Lemma ccompat_tm_down_aux n :
n ⊨ ( ∀ᵢ ξ₁' ξ₂' t₁' t₂' ψ Xs₁ Xs₂,
      𝓤⟦ (Ξ & X ~ (T, 𝓔)) ⊢ 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁' ξ₂' t₁' t₂' ψ Xs₁ Xs₂ ⇒
      (X ∉ Xs₁ ∧ X ∉ Xs₂)ᵢ
    ) →
n ⊨ ∀ᵢ ζ₁ ζ₂ ξ₁ ξ₂ t₁ t₂,
    𝓣⟦ Ξ & (X ~ (T,𝓔)) ⊢ T # (ef_lbl (lbl_id (lid_f X))) :: 𝓔 ⟧
      δ₁ δ₂ δ ρ₁ ρ₂ ρ
      (ζ₁ ++ X :: ξ₁) (ζ₂ ++ X :: ξ₂) t₁ t₂ ⇒
    𝓣⟦ Ξ & (X ~ (T,𝓔)) ⊢ T # 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ
      (ζ₁ ++ X :: ξ₁) (ζ₂ ++ X :: ξ₂)
      (ktx_plug (ktx_down ktx_hole X) t₁)
      (ktx_plug (ktx_down ktx_hole X) t₂).
Proof.
intro FrX.
loeb_induction LöbIH.
iintro ζ₁ ; iintro ζ₂ ; iintro ξ₁ ; iintro ξ₂ ; iintro t₁ ; iintro t₂ ; iintro Ht.
apply plug1 with
  (ε := ef_lbl (lbl_id (lid_f X))) (Ta := T) (ξ₁ := ζ₁ ++ X :: ξ₁) (ξ₂ := ζ₂ ++ X :: ξ₂).
+ exact FrX.
+ iintro ξ₁' ; iintro ξ₂' ; iintro v₁ ; iintro v₂ ;
  iintro Hξ₁' ; iintro Hξ₂' ; iintro Hv.
  ielim_prop Hξ₁' ; ielim_prop Hξ₂'.
  eapply 𝓣_step_r.
  { simpl.
    apply step_down_val.
  }
  eapply 𝓣_step_l.
  { simpl.
    apply step_down_val.
  }
  iintro_later.
  apply 𝓥_in_𝓣 ; apply Hv.
+ clear - LöbIH.
  iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂'.
  iintro K₁ ; iintro K₂ ;
  iintro s₁ ; iintro s₂ ; iintro ψ ; iintro Xs₁ ; iintro Xs₂.
  iintro H.
  iintro Xs_K₁K₂.
  iintro Hw.
  ielim_prop Hξ₁' ; ielim_prop Hξ₂'.
  ielim_prop Xs_K₁K₂.

  idestruct H as 𝔽 H ;
  idestruct H as X₁ H ; idestruct H as X₂ H ;
  idestruct H as h₁ H ; idestruct H as h₂ H ;
  idestruct H as v₁ H ; idestruct H as v₂ H ;
  idestruct H as Hρ₁ρ₂ H ;
  idestruct H as Hs₁s₂ H ; idestruct H as HXs₁Xs₂ H ; idestruct H as Hr H ;
  idestruct H as Hv Hψ.

  ielim_prop Hρ₁ρ₂ ; destruct Hρ₁ρ₂ as [Hρ₁ Hρ₂].
  ielim_prop Hs₁s₂ ; destruct Hs₁s₂ as [Hs₁ Hs₂].
  ielim_prop HXs₁Xs₂ ; destruct HXs₁Xs₂ as [HXs₁ HXs₂].
  simpl in Hρ₁, Hρ₂ ; inversion Hρ₁ ; inversion Hρ₂ ; clear Hρ₁ Hρ₂.
  subst s₁ s₂ Xs₁ Xs₂ X₁ X₂.

  idestruct Hr as r₁ Hr ; idestruct Hr as r₂ Hr ; idestruct Hr as H_r₁r₂ Hr.
  ielim_prop H_r₁r₂ ; destruct H_r₁r₂ as [H_r₁ H_r₂].
  subst h₁ h₂.

  idestruct Hr as _T Hr ; idestruct Hr as _𝓔 Hr ; idestruct Hr as _BindsX Hr.
  ielim_prop _BindsX.
  apply binds_concat_inv in _BindsX.
  destruct _BindsX as [ _BindsX | [ H1 H2 ] ] ;
  [ | rewrite dom_single in H1 ; apply notin_same in H1 ; contradict H1 ].
  apply binds_single_inv in _BindsX.
  destruct _BindsX as [ _ H' ] ; inversion H' ; clear H' ; subst _T _𝓔.

  simpl.
  specialize (Xs_K₁K₂ X).
  assert (tunnels X K₁) ; [ crush | ].
  assert (tunnels X K₂) ; [ crush | ].
  eapply 𝓣_step_r.
  { apply step_down_up ; eauto. }
  eapply 𝓣_step_l.
  { apply step_down_up ; eauto. }
  later_shift.

  ispecialize Hr ξ₁' ; ispecialize Hr ξ₂'.
  ispecialize Hr ; [ auto | ].
  ispecialize Hr ; [ auto | ].
  iespecialize Hr.
  ispecialize Hr ; [ apply Hv | ].
  erewrite I_iff_elim_M ; [ | apply fold_𝓥𝓤_in_𝓣 ].
  iapply Hr.

  clear - LöbIH Hψ Hw Hξ₁' Hξ₂'.
  iintro ξ₁'' ; iintro ξ₂'' ; iintro u₁ ; iintro u₂ ;
  iintro Hξ₁'' ; iintro  Hξ₂'' ; iintro Hu.
  ispecialize Hψ ξ₁'' ; ispecialize Hψ ξ₂''.
  iespecialize Hψ ; idestruct Hψ as Hψ Hψr ; clear Hψr.
  ispecialize Hψ.
  { iintro_later ; repeat ieexists ; isplit.
    + iintro_prop ; split ; reflexivity.
    + eassumption.
  }
  iespecialize Hw.
  ispecialize Hw ; [ apply Hξ₁'' | ].
  ispecialize Hw ; [ apply Hξ₂'' | ].
  ispecialize Hw ; [ apply Hψ | ].

  later_shift.
  erewrite <- I_iff_elim_M ; [ | apply fold_𝓥𝓤_in_𝓣 ].

  simpl ktx_plug in LöbIH.
  ielim_prop Hξ₁'' ; ielim_prop Hξ₂''.
  apply postfix_inv_app in Hξ₁'' ; destruct Hξ₁'' as [ ζ₁'' Hξ₁'' ].
  apply postfix_inv_app in Hξ₂'' ; destruct Hξ₂'' as [ ζ₂'' Hξ₂'' ].
  apply postfix_inv_app in Hξ₁' ; destruct Hξ₁' as [ ζ₁' Hξ₁' ].
  apply postfix_inv_app in Hξ₂' ; destruct Hξ₂' as [ ζ₂' Hξ₂' ].
  ispecialize LöbIH (ζ₁'' ++ ζ₁' ++ ζ₁) ;
  ispecialize LöbIH (ζ₂'' ++ ζ₂' ++ ζ₂) ;
  ispecialize LöbIH ξ₁ ;
  ispecialize LöbIH ξ₂.
  repeat rewrite <- app_assoc in LöbIH.
  rewrite <- Hξ₁', <- Hξ₂', <- Hξ₁'', <- Hξ₂'' in LöbIH.
  iespecialize LöbIH.
  ispecialize LöbIH ; [ apply Hw | ].
  apply LöbIH.
+ crush.
+ crush.
+ assumption.
Qed.

Context (FrX_Ξ : X # Ξ).
Context (Wf_Ξ : wf_XEnv Ξ).
Context (Wf_T : wf_ty Ξ T).
Context (Wf_𝓔 : wf_eff Ξ 𝓔).

Hint Constructors wf_XEnv.

Lemma ccompat_tm_down n ξ₁ ξ₂ t₁ t₂ :
n ⊨ ( ∀ᵢ ξ₁' ξ₂' t₁' t₂' ψ Xs₁ Xs₂,
      𝓤⟦ (Ξ & X ~ (T, 𝓔)) ⊢ 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁' ξ₂' t₁' t₂' ψ Xs₁ Xs₂ ⇒
      (X ∉ Xs₁ ∧ X ∉ Xs₂)ᵢ
    ) →
X ∉ from_list ξ₁ → X ∉ from_list ξ₂ →
n ⊨ 𝓣⟦ (Ξ & (X ~ (T, 𝓔))) ⊢ T # (ef_lbl (lbl_id (lid_f X))) :: 𝓔 ⟧
    δ₁ δ₂ δ ρ₁ ρ₂ ρ
    (X :: ξ₁) (X :: ξ₂)
    (L_subst_tm (lid_f X) t₁) (L_subst_tm (lid_f X) t₂) →
n ⊨ 𝓣⟦ Ξ ⊢ T # 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ (⬇ t₁) (⬇ t₂).
Proof.
intros FrX_𝓔 FrX_ξ₁ FrX_ξ₂ Ht.
specialize (ccompat_tm_down_aux FrX_𝓔) as H.
ispecialize H ([] : list var).
ispecialize H ([] : list var).
iespecialize H.
repeat rewrite app_nil_l in H.
simpl ktx_plug in H.

eapply 𝓣_step_r.
{ apply step_Down with (X := X) ; assumption. }
eapply 𝓣_step_l.
{ apply step_Down with (X := X) ; assumption. }

iintro_later.
iespecialize H ; ispecialize H ; [ apply Ht | ].
erewrite I_iff_elim_M ; [ apply H | apply X_weaken_𝓣 ] ; crush.
Qed.

End section_ccompat_tm_down.

Section section_compat_tm_down.
Context (n : nat).
Context (EV HV V : Set).
Context (Ξ : XEnv EV HV).
Context (P : HV → F).
Context (Γ : V → ty EV HV ∅).
Context (Wf_Γ : wf_Γ Ξ Γ).
Context (t₁ t₂ : tm EV HV V (inc ∅)).
Context (T : ty EV HV ∅) (𝓔 : eff EV HV ∅).
Context (Wf_Ξ : wf_XEnv Ξ).
Context (Wf_T : wf_ty Ξ T).
Context (Wf_𝓔 : wf_eff Ξ 𝓔).

Hint Resolve subset_union_l subset_union_r postfix_refl.
Hint Resolve 𝓥_monotone.
Hint Rewrite in_union.
Hint Constructors wf_XEnv postfix.

Lemma compat_tm_down (B : vars) :
( ∀ X, X \notin B →
  n ⊨ ⟦ (Ξ & (X ~ (T, 𝓔))) P Γ ⊢
        (L_subst_tm (lid_f X) t₁) ≼ˡᵒᵍ (L_subst_tm (lid_f X) t₂) :
        T # (ef_lbl (lbl_id (lid_f X))) :: 𝓔 ⟧
) →
n ⊨ ⟦ Ξ P Γ ⊢ (⬇ t₁) ≼ˡᵒᵍ (⬇ t₂) : T # 𝓔 ⟧.
Proof.
intro Ht.
iintro ξ₁ ; iintro ξ₂ ; iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ; iintro γ₁ ; iintro γ₂.
pick_fresh_gen (from_list ξ₁ \u from_list ξ₂ \u B) X.
assert (X ∉ B) as FrB ; [ crush | ].
specialize (Ht X FrB).
iintro Hξ ; iintro cl_δ ; iintro cl_ρ₁ρ₂ ; iintro Hρ ; iintro Hγ.
ielim_prop Hξ ; ielim_prop cl_ρ₁ρ₂.
specialize Hξ as Hξ_copy ; destruct Hξ_copy as [Hξ₁ Hξ₂].

assert (X ∉ from_list ξ₁) as Frξ₁ ; [ crush | ].
assert (X ∉ from_list ξ₂) as Frξ₂ ; [ crush | ].
assert (X ∉ dom Ξ) as FrΞ ; [ intro ; crush | ].

ispecialize Ht (X :: ξ₁) ; ispecialize Ht (X :: ξ₂).
ispecialize Ht δ₁ ; ispecialize Ht δ₂ ; ispecialize Ht δ.
ispecialize Ht ρ₁ ; ispecialize Ht ρ₂ ; ispecialize Ht ρ.
ispecialize Ht γ₁ ; ispecialize Ht γ₂.
ispecialize Ht.
{ iintro_prop ; split ; [ clear - Hξ₁ | clear - Hξ₂ ] ;
  rewrite dom_concat, from_list_cons, dom_single, union_comm ;
  apply subset_union_2 ; crush.
}
ispecialize Ht.
{ repeat iintro ; iespecialize cl_δ ; ispecialize cl_δ ; [ eassumption | ].
  repeat rewrite from_list_cons ; ielim_prop cl_δ.
  crush.
}
ispecialize Ht.
{ iintro_prop ; intros α Y ; specialize (cl_ρ₁ρ₂ α Y) ;
  clear - cl_ρ₁ρ₂ ; repeat rewrite from_list_cons ; crush.
}
ispecialize Ht.
{ eapply 𝑷_monotone ; eauto. }
ispecialize Ht.
{ iintro x ; ispecialize Hγ x ; clear - Wf_Ξ Wf_Γ Wf_T Wf_𝓔 FrΞ Hγ.
  erewrite <- I_iff_elim_M ; [ | apply X_weaken_𝓥 ] ; eauto.
}

simpl.
apply ccompat_tm_down with (X := X) ; try assumption.
+ iintro ξ₁' ; iintro ξ₂' ;
  iintro s₁ ; iintro s₂ ; iintro ψ ; iintro Xs₁ ; iintro Xs₂ ; iintro Hs.
  erewrite <- I_iff_elim_M in Hs ; [ | apply X_weaken_𝓤 ; crush ].
  iintro_prop.
  assert (Xs₁ \c from_list ξ₁ ∧ Xs₂ \c from_list ξ₂) as HXs₁Xs₂.
  { eapply Xs_is_𝓤_bounded ; eassumption. }
  clear - HXs₁Xs₂ Frξ₁ Frξ₂.
  destruct HXs₁Xs₂.
  split ; intro ; auto.
+ clear - Ht.
  repeat erewrite <- V_L_bind_tm, <- HV_L_bind_tm, <- EV_L_bind_tm.
  { apply Ht. }
  { intro ; unfold compose.
    erewrite L_bind_map_eff, L_bind_eff_id, L_map_eff_id ; crush. }
  { intro ; unfold compose.
    erewrite L_bind_map_hd, L_bind_hd_id, L_map_hd_id ; crush. }
  { intro ; unfold compose.
    erewrite L_bind_map_val, L_bind_val_id, L_map_val_id ; crush. }
  { intro ; unfold compose.
    erewrite L_bind_map_eff, L_bind_eff_id, L_map_eff_id ; crush. }
  { intro ; unfold compose.
    erewrite L_bind_map_hd, L_bind_hd_id, L_map_hd_id ; crush. }
  { intro ; unfold compose.
    erewrite L_bind_map_val, L_bind_val_id, L_map_val_id ; crush. }

Qed.

End section_compat_tm_down.


Require Import Kami.All Kami.Compiler.Compiler.
Require Import Kami.Notations.
Require Import Kami.Compiler.CompilerSimple.

Section SemSimple.
  Local Notation UpdRegT := RegsT.
  Local Notation UpdRegsT := (list UpdRegT).

  Local Notation RegMapType := (RegsT * UpdRegsT)%type.

  Inductive Sem_RmeSimple: (RmeSimple type RegMapType) -> RegMapType -> Prop :=
  | SemVarRME v:
      Sem_RmeSimple (VarRME _ v) v
  | SemUpdRegRMETrue r (pred: Bool @# type) k val regMap
                  (HPredTrue: evalExpr pred = true)
                  old upds
                  (HSem_RmeSimple : Sem_RmeSimple regMap (old, upds))
                  upds'
                  (HEqual : upds' = (hd nil upds ++ ((r, existT _ k (evalExpr val)) :: nil)) :: tl upds):
      Sem_RmeSimple (@UpdRegRME _ _ r pred k val regMap) (old, upds')
  | SemUpdRegRMEFalse r (pred: Bool @# type) k val regMap
                   (HPredFalse: evalExpr pred = false)
                   old upds
                   (HSem_RmeSimple: Sem_RmeSimple regMap (old, upds)):
      Sem_RmeSimple (@UpdRegRME _ _ r pred k val regMap) (old, upds)
  | SemWriteRMESome idxNum num writePort dataArray idx Data val optMask mask pred writeMap readMap arr old upds
                      (HMask : optMask = Some mask)
                      (HUpdate : Sem_RmeSimple
                                   (UpdRegRME dataArray pred
                                           (fold_left (fun newArr i =>
                                                         ITE
                                                           (ReadArrayConst mask i)
                                                           (UpdateArray newArr
                                                                        (CABit Add (idx :: Const type (natToWord _ (proj1_sig (Fin.to_nat i)))
                                                                                :: nil))
                                                                        (ReadArrayConst val i))
                                                           newArr
                                                      ) (getFins num)
                                                      arr)
                                           writeMap) (old, upds)):
                      Sem_RmeSimple (@WriteRME _ _ idxNum num writePort dataArray idx Data val optMask pred writeMap readMap arr) (old, upds)
  | SemWriteRMENone idxNum num writePort dataArray idx Data val optMask pred writeMap readMap arr old upds
                      (HMask : optMask = None)
                      (HUpdate : Sem_RmeSimple
                                   (UpdRegRME dataArray pred
                                              (fold_left (fun newArr i =>
                                                            (UpdateArray newArr
                                                                         (CABit Add (idx :: Const type (natToWord _ (proj1_sig (Fin.to_nat i)))
                                                                                :: nil))
                                                                         (ReadArrayConst val i))
                                                         ) (getFins num)
                                                         arr)
                                              writeMap) (old, upds)):
                      Sem_RmeSimple (@WriteRME _ _ idxNum num writePort dataArray idx Data val optMask pred writeMap readMap arr) (old, upds)
  | SemReadReqRMETrue idxNum num readReq readReg dataArray idx Data isAddr pred writeMap readMap arr old upds
                   (HisAddr : isAddr = true)
                   (HWriteMap : Sem_RmeSimple (UpdRegRME readReg pred (Var type (SyntaxKind _) (evalExpr idx)) writeMap) (old, upds)):
                   Sem_RmeSimple (@ReadReqRME _ _ idxNum num readReq readReg dataArray idx Data isAddr pred writeMap readMap arr) (old, upds)
  | SemReadReqRMEFalse idxNum num readReq readReg dataArray idx Data isAddr pred writeMap readMap arr old upds
                   (HisAddr : isAddr = false)
                   (HWriteMap : Sem_RmeSimple
                                  (UpdRegRME readReg pred
                                             (BuildArray (fun i : Fin.t num =>
                                                            ReadArray
                                                              arr
                                                              (CABit Add (Var type (SyntaxKind _) (evalExpr idx) ::
                                                                              Const type (natToWord _ (proj1_sig (Fin.to_nat i)))::nil))))
                                             writeMap) (old, upds)):
      Sem_RmeSimple (@ReadReqRME _ _ idxNum num readReq readReg dataArray idx Data isAddr pred writeMap readMap arr) (old, upds)
  | SemReadRespRME idxNum num readResp readReg dataArray writePort isWriteMask Data isAddr writeMap readMap old upds
                       (HWriteMap : Sem_RmeSimple writeMap (old, upds)):
      Sem_RmeSimple (@ReadRespRME _ _ idxNum num readResp readReg dataArray writePort isWriteMask Data isAddr writeMap readMap) (old, upds)
  | SemAsyncReadRME (idxNum num : nat) (readPort dataArray : string) writePort isWriteMask (idx : Bit (Nat.log2_up idxNum) @# type) (pred : Bool @# type) (k : Kind) (writeMap readMap : RmeSimple type RegMapType)
                 old upds (HNoOp : Sem_RmeSimple writeMap (old, upds)):
      Sem_RmeSimple (@AsyncReadRME _ _ idxNum num readPort dataArray writePort isWriteMask idx pred k writeMap readMap) (old, upds)
  | SemCompactRME old upds regMap (HSemRegMap: Sem_RmeSimple regMap (old, upds)):
      Sem_RmeSimple (@CompactRME _ _ regMap) (old, nil::upds).

  Definition WfRmeSimple (regMapExpr : RmeSimple type RegMapType) (regMap : RegMapType) :=
    Sem_RmeSimple regMapExpr regMap /\
    let '(old, new) := regMap in
    forall u, In u new -> NoDup (map fst u) /\ SubList (getKindAttr u) (getKindAttr old).

  Inductive SemCompActionSimple: forall k, CompActionSimple type RegMapType k -> RegMapType ->  MethsT -> type k -> Prop :=
  | SemCompCall_simple_True (f: string) (argRetK: Kind * Kind) (pred: Bool @# type)
                            (arg: fst argRetK @# type)
                            lret (cont: fullType type (SyntaxKind (snd argRetK)) -> CompActionSimple _ _ lret)
                            (ret: fullType type (SyntaxKind (snd argRetK)))
                            regMap calls val newCalls
                            (HNewCalls : newCalls = (f, existT _ argRetK (evalExpr arg, ret)) :: calls)
                            (HSemCompActionSimple: SemCompActionSimple (cont ret) regMap calls val)
                            (HPred : evalExpr pred = true):
      SemCompActionSimple (@CompCall_simple _ _ f argRetK pred arg lret cont) regMap newCalls val
  | SemCompCall_simple_False (f: string) (argRetK: Kind * Kind) (pred: Bool @# type)
                             (arg: fst argRetK @# type)
                             lret (cont: fullType type (SyntaxKind (snd argRetK)) -> CompActionSimple _ _ lret)
                             (ret: fullType type (SyntaxKind (snd argRetK)))
                             regMap calls val
                             (HSemCompActionSimple: SemCompActionSimple (cont ret) regMap calls val)
                             (HPred : evalExpr pred = false):
      SemCompActionSimple (@CompCall_simple _ _ f argRetK pred arg lret cont) regMap calls val
  | SemCompLetExpr_simple k e lret cont
                          regMap calls val
                          (HSemCompActionSimple: SemCompActionSimple (cont (evalExpr e)) regMap calls val):
      SemCompActionSimple (@CompLetExpr_simple _ _ k e lret cont) regMap calls val
  | SemCompNondet_simple k lret cont
                         ret regMap calls val
                         (HSemCompActionSimple: SemCompActionSimple (cont ret) regMap calls val):
      SemCompActionSimple (@CompNondet_simple _ _ k lret cont) regMap calls val
  | SemCompSys_simple pred ls lret cont
               regMap calls val
               (HSemCompActionSimple: SemCompActionSimple cont regMap calls val):
      SemCompActionSimple (@CompSys_simple _ _ pred ls lret cont) regMap calls val
  | SemCompReadReg_simple r k readMap lret cont
                          regMap calls val regVal
                          updatedRegs readMapValOld readMapValUpds
                          (HReadMap: Sem_RmeSimple readMap (readMapValOld, readMapValUpds))
                          (HUpdatedRegs: PriorityUpds readMapValOld readMapValUpds updatedRegs)
                          (HIn: In (r, (existT _ k regVal)) updatedRegs)
                          (HSemCompActionT: SemCompActionSimple (cont regVal) regMap calls val):
      SemCompActionSimple (@CompReadReg_simple _ _ r k readMap lret cont) regMap calls val
  | SemCompRet_simple lret e regMap regMapVal calls
                      (HCallsNil : calls = nil)
                      (HRegMapWf: WfRmeSimple regMap regMapVal):
      SemCompActionSimple (@CompRet_simple _ _ lret e regMap) regMapVal calls (evalExpr e)
  | SemCompLetFull_simple k a lret cont
                          regMap_a calls_a val_a
                          (HSemCompActionSimple_a: SemCompActionSimple a regMap_a calls_a val_a)
                          regMap_cont calls_cont val_cont newCalls
                          (HNewCalls : newCalls = calls_a ++ calls_cont)
                          (HSemCompActionSimple_cont: SemCompActionSimple (cont val_a regMap_a) regMap_cont calls_cont val_cont):
      SemCompActionSimple (@CompLetFull_simple _ _ k a lret cont) regMap_cont newCalls val_cont
  | SemCompAsyncReadRmeSimple num (readPort dataArray : string) writePort isWriteMask idxNum (idx : Bit (Nat.log2_up idxNum) @# type) pred Data readMap lret
                            updatedRegs readMapValOld readMapValUpds regVal regMap
                            (HReadMap : Sem_RmeSimple readMap (readMapValOld, readMapValUpds))
                            (HUpdatedRegs : PriorityUpds readMapValOld readMapValUpds updatedRegs)
                            (HIn :  In (dataArray, (existT _ (SyntaxKind (Array idxNum Data)) regVal)) updatedRegs)
                            cont calls val contArray
                            (HContArray : contArray =
                                          BuildArray (fun i : Fin.t num =>
                                                        ReadArray
                                                          (Var type _ regVal)
                                                          (CABit Add (Var type (SyntaxKind _) (evalExpr idx) ::
                                                                          Const type (natToWord _ (proj1_sig (Fin.to_nat i)))::nil))))
                            (HSemCompActionSimple : SemCompActionSimple (cont (evalExpr contArray)) regMap calls val):
      SemCompActionSimple (@CompAsyncRead_simple _ _ idxNum num readPort dataArray writePort isWriteMask idx pred Data readMap lret cont) regMap calls val
  | SemCompWrite_simple (writePort dataArray : string) idxNum Data (readMap : RmeSimple type RegMapType) lret
                     updatedRegs readMapValOld readMapValUpds regVal
                     (HReadMap : Sem_RmeSimple readMap (readMapValOld, readMapValUpds))
                     (HUpdatedRegs : PriorityUpds readMapValOld readMapValUpds updatedRegs)
                     (HIn : In (dataArray, (existT _ (SyntaxKind (Array idxNum Data)) regVal)) updatedRegs)
                     cont regMap_cont calls val
                     (HSemCompActionSimple : SemCompActionSimple (cont regVal) regMap_cont calls val):
      SemCompActionSimple (@CompWrite_simple _ _ idxNum Data writePort dataArray readMap lret cont) regMap_cont calls val
  | SemCompSyncReadReq_simple_True num idxNum readReq readReg dataArray k (isAddr : bool) readMap lret cont
                                   regMapVal
                                   (HisAddr : isAddr = true)
                                   regMap_cont calls val
                                   (HSemCompActionSimple : SemCompActionSimple (cont regMapVal) regMap_cont calls val):
      SemCompActionSimple (@CompSyncReadReq_simple _ _ idxNum num k readReq readReg dataArray isAddr readMap lret cont) regMap_cont calls val
  | SemCompSyncReadReq_simple_False num idxNum readReq readReg dataArray (idx : Bit (Nat.log2_up idxNum) @# type) Data (isAddr : bool)
                                    (writeMap : RegMapExpr type RegMapType) readMap lret cont
                                    (HisAddr : isAddr = false)
                                    updatedRegs readMapValOld readMapValUpds regV
                                    (HReadMap : Sem_RmeSimple readMap (readMapValOld, readMapValUpds))
                                    (HUpdatedRegs : PriorityUpds readMapValOld readMapValUpds updatedRegs)
                                    (HRegVal : In (dataArray, (existT _ (SyntaxKind (Array idxNum Data)) regV)) updatedRegs)
                                    regMap_cont calls val
                                    (HSemCompActionSimple : SemCompActionSimple (cont regV) regMap_cont calls val):
      SemCompActionSimple (@CompSyncReadReq_simple _ _ idxNum num Data readReq readReg dataArray isAddr readMap lret cont) regMap_cont calls val
  | SemCompSyncReadRes_simple_True num idxNum readResp readRegName dataArray writePort isWriteMask Data isAddr readMap lret cont
                                   (HisAddr : isAddr = true)
                                   updatedRegs readMapValOld readMapValUpds regVal idx
                                   (HReadMap : Sem_RmeSimple readMap (readMapValOld, readMapValUpds))
                                   (HUpdatedRegs : PriorityUpds readMapValOld readMapValUpds updatedRegs)
                                   (HRegVal1 : In (readRegName, existT _ (SyntaxKind (Bit (Nat.log2_up idxNum))) idx) updatedRegs)
                                   (HRegVal2 : In (dataArray, existT _ (SyntaxKind (Array idxNum Data)) regVal) updatedRegs)
                                   (contArray : Expr type (SyntaxKind (Array num Data)))
                                   (HContArray : contArray =
                                                 BuildArray (fun i : Fin.t num =>
                                                               ReadArray
                                                                 (Var type _ regVal)
                                                                 (CABit Add (Var type (SyntaxKind _) idx ::
                                                                                Const type (natToWord _ (proj1_sig (Fin.to_nat i)))::nil))))
                                   regMap calls val
                                   (HSemCompActionSimple : SemCompActionSimple (cont (evalExpr contArray)) regMap calls val):
      SemCompActionSimple (@CompSyncReadRes_simple _ _ idxNum num readResp readRegName dataArray writePort isWriteMask Data isAddr readMap lret cont) regMap calls val
  | SemCompSyncReadRes_simple_False num idxNum readResp readRegName dataArray writePort isWriteMask Data isAddr readMap lret cont
                                    (HisAddr : isAddr = false)
                                    updatedRegs readMapValOld readMapValUpds regVal
                                    (HReadMap : Sem_RmeSimple readMap (readMapValOld, readMapValUpds))
                                    (HUpdatedRegs : PriorityUpds readMapValOld readMapValUpds updatedRegs)
                                    (HIn1 : In (readRegName, (existT _ (SyntaxKind (Array num Data)) regVal)) updatedRegs)
                                    regMap calls val
                                    (HSemCompActionSimple : SemCompActionSimple (cont regVal) regMap calls val):
      SemCompActionSimple (@CompSyncReadRes_simple _ _ idxNum num readResp readRegName dataArray writePort isWriteMask Data isAddr readMap lret cont) regMap calls val.
  Variable (k : Kind) (a : CompActionSimple type RegMapType k) (regInits : list RegInitT).

  Section Loop.
    Variable f: RegsT -> CompActionSimple type RegMapType Void.

    Inductive SemCompActionSimple_Trace: RegsT -> list UpdRegsT -> list MethsT -> Prop :=
    | SemCompActionSimple_TraceInit (oInit : RegsT) (lupds : list UpdRegsT) (lcalls : list MethsT)
                             (HNoUpds : lupds = nil) (HNoCalls : lcalls = nil)
                             (HInitRegs : Forall2 regInit oInit regInits) :
        SemCompActionSimple_Trace oInit lupds lcalls
    | SemCompActionSimple_TraceCont (o o' : RegsT) (lupds lupds' : list UpdRegsT) (upds : UpdRegsT)
                             (lcalls lcalls' : list MethsT) (calls : MethsT) val
                             (HOldTrace : SemCompActionSimple_Trace o lupds lcalls)
                             (HSemAction : SemCompActionSimple (f o) (o, upds) calls val)
                             (HNewUpds : lupds' = upds :: lupds)
                             (HNewCalls : lcalls' = calls :: lcalls)
                             (HPriorityUpds : PriorityUpds o upds o') :
        SemCompActionSimple_Trace o' lupds' lcalls'.
  End Loop.
End SemSimple.


From Velus Require Import Common.
From Velus Require Import Environment.
From Velus Require Import Operators.
From Velus Require Import Clocks.
From Velus Require Import Lustre.LSyntax.
From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import NLustre.NLSyntax.

From Coq Require Import Omega.
From Coq Require Import Permutation.
From Coq Require Import String.

From Coq Require Import List.
Import List.ListNotations.

From compcert Require Import common.Errors.
Open Scope error_monad_scope.

(** * Turn a normalized Lustre program into an NLustre program *)

(** Transcription algorithm and common lemmas for Correctness,
    Typing and Clocking preservation *)

Module Type TR
       (Import Ids  : IDS)
       (Import Op   : OPERATORS)
       (Import OpAux: OPERATORS_AUX Op)
       (L           : LSYNTAX  Ids Op)
       (Import CE   : CESYNTAX     Op)
       (NL          : NLSYNTAX Ids Op CE).

  Fixpoint to_lexp (e : L.exp) : res CE.exp :=
    match e with
    | L.Econst c                 => OK (CE.Econst c)
    | L.Evar x (ty, ck)          => OK (CE.Evar x ty)
    | L.Eunop op e (ty, ck)      => do le <- to_lexp e;
                                    OK (CE.Eunop op le ty)
    | L.Ebinop op e1 e2 (ty, ck) => do le1 <- to_lexp e1;
                                    do le2 <- to_lexp e2;
                                    OK (CE.Ebinop op le1 le2 ty)
    | L.Ewhen [e] x b ([ty], ck) => do le <- to_lexp e;
                                    OK (CE.Ewhen le x b)
    | L.Efby _ _ _
    | L.Earrow _ _ _
    | L.Ewhen _ _ _ _
    | L.Emerge _ _ _ _
    | L.Eite _ _ _ _
    | L.Eapp _ _ _ _    => Error (msg "expression not normalized")
    end.

  Fixpoint to_cexp (e : L.exp) : res CE.cexp :=
    match e with
    | L.Econst _
    | L.Evar _ _
    | L.Eunop _ _ _
    | L.Ebinop _ _ _ _
    | L.Ewhen _ _ _ _                 => do le <- to_lexp e;
                                         OK (CE.Eexp le)

    | L.Emerge x [et] [ef] ([ty], ck) => do cet <- to_cexp et;
                                         do cef <- to_cexp ef;
                                         OK (CE.Emerge x cet cef)

    | L.Eite e [et] [ef] ([ty], ck)   => do le <- to_lexp e;
                                         do cet <- to_cexp et;
                                         do cef <- to_cexp ef;
                                         OK (CE.Eite le cet cef)

    | L.Emerge _ _ _ _
    | L.Eite _ _ _ _
    | L.Efby _ _ _
    | L.Earrow _ _ _
    | L.Eapp _ _ _ _    => Error (msg "control expression not normalized")
    end.

  Fixpoint suffix_of_clock (ck : clock) (acc : list (ident * bool))
                                                    : list (ident * bool) :=
    match ck with
    | Cbase => acc
    | Con ck' x b => suffix_of_clock ck' ((x, b) :: acc)
    end.

  Fixpoint clock_of_suffix (sfx : list (ident * bool)) (ck : clock) : clock :=
    match sfx with
    | [] => ck
    | (x, b) :: sfx' => clock_of_suffix sfx' (Con ck x b)
    end.

  Fixpoint common_suffix (sfx1 sfx2 : list (ident * bool))
                                                 : list (ident * bool) :=
    match sfx1, sfx2 with
    | [],  _ => []
    | _ , [] => []
    | (x1, b1)::sfx1', (x2, b2)::sfx2' =>
      if (Pos.eqb x1 x2) && (b1 ==b b2) then (x1, b1) :: common_suffix sfx1' sfx2'
      else []
    end.

  Definition find_base_clock (cks : list clock) : clock :=
    match cks with
    | [] => Cbase
    | ck::cks =>
      let sfx := fold_left
                   (fun sfx1 ck2 => common_suffix sfx1 (suffix_of_clock ck2 []))
                   cks (suffix_of_clock ck [])
      in
      clock_of_suffix sfx Cbase
    end.

  Definition find_clock (env : Env.t (type * clock)) (x : ident) : res clock :=
    match Env.find x env with
    | None => Error (msg "find_clock failed unexpectedly")
    | Some (ty, ck) => OK ck
    end.

  Fixpoint to_constant (e : L.exp) : res const :=
    match e with
    | L.Econst c => OK c
    | L.Ewhen [e] _ _ _ => to_constant e
    | _ => Error (msg "not a constant")
    end.

  Definition to_equation (env : Env.t (type * clock)) (envo : ident -> res unit)
                         (eq : L.equation) : res NL.equation :=
    let (xs, es) := eq in
    match es with
    | [e] =>
      match e with
      | L.Eapp f es None _ =>
        do les <- mmap to_lexp es;
        OK (NL.EqApp xs (find_base_clock (L.clocksof es)) f les None)
      | L.Eapp f es (Some (L.Evar x (_, (ckx, _)))) _ => (* use clock annot or lookup? *)
        do les <- mmap to_lexp es;
        OK (NL.EqApp xs (find_base_clock (L.clocksof es)) f les (Some (x, ckx)))
      | L.Eapp f es (Some _) _ => Error (msg "reset equation not normalized")
      | L.Efby [e0] [e] _ =>
        match xs with
          | [x] =>
            do _  <- envo x;
            do c0 <- to_constant e0;
            do ck <- find_clock env x;
            do le <- to_lexp e;
            OK (NL.EqFby x ck c0 le)
          | _ => Error (msg "fby equation not normalized")
        end
      | _ =>
        match xs with
        | [x] =>
          do ck <- find_clock env x;
          do ce <- to_cexp e;
          OK (NL.EqDef x ck ce)
        | _ => Error (msg "basic equation not normalized")
        end
      end
    | _ => Error (msg "equation not normalized")
    end.

    (* match eq with *)
    (* | (xs, [L.Eapp f es None _]) => *)
    (*     do les <- mmap to_lexp es; *)
    (*     OK (NL.EqApp xs (find_base_clock (L.clocksof es)) f les None) *)

    (* | (xs, [L.Eapp f es (Some (L.Evar x _)) _]) => *)
    (*     do les <- mmap to_lexp es; *)
    (*     OK (NL.EqApp xs (find_base_clock (L.clocksof es)) f les (Some x)) *)

    (* | ([x], [L.Efby [e0] [e] _]) => *)
    (*     do _  <- envo x; *)
    (*     do c0 <- to_constant e0; *)
    (*     do ck <- find_clock env x; *)
    (*     do le <- to_lexp e; *)
    (*     OK (NL.EqFby x ck c0 le) *)

    (* | ([x], [e]) => *)
    (*     do ck <- find_clock env x; *)
    (*     do ce <- to_cexp e; *)
    (*     OK (NL.EqDef x ck ce) *)

    (* | _ => Error (msg "equation not normalized") *)
    (* end. *)

  Lemma find_clock_in_env :
    forall x env ty ck,
      Env.find x env = Some (ty, ck) ->
      find_clock env x = OK ck.
  Proof.
    intros * H. unfold find_clock. now rewrite H.
  Qed.

  Lemma find_clock_out : forall n x ty ck,
      In (x, (ty, ck)) (L.n_out n) ->
      find_clock
        (Env.adds' (L.n_vars n)
                   (Env.adds' (L.n_in n) (Env.from_list (L.n_out n)))
        ) x = OK ck.
  Proof.
    intros * Hin.
    unfold Env.from_list. eapply find_clock_in_env.
    apply In_InMembers in Hin as Hinm.
    pose proof (L.n_nodup n) as Hnodup.
    rewrite 2 Env.gsso'. apply Env.In_find_adds'; eauto.
    - eapply NoDupMembers_app_r, NoDupMembers_app_r, NoDupMembers_app_l in Hnodup; eauto.
    - eapply NoDupMembers_app_InMembers_l; eauto.
      repeat rewrite InMembers_app; auto.
    - eapply NoDupMembers_app_r in Hnodup.
      eapply NoDupMembers_app_InMembers_l; eauto.
      rewrite InMembers_app; auto.
  Qed.

  Lemma ok_fst_defined eq eq' :
    forall env envo,
      to_equation env envo eq = OK eq' -> fst eq = NL.var_defined eq'.
  Proof.
    intros env envo Htoeq.
    unfold to_equation in Htoeq.
    cases; monadInv Htoeq; inv EQ; simpl; auto.
  Qed.

  Lemma nl_vars_defined_cons:
    forall eq eqs,
      NL.vars_defined (eq::eqs) = NL.var_defined eq ++ NL.vars_defined eqs.
  Proof.
    intros. unfold NL.vars_defined. now simpl.
  Qed.

  Remark mmap_cons:
    forall (A B: Type) (f: A -> res B) (l: list A) (r: list B) (x: A),
      mmap f (x :: l) = OK r ->
      exists x' l', r = x' :: l' /\ f x = OK x' /\ mmap f l = OK l'.
  Proof.
    induction l; simpl; intros.
    monadInv H. exists x0, []. auto.
    monadInv H. exists x0, x1. auto.
  Qed.

  Remark mmap_cons2:
    forall (A B: Type) (f: A -> res B) (l: list A) (r: list B) (x: B),
      mmap f (l) = OK (x :: r) ->
      exists x' l', l = x' :: l' /\ f x' = OK x /\ mmap f l' = OK r.
  Proof.
    induction l; simpl; intros.
    monadInv H.
    monadInv H. exists a, l. auto.
  Qed.

  Remark mmap_cons3:
    forall (A B: Type) (f: A -> res B) (l: list A) (r: list B) (x: A) (y : B),
      mmap f (x :: l) = OK (y :: r) ->
      f x = OK y /\ mmap f l = OK r.
  Proof.
    induction l; simpl; intros; monadInv H; auto.
  Qed.

  Definition mmap_to_equation env envo n :
    res { neqs | mmap (to_equation env envo) n.(L.n_eqs) = OK neqs }.
  Proof.
    destruct (mmap (to_equation env envo) n.(L.n_eqs)).
    left. eauto.
    right. auto.
  Defined.

  Unset Program Cases.
  Program Definition to_node (n : L.node)
    (Hpref : PS.Equal (L.n_prefixes n) (PSP.of_list gensym_prefs)) : res NL.node :=
    let envo := Env.from_list n.(L.n_out) in
    let env := Env.adds' n.(L.n_vars) (Env.adds' n.(L.n_in) envo) in
    let is_not_out :=
        fun x => if Env.mem x envo
              then Error (msg "output variable defined as a fby")
              else OK tt in
    match mmap_to_equation env is_not_out n (* return _ *) with
    | OK (exist neqs P) =>
      OK {|
          NL.n_name     := n.(L.n_name);
          NL.n_in       := n.(L.n_in);
          NL.n_out      := n.(L.n_out);
          NL.n_vars     := n.(L.n_vars);
          NL.n_eqs      := neqs;

          NL.n_ingt0    := L.n_ingt0 n;
          NL.n_outgt0   := L.n_outgt0 n;
          NL.n_defd     := _;
          NL.n_vout     := _;
          NL.n_nodup    := _;
          NL.n_good     := _
        |}
    | Error e => Error e
    end.

  (* NL.n_defd obligation *)
  Next Obligation.
    clear H0 H.
    monadInv P.
    assert (NL.vars_defined neqs = L.vars_defined (L.n_eqs n)). clear P.
    { revert H. revert neqs. induction (L.n_eqs n); simpl.
    - intros neqs Htr. inv Htr. auto.
    - intros neqs Htoeq. inv Htoeq.
      apply IHl in H3. simpl.
      apply ok_fst_defined in H1. rewrite H3. now rewrite <- H1.
    }
    rewrite H0.
    exact (L.n_defd n).
  Qed.

  (* NL.n_vout obligation *)
  Next Obligation.
    clear H H1. rename H0 into Hin. rename P into Heqr.

    monadInv Heqr. induction H as [| eq leq eq' leq' Htoeq ].
    intro Hbad. inv Hbad.
    assert (Hmmap := Heqr).
    apply mmap_cons2 in Heqr.
    destruct Heqr as (eq'' & leq'' & Heqs' & Htoeq' & Hmmap').
    inv Heqs'.
    simpl. destruct (NL.is_fby eq') eqn:?.
    - unfold NL.vars_defined, flat_map. simpl. rewrite in_app.
      intro Hi. destruct Hi.
      + unfold to_equation in Htoeq. destruct eq''.
        cases_eqn E; monadInv1 Htoeq; inv Heqb.
        simpl in H0. destruct H0; auto. subst. inv EQ.
        apply Env.Props.P.F.not_mem_in_iff in E8. apply E8.
        rewrite in_map_iff in Hin.
        destruct Hin as ((x & ?) & Hfst & Hin). inv Hfst.
        eapply Env.find_In. eapply Env.In_find_adds'; simpl; eauto.
        destruct n. simpl. assert (Hnodup := n_nodup).
        apply NoDupMembers_app_r, NoDupMembers_app_r, NoDupMembers_app_l in Hnodup; auto.
      + apply IHlist_forall2; auto.
    - apply IHlist_forall2; eauto.
  Qed.

  Next Obligation.
    specialize (L.n_nodup n) as Hndup.
    repeat rewrite app_assoc in *. apply NoDupMembers_app_l in Hndup; auto.
  Qed.

  (* NL.n_good obligation *)
  Next Obligation.
    pose proof (L.n_good n) as (Hgood&Hat).
    split; auto.
    repeat rewrite map_app in *.
    eapply Forall_impl; [|eapply Forall_incl; eauto].
    - intros * [?|(pref&?&?&?)]; subst; [left|right]; auto.
      exists pref. rewrite <- Hpref. eauto.
    - apply incl_appr', incl_appr', incl_appl, incl_refl.
  Qed.

  Fixpoint to_global (g : L.global) :
    Forall (fun n => PS.Equal (L.n_prefixes n) (PSP.of_list gensym_prefs)) g ->
    res NL.global.
  Proof.
    destruct g as [|hd tl]; intros Hprefs.
    - exact (OK []).
    - refine (bind (to_node hd _) (fun hd' => bind (to_global tl _) (fun tl' => OK (hd'::tl')))).
      + inv Hprefs; auto.
      + inv Hprefs; auto.
  Defined.

  (** Helper for the l_to_nl function *)
  Program Definition to_global' (G : {G | Forall (fun n => PS.Equal (L.n_prefixes n) (PSP.of_list gensym_prefs)) G}) :
    res NL.global := to_global G _.

  Ltac tonodeInv H :=
    match type of H with
    | (to_node ?n _ = OK _) =>
      let Hs := fresh in
      let Hmmap := fresh "Hmmap" in
      unfold to_node in H;
      destruct(mmap_to_equation
               (Env.adds' (L.n_vars n)
                (Env.adds' (L.n_in n)
                 (Env.from_list (L.n_out n))))
            (fun x : Env.key =>
             if Env.mem x (Env.from_list (L.n_out n))
             then Error (msg "output variable defined as a fby")
             else OK tt) n)
      as [ Hs | Hs ];
      try (destruct Hs as (? & Hmmap)); inv H
    end.

  Lemma find_node_hd f a G n :
    L.find_node f (a :: G) = Some n ->
    ((ident_eqb (L.n_name a) f) = true  /\ a = n) \/
    ((ident_eqb (L.n_name a) f) = false /\ L.find_node f G = Some n).
  Proof.
    simpl. intro.
    case_eq (ident_eqb (L.n_name a) f); intro; rewrite H0 in H; inv H.
    auto. right. auto.
  Qed.

  Lemma find_node_In :
    forall f G n, L.find_node f G = Some n -> In n G.
  Proof.
    induction G; intros * Hfind; try discriminate.
    inv Hfind. destruct (ident_eqb (L.n_name a) f).
    inv H0. simpl. now left.
    simpl. right. now apply IHG.
  Qed.

  Lemma to_node_name n n' Hpref :
    to_node n Hpref = OK n' -> L.n_name n = NL.n_name n'.
  Proof.
    intro Htr. tonodeInv Htr. now simpl.
  Qed.

  Lemma to_node_in n n' Hpref :
    to_node n Hpref = OK n' -> L.n_in n = NL.n_in n'.
  Proof.
    intro Htr. tonodeInv Htr. now simpl.
  Qed.

  Lemma to_node_out n n' Hpref :
    to_node n Hpref = OK n' -> L.n_out n = NL.n_out n'.
  Proof.
    intro Htr. tonodeInv Htr. now simpl.
  Qed.

  Lemma to_node_vars n n' Hpref :
    to_node n Hpref = OK n' -> L.n_vars n = NL.n_vars n'.
  Proof.
    intro Htr. tonodeInv Htr. now simpl.
  Qed.

  Lemma find_node_global (G: L.global) Hprefs (P: NL.global) (f: ident) (n: L.node) :
    to_global G Hprefs = OK P ->
    L.find_node f G = Some n ->
    exists n' Hpref, NL.find_node f P = Some n' /\ to_node n Hpref = OK n'.
  Proof.
    revert P.
    induction G; intros * Htrans Hfind. inversion Hfind.
    apply find_node_hd in Hfind.
    destruct Hfind as [(Heq&?)|(Hneq&Hfind)]; subst.
    - monadInv Htrans.
      exists x. eexists; split; eauto.
      simpl. apply to_node_name in EQ. rewrite <- EQ, Heq. reflexivity.
    - monadInv Htrans.
      eapply IHG in EQ1 as (n'&?&P'&nP); eauto.
      exists n'. eexists; split; eauto. simpl.
      apply to_node_name in EQ. rewrite <- EQ, Hneq; auto.
  Qed.

  Lemma find_node_global' (G: L.global) Hprefs (P: NL.global) (f: ident) (n': NL.node) :
    to_global G Hprefs = OK P ->
    NL.find_node f P = Some n' ->
    exists n Hpref, L.find_node f G = Some n /\ to_node n Hpref = OK n'.
  Proof.
    revert P.
    induction G; intros * Htrans Hfind; simpl in *; monadInv Htrans; simpl in *; try congruence.
    destruct (ident_eqb (NL.n_name x) f) eqn:Hname.
    - clear EQ1. inv Hfind.
      erewrite to_node_name, Hname; eauto.
    - eapply IHG in EQ1 as (n&?&Hfind'&Hton); eauto.
      erewrite to_node_name, Hname; eauto.
  Qed.

  Section Envs_eq.

    Definition envs_eq (env : Env.t (type * clock))
               (cenv : list (ident * clock)) :=
      forall (x : ident) (ck : clock),
        In (x,ck) cenv <-> exists ty, Env.find x env = Some (ty,ck).

    Lemma envs_eq_find :
      forall env cenv x ck,
        envs_eq env cenv ->
        In (x, ck) cenv ->
        find_clock env x = OK ck.
    Proof.
      unfold find_clock, envs_eq. intros * Heq Hin.
      rewrite Heq in Hin. destruct Hin as [? Hfind].
      now rewrite Hfind.
    Qed.

    Lemma envs_eq_find' :
      forall env cenv x ck,
        envs_eq env cenv ->
        find_clock env x = OK ck ->
        In (x, ck) cenv.
    Proof.
      unfold find_clock, envs_eq. intros * Heq Hfind.
      rewrite Heq.
      destruct Env.find.
      - destruct p. inv Hfind. eexists; eauto.
      - inv Hfind.
    Qed.

    Lemma envs_eq_app_comm :
      forall env (xs ys : list (ident * (type * clock))),
        envs_eq env (idck (xs ++ ys))
        <-> envs_eq env (idck (ys ++ xs)).
    Proof.
      split; unfold envs_eq; intros Heq x ck; split; intro Hin;
        try (rewrite idck_app in Hin;
             apply in_app_comm in Hin; apply Heq; now rewrite idck_app);
        try (rewrite idck_app; rewrite in_app_comm; rewrite <- idck_app;
             now apply Heq).
    Qed.

    Lemma env_eq_env_from_list:
      forall xs,
        NoDupMembers xs ->
        envs_eq (Env.from_list xs) (idck xs).
    Proof.
      intros xs Hnodup x ck. split.
      - unfold idck. rewrite in_map_iff.
        intro Hxs. destruct Hxs as (y & Hx & Hin). inv Hx.
        exists (fst (snd y)).
        apply Env.In_find_adds'; auto.
        destruct y as [? [? ?]]. auto.
      - intro Hfind. destruct Hfind as [ty Hfind].
        apply Env.from_list_find_In in Hfind.
        unfold idck. rewrite in_map_iff. exists (x,(ty,ck)). simpl. tauto.
    Qed.

    Lemma env_eq_env_adds':
      forall s xs ys,
        NoDupMembers (xs ++ ys) ->
        envs_eq s (idck ys) ->
        envs_eq (Env.adds' xs s) (idck (xs ++ ys)).
    Proof.
      intros s xs ys Hnodup Heq x ck. split.
      - rewrite idck_app. rewrite in_app_iff. destruct 1 as [Hin | Hin].
        unfold idck in Hin. rewrite in_map_iff in Hin.
        destruct Hin as (y & Hx & Hin). inv Hx. exists (fst (snd y)).
        apply Env.In_find_adds'; auto.
        now apply NoDupMembers_app_l in Hnodup.
        destruct y as (? & ? & ?). now simpl.
        assert (Hin' := Hin).
        apply Heq in Hin. destruct Hin as [ty Hin].
        exists ty. rewrite <- Hin. apply Env.gsso'.
        apply In_InMembers in Hin'. rewrite InMembers_idck in Hin'.
        eapply NoDupMembers_app_InMembers; eauto.
        now rewrite Permutation_app_comm.
      - destruct 1 as [ty Hfind].
        apply Env.find_env_from_list' in Hfind.
        destruct Hfind as [Hin | [Hin Hfind]];
          rewrite idck_app; apply in_app_iff.
        left. rewrite In_idck_exists. eauto.
        right. unfold envs_eq in Heq. rewrite Heq. eauto.
    Qed.

    Lemma envs_eq_node (n : L.node) :
      envs_eq
        (Env.adds' (L.n_vars n)
                   (Env.adds' (L.n_in n)
                              (Env.from_list (L.n_out n))))
        (idck (L.n_in n ++ L.n_vars n ++ L.n_out n)).
    Proof.
      rewrite envs_eq_app_comm.
      rewrite <- app_assoc.
      apply env_eq_env_adds'. rewrite app_assoc.
      rewrite Permutation_app_comm. specialize (L.n_nodup n) as Hnd.
      repeat rewrite app_assoc in *. apply NoDupMembers_app_l in Hnd; auto.
      rewrite envs_eq_app_comm.
      apply env_eq_env_adds'. assert (Hnodup := L.n_nodup n).
      repeat rewrite app_assoc in Hnodup. apply NoDupMembers_app_l in Hnodup. rewrite <- app_assoc in Hnodup.
      rewrite Permutation_app_comm in Hnodup.
      rewrite <- app_assoc in Hnodup. apply NoDupMembers_app_r in Hnodup.
      now rewrite Permutation_app_comm.
      apply env_eq_env_from_list. assert (Hnodup := L.n_nodup n).
      now apply NoDupMembers_app_r, NoDupMembers_app_r, NoDupMembers_app_l in Hnodup.
    Qed.

  End Envs_eq.

  Section Clock_operations.

    Lemma suffix_of_clock_app:
      forall sfx sfx' ck,
        suffix_of_clock ck (sfx ++ sfx') = (suffix_of_clock ck sfx) ++ sfx'.
    Proof.
      intros sfx sfx'; revert sfx' sfx.
      induction sfx' as [|xb sfx' IH].
      now setoid_rewrite app_nil_r.
      intros sfx ck.
      rewrite <-app_last_app, IH, <-app_last_app  with (xs':=sfx'). f_equal.
      revert sfx; clear.
      induction ck; auto.
      simpl; intros sfx.
      now rewrite app_comm_cons, IHck.
    Qed.

    Lemma clock_of_suffix_app:
      forall sfx sfx' ck,
        clock_of_suffix (sfx ++ sfx') ck
        = clock_of_suffix sfx' (clock_of_suffix sfx ck).
    Proof.
      induction sfx as [|(x, b) sfx IH].
      now setoid_rewrite app_nil_l.
      intros sfx' ck.
      now simpl; rewrite IH.
    Qed.

    Remark clock_of_suffix_of_clock:
      forall ck,
        clock_of_suffix (suffix_of_clock ck []) Cbase = ck.
    Proof.
      induction ck; auto; simpl in *.
      now rewrite <-(app_nil_l [(i, b)]),
      suffix_of_clock_app, clock_of_suffix_app, IHck.
    Qed.

    Lemma common_suffix_app :
      forall l l1 l2,
        common_suffix (l ++ l1) (l ++ l2) = l ++ common_suffix l1 l2.
    Proof.
      induction l; simpl; auto.
      intros. cases_eqn HH. now f_equal.
      now rewrite equiv_decb_refl, Pos.eqb_refl in HH0.
    Qed.

    Lemma common_suffix_app_l :
      forall l l1 l2,
        length l2 < length l1 ->
        common_suffix l1 l2 = common_suffix (l1 ++ l) l2.
    Proof.
      induction l1; simpl; intros * Hlen.
      - inv Hlen.
      - cases_eqn HH. f_equal. apply IHl1. simpl in Hlen. omega.
    Qed.

    Lemma clock_parent_length :
      forall ck ck',
        clock_parent ck ck' ->
        length (suffix_of_clock ck []) < length (suffix_of_clock ck' []).
    Proof.
      induction 1; simpl;
        setoid_rewrite <- app_nil_l at 4;
        setoid_rewrite suffix_of_clock_app;
        rewrite app_length; simpl; omega.
    Qed.

    Lemma parent_common_suffix :
      forall ck ck',
        clock_parent ck ck' ->
        common_suffix (suffix_of_clock ck' []) (suffix_of_clock ck []) =
        suffix_of_clock ck [].
    Proof.
      induction 1; simpl; setoid_rewrite <- app_nil_l at 3.
      - setoid_rewrite <- app_nil_r at 7.
        rewrite suffix_of_clock_app.
        rewrite common_suffix_app. simpl. now rewrite app_nil_r.
      - rewrite suffix_of_clock_app, <- common_suffix_app_l; auto.
        now apply clock_parent_length.
    Qed.

    Lemma common_suffix_id :
      forall sfx, common_suffix sfx sfx = sfx.
    Proof.
      induction sfx as [| []]; simpl. auto. rewrite IHsfx.
      rewrite equiv_decb_refl, Pos.eqb_refl. now simpl.
    Qed.

    Lemma common_suffix_comm :
      forall sfx1 sfx2, common_suffix sfx1 sfx2 = common_suffix sfx2 sfx1.
    Proof.
      induction sfx1 as [| [i1 b1]], sfx2 as [| [i2 b2]]; simpl; auto.
      cases_eqn EQ.
      - apply andb_prop in EQ as [H].
        apply Peqb_true_eq in H. subst.
        Coq.Bool.Bool.destr_bool; f_equal; auto; f_equal.
      -  apply andb_prop in EQ as [H].
         apply Peqb_true_eq in H. subst.
         apply Bool.andb_false_iff in EQ0 as [];
           Coq.Bool.Bool.destr_bool; now rewrite Pos.eqb_refl in H.
      -  apply andb_prop in EQ0 as [H].
         apply Peqb_true_eq in H. subst.
         apply Bool.andb_false_iff in EQ as [];
           Coq.Bool.Bool.destr_bool; now rewrite Pos.eqb_refl in H.
    Qed.

    Inductive prefix {A} : list A -> list A -> Prop :=
    | prefixNil: forall (l: list A), prefix nil l
    | prefixCons: forall (a: A)(l m:list A), prefix l m -> prefix (a::l) (a::m).
    Hint Constructors prefix.

    Lemma prefix_app:
      forall {A} (l l' : list A), prefix l (l ++ l').
    Proof.
      induction l; simpl; auto.
    Qed.

    Lemma prefix_app':
      forall {A} (l l1 l2 : list A), prefix l l1 -> prefix l (l1 ++ l2).
    Proof.
      induction 1; simpl; auto.
    Qed.

    Lemma prefix_refl :
      forall {A} (l : list A), prefix l l.
    Proof. induction l; auto. Qed.

    Lemma prefix_app3 :
      forall {A} (l1 l2 : list A) e,
        prefix l1 (l2 ++ [e]) ->
        prefix l1 l2 \/ l1 = (l2 ++ [e]).
    Proof.
      intros * Hp. revert dependent l1.
      induction l2; simpl; intros.
      - inv Hp; auto. inv H1; auto.
      - inv Hp; auto. specialize (IHl2 _ H1) as []; auto.
        right. now f_equal.
    Qed.

    Lemma suffix_of_clock_Con:
      forall ck i b,
        suffix_of_clock (Con ck i b) [] =
        suffix_of_clock ck [(i, b)].
    Proof. auto. Qed.

    Lemma suffix_of_clock_inj :
      forall ck ck',
        suffix_of_clock ck [] = suffix_of_clock ck' [] ->
        ck = ck'.
    Proof.
      induction ck, ck'; simpl; auto; intros * Hs.
      - setoid_rewrite <- app_nil_l in Hs at 3.
        rewrite suffix_of_clock_app in Hs.
        now apply app_cons_not_nil in Hs.
      - setoid_rewrite <- app_nil_l in Hs at 2.
        rewrite suffix_of_clock_app in Hs.
        symmetry in Hs. now apply app_cons_not_nil in Hs.
      - setoid_rewrite <- app_nil_l in Hs at 2.
        symmetry in Hs. setoid_rewrite <- app_nil_l in Hs at 2. symmetry in Hs.
        rewrite 2 suffix_of_clock_app in Hs.
        apply app_inj_tail in Hs as [He Hp]. inv Hp.
        specialize (IHck _ He). now subst.
    Qed.

    Lemma prefix_parent :
      forall bk ck,
        ck = bk \/ clock_parent bk ck <->
        prefix (suffix_of_clock bk []) (suffix_of_clock ck []).
    Proof.
      split.
      - destruct 1 as [|H]. subst. apply prefix_refl.
        induction H; simpl.
        + setoid_rewrite <- app_nil_l at 4.
          rewrite suffix_of_clock_app. apply prefix_app.
        + setoid_rewrite <- app_nil_l at 4.
          rewrite suffix_of_clock_app. now apply prefix_app'.
      - intro Hp. revert dependent bk.
        induction ck; intros.
        + simpl in *. inv Hp. destruct bk; simpl in *; auto.
          setoid_rewrite <- app_nil_l in H0 at 3.
          rewrite suffix_of_clock_app in H0.
          now apply app_cons_not_nil in H0.
        + simpl in *.
          setoid_rewrite <- app_nil_l in Hp at 4.
          rewrite suffix_of_clock_app in Hp.
          apply prefix_app3 in Hp as [Hp|Heq].
          specialize (IHck _ Hp) as []; subst; auto.
          rewrite <- suffix_of_clock_app in Heq.
          rewrite app_nil_l, <- suffix_of_clock_Con in Heq.
          apply suffix_of_clock_inj in Heq. subst. auto.
    Qed.

    Lemma prefix_common_suffix :
      forall sfx1 sfx2 p,
        prefix p sfx1 ->
        prefix p sfx2 ->
        prefix p (common_suffix sfx1 sfx2).
    Proof.
      intros. revert dependent sfx2.
      induction H as [|a]. auto. intros * Hp. simpl. destruct a.
      destruct sfx2. inv Hp. destruct p. inv Hp.
      rewrite equiv_decb_refl, Pos.eqb_refl. simpl. constructor. auto.
    Qed.

    Lemma suffix_of_clock_of_suffix :
      forall sfx, sfx = suffix_of_clock (clock_of_suffix sfx Cbase) [].
    Proof.
      intro sfx.
      assert (suffix_of_clock Cbase [] = []) by auto.
      rewrite <- app_nil_l, <- H at 1.
      generalize Cbase.
      induction sfx as [|[i b]]. simpl in *; auto.
      now setoid_rewrite app_nil_r.
      simpl in *. setoid_rewrite <- IHsfx.
      setoid_rewrite <- suffix_of_clock_app. setoid_rewrite app_nil_l at 2.
      now simpl.
    Qed.

    Lemma Tim :
      forall bk ck ck',
        clock_parent bk ck ->
        clock_parent bk ck' ->
        exists d, (d = bk \/ clock_parent bk d) /\
             suffix_of_clock d [] =
             common_suffix (suffix_of_clock ck []) (suffix_of_clock ck' []).
    Proof.
      intros * Hp Hp'.
      eapply or_intror in Hp. apply prefix_parent in Hp.
      eapply or_intror in Hp'. apply prefix_parent in Hp'.
      pose proof (prefix_common_suffix _ _ _ Hp Hp') as Hc.
      rewrite suffix_of_clock_of_suffix in Hc.
      apply prefix_parent in Hc.
      esplit. split; eauto using suffix_of_clock_of_suffix.
    Qed.

    Lemma find_base_clock_bck:
      forall lck bk,
        In bk lck ->
        Forall (fun ck => ck = bk \/ clock_parent bk ck) lck ->
        find_base_clock lck = bk.
    Proof.
      destruct lck. inversion 1.
      simpl. intros * Hin Hf. rewrite <- fold_left_map.
      apply Forall_cons2 in Hf as [Hf1 Hf2].
      revert dependent c. induction lck. simpl. intros.
      inv Hin; try tauto.
      now rewrite clock_of_suffix_of_clock.
      simpl. apply Forall_cons2 in Hf2 as [? Hf]. specialize (IHlck Hf).
      intros. destruct H, Hf1; subst.
      - rewrite common_suffix_id. eauto.
      - rewrite parent_common_suffix; eauto.
      - rewrite common_suffix_comm, parent_common_suffix; eauto.
      - pose proof (Tim _ _ _ H H0) as (?&?& H2).
        rewrite common_suffix_comm, <- H2.
        eapply IHlck; eauto.
        destruct Hin as [|[]]; auto; subst; exfalso;
          eapply clock_parent_not_refl; eauto.
    Qed.

  End Clock_operations.

  Fact to_global_names : forall name G G' Hprefs,
      Forall (fun n => (name <> L.n_name n)%type) G ->
      to_global G Hprefs = OK G' ->
      Forall (fun n => (name <> NL.n_name n)%type) G'.
  Proof.
    induction G; intros * Hnames Htog; inv Hnames; monadInv Htog; constructor; eauto.
    erewrite to_node_name in H1; eauto.
  Qed.

  Ltac simpl_Foralls :=
    repeat
      match goal with
      | H: Forall _ [] |- _ => inv H
      | H: Forall _ [_] |- _ => inv H
      | H: Forall _ (_::_) |- _ => inv H
      | H: Forall2 _ [_] _ |- _ => inv H
      | H: Forall2 _ [] _ |- _ => inv H
      | H: Forall2 _ _ [_] |- _ => inv H
      | H: Forall2 _ _ [] |- _ => inv H
      end.

End TR.

Module TrFun
       (Ids   : IDS)
       (Op    : OPERATORS)
       (OpAux : OPERATORS_AUX Op)
       (L     : LSYNTAX  Ids Op)
       (CE    : CESYNTAX     Op)
       (NL    : NLSYNTAX Ids Op CE)
       <: TR Ids Op OpAux L CE NL.
  Include TR Ids Op OpAux L CE NL.
End TrFun.