From compcert Require Import Smallstep Clight Integers Events Behaviors.
Require Import Coqlib.
Require Import ImpPrelude.
Require Import STS.
Require Import Behavior.
Require Import Imp.
Require Import Imp2Csharpminor.
From Ordinal Require Import Ordinal.

Set Implicit Arguments.

Section Beh.

  Inductive match_val : eventval -> Z -> Prop :=
  | match_val_intro :
      forall v, match_val (EVlong v) (Int64.signed v).

  Inductive match_event : Events.event -> STS.event -> Prop :=
  | match_event_intro
      name eargs uargs er ur
      (MV: Forall2 match_val eargs uargs)
      (MV: match_val er ur)
    :
      match_event (Event_syscall name eargs er) (event_sys name uargs↑ ur↑)
  .

  Variant _match_beh (match_beh: _ -> _ -> Prop) (tgtb : program_behavior) (srcb : Tr.t) : Prop :=
  | match_beh_Terminates
      tr mtr r
      (MT : Forall2 match_event tr mtr)
      (TB : tgtb = Terminates tr r)
      (SB : srcb = Tr.app mtr (Tr.done r.(Int.intval)↑))
    :
      _match_beh match_beh tgtb srcb
  | match_beh_Diverges
      tr mtr
      (MT : Forall2 match_event tr mtr)
      (TB : tgtb = Diverges tr)
      (SB : srcb = Tr.app mtr (Tr.spin))
    :
      _match_beh match_beh tgtb srcb
  | match_beh_Reacts
      ev mev trinf mtrinf
      (ME : match_event ev mev)
      (MB : match_beh (Reacts trinf) mtrinf)
      (TB : tgtb = Reacts (Econsinf ev trinf))
      (SB : srcb = Tr.cons mev mtrinf)
    :
      _match_beh match_beh tgtb srcb
  | match_beh_ub_trace
      mtr tr
      (SB : srcb = Tr.app mtr (Tr.ub))
      (MT : Forall2 match_event tr mtr)
      (TB : behavior_prefix tr tgtb)
    :
      _match_beh match_beh tgtb srcb.

  Definition match_beh : _ -> _ -> Prop := paco2 _match_beh bot2.

  Lemma match_beh_mon : monotone2 _match_beh.
  Proof.
    ii. inv IN.
    - econs 1; eauto.
    - econs 2; eauto.
    - econs 3; eauto.
    - econs 4; eauto.
  Qed.

End Beh.
Hint Constructors _match_beh.
Hint Unfold match_beh.
Hint Resolve match_beh_mon: paco.

Definition improves2 {L0 L1} (st_src0: L0.(STS.state)) (st_tgt0: L1.(Smallstep.state)): Prop :=
  forall tr_tgt (BEH: state_behaves L1 st_tgt0 tr_tgt),
  exists tr_src, (<<BEH: (Beh.of_state L0 st_src0) tr_src>>) /\
                 (<<SIM: match_beh tr_tgt tr_src>>)
.

Definition improves2_program (L0: STS.semantics) (L1: Smallstep.semantics) : Prop :=
  forall tr_tgt (BEH: program_behaves L1 tr_tgt),
  exists tr_src, (<<BEH: (Beh.of_state L0 L0.(initial_state)) tr_src>>) /\
                 (<<SIM: match_beh tr_tgt tr_src>>)
.

Definition improves (L0 L1: STS.semantics): Prop :=
  Beh.improves (Beh.of_program L0) (Beh.of_program L1)
.

Lemma improves_combine: forall (S I: STS.semantics) (A: Smallstep.semantics),
    improves S I -> improves2_program I A -> improves2_program S A.
Proof.
  i. ii. exploit H0; et. i; des. exists tr_src. esplits; et. eapply H; et.
Qed.

(************************ Coq Aux ****************************)
(************************ Coq Aux ****************************)
(************************ Coq Aux ****************************)
Fixpoint sequence X (xs: list (option X)): option (list X) :=
  match xs with
  | nil => Some nil
  | Some hd :: tl => do tl <- (sequence tl); Some (hd :: tl)
  | None :: _ => None
  end
.

(*** it is basically sequence with return type (Err (list X) (list X)). ***)
(*** i.e., fails with information ***)
Fixpoint squeeze X (es: list (option X)): ((list X) * bool) :=
  match es with
  | [] => ([], true)
  | Some e :: tl => let '(es, succ) := squeeze tl in ((e :: es), succ)
  | _ => ([], false)
  end
.

Lemma squeeze_app X (l0 l1: list (option X))
  :
    squeeze (l0 ++ l1) =
    let '(l0', b0) := squeeze l0 in
    if b0
    then let '(l1', b1) := squeeze l1 in (l0'++l1', b1)
    else (l0', false).
Proof.
  revert l1. induction l0; ss.
  { i. des_ifs. }
  { i. des_ifs.
    { rewrite IHl0 in Heq. rewrite Heq1 in *. clarify. }
    { rewrite IHl0 in Heq. clarify. }
  }
Qed.

Definition option_to_list X (x: option X): list X :=
  match x with
  | Some x => [x]
  | _ => []
  end
.
Coercion option_to_list: option >-> list.
Hint Constructors Forall2.

(************************ Tgt Aux ****************************)
(************************ Tgt Aux ****************************)
(************************ Tgt Aux ****************************)
Definition single_events_at (L: Smallstep.semantics) (s:L.(Smallstep.state)) : Prop :=
  forall t s', Step L s t s' -> (t = E0).

Record wf_at (L: Smallstep.semantics) (s:L.(Smallstep.state)) : Prop :=
  Wf_at {
      wf_at_determ:
        forall s1 t2 s2
               (STEP0: Step L s E0 s1)
               (STEP1 :Step L s t2 s2),
          (<<EQ: s1 = s2 /\ t2 = E0>>);
      wf_at_final:
        forall tr s' retv
               (FINAL: Smallstep.final_state L s retv)
               (STEP: Step L s tr s'),
          False;
      wf_at_final_determ:
        forall retv0 retv1
               (FINAL0: Smallstep.final_state L s retv0)
               (FINAL1: Smallstep.final_state L s retv1),
          (<<EQ: retv0 = retv1>>);
    }.

Definition wf_semantics (L: Smallstep.semantics) : Prop :=
  forall st, wf_at L st.

(* Record strict_determinate_at (L: Smallstep.semantics) (s:L.(Smallstep.state)) : Prop := *)
(*   Strict_determinate_at { *)
(*       ssd_determ_at: forall t1 s1 t2 s2 *)
(*         (STEP0: Step L s t1 s1) *)
(*         (STEP1 :Step L s t2 s2), *)
(*         <<EQ: s1 = s2>>; *)
(*     ssd_determ_at_final: forall tr s' retv *)
(*         (FINAL: Smallstep.final_state L s retv) *)
(*         (STEP: Step L s tr s'), *)
(*         False; *)
(*     ssd_traces_at: *)
(*       single_events_at L s *)
(*   }. *)

(************************ Src Aux ****************************)
(************************ Src Aux ****************************)
(************************ Src Aux ****************************)

Definition wf (L: semantics) (st0: L.(state)): Prop :=
  forall (ANG: L.(state_sort) st0 = angelic),
  forall st1 st1' (STEP: step L st0 None st1) (STEP: step L st0 None st1'), st1 = st1'
.

Section STAR.
  Variable L: semantics.
  Variable P: L.(state) -> Prop.
  Inductive pstar: L.(state) -> list event -> L.(state) -> Prop :=
  | star_refl: forall st_src0, pstar st_src0 [] st_src0
  | star_step: forall
      st_src0 es0 st_src1 es1 st_src2
      (P: P st_src0)
      (HD: step L st_src0 es0 st_src1)
      (TL: pstar st_src1 es1 st_src2)
    ,
      pstar st_src0 (es0 ++ es1) st_src2
  .
End STAR.
Hint Constructors pstar.
Definition dstar L := pstar L (fun st_src0 => L.(state_sort) st_src0 = demonic).
Definition star L := pstar L (wf L).

Lemma star_trans
      L
      st0 st1 st2 es0 es1
      (STEPS0: star L st0 es0 st1)
      (STEPS1: star L st1 es1 st2)
  :
    star L st0 (es0 ++ es1) st2.
Proof.
  revert es1 st2 STEPS1. induction STEPS0; et.
  i. rewrite <- List.app_assoc.
  econs; et. eapply IHSTEPS0. et.
Qed.

Lemma star_des
      L
      st0 e es st2
      (STAR: star L st0 (e :: es) st2)
  :
    exists st1, <<HD: star L st0 [e] st1>> /\ <<TL: star L st1 es st2>>
.
Proof.
  remember (e :: es) as x. revert Heqx. revert e es.
  induction STAR; ii; ss.
  destruct es0; ss.
  - clarify. esplits; et. change [e] with ((option_to_list (Some e)) ++ []).
    econs; ss; et.
  - subst. exploit IHSTAR; et. i; des. esplits; et.
    change [e] with ((@option_to_list event None) ++ [e]).
    econs; ss; et.
Qed.

Lemma star_event_ind
      L
      (P: L.(state) -> list event -> L.(state) -> Prop)
      (BASE: forall st0 st1, star L st0 [] st1 -> P st0 [] st1)
      (SUCC: forall e es st0 st1 st2, star L st0 [e] st1 -> star L st1 es st2 ->
                                      P st1 es st2 -> P st0 (e :: es) st2)
  :
    forall st0 es st1, star L st0 es st1 -> P st0 es st1
.
Proof.
  fix IH 2.
  i.
  destruct es; ss.
  - eapply BASE. ss.
  - eapply star_des in H. des. rename st2 into st_mid.
    eapply SUCC.
    { et. }
    { et. }
    eapply IH.
    eapply TL.
Qed.

Lemma star_single_exact
      L0 st0 st3 e0
      (STAR: star L0 st0 [e0] st3)
  :
    exists st1 st2, (<<STAR: star L0 st0 [] st1>>) /\
                    (<<VIS: step L0 st1 (Some e0) st2>>) /\
                    (<<STAR: star L0 st2 [] st3>>)
.
Proof.
  dependent induction STAR; ii; ss.
  destruct es0; ss.
  { destruct es1; ss. clarify. esplits; et. econs. }
  clarify.
  exploit IHSTAR; et. i; des. esplits; try apply VIS; et.
  replace [] with ((@option_to_list event None) ++ []) by ss.
  econs; et.
Qed.

Definition NoStuck L (st_src0: state L): Prop :=
  L.(state_sort) st_src0 = angelic ->
  (<<NOSTUCK: exists ev st_src1, step L st_src0 ev st_src1>>)
(* (<<DTM: forall st_src1 st_src1', *)
(*     step L st_src0 None st_src1 -> *)
(*     step L st_src0 None st_src1' -> *)
(*     st_src1 = st_src1'>>) *)
.

(* Definition wf (L: semantics): Prop := *)
(*   forall (st0: L.(state)) (ANG: L.(state_sort) st0 = angelic), *)
(*   forall st1 st1' (STEP: step L st0 None st1) (STEP: step L st0 None st1'), st1 = st1' *)
(* . *)

Section BEH.

Variable L: semantics.
(* Hypothesis WFSRC: wf L. *)
(* Hypothesis WFSRC: forall st, (state_sort L st = angelic) -> wf L st. *)

(*** TODO: move to proper place? ***)
Lemma _beh_astep_rev
      r tr st0 ev st1
      (SRT: _.(state_sort) st0 = angelic)
      (WFSRC: wf _ st0)
      (STEP: _.(step) st0 ev st1)
      (BEH: paco2 (Beh._of_state L) r st1 tr)
  :
    <<BEH: paco2 (Beh._of_state L) r st0 tr>>
.
Proof.
  exploit wf_angelic; et. i; clarify.
  pfold. econsr; ss; et. rr. ii. exploit wf_angelic; et. i; des. subst.
  exploit WFSRC; [..|apply STEP|apply STEP0|]; ss. i; subst. esplits; et.
  punfold BEH.
Qed.

Lemma beh_of_state_star
      r st_src0 st_src1 es0 tr1
      (BEH: paco2 (Beh._of_state L) r st_src1 tr1)
      (STAR: star L st_src0 es0 st_src1)
  :
    <<BEH: paco2 (Beh._of_state L) r st_src0 (Tr.app es0 tr1)>>
.
Proof.
  revert BEH. revert tr1.
  induction STAR; ii; ss.
  exploit IHSTAR; et.
  intro U; des.
  destruct (state_sort L st_src0) eqn:T.
  - exploit wf_angelic; et. i; subst. ss.
    eapply _beh_astep_rev; et.
  - exploit wf_demonic; et. i; subst. ss.
    pfold. econs; ss; et. rr. esplits; ss; et. punfold U.
  - exploit wf_final; et. ss.
  - destruct es0; ss; cycle 1.
    { exploit wf_vis_event; et. ss. }
    pfold; econs; ss; et.
Qed.

Variant starC (r: (state L -> Tr.t -> Prop)): (state L -> Tr.t -> Prop) :=
| starC_intro
    st0 st1 tr
    (STAR: star L st0 [] st1)
    (SIM: r st1 tr)
  :
    starC r st0 tr
.

Hint Constructors starC: core.

Lemma starC_mon
      r1 r2
      (LE: r1 <2= r2)
  :
    starC r1 <2= starC r2
.
Proof. ii. destruct PR; econs; et. Qed.

Hint Resolve starC_mon: paco.

Lemma starC_prespectful: prespectful2 (Beh._of_state L) starC.
Proof.
  econs; eauto with paco.
  ii. rename x0 into st0. rename x1 into tr.
  inv PR. rename st2 into st1.
  apply GF in SIM.
  { change tr with (Tr.app [] tr). eapply beh_of_state_star; et. pfold.
    eapply Beh.of_state_mon; et.
  }
Qed.

Lemma starC_spec: starC <3= gupaco2 (Beh._of_state L) (cpn2 (Beh._of_state L)).
Proof. intros. eapply prespect2_uclo; eauto with paco. eapply starC_prespectful. Qed.

Variant starC2 (r: (state L -> Tr.t -> Prop)): (state L -> Tr.t -> Prop) :=
| starC2_intro
    st0 st1 tr0 tr1
    (STAR: star L st0 tr0 st1)
    (SIM: r st1 tr1)
  :
    starC2 r st0 (Tr.app tr0 tr1)
.

Hint Constructors starC2: core.

Lemma starC2_mon
      r1 r2
      (LE: r1 <2= r2)
  :
    starC2 r1 <2= starC2 r2
.
Proof. ii. destruct PR; econs; et. Qed.

Hint Resolve starC2_mon: paco.

Lemma starC2_prespectful: prespectful2 (Beh._of_state L) starC2.
Proof.
  econs; eauto with paco.
  ii. rename x0 into st0. rename x1 into tr.
  inv PR. rename st2 into st1.
  apply GF in SIM.
  { eapply beh_of_state_star; ss; et. pfold.
    eapply Beh.of_state_mon; et.
  }
Qed.

Lemma starC2_spec: starC2 <3= gupaco2 (Beh._of_state L) (cpn2 (Beh._of_state L)).
Proof. intros. eapply prespect2_uclo; eauto with paco. eapply starC2_prespectful. Qed.

End BEH.

(************************ Decompile ****************************)
(************************ Decompile ****************************)
(************************ Decompile ****************************)

Definition decompile_eval (ev: eventval): option Z :=
  match ev with
  | EVlong i => Some (Int64.signed i)
  | _ => None
  end
.

Definition decompile_event (ev: Events.event): option event :=
  match ev with
  | Event_syscall fn evs ev =>
    do vs <- sequence (List.map decompile_eval evs);
    do v <- decompile_eval ev;
    Some (event_sys fn vs↑ v↑)
  | _ => None
  end.

(* Definition _decompile_trinf decompile_trinf (tr: traceinf): Tr.t := *)
(*   match tr with *)
(*   | Econsinf ev tr => *)
(*     match decompile_event ev with *)
(*     | Some ev => Tr.cons ev (decompile_trinf tr) *)
(*     | _ => Tr.ub *)
(*     end *)
(*   end *)
(* . *)

(* CoFixpoint decompile_trinf (tr: traceinf): Tr.t := *)
(*   _decompile_trinf decompile_trinf tr. *)
CoFixpoint decompile_trinf (tr: traceinf): Tr.t :=
  match tr with
  | Econsinf ev tr =>
    match decompile_event ev with
    | Some ev => Tr.cons ev (decompile_trinf tr)
    | _ => Tr.ub
    end
  end
.

Variant _Tr: Type :=
| _Tr_done (retv: Any.t)
| _Tr_spin
| _Tr_ub
| _Tr_nb
| _Tr_cons (hd: event) (tl: Tr.t)
.

Definition match_Tr (tr: Tr.t) :=
  match tr with
  | Tr.done retv => _Tr_done retv
  | Tr.spin => _Tr_spin
  | Tr.ub => _Tr_ub
  | Tr.nb => _Tr_nb
  | Tr.cons hd tl => _Tr_cons hd tl
  end.

Lemma Tr_eta (tr0 tr1: Tr.t)
      (EQ: match_Tr tr0 = match_Tr tr1)
  :
    tr0 = tr1.
Proof.
  destruct tr0, tr1; ss; clarify.
Qed.

Lemma unfold_decompile_trinf
      tr
  :
    (decompile_trinf tr) =
    (match tr with
     | Econsinf ev tr =>
       match decompile_event ev with
       | Some ev => Tr.cons ev (decompile_trinf tr)
       | _ => Tr.ub
       end
     end)
.
Proof.
  destruct tr. eapply Tr_eta. ss.
Qed.

Lemma decompile_trinf_app
      tr_tgt tr_src T
      (MB: squeeze (List.map decompile_event tr_tgt) = (tr_src, true))
  :
    (decompile_trinf (tr_tgt *** T)) = Tr.app tr_src (decompile_trinf T)
.
Proof.
  ginduction tr_tgt; ii; ss; clarify.
  des_ifs. ss.
  rewrite unfold_decompile_trinf. des_ifs. f_equal.
  eapply IHtr_tgt; ss.
Qed.

Definition transl_beh (p: program_behavior): Tr.t :=
  match p with
  | Terminates tr i =>
    let '(es, succ) := squeeze (List.map decompile_event tr) in
    Tr.app es (if succ then (Tr.done (Int.unsigned i)↑) else Tr.ub)
  | Diverges tr =>
    let '(es, succ) := squeeze (List.map decompile_event tr) in
    Tr.app es (if succ then (Tr.spin) else Tr.ub)
  | Reacts tr => (decompile_trinf tr)
  | Goes_wrong tr =>
    let '(es, succ) := squeeze (List.map decompile_event tr) in
    Tr.app es Tr.ub
  end
.

Lemma decompile_match_val v0 v1
      (SEQ: decompile_eval v0 = Some v1)
  :
    match_val v0 v1.
Proof.
  unfold decompile_eval in *. des_ifs.
Qed.

Lemma decompile_match_vals l0 l1
      (SEQ: sequence (List.map decompile_eval l0) = Some l1)
  :
    Forall2 match_val l0 l1.
Proof.
  revert l1 SEQ. induction l0; ss.
  { i. clarify. }
  { i. uo. des_ifs. econs; et.
    eapply decompile_match_val; et. }
Qed.

Lemma decompile_match_event
      e0 e1
      (D: decompile_event e0 = Some e1)
  :
    <<M: match_event e0 e1>>
.
Proof.
  destruct e0; ss. uo. des_ifs. econs.
  { eapply decompile_match_vals; et. }
  { eapply decompile_match_val; et. }
Qed.

Lemma match_val_iff v0 v1
  :
    decompile_eval v0 = Some v1 <->
    match_val v0 v1.
Proof.
  split.
  { eapply decompile_match_val. }
  i. inv H. ss.
Qed.

Lemma match_vals_iff l0 l1
  :
    sequence (List.map decompile_eval l0) = Some l1 <->
    Forall2 match_val l0 l1.
Proof.
  split.
  { eapply decompile_match_vals. }
  revert l1. induction l0; ss.
  { i. inv H. ss. }
  { i. inv H. hexploit IHl0; et. i.
    uo. rewrite H.
    eapply match_val_iff in H2. rewrite H2. ss. }
Qed.

Lemma match_event_iff
      e_src e_tgt
  :
    decompile_event e_tgt = Some e_src <->
    match_event e_tgt e_src
.
Proof.
  split.
  { eapply decompile_match_event. }
  i. inv H. ss. uo.
  eapply match_vals_iff in MV. rewrite MV.
  eapply match_val_iff in MV0. rewrite MV0. ss.
Qed.

Lemma match_event_squeeze
      e_src e_tgt
  :
    squeeze [decompile_event e_tgt] = ([e_src], true) <->
    match_event e_tgt e_src
.
Proof.
  split; i.
  - ss. des_ifs. eapply match_event_iff; et.
  - eapply match_event_iff in H; et. ss. des_ifs.
Qed.

Lemma match_events_squeeze
      es_src es_tgt
  :
    squeeze (List.map decompile_event es_tgt) = (es_src, true) <->
    Forall2 match_event es_tgt es_src
.
Proof.
  revert es_tgt. induction es_src; ss.
  { i. split.
    { destruct es_tgt; ss. des_ifs. }
    { i. inv H. ss. }
  }
  { i. split.
    { i. destruct es_tgt; ss. des_ifs.
      hexploit IHes_src; et. i. econs.
      { eapply match_event_squeeze. ss. rewrite Heq. ss. }
      { eapply H. et. }
    }
    { i. inv H. eapply IHes_src in H4. ss.
      eapply match_event_iff in H3. rewrite H3.
      rewrite H4. ss.
    }
  }
Qed.

Theorem decompile_trinf_spec
        tr
  :
    match_beh (Reacts tr) (decompile_trinf tr)
.
Proof.
  revert tr.
  pcofix CIH.
  i. destruct tr; ss.
  rewrite unfold_decompile_trinf. des_ifs.
  - eapply match_event_iff in Heq. dup Heq. inv Heq.
    pfold. eapply match_beh_Reacts; et.
  - pfold. econsr; ss; et.
    r. esplits; ss; et. rewrite behavior_app_E0. ss.
Qed.

Section SIM.

  Variable L0: STS.semantics.
  Variable L1: Smallstep.semantics.
  Let idx := Ord.t.
  Let ord := Ord.lt.

  Local Open Scope smallstep_scope.

  Variant _sim sim (i0: idx) (st_src0: L0.(STS.state)) (st_tgt0: L1.(Smallstep.state)): Prop :=
  | sim_fin
      retv
      (RANGE: (0 <= retv <= Int.max_unsigned)%Z)
      (* (RANGE: (Int.min_signed <= retv <= Int.max_signed)%Z) *)
      (SRT: _.(state_sort) st_src0 = final retv↑)
      (SRT: _.(Smallstep.final_state) st_tgt0 (Int.repr retv))
      (* (DTM: True) (*** TODO: copy-paste sd_final_determ in Smallstep.v ***) *)
    :
      _sim sim i0 st_src0 st_tgt0

  | sim_vis
      (SRT: _.(state_sort) st_src0 = vis)
      (SRT: exists _ev_tgt _st_tgt1, Step L1 st_tgt0 [_ev_tgt] _st_tgt1)
      (SIM: forall ev_tgt st_tgt1
          (STEP: Step L1 st_tgt0 ev_tgt st_tgt1)
        ,
          exists st_src1 ev_src (STEP: _.(step) st_src0 (Some ev_src) st_src1),
            (<<MATCH: Forall2 match_event ev_tgt [ev_src]>>) /\
            (<<SIM: exists i1, sim i1 st_src1 st_tgt1>>))
    :
      _sim sim i0 st_src0 st_tgt0

  | sim_demonic_src
      (SRT: _.(state_sort) st_src0 = demonic)
      (SIM: exists st_src1
          (STEP: _.(step) st_src0 None st_src1)
        ,
          exists i1, <<ORD: ord i1 i0>> /\ <<SIM: sim i1 st_src1 st_tgt0>>)
    :
      _sim sim i0 st_src0 st_tgt0
  | sim_demonic_tgt_dtm
      (*** WRONG DEF, Note: UB in tgt ***)
      (* (SIM: forall st_tgt1 *)
      (*     (STEP: Step L1 st_tgt0 E0 st_tgt1) *)
      (*   , *)
      (*     exists i1, <<ORD: ord i1 i0>> /\ <<SIM: sim i1 st_src0 st_tgt1>>) *)
      (SIM: exists st_tgt1
          (STEP: Step L1 st_tgt0 E0 st_tgt1)
        ,
          exists i1, <<ORD: ord i1 i0>> /\ <<SIM: sim i1 st_src0 st_tgt1>>)
      (*** equivalent def ***)
      (* st_tgt1 *)
      (* (STEP: Step L1 st_tgt0 E0 st_tgt1) *)
      (* i1 *)
      (* (ORD: ord i1 i0) *)
      (* (SIM: sim i1 st_src0 st_tgt1) *)
    :
      _sim sim i0 st_src0 st_tgt0
  | sim_angelic_src
      (SRT: _.(state_sort) st_src0 = angelic)
      (DTM: forall st1 st2, (<<DTM1: _.(step) st_src0 None st1>>) -> (<<DTM2: _.(step) st_src0 None st2>>) -> st1 = st2)
      (SIM: forall st_src1
          (STEP: _.(step) st_src0 None st_src1)
        ,
          exists i1, <<ORD: ord i1 i0>> /\ <<SIM: sim i1 st_src1 st_tgt0>>)
    :
      _sim sim i0 st_src0 st_tgt0

  | sim_demonic_both
      (SRT: _.(state_sort) st_src0 = demonic)
      (SIM: exists st_tgt1
          (STEP: Step L1 st_tgt0 E0 st_tgt1)
        ,
          exists st_src1 (STEP: _.(step) st_src0 None st_src1),
            <<SIM: exists i1, sim i1 st_src1 st_tgt1>>)
    :
      _sim sim i0 st_src0 st_tgt0
  .

  Definition sim: _ -> _ -> _ -> Prop := paco3 _sim bot3.

  Lemma sim_mon: monotone3 _sim.
  Proof.
    ii. inv IN.

    - econs 1; et.
    - econs 2; et. i. exploit SIM; et. i; des. esplits; et.
    - econs 3; et. des. esplits; et.
    - econs 4; et. des. esplits; et.
    - econs 5; et. i. exploit SIM; et. i; des. esplits; et.
    - econs 6; et. des. esplits; et.
  Qed.

  Hint Constructors _sim.
  Hint Unfold sim.
  Hint Resolve sim_mon: paco.

  Variant ordC (r: idx -> L0.(STS.state) -> L1.(Smallstep.state) -> Prop):
    idx -> L0.(STS.state) -> L1.(Smallstep.state) -> Prop :=
  | ordC_intro
      o0 o1 st_src st_tgt
      (ORD: Ord.le o0 o1)
      (SIM: r o0 st_src st_tgt)
    :
      ordC r o1 st_src st_tgt
  .

  Lemma ordC_mon
        r1 r2
        (LE: r1 <3= r2)
    :
      ordC r1 <3= ordC r2
  .
  Proof. ii. destruct PR; econs; et. Qed.

  Hint Resolve ordC_mon: paco.

  Lemma ordC_compatible: compatible3 (_sim) ordC.
  Proof.
    econs; eauto with paco.
    ii. inv PR. rename x0 into o1. rename x1 into st_src. rename x2 into st_tgt. inv SIM.
    - econs 1; eauto.
    - econs 2; eauto. i. hexploit SIM0; et. i. des. esplits; et. econs; [|et]. refl.
    - econs 3; eauto. des. esplits; et. { eapply Ord.lt_le_lt; et. } econs; et. refl.
    - econs 4; eauto. des. esplits; et. { eapply Ord.lt_le_lt; et. } econs; et. refl.
    - econs 5; eauto. i. hexploit SIM0; et. i. des. esplits; et.
      { eapply Ord.lt_le_lt; et. } econs; et. refl.
    - econs 6; eauto. des. esplits; et. econs; [|et]. refl.
  Qed.

  Lemma ordC_spec: ordC <4= gupaco3 (_sim) (cpn3 _sim).
  Proof.
    intros. gclo. econs.
    { eapply ordC_compatible. }
    eapply ordC_mon; [|et]. i. gbase. auto.
  Qed.

  Record simulation: Prop := mk_simulation {
    sim_init: forall st_tgt0 (INITT: L1.(Smallstep.initial_state) st_tgt0),
        exists i0, (<<SIM: sim i0 L0.(initial_state) st_tgt0>>);
    (* sim_init: exists i0 st_tgt0, (<<SIM: sim i0 L0.(initial_state) st_tgt0>>) /\ *)
    (*                              (<<INITT: L1.(Smallstep.initial_state) st_tgt0>>); *)
    (* sim_dtm: True; *)
  }
  .

  Hypothesis WF: well_founded ord.
  Hypothesis WFSEM: wf_semantics L1.

  Ltac pc H := rr in H; desH H; ss.

  Definition safe_along_events (st_src0: state L0) (tr: list Events.event): Prop := forall
      st_src1
      tx ty tx_src
      (STAR: star L0 st_src0 tx_src st_src1)
      (MB: squeeze (List.map decompile_event tx) = (tx_src, true))
      (PRE: tx ++ ty = tr)
    ,
      <<SAFE: NoStuck L0 st_src1>>
  .

  Definition safe_along_trace (st_src0: state L0) (tr: program_behavior) : Prop := forall
      thd
      (BEH: behavior_prefix thd tr)
    ,
      safe_along_events st_src0 thd
  .

  Lemma match_beh_cons
        b0 b1
        e0 e1
        b0_ b1_
        (B0_: b0_ = (behavior_app [e0] b0))
        (B1_: b1_ = (Tr.app [e1] b1))
        (M0: match_beh b0 b1)
        (M1: match_event e0 e1)
    :
      <<M: match_beh b0_ b1_>>
  .
  Proof.
    subst.
    revert_until b0. revert b0.
    pcofix CIH. i. punfold M0. inv M0.
    - pfold. econs 1; try refl; ss; et.
    - pfold. econs 2; try refl; ss; et.
    - pfold. econs 3; try refl; ss; et. pclearbot. right.
      change (Reacts (Econsinf ev trinf)) with (behavior_app [ev] (Reacts trinf)).
      eapply CIH; et.
    - pfold. econs 4.
      { instantiate (1:=e1 :: mtr). ss; et. }
      { econs; ss; et. }
      rr in TB. des. subst.
      rr. esplits; ss; et. rewrite <- behavior_app_assoc. ss.
  Qed.

  Lemma match_val_inj
        v_tgt0 v_src0 v_src1
        (M0: match_val v_tgt0 v_src0)
        (M1: match_val v_tgt0 v_src1)
    :
      v_src0 = v_src1
  .
  Proof. inv M0. inv M1. ss. Qed.

  Lemma match_event_inj
        e_tgt0 e_src0 e_src1
        (M0: match_event e_tgt0 e_src0)
        (M1: match_event e_tgt0 e_src1)
    :
      e_src0 = e_src1
  .
  Proof.
    inv M0. inv M1. f_equal.
    { f_equal. clear - MV MV1. ginduction MV; ii; ss.
      { inv MV1; ss. }
      inv MV1; ss.
      f_equal; et.
      eapply match_val_inj; et.
    }
    f_equal. eapply match_val_inj; et.
  Qed.

  Lemma safe_along_events_step_some
        st_src0 st_src1 e_src e0 es0
        (WFSRC: wf L0 st_src0)
        (STEP: step L0 st_src0 (Some e_src) st_src1)
        (MB: decompile_event e0 = Some e_src)
        (SAFE: safe_along_events st_src0 ([e0] ++ es0))
    :
      <<SAFE: safe_along_events st_src1 es0>>
  .
  Proof.
    ii. des; clarify. eapply SAFE; ss.
    { econs; et. }
    { instantiate (1 := e0 :: _). ss. des_ifs. rewrite MB0 in *; clarify. }
    { ss. }
  Qed.

  Lemma safe_along_events_step_none
        st_src0 st_src1 es0
        (WFSRC: wf L0 st_src0)
        (STEP: step L0 st_src0 None st_src1)
        (SAFE: safe_along_events st_src0 es0)
    :
      <<SAFE: safe_along_events st_src1 es0>>
  .
  Proof.
    ii. des; clarify. eapply SAFE; ss.
    { econs; et. }
    { ss. }
  Qed.

  Lemma safe_along_events_star
        st_src0 st_src1 es0_src es0 es1
        (STAR: star L0 st_src0 es0_src st_src1)
        (MB: squeeze (List.map decompile_event es0) = (es0_src, true))
        (SAFE: safe_along_events st_src0 (es0 ++ es1))
    :
      <<SAFE: safe_along_events st_src1 es1>>
  .
  Proof.
    revert st_src0 st_src1 es0_src es1 STAR MB SAFE. induction es0; ss.
    { i. clarify. ii. subst. exploit SAFE; [..|et|et].
      { instantiate (1:=tx_src).
        change tx_src with ([] ++ tx_src). eapply star_trans; et. }
      { et. }
      { et. }
    }
    { i. des_ifs. ii. subst. exploit SAFE; [..|et|et].
      { instantiate (1:=_ ++ _). eapply star_trans; et. }
      { instantiate (1:=a :: es0 ++ tx). ss. rewrite Heq.
        rewrite List.map_app. rewrite squeeze_app.
        rewrite MB. des_ifs. }
      { instantiate (1:=ty). ss. rewrite ! List.app_assoc. auto. }
    }
  Qed.

  (* Hypothesis WFSRC: wf L0. *)

  Lemma simulation_star
        i0 st_src0 tr_tgt st_tgt1 st_tgt0
        (* (MATCH: Forall2 match_event tr_tgt tr_src) *)
        (STEP: Star L1 st_tgt0 tr_tgt st_tgt1)
        (SIM: sim i0 st_src0 st_tgt0)
        (SAFE: safe_along_events st_src0 tr_tgt)
    :
      exists i1 st_src1 tr_src,
        (<<MB: squeeze (List.map decompile_event tr_tgt) = (tr_src, true)>>) /\
        (<<STEP: star L0 st_src0 tr_src st_src1>>) /\
        (<<SIM: sim i1 st_src1 st_tgt1>>)
  .
  Proof.
    revert SAFE. revert SIM. depgen st_src0. revert i0.
    induction STEP; ii; ss.
    { esplits; et. econs; ss. }
    subst. rename s1 into st_tgt0. rename s2 into st_tgt1. rename s3 into st_tgt2.
    rename t1 into tr_tgt0. rename t2 into tr_tgt1.

    revert_until i0. pattern i0. eapply well_founded_ind; et. clear i0. intros i0 IH. i.

    punfold SIM. inv SIM.
    - (* fin *)
      exploit wf_at_final; [apply WFSEM|..]; et. ss.
    - (* vis *)
      clear SRT0. exploit SIM0; et. i; des. pclearbot.
      inv MATCH; ss. inv H4; ss. rename H3 into MB. eapply match_event_iff in MB. des_ifs.
      exploit IHSTEP; et.
      { eapply safe_along_events_step_some; et. unfold wf. i. rewrite ANG in SRT. ss. }
      i; des. clarify.
      esplits; et. rewrite cons_app.
      change [ev_src] with (option_to_list (Some ev_src)).
      econs; et.
      unfold wf. i. rewrite ANG in SRT. ss.
    - (* dsrc *)
      des. pclearbot. exploit IH; et.
      { eapply safe_along_events_step_none; et. unfold wf. i. rewrite ANG in SRT. ss. }
      i; des.
      esplits; et.
      rewrite <- (app_nil_l tr_src).
      change [] with (@option_to_list event None).
      econs; et.
      unfold wf. i. rewrite ANG in SRT. ss.
    - (* dtgt *)
      des. pclearbot. exploit wf_at_determ;[apply WFSEM|apply STEP0|apply H|]. i; des. subst.
      exploit IHSTEP; et.
    - (* asrc *)
      exploit SAFE; try apply SRT.
      { econs; et. }
      { instantiate (1:=[]). ss. }
      { ss. }
      i; des.
      exploit wf_angelic; et. i; subst.
      exploit SIM0; et. i; des. pclearbot.
      exploit IH; et.
      { eapply safe_along_events_step_none; et. unfold wf. i. apply DTM; eauto. }
      i; des.
      esplits; et.
      rewrite <- (app_nil_l tr_src).
      change [] with (@option_to_list event None).
      econs; et.
      unfold wf. i. apply DTM; eauto.
    - (* dboth *)
      des. pclearbot.
      exploit wf_at_determ;[apply WFSEM|apply STEP0|apply H|]. i; des. subst.
      exploit IHSTEP; et.
      { eapply safe_along_events_step_none; et. unfold wf. i. rewrite ANG in SRT. ss. }
      i; des.
      esplits; et. rewrite <- (app_nil_l tr_src).
      change [] with (@option_to_list event None).
      econs; et.
      unfold wf. i. rewrite ANG in SRT. ss.
  Qed.

  Lemma sim_forever_silent
        i st_src st_tgt
        (SIM: sim i st_src st_tgt)
        (SILENT: Forever_silent L1 st_tgt)
    :
      Beh.state_spin L0 st_src.
  Proof.
    revert i st_src st_tgt SIM SILENT. pcofix CIH.
    intros i. induction (WF i). rename x into i. rename H0 into IH. clear H.
    i. inv SILENT. punfold SIM. inv SIM.
    { exploit wf_at_final; [apply WFSEM|..]; et. ss. }
    { des. hexploit wf_at_determ; [apply WFSEM|apply H|apply SRT0|]. i. des. clarify. }
    { des. inv SIM; ss. pfold. econs 2; et. esplits; et. right.
      eapply CIH; et. econs; et. }
    { des. inv SIM; ss. eapply IH; et.
      hexploit wf_at_determ; [apply WFSEM|apply STEP|apply H|]. i. des. clarify. }
    { pfold. econs 1; et. i.
      hexploit wf_angelic; et. i. subst.
      hexploit SIM0; et. i. des. inv SIM; ss. right. eapply CIH; et. econs; et. }
    { pfold. des. inv SIM; ss.
      hexploit wf_at_determ; [apply WFSEM|apply STEP|apply H|]. i. des. clarify.
      econs 2; et. esplits; et. }
  Qed.

  Lemma sim_goes_wrong
        i st_src st_tgt
        (SIM: sim i st_src st_tgt)
        (NOSTEP: Nostep L1 st_tgt)
        (NOFINAL: forall r, ~ L1.(Smallstep.final_state) st_tgt r)
    :
      Beh.of_state L0 st_src Tr.ub.
  Proof.
    ginit.
    { eapply cpn2_wcompat. eapply Beh.of_state_mon. }
    revert st_src st_tgt SIM NOSTEP NOFINAL.
    induction (WF i). rename x into i. rename H0 into IH. clear H.
    i. punfold SIM. inv SIM; ss.
    { exfalso. eapply NOFINAL; et. }
    { des. exfalso. eapply NOSTEP; et. }
    { des. inv SIM; ss.
      guclo starC_spec. econs.
      { instantiate (1:=st_src1).
        change ([]: list event) with (None ++ []: list event). econs; et.
        unfold wf; i. rewrite ANG in SRT; ss.
      }
      { eapply IH; et. }
    }
    { des. exfalso. eapply NOSTEP; et. }
    { destruct (classic (exists ev st_src1, step L0 st_src ev st_src1)).
      { des. exploit wf_angelic; et. i; subst. exploit SIM0; et. i; des. inv SIM; ss.
      guclo starC_spec. econs.
      { instantiate (1:=st_src1).
        change ([]: list event) with (None ++ []: list event). econs; et.
        unfold wf; i. eapply DTM; eauto.
      }
      { eapply IH; et. }
      }
      { gstep. econs 6; et. ii. exfalso. eapply H. et. }
    }
    { des. exfalso. eapply NOSTEP; et. }
  Qed.

  Lemma adequacy
        i0 st_src0 st_tgt0
        (SIM: sim i0 st_src0 st_tgt0)
    :
      <<IMPR: improves2 st_src0 st_tgt0>>
  .
  Proof.
    ii.
    (* set (transl_beh tr_tgt) as tr_src in *. *)
    destruct (classic (safe_along_trace st_src0 tr_tgt)); rename H into SAFE.
    { (*** safe ***)
      exists (transl_beh tr_tgt).
      inv BEH.
      - (rename t into tr; rename H into STAR; rename s' into st_tgt1; rename H0 into FIN).
        esplits; et.
        + ss. des_ifs_safe.
          hexploit simulation_star; try apply STAR; et.
          { eapply SAFE. exists (Terminates [] r). ss. unfold Eapp. rewrite app_nil_r; ss. }
          i; des.
          rewrite MB in *. clarify.

          (*** 1. Lemma: star + Beh.of_state -> Beh.of_state app ***)
          (*** 2. wf induction on i1 ***)
          eapply beh_of_state_star; ss; et.
          cut (Beh.of_state L0 st_src1 (Tr.done (Int.unsigned r)↑)); ss.
          (* assert(SAFE0: safe_along_trace st_src1 (Terminates tr r)). *)
          assert(SAFE0: safe_along_events st_src1 []).
          { clear - SAFE STEP MB.
            r in SAFE. specialize (SAFE tr).
            hexploit1 SAFE.
            { eexists (Terminates nil _). ss. unfold Eapp. rewrite List.app_nil_r. ss. }
            eapply safe_along_events_star; et.
            rewrite List.app_nil_r. ss.
          }
          clear - SAFE0 FIN WF SIM0 WFSEM.
          revert_until i1. pattern i1. eapply well_founded_ind; et. clear i1. intros i0 IH.
          i. punfold SIM0. inv SIM0.
          * pfold. econs; ss; et.
            exploit wf_at_final_determ; [eapply WFSEM|eapply SRT0|eapply FIN|].
            i. des. clarify.
            rewrite SRT. rewrite Int.unsigned_repr; auto.
          * des. exploit wf_at_final; [apply WFSEM|..]; et. ss.
          * des. pclearbot.
            exploit IH; et.
            { eapply safe_along_events_step_none; et. unfold wf; i. rewrite ANG in SRT; ss. }
            intro U.
            eapply Beh.beh_dstep; ss; et.
          * des. exploit wf_at_final; [apply WFSEM|..]; et. ss.
          * destruct (classic (exists ev st_src2, step L0 st_src1 ev st_src2)).
            { des. exploit wf_angelic; et. i; subst. exploit SIM; et. i; des.
              pclearbot.
              exploit IH; et.
              { eapply safe_along_events_step_none; et. unfold wf; i. eapply DTM; eauto. }
              i; des.
              eapply _beh_astep_rev; ss; et. unfold wf; i. eapply DTM; eauto. }
            contradict H. eapply SAFE0; et.
            { econs; ss; et. }
            { instantiate (1:=[]). ss. }
            { esplits; ss. }
          * des. exploit wf_at_final; [apply WFSEM|..]; et. ss.
        + ss. clear.
          induction tr; ii; ss.
          { pfold. econs; ss; et. }
          destruct (decompile_event a) eqn:T.
          * des_ifs_safe.
            eapply match_beh_cons; ss.
            { instantiate (1:=Terminates tr r). instantiate (1:=a). ss. }
            { ss. }
            { eapply decompile_match_event; ss. }
          * des_ifs_safe. ss. pfold; econsr; et; ss. r. esplits; et.
            rewrite behavior_app_E0; et.

      - (* diverge *)
        (rename t into tr).
        esplits; et.
        + rename H0 into BEH. ss.
          ginit. { eapply cpn2_wcompat; eauto with paco. } revert_until WFSEM. gcofix CIH. i.
          inv BEH.
          rename s2 into st_tgt1. rename tr into tr_tgt. rename H into STAR.
          hexploit simulation_star; try apply STAR; et.
          { eapply SAFE. exists (Diverges []). ss. rewrite E0_right. auto. }
          i; des.
          rewrite MB.
          guclo starC2_spec. econs; et.
          gfinal. right. pfold. econs 2.
          eapply sim_forever_silent; et. econs; et.
        + ss. clear.
          induction tr; ii; ss.
          { pfold. econs 2; ss; et. }
          destruct (decompile_event a) eqn:T.
          * des_ifs_safe.
            eapply match_beh_cons; ss.
            { instantiate (1:=Diverges tr). instantiate (1:=a). ss. }
            { ss. }
            { eapply decompile_match_event; ss. }
          * des_ifs_safe. ss. pfold; econsr; et; ss. r. esplits; et.
            rewrite behavior_app_E0; et.

      - (* forever_reactive *)
        (rename T into tr).
        esplits; et.
        + rename H into BEH. ss.
          ginit. { eapply cpn2_wcompat; eauto with paco. } revert_until WFSEM. gcofix CIH. i.
          (* revert_until WFSRC. pcofix CIH. i. *)
          inv BEH.
          rename s2 into st_tgt1. rename t into tr_tgt. rename H into STAR.
          hexploit simulation_star; try apply STAR; et.
          { eapply SAFE. exists (Reacts T). ss. }
          i; des.

          erewrite decompile_trinf_app; et.

          exploit CIH; et.
          { clear - SAFE MB STEP. r. i. eapply safe_along_events_star; et.
            eapply SAFE. r in BEH. des. r. exists beh'. rewrite behavior_app_assoc.
            rewrite <- BEH. ss. }
          intro KNOWLEDGE.
          assert(PROG: tr_src <> []).
          { ii; subst; ss. destruct tr_tgt; ss. des_ifs. }
          clear - KNOWLEDGE PROG STEP.
          induction STEP using star_event_ind; ss.
          clear_tac. spc IHSTEP1.
          eapply star_single_exact in STEP1. des.
          guclo starC_spec. econs; et.
          gstep. econs; et.
          { destruct (state_sort L0 st3) eqn:SORT; auto.
            - exfalso. hexploit wf_angelic; et; ss.
            - exfalso. hexploit wf_demonic; et; ss.
            - exfalso. hexploit wf_final; et; ss.
          }
          guclo starC_spec. econs; et.
          destruct es; ss.
          * guclo starC_spec. econs; et. gbase. et.
          * exploit IHSTEP1; ss; et. intro U. eapply gpaco2_mon; et. ii; ss.
        + eapply decompile_trinf_spec.

      - (* goes wrong *)
        (rename t into tr).
        esplits; et.
        + rename H0 into BEH. ss.
          ginit. { eapply cpn2_wcompat; eauto with paco. } revert_until WFSEM. gcofix CIH. i.
          hexploit simulation_star; try apply STAR; et.
          { eapply SAFE. exists (Goes_wrong []). ss. rewrite E0_right. auto. }
          i; des.
          rewrite MB.
          guclo starC2_spec. econs; et.
          gfinal. right. eapply paco2_mon.
          { eapply sim_goes_wrong; et. }
          { ss. }
        + ss. clear.
          induction tr; ii; ss.
          { pfold. econs 4; ss; et. ss. exists (Goes_wrong []). ss. }
          destruct (decompile_event a) eqn:T.
          * des_ifs_safe.
            eapply match_beh_cons; ss.
            { instantiate (1:=Goes_wrong tr). instantiate (1:=a). ss. }
            { ss. }
            { eapply decompile_match_event; ss. }
          * des_ifs_safe. ss. pfold; econsr; et; ss. r. esplits; et.
            rewrite behavior_app_E0; et.
    }
    { (*** unsafe ***)
      assert(NOTSAFE:
               exists st_src1 thd thd_tgt,
                 (<<B: behavior_prefix thd_tgt tr_tgt>>)
                 /\ (<<MB: squeeze (List.map decompile_event thd_tgt) = (thd, true)>>)
                 /\ (<<STAR: star L0 st_src0 thd st_src1>>)
                 /\ (<<STUCK: ~NoStuck L0 st_src1>>)).
      { unfold safe_along_trace in SAFE. Psimpl. des.
        unfold safe_along_events in *. Psimpl. des.
        Psimpl. des. Psimpl. des.
        subst.
        esplits; try apply SAFE1; ss; et.
        clear - SAFE.
        r in SAFE. des; subst. r. eexists (behavior_app _ _).
        rewrite <- behavior_app_assoc. ss; et.
      }
      des.
      exists (Tr.app thd Tr.ub). esplits; ss.
      - clear - STAR STUCK.
        eapply beh_of_state_star; et. unfold NoStuck in *.
        repeat (Psimpl; des; unfold NW in *). clears st_src0. clear st_src0.
        pfold. econsr; ss; et. ii. exploit wf_angelic; ss; et. i; subst. exfalso.
        exploit STUCK0; ss; et.
      - r in B. des. subst. clear - MB.
        ginduction thd_tgt; ii; ss; clarify.
        { ss. pfold. econsr; ss; et.
          { r. esplits; ss; et. }
        }
        des_ifs. ss.
        eapply match_event_iff in Heq.
        eapply match_beh_cons; ss; et. rewrite <- behavior_app_assoc. ss.
    }
  Qed.

End SIM.
Hint Constructors _sim.
Hint Unfold sim.
Hint Resolve sim_mon: paco.


From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.

Require Import Event.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Thread.
Require Import Configuration.
Require Import Behavior.

Set Implicit Arguments.

Section Simulation.
  Definition SIM := forall (c1_src c1_tgt: Configuration.t), Prop.

  Definition _sim (sim: SIM) (c1_src c1_tgt:Configuration.t): Prop :=
    forall (WF_SRC: Configuration.wf c1_src)
      (WF_TGT: Configuration.wf c1_tgt),
      <<TERMINAL:
        forall (TERMINAL_TGT: Threads.is_terminal (Configuration.threads c1_tgt)),
        exists c2_src,
          <<STEPS_SRC: rtc Configuration.tau_step c1_src c2_src>> /\
          <<TERMINAL_SRC: Threads.is_terminal (Configuration.threads c2_src)>>>> /\
      <<STEP:
        forall e tid c2_tgt
          (STEP_TGT: Configuration.step e tid c1_tgt c2_tgt),
        exists c2_src,
          <<STEP_SRC: Configuration.opt_step e tid c1_src c2_src>> /\
          <<SIM: sim c2_src c2_tgt>>>>
  .

  Lemma _sim_mon: monotone2 _sim.
  Proof.
    ii. exploit IN; eauto. i. des.
    econs; eauto. ii.
    exploit STEP; eauto. i. des. eauto.
  Qed.
  Hint Resolve _sim_mon: paco.

  Definition sim: SIM := paco2 _sim bot2.
End Simulation.
Hint Resolve _sim_mon: paco.

Lemma sim_adequacy
      c_src c_tgt
      (WF_SRC: Configuration.wf c_src)
      (WF_TGT: Configuration.wf c_tgt)
      (SIM: sim c_src c_tgt):
  behaviors Configuration.step c_tgt <1= behaviors Configuration.step c_src.
Proof.
  i. revert c_src WF_SRC WF_TGT SIM.
  induction PR; i.
  - punfold SIM0. exploit SIM0; eauto. i. des.
    hexploit TERMINAL0; eauto. i. des.
    eapply rtc_tau_step_behavior; eauto.
    econs 1. eauto.
  - punfold SIM0. exploit SIM0; eauto. i. des.
    exploit STEP0; eauto. i. des.
    exploit Configuration.step_future; try exact STEP; eauto. i. des.
    exploit Configuration.opt_step_future; try exact STEP_SRC; eauto. i. des.
    inv SIM1; ss. inv STEP_SRC.
    econs 2; eauto.
  - punfold SIM0. exploit SIM0; eauto. i. des.
    exploit STEP0; eauto. i. des.
    exploit Configuration.step_future; try exact STEP; eauto. i. des.
    exploit Configuration.opt_step_future; try exact STEP_SRC; eauto. i. des.
    inv SIM1; ss. inv STEP_SRC.
    econs 3; eauto.
  - punfold SIM0. exploit SIM0; eauto. i. des.
    exploit STEP0; eauto. i. des.
    exploit Configuration.step_future; try exact STEP; eauto. i. des.
    exploit Configuration.opt_step_future; try exact STEP_SRC; eauto. i. des.
    inv SIM1; ss. inv STEP_SRC; eauto.
    econs 4; eauto.
Qed.


From trace_program_logic.prelude Require Import classical.
From trace_program_logic.traces Require Import trace.
From trace_program_logic.program_logic Require Import
     ectx_language language traces.

(** Ideally, all definitions in this file should be computational.
    But that's is too much work. Hence, since we already assume classical
    axioms in this work we can use those to axiomatize the function that
    given an execution extracts its observations. *)

Record Event (Λ : language) := mkEvent {
  is_triggered :> expr Λ → state Λ → expr Λ → state Λ → Prop;
  (* The following two axioms ensure that events are only triggered
     on head steps. *)
  is_triggered_not_val :
    ∀ e1 σ1 e2 σ2, is_triggered e1 σ1 e2 σ2 → to_val e1 = None;
  is_triggered_ectx_free :
    ∀ e1 σ1 e2 σ2,
      is_triggered e1 σ1 e2 σ2 →
      ∀ K e1', e1 = ectx_fill K e1' → is_Some (to_val e1') ∨ K = ectx_emp;
  is_triggered_not_stuttering :
    ∀ e1 σ1 e2 σ2,
      is_triggered e1 σ1 e2 σ2 → e1 ≠ e2;
}.

Arguments is_triggered {_} _ _ _ _.
Arguments is_triggered_not_val {_} _ _ _ _.
Arguments is_triggered_ectx_free {_} _.
Arguments is_triggered_not_stuttering {_} _.

Record EventObservation (Λ : language) := mkEventObservation {
  pre_expr : expr Λ;
  pre_state : state Λ;
  post_expr : expr Λ;
  post_state : state Λ;
}.

Arguments mkEventObservation {_} _ _ _ _.
Arguments pre_state {_} _.
Arguments pre_expr {_} _.
Arguments post_state {_} _.
Arguments post_expr {_} _.

Definition validEventObservation
           {Λ : language} (EV : Event Λ) (eo : EventObservation Λ) :=
  EV eo.(pre_expr) eo.(pre_state) eo.(post_expr) eo.(post_state).

Definition event_obs (Λ : language) := list (EventObservation Λ).

Definition valid_event_obs
           {Λ : language} (EV : Event Λ) (eo : event_obs Λ)  : Prop :=
  Forall (validEventObservation EV) eo.

Inductive trace_has_events {Λ : language} (EV : Event Λ) :
          execution_trace Λ → event_obs Λ → Prop :=
| singleton_events c : trace_has_events EV {tr[c]} []
| extend_observed ex c c' tp1 tp2 efs K eo eobs oζ:
    trace_ends_in ex c →
    c.2 = eo.(pre_state) →
    c.1 = tp1 ++ ectx_fill K eo.(pre_expr) :: tp2 →
    c'.2 = eo.(post_state) →
    c'.1 = tp1 ++ ectx_fill K eo.(post_expr) :: tp2 ++ efs →
    validEventObservation EV eo →
    trace_has_events EV ex eobs →
    trace_has_events EV (ex :tr[oζ]: c') (eobs ++ [eo])
| extend_not_observed ex c c' eobs oζ:
    trace_ends_in ex c →
    (∀ tp1 tp2 efs K e1 e2,
      c.1 = tp1 ++ ectx_fill K e1 :: tp2 →
      c'.1 = tp1 ++ ectx_fill K e2 :: tp2 ++ efs →
      ¬ EV e1 c.2 e2 c'.2) →
    trace_has_events EV ex eobs →
    trace_has_events EV (ex :tr[oζ]: c') eobs.

Section properties.
  Context {Λ : language} (EV : Event Λ).

  Implicit Types e : expr Λ.
  Implicit Types tp : list (expr Λ).
  Implicit Types σ : state Λ.
  Implicit Types eobs : event_obs Λ.
  Implicit Types obs : EventObservation Λ.
  Implicit Types ex : execution_trace Λ.

  Lemma validEventObservation_exprs_neq obs :
    validEventObservation EV obs → obs.(pre_expr) ≠ obs.(post_expr).
  Proof. intros; eapply is_triggered_not_stuttering; done. Qed.

  Lemma validEventObservation_not_val obs :
    validEventObservation EV obs → to_val obs.(pre_expr) = None.
  Proof. intros; eapply is_triggered_not_val; done. Qed.

  Lemma trace_has_events_valid ex eobs :
    trace_has_events EV ex eobs → valid_event_obs EV eobs.
  Proof.
    induction 1 as [|ex [tp σ] [tp' σ']|]; simplify_eq/=.
    - by constructor.
    - apply Forall_app; split; first done.
      apply Forall_singleton; done.
    - done.
  Qed.

  Lemma event_in_the_middle tp1 tp2 K e1 e2 efs tp1' tp2' K' eo efs' :
    validEventObservation EV eo →
    to_val e1 = None →
    (∀ e1' K'', e1 = ectx_fill K'' e1' → is_Some (to_val e1') ∨ K'' = ectx_emp) →
    tp1 ++ ectx_fill K e1 :: tp2 = tp1' ++ ectx_fill K' (pre_expr eo) :: tp2' →
    tp1 ++ ectx_fill K e2 :: tp2 ++ efs =
    tp1' ++ ectx_fill K' (post_expr eo) :: tp2' ++ efs' →
    pre_expr eo = e1 ∧ post_expr eo = e2.
  Proof.
    intros HEV He1 Hnectx Heq1 Heq2.
    destruct (decide (length tp1' < length tp1)).
    { pose proof (f_equal (λ x, x !! length tp1') Heq1) as Heq1'.
      rewrite /= lookup_app_l // lookup_app_r // Nat.sub_diag /= in Heq1'.
      pose proof (f_equal (λ x, x !! length tp1') Heq2) as Heq2'.
      rewrite /= lookup_app_l // lookup_app_r // Nat.sub_diag /= in Heq2'.
      rewrite Heq1' in Heq2'; simplify_eq.
      apply ectx_fill_inj in Heq2'.
      exfalso; eapply validEventObservation_exprs_neq; done. }
    pose proof (f_equal (λ x, x !! length tp1') Heq1) as Heq1'.
    rewrite /= lookup_app_r in Heq1'; last lia.
    rewrite // lookup_app_r // Nat.sub_diag /= in Heq1'.
    pose proof (f_equal (λ x, x !! length tp1') Heq2) as Heq2'.
    rewrite /= lookup_app_r in Heq2'; last lia.
    rewrite // lookup_app_r // Nat.sub_diag /= in Heq2'.
    rewrite /= app_comm_cons lookup_app_l in Heq2'; last first.
    { simpl.
      assert (length tp1' < length tp1 + S (length tp2)); last lia.
      pose proof (f_equal length Heq1) as Heq'.
      rewrite !app_length //= in Heq'; lia. }
    destruct (length tp1' - length tp1); last first.
    { simpl in *.
      rewrite Heq1' in Heq2'; simplify_eq.
      apply ectx_fill_inj in Heq2'.
      exfalso; eapply validEventObservation_exprs_neq; done. }
    simplify_eq/=.
    pose proof Heq1' as Heq1''.
    apply ectx_fill_positive in Heq1'' as [[K'' ->]|[K'' ->]];
          [| |done|
             by apply validEventObservation_not_val].
    - rewrite ectx_comp_comp in Heq2'.
      apply ectx_fill_inj in Heq2'.
      rewrite ectx_comp_comp in Heq1'.
      apply ectx_fill_inj in Heq1'.
      simplify_eq.
      assert (K'' = ectx_emp) as ->.
      { edestruct Hnectx as [[]|]; [done| |done].
        pose proof (validEventObservation_not_val _ HEV); simplify_eq. }
      rewrite !ectx_fill_emp; done.
    - rewrite ectx_comp_comp in Heq1'.
      apply ectx_fill_inj in Heq1'.
      rewrite ectx_comp_comp in Heq2'.
      apply ectx_fill_inj in Heq2'.
      assert (K'' = ectx_emp) as ->.
      { edestruct @is_triggered_ectx_free as [[]|];
          [done|symmetry; done| |done].
        pose proof (validEventObservation_not_val _ HEV); simplify_eq. }
      rewrite ectx_fill_emp in Heq1'.
      rewrite ectx_fill_emp in Heq2'.
      simplify_eq; done.
  Qed.

  (** This lemma, proven completely constructively, is an evidence why we
      are justified in using classical logic in constructing observations of
      a valid execution trace. *)
  Lemma trace_has_events_functional ex eobs eobs' :
    valid_exec ex →
    trace_has_events EV ex eobs →
    trace_has_events EV ex eobs' →
    eobs = eobs'.
  Proof.
    intros Hex; revert eobs eobs'.
    induction Hex as [|ex [tp σ] oζ [tp' σ'] Hendsin Hstep Hex IHex];
      intros eobs eobs'.
    { do 2 inversion 1; simplify_eq; done. }
    inversion 1 as [|ex' [tpz σz] [tpy σy] tp1z tp2z ? ? obs3 ? eobs3 Hendsin'|
                    ex' [tpz σz] [tpy σy] ? ? Hendsin' Hnobs]; simplify_eq/=.
    - pose proof (trace_ends_in_inj _ _ _ Hendsin Hendsin'); simplify_eq.
      inversion 1 as [|ex' [tpx σx] [tpw σw] tp1x tp2x ? ? obs4 ? eobs4 Hendsin''
                           ??? Htpseq| ex' [tpx σx] [tpw σw] ? ? Hendsin'' Hnobs];
        simplify_eq/=.
      + repeat f_equal; first by apply IHex.
        pose proof (trace_ends_in_inj _ _ _ Hendsin' Hendsin'') as Htpseq'.
        simplify_eq Htpseq'; intros Htpseq'1 Htpseq'2; clear Htpseq'.
        assert (pre_expr obs3 = pre_expr obs4 ∧ post_expr obs3 = post_expr obs4)
          as [? ?].
        eapply event_in_the_middle; [done| | |done|].
        { apply validEventObservation_not_val; done. }
        { intros; eapply is_triggered_ectx_free; eauto. }
        { done. }
        destruct obs3; destruct obs4; simplify_eq/=; done.
      + pose proof (trace_ends_in_inj _ _ _ Hendsin Hendsin''); simplify_eq.
        exfalso; eapply Hnobs; eauto.
    - pose proof (trace_ends_in_inj _ _ _ Hendsin Hendsin'); simplify_eq.
      inversion 1 as [|ex' [tpx σx] [tpw σw] ? ? ? ? obs4 eobs4 ?  Hendsin''|
                    ex' [tpx σx] [tpw σw] ? Hendsin'' Hnobs']; simplify_eq/=.
      + pose proof (trace_ends_in_inj _ _ _ Hendsin Hendsin''); simplify_eq.
        exfalso; eapply Hnobs; eauto.
      + apply IHex; done.
  Qed.

  Lemma trace_has_valid_events ex eobs :
    trace_has_events EV ex eobs → valid_event_obs EV eobs.
  Proof.
    induction 1; [constructor| |done].
    apply Forall_app_2; first done.
    apply Forall_singleton; done.
  Qed.

  Lemma events_for_trace ex : ∃ eobs, trace_has_events EV ex eobs.
  Proof.
    induction ex as [c|ex [eobs Hthe] ? c].
    { eexists; econstructor. }
    destruct (ExcludedMiddle ((∃ tp1 tp2 efs K e1 e2,
      (trace_last ex).1 = tp1 ++ ectx_fill K e1 :: tp2 ∧
      c.1 = tp1 ++ ectx_fill K e2 :: tp2 ++ efs ∧
      EV e1 (trace_last ex).2 e2 c.2))) as
        [(tp1&tp2&efs&K&e1&e2&Heq1&Heq2&HEV)|Hnex].
    - exists (eobs ++ [mkEventObservation e1 (trace_last ex).2 e2 c.2]).
      econstructor; eauto using trace_ends_in_last.
    - exists eobs; econstructor; [done| |done].
      intros ?????????; apply Hnex; eauto 10.
  Qed.

  Definition events_of_trace ex : event_obs Λ := epsilon (events_for_trace ex).

  Lemma trace_has_events_of_trace ex :
    trace_has_events EV ex (events_of_trace ex).
  Proof. apply (epsilon_correct _ (events_for_trace ex)). Qed.

  Lemma events_of_trace_valid ex : valid_event_obs EV (events_of_trace ex).
  Proof. eapply trace_has_valid_events; apply trace_has_events_of_trace. Qed.

  Lemma events_of_trace_extend_same_tp ex c c' oζ:
    valid_exec (ex :tr[oζ]: c') →
    c.1 = c'.1 →
    trace_ends_in ex c →
    events_of_trace (ex :tr[oζ]: c') = events_of_trace ex.
  Proof.
    intros Hex Htps Hc.
    destruct c as [tp σ]; destruct c' as [tp' σ']; simplify_eq/=.
    cut (∀ eobs, trace_has_events EV (ex :tr[oζ]: (tp', σ')) eobs → events_of_trace ex = eobs).
    { intros Help. erewrite Help; first done. apply trace_has_events_of_trace. }
    intros eobs Heobs.
    eapply trace_has_events_functional; [|apply trace_has_events_of_trace|].
    { inversion Hex; done. }
    inversion Heobs as [|?????? K ??? Hei|]; simplify_eq/=; last done.
    pose proof (trace_ends_in_inj _ _ _ Hc Hei); simplify_eq/=.
    exfalso; eapply validEventObservation_exprs_neq; first done.
    eapply ectx_fill_inj; done.
  Qed.

  Lemma events_of_singleton_trace c : events_of_trace {tr[c]} = [].
  Proof.
    eapply trace_has_events_functional;
      [constructor|apply trace_has_events_of_trace|constructor].
  Qed.

  Lemma events_of_trace_extend_pure ex c c' oζ:
    (∀ eo, validEventObservation EV eo → eo.(pre_state) ≠ eo.(post_state)) →
    valid_exec (ex :tr[oζ]: c') →
    c.2 = c'.2 →
    trace_ends_in ex c →
    events_of_trace (ex :tr[oζ]: c') = events_of_trace ex.
  Proof.
    intros Himpure Hex Htps Hc.
    destruct c as [tp σ]; destruct c' as [tp' σ']; simplify_eq/=.
    cut (∀ eobs, trace_has_events EV (ex :tr[oζ]: (tp', σ')) eobs → events_of_trace ex = eobs).
    { intros Help. erewrite Help; first done. apply trace_has_events_of_trace. }
    intros eobs Heobs.
    eapply trace_has_events_functional; [|apply trace_has_events_of_trace|].
    { inversion Hex; done. }
    inversion Heobs as [|?????? K ??? Hei|]; simplify_eq/=; last done.
    pose proof (trace_ends_in_inj _ _ _ Hc Hei); simplify_eq/=.
    exfalso; eapply Himpure; eauto.
  Qed.

    Definition event_is_triggered (ob : EventObservation Λ) (c c' : cfg Λ) :=
    ∃ K tp1 tp2 efs,
      c.2 = ob.(pre_state) ∧
      c.1 = tp1 ++ ectx_fill K ob.(pre_expr) :: tp2 ∧
      c'.2 = ob.(post_state) ∧
      c'.1 = tp1 ++ ectx_fill K ob.(post_expr) :: tp2 ++ efs.

  Lemma events_of_trace_extend_app (ex : execution_trace Λ) (c : cfg Λ) oζ:
    valid_exec (ex :tr[oζ]: c) →
    ∃ evs,
      length evs ≤ 1 ∧
      events_of_trace (ex :tr[oζ]: c) = events_of_trace ex ++ evs ∧
      ∀ ev, ev ∈ evs → event_is_triggered ev (trace_last ex) c.
  Proof.
    intros Hvl.
    pose proof (trace_has_events_of_trace (ex :tr[oζ]: c)) as Hthe.
    inversion Hthe as [|?????????? Hend|]; simplify_eq.
    - eexists [_]; split; first done.
      erewrite (trace_has_events_functional ex (events_of_trace ex));
        [|by eapply valid_exec_exec_extend_inv; eauto|by apply trace_has_events_of_trace|by eauto].
      split; first done.
      intros ev; rewrite elem_of_list_singleton; intros ->.
      apply last_eq_trace_ends_in in Hend; simplify_eq.
      eexists _, _, _, _; eauto.
    - exists []; split; simpl; first lia.
      rewrite app_nil_r.
      split; last set_solver.
      apply (trace_has_events_functional (ex :tr[oζ]: c)); [done|by apply trace_has_events_of_trace|].
      eapply extend_not_observed; [eauto|eauto|by apply trace_has_events_of_trace].
  Qed.

  Lemma events_of_trace_app (ex : execution_trace Λ) (l : list (olocale Λ * cfg Λ)) :
    valid_exec (ex +trl+ l) →
    ∃ evs,
      length evs ≤ length l ∧
      events_of_trace (ex +trl+ l) = events_of_trace ex ++ evs ∧
      ∀ ev  oζ1 oζ2,
        ev ∈ evs →
        ∃ i c1 c2 oζ1' oζ2',
          ((oζ1, trace_last ex) :: l) !! i = Some (oζ1', c1) ∧
          ((oζ2, trace_last ex) :: l) !! S i = Some (oζ2', c2) ∧
          event_is_triggered ev c1 c2.
  Proof.
    induction l as [|[??]  ?] using rev_ind.
    { exists []; rewrite /= app_nil_r; split_and!; [done|done|]. set_solver. }
    rewrite -trace_append_list_assoc /=.
    intros Hvl.
    destruct IHl as (evs & Hevs1 & Hevs2 & Hevs3).
    { eapply valid_exec_exec_extend_inv; eauto. }
    apply events_of_trace_extend_app in Hvl as (evs' & Hevs'1 & Hevs'2 & Hevs'3).
    rewrite Hevs2 in Hevs'2; rewrite Hevs'2.
    rewrite -app_assoc.
    eexists; split_and!; [|done|].
    { rewrite !app_length /=; lia. }
    intros ev oζ1 oζ2 [Hev|Hev]%elem_of_app.
    - destruct (Hevs3 ev oζ1 oζ2 Hev) as (i & c1 & c2 & oζ1' & oζ2' & Hc1 & Hc2 & Htrg).
      exists i, c1, c2, oζ1', oζ2'.
      rewrite (lookup_app_l (_ :: _)); last first.
      { apply lookup_lt_Some in Hc1; simpl in *; lia. }
      rewrite lookup_app_l; last first.
      { apply lookup_lt_Some in Hc2; simpl in *; lia. }
      done.
    - destruct (trace_last_of_append_list ex l oζ1) as [oζ Heq].
      eexists (length l), _, _, oζ, _; split_and!; last by apply Hevs'3.
      + rewrite -Heq.
        rewrite (lookup_app_l (_ :: _)); first done.
        simpl; lia.
      + rewrite lookup_app_r; last done.
        rewrite Nat.sub_diag //.
  Qed.

  Lemma events_of_trace_app_map (ex : execution_trace Λ) (l : list (olocale Λ * cfg Λ)) :
    valid_exec (ex +trl+ l) →
    ∃ evs,
      length evs ≤ length l ∧
      events_of_trace (ex +trl+ l) = events_of_trace ex ++ evs ∧
      ∀ ev,
        ev ∈ evs →
        ∃ i c1 c2,
          (trace_last ex :: map snd l) !! i = Some c1 ∧
          (trace_last ex ::  map snd l) !! S i = Some c2 ∧
          event_is_triggered ev c1 c2.
  Proof.
    intros Hval. destruct (events_of_trace_app ex l Hval) as (evs & Hlen & Hevs & H).
    exists evs; repeat (split =>//). intros ev Hin.
    destruct (H ev inhabitant inhabitant Hin) as (i & c1 & c2 & oζ1 & oζ2 & Hi & HSi & Htrig).
    exists i, c1, c2. change (trace_last ex :: map snd l) with (map snd $ (inhabitant, trace_last ex) :: l).
    rewrite ->!list_lookup_fmap, Hi, HSi. done.
  Qed.
End properties.

Section properties.
  Context {Λ : ectxLanguage} (EV : Event Λ).

  Implicit Types e : expr Λ.
  Implicit Types tp : list (expr Λ).
  Implicit Types K : ectx Λ.
  Implicit Types σ : state Λ.
  Implicit Types eobs : event_obs Λ.
  Implicit Types obs : EventObservation Λ.
  Implicit Types ex : execution_trace Λ.

  Lemma events_of_trace_extend_triggered ex tp1 tp2 K e1 e2 efs σ1 σ2 oζ :
    valid_exec ex →
    trace_ends_in ex (tp1 ++ fill K e1 :: tp2, σ1) →
    head_step e1 σ1 e2 σ2 efs →
    EV e1 σ1 e2 σ2 →
    events_of_trace EV (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) =
    events_of_trace EV ex ++ [mkEventObservation e1 σ1 e2 σ2].
  Proof.
    intros HexV Hex Hhstep HEV.
    pose proof (trace_has_events_of_trace
                  EV (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2))) as Hhasevs.
    inversion Hhasevs as
        [|??? tp1' tp2' efs' K' eo eobs ? Hei ? Heq1 ? Heq2 HEV' ? Heq3 Heq4|
         ????? Hei HnEV]; simplify_eq.
    - pose proof (trace_ends_in_inj _ _ _ Hex Hei); simplify_eq.
      rewrite -Heq4.
      assert (eobs = events_of_trace EV ex) as ->.
      { eapply trace_has_events_functional;
          [done|done| apply trace_has_events_of_trace]. }
      repeat f_equal. simpl in *.
      assert (pre_expr eo = e1 ∧ post_expr eo = e2) as [? ?].
      eapply event_in_the_middle; [done| | |done|].
      { eapply val_head_stuck; done. }
      { intros ?? ->; eapply head_ctx_step_val; done. }
      { done. }
      destruct eo; simplify_eq/=; done.
    - pose proof (trace_ends_in_inj _ _ _ Hex Hei); simplify_eq.
      exfalso; eapply HnEV; eauto.
  Qed.

  Lemma events_of_trace_extend_not_triggered ex tp1 tp2 K e1 e2 efs σ1 σ2 oζ:
    valid_exec ex →
    trace_ends_in ex (tp1 ++ fill K e1 :: tp2, σ1) →
    head_step e1 σ1 e2 σ2 efs →
    ¬ EV e1 σ1 e2 σ2 →
    events_of_trace EV (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2)) =
    events_of_trace EV ex.
  Proof.
    intros HexV Hex Hhstep HEV.
    pose proof (trace_has_events_of_trace
                  EV (ex :tr[oζ]: (tp1 ++ fill K e2 :: tp2 ++ efs, σ2))) as Hhasevs.
    inversion Hhasevs as
        [|??? tp1' tp2' efs' K' eo eobs ? Hei ? Heq1 ? Heq2 HEV' ? Heq3 Heq4|
         ????? Hei HnEV Hhasevs']; simplify_eq/=.
    - pose proof (trace_ends_in_inj _ _ _ Hex Hei); simplify_eq/=.
      exfalso.
      assert (pre_expr eo = e1 ∧ post_expr eo = e2) as [? ?].
      eapply event_in_the_middle; [done| | |done|].
      { eapply val_head_stuck; done. }
      { intros ?? ->; eapply head_ctx_step_val; done. }
      { done. }
      destruct eo; simplify_eq/=; done.
    - pose proof (trace_ends_in_inj _ _ _ Hex Hei); simplify_eq.
      eapply trace_has_events_functional;
        [done|done| apply trace_has_events_of_trace].
  Qed.

End properties.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness proof for constant propagation (processor-dependent part). *)

Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Events.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import ConstpropOp.
Require Import Constprop.

(** * Correctness of the static analysis *)

Section ANALYSIS.

Variable ge: genv.
Variable sp: val.

(** We first show that the dataflow analysis is correct with respect
  to the dynamic semantics: the approximations (sets of values)
  of a register at a program point predicted by the static analysis
  are a superset of the values actually encountered during concrete
  executions.  We formalize this correspondence between run-time values and
  compile-time approximations by the following predicate. *)

Definition val_match_approx (a: approx) (v: val) : Prop :=
  match a with
  | Unknown => True
  | I p => v = Vint p
  | F p => v = Vfloat p
  | L p => v = Vlong p
  | G symb ofs => v = symbol_address ge symb ofs
  | S ofs => v = Val.add sp (Vint ofs)
  | Novalue => False
  end.

Inductive val_list_match_approx: list approx -> list val -> Prop :=
  | vlma_nil:
      val_list_match_approx nil nil
  | vlma_cons:
      forall a al v vl,
      val_match_approx a v ->
      val_list_match_approx al vl ->
      val_list_match_approx (a :: al) (v :: vl).

Ltac SimplVMA :=
  match goal with
  | H: (val_match_approx (I _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (F _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (L _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (G _ _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (S _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | _ =>
      idtac
  end.

Ltac InvVLMA :=
  match goal with
  | H: (val_list_match_approx nil ?vl) |- _ =>
      inv H
  | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ =>
      inv H; SimplVMA; InvVLMA
  | _ =>
      idtac
  end.

(** We then show that [eval_static_operation] is a correct abstract
  interpretations of [eval_operation]: if the concrete arguments match
  the given approximations, the concrete results match the
  approximations returned by [eval_static_operation]. *)

Lemma eval_static_shift_correct:
  forall s n, eval_shift s (Vint n) = Vint (eval_static_shift s n).
Proof.
  intros. destruct s; simpl; rewrite s_range; auto.
Qed.

Lemma eval_static_condition_correct:
  forall cond al vl m b,
  val_list_match_approx al vl ->
  eval_static_condition cond al = Some b ->
  eval_condition cond vl m = Some b.
Proof.
  intros until b.
  unfold eval_static_condition.
  case (eval_static_condition_match cond al); intros;
  InvVLMA; simpl; try (rewrite eval_static_shift_correct); congruence.
Qed.

Remark shift_symbol_address:
  forall symb ofs n,
  symbol_address ge symb (Int.add ofs n) = Val.add (symbol_address ge symb ofs) (Vint n).
Proof.
  unfold symbol_address; intros. destruct (Genv.find_symbol ge symb); auto.
Qed.

Lemma eval_static_operation_correct:
  forall op al vl m v,
  val_list_match_approx al vl ->
  eval_operation ge sp op vl m = Some v ->
  val_match_approx (eval_static_operation op al) v.
Proof.
  intros until v.
  unfold eval_static_operation.
  case (eval_static_operation_match op al); intros;
  InvVLMA; simpl in *; FuncInv; try (subst v); try (rewrite eval_static_shift_correct); auto.
  destruct (propagate_float_constants tt); simpl; auto.
  rewrite shift_symbol_address; auto.
  rewrite shift_symbol_address; auto.
  rewrite Val.add_assoc; auto.
  rewrite Val.add_assoc; auto.
  fold (Val.add (Vint n1) (symbol_address ge s2 n2)).
  rewrite Int.add_commut. rewrite Val.add_commut. rewrite shift_symbol_address; auto.
  fold (Val.add (Vint n1) (Val.add sp (Vint n2))).
  rewrite Val.add_permut. auto.
  rewrite shift_symbol_address. auto.
  rewrite Val.add_assoc. auto.
  rewrite Int.sub_add_opp. rewrite shift_symbol_address. rewrite Val.sub_add_opp. auto.
  rewrite Val.sub_add_opp. rewrite Val.add_assoc. rewrite Int.sub_add_opp. auto.
  rewrite Int.sub_add_opp. rewrite shift_symbol_address. rewrite Val.sub_add_opp. auto.
  destruct (Int.eq n2 Int.zero). inv H0.
    destruct (Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H0; simpl; auto.
  destruct (Int.eq n2 Int.zero); inv H0. simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  unfold eval_static_intoffloat. destruct (Float.intoffloat n1); simpl in H0; inv H0; simpl; auto.
  unfold eval_static_intuoffloat. destruct (Float.intuoffloat n1); simpl in H0; inv H0; simpl; auto.
  destruct (propagate_float_constants tt); simpl; auto.
  destruct (propagate_float_constants tt); simpl; auto.
  unfold eval_static_condition_val, Val.of_optbool.
  destruct (eval_static_condition c vl0) eqn:?.
  rewrite (eval_static_condition_correct _ _ _ m _ H Heqo).
  destruct b; simpl; auto.
  simpl; auto.
Qed.

Lemma eval_static_addressing_correct:
  forall addr al vl v,
  val_list_match_approx al vl ->
  eval_addressing ge sp addr vl = Some v ->
  val_match_approx (eval_static_addressing addr al) v.
Proof.
  intros until v. unfold eval_static_addressing.
  case (eval_static_addressing_match addr al); intros;
  InvVLMA; simpl in *; FuncInv; try (subst v); try (rewrite eval_static_shift_correct); auto.
  rewrite shift_symbol_address; auto.
  rewrite Val.add_assoc. auto.
  repeat rewrite shift_symbol_address. auto.
  fold (Val.add (Vint n1) (symbol_address ge id ofs)).
  repeat rewrite shift_symbol_address. apply Val.add_commut.
  repeat rewrite Val.add_assoc. auto.
  fold (Val.add (Vint n1) (Val.add sp (Vint ofs))).
  rewrite Val.add_permut. decEq. rewrite Val.add_commut. auto.
  rewrite shift_symbol_address. auto.
  rewrite Val.add_assoc. auto.
Qed.

(** * Correctness of strength reduction *)

(** We now show that strength reduction over operators and addressing
  modes preserve semantics: the strength-reduced operations and
  addressings evaluate to the same values as the original ones if the
  actual arguments match the static approximations used for strength
  reduction. *)

Section STRENGTH_REDUCTION.

Variable app: D.t.
Variable rs: regset.
Variable m: mem.
Hypothesis MATCH: forall r, val_match_approx (approx_reg app r) rs#r.

Ltac InvApproxRegs :=
  match goal with
  | [ H: _ :: _ = _ :: _ |- _ ] =>
        injection H; clear H; intros; InvApproxRegs
  | [ H: ?v = approx_reg app ?r |- _ ] =>
        generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs
  | _ => idtac
  end.

Lemma cond_strength_reduction_correct:
  forall cond args vl,
  vl = approx_regs app args ->
  let (cond', args') := cond_strength_reduction cond args vl in
  eval_condition cond' rs##args' m = eval_condition cond rs##args m.
Proof.
  intros until vl. unfold cond_strength_reduction.
  case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVMA.
  rewrite H0. apply Val.swap_cmp_bool.
  rewrite H. auto.
  rewrite H0. apply Val.swap_cmpu_bool.
  rewrite H. auto.
  rewrite H. rewrite eval_static_shift_correct. auto.
  rewrite H. rewrite eval_static_shift_correct. auto.
  auto.
  destruct (Float.eq_dec n1 Float.zero); simpl; auto.
  rewrite H0; subst n1. destruct (rs#r2); simpl; auto. rewrite Float.cmp_swap. auto.
  destruct (Float.eq_dec n2 Float.zero); simpl; auto.
  congruence.
  destruct (Float.eq_dec n1 Float.zero); simpl; auto.
  rewrite H0; subst n1. destruct (rs#r2); simpl; auto. rewrite Float.cmp_swap. auto.
  destruct (Float.eq_dec n2 Float.zero); simpl; auto.
  congruence.
  auto.
Qed.

Lemma make_addimm_correct:
  forall n r,
  let (op, args) := make_addimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.add rs#r (Vint n)) v.
Proof.
  intros. unfold make_addimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst. exists (rs#r); split; auto. destruct (rs#r); simpl; auto; rewrite Int.add_zero; auto.
  exists (Val.add rs#r (Vint n)); auto.
Qed.

Lemma make_shlimm_correct:
  forall n r1 r2,
  rs#r2 = Vint n ->
  let (op, args) := make_shlimm n r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v.
Proof.
  Opaque mk_shift_amount.
  intros; unfold make_shlimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shl_zero. auto.
  destruct (Int.ltu n Int.iwordsize) eqn:?; intros.
  econstructor; split. simpl; eauto.  rewrite mk_shift_amount_eq; auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_shrimm_correct:
  forall n r1 r2,
  rs#r2 = Vint n ->
  let (op, args) := make_shrimm n r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shrimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shr_zero. auto.
  destruct (Int.ltu n Int.iwordsize) eqn:?; intros.
  econstructor; split. simpl; eauto.  rewrite mk_shift_amount_eq; auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_shruimm_correct:
  forall n r1 r2,
  rs#r2 = Vint n ->
  let (op, args) := make_shruimm n r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shruimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shru_zero. auto.
  destruct (Int.ltu n Int.iwordsize) eqn:?; intros.
  econstructor; split. simpl; eauto.  rewrite mk_shift_amount_eq; auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_mulimm_correct:
  forall n r1 r2,
  rs#r2 = Vint n ->
  let (op, args) := make_mulimm n r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_mulimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (Vint Int.zero); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.one; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_one; auto.
  destruct (Int.is_power2 n) eqn:?; intros.
  exploit Int.is_power2_range; eauto. intros R.
  econstructor; split. simpl; eauto. rewrite mk_shift_amount_eq; auto.
  rewrite (Val.mul_pow2 rs#r1 _ _ Heqo). auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_divimm_correct:
  forall n r1 r2 v,
  Val.divs rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_divimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divimm.
  destruct (Int.is_power2 n) eqn:?.
  destruct (Int.ltu i (Int.repr 31)) eqn:?.
  exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence.
  exists v; auto.
  exists v; auto.
Qed.

Lemma make_divuimm_correct:
  forall n r1 r2 v,
  Val.divu rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_divuimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divuimm.
  destruct (Int.is_power2 n) eqn:?.
  replace v with (Val.shru rs#r1 (Vint i)).
  econstructor; split. simpl. rewrite mk_shift_amount_eq. eauto.
  eapply Int.is_power2_range; eauto. auto.
  eapply Val.divu_pow2; eauto. congruence.
  exists v; auto.
Qed.

Lemma make_andimm_correct:
  forall n r,
  let (op, args) := make_andimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v.
Proof.
  intros; unfold make_andimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (Vint Int.zero); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_mone; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_orimm_correct:
  forall n r,
  let (op, args) := make_orimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v.
Proof.
  intros; unfold make_orimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (Vint Int.mone); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_mone; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_xorimm_correct:
  forall n r,
  let (op, args) := make_xorimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v.
Proof.
  intros; unfold make_xorimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.xor_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (Val.notint (rs#r)); split. auto.
  destruct (rs#r); simpl; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_mulfimm_correct:
  forall n r1 r2,
  rs#r2 = Vfloat n ->
  let (op, args) := make_mulfimm n r1 r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v.
Proof.
  intros; unfold make_mulfimm.
  destruct (Float.eq_dec n (Float.floatofint (Int.repr 2))); intros.
  simpl. econstructor; split. eauto. rewrite H; subst n.
  destruct (rs#r1); simpl; auto. rewrite Float.mul2_add; auto.
  simpl. econstructor; split; eauto.
Qed.

Lemma make_mulfimm_correct_2:
  forall n r1 r2,
  rs#r1 = Vfloat n ->
  let (op, args) := make_mulfimm n r2 r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v.
Proof.
  intros; unfold make_mulfimm.
  destruct (Float.eq_dec n (Float.floatofint (Int.repr 2))); intros.
  simpl. econstructor; split. eauto. rewrite H; subst n.
  destruct (rs#r2); simpl; auto. rewrite Float.mul2_add; auto.
  rewrite Float.mul_commut; auto.
  simpl. econstructor; split; eauto.
Qed.

Lemma op_strength_reduction_correct:
  forall op args vl v,
  vl = approx_regs app args ->
  eval_operation ge sp op rs##args m = Some v ->
  let (op', args') := op_strength_reduction op args vl in
  exists w, eval_operation ge sp op' rs##args' m = Some w /\ Val.lessdef v w.
Proof.
  intros until v; unfold op_strength_reduction;
  case (op_strength_reduction_match op args vl); simpl; intros.
(* add *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.add_commut. apply make_addimm_correct.
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_addimm_correct.
(* addshift *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H. rewrite eval_static_shift_correct. apply make_addimm_correct.
(* sub *)
  InvApproxRegs; SimplVMA. inv H0. rewrite H1. econstructor; split; eauto.
  InvApproxRegs; SimplVMA. inv H0. rewrite H. rewrite Val.sub_add_opp. apply make_addimm_correct.
(* subshift *)
  InvApproxRegs; SimplVMA. inv H0. rewrite H. rewrite eval_static_shift_correct. rewrite Val.sub_add_opp. apply make_addimm_correct.
(* rsubshift *)
  InvApproxRegs; SimplVMA. inv H0. rewrite H. rewrite eval_static_shift_correct. econstructor; split; eauto.
(* mul *)
  InvApproxRegs; SimplVMA. inv H0. rewrite H1. rewrite Val.mul_commut. apply make_mulimm_correct; auto.
  InvApproxRegs; SimplVMA. inv H0. rewrite H. apply make_mulimm_correct; auto.
(* divs *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_divimm_correct; auto.
(* divu *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_divuimm_correct; auto.
(* and *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.and_commut. apply make_andimm_correct.
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_andimm_correct.
(* andshift *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H. rewrite eval_static_shift_correct. apply make_andimm_correct.
(* or *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.or_commut. apply make_orimm_correct.
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_orimm_correct.
(* orshift *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H. rewrite eval_static_shift_correct. apply make_orimm_correct.
(* xor *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.xor_commut. apply make_xorimm_correct.
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_xorimm_correct.
(* xorshift *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H. rewrite eval_static_shift_correct. apply make_xorimm_correct.
(* bic *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_andimm_correct.
(* bicshift *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H. rewrite eval_static_shift_correct. apply make_andimm_correct.
(* shl *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shlimm_correct; auto.
(* shr *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shrimm_correct; auto.
(* shru *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shruimm_correct; auto.
(* cmp *)
  generalize (cond_strength_reduction_correct c args0 vl0).
  destruct (cond_strength_reduction c args0 vl0) as [c' args']; intros.
  rewrite <- H1 in H0; auto. econstructor; split; eauto.
(* mulf *)
  inv H0. assert (rs#r2 = Vfloat n2). InvApproxRegs; SimplVMA; auto.
  apply make_mulfimm_correct; auto.
  inv H0. assert (rs#r1 = Vfloat n1). InvApproxRegs; SimplVMA; auto.
  apply make_mulfimm_correct_2; auto.
(* default *)
  exists v; auto.
Qed.

Lemma addr_strength_reduction_correct:
  forall addr args vl,
  vl = approx_regs app args ->
  let (addr', args') := addr_strength_reduction addr args vl in
  eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args.
Proof.
  intros until vl. unfold addr_strength_reduction.
  destruct (addr_strength_reduction_match addr args vl); simpl; intros; InvApproxRegs; SimplVMA.
  rewrite H; rewrite H0. rewrite Val.add_assoc; auto.
  rewrite H; rewrite H0. rewrite Val.add_permut; auto.
  rewrite H0. rewrite Val.add_commut. auto.
  rewrite H. auto.
  rewrite H; rewrite H0. rewrite Val.add_assoc. rewrite eval_static_shift_correct. auto.
  rewrite H. rewrite eval_static_shift_correct. auto.
  rewrite H. rewrite Val.add_assoc. auto.
  auto.
Qed.

End STRENGTH_REDUCTION.

End ANALYSIS.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal76.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) (Cons Zero Nil))).
Definition lfind_example_2  := ( Nil).
Definition lfind_example_3  := ( Cons (Succ (Succ (Succ (Succ Zero))))         (Cons Zero (Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil))))).
Definition lfind_example_4  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_5  := ( Nil).
Definition lfind_example_6  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_7  := ( Nil).
Definition lfind_example_8  := ( Cons (Succ Zero) (Cons (Succ Zero) Nil)).
Definition lfind_example_9  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_10  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_11  := ( Cons (Succ Zero) (Cons (Succ (Succ (Succ Zero))) Nil)).
Definition lfind_example_12  := ( Cons (Succ Zero) Nil).
Definition lfind_example_13  := ( Cons (Succ Zero)         (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero (Cons Zero Nil))))).
Definition lfind_example_14  := ( Nil).
Definition lfind_example_15  := ( Cons (Succ Zero) Nil).
Definition lfind_example_16  := ( Nil).
Definition lfind_example_17  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_18  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_19  := ( Nil).
Definition lfind_example_20  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_21  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_22  := ( Cons Zero (Cons (Succ Zero) (Cons Zero (Cons (Succ (Succ Zero)) Nil)))).
Definition lfind_example_23  := ( Nil).
Definition lfind_example_24  := ( Nil).
Definition lfind_example_25  := ( Nil).
Definition lfind_example_26  := ( Cons (Succ Zero) (Cons (Succ Zero) Nil)).
Definition lfind_example_27  := ( Nil).
Definition lfind_example_28  := ( Cons (Succ Zero) Nil).
Definition lfind_example_29  := ( Cons Zero         (Cons (Succ Zero)            (Cons (Succ Zero)               (Cons (Succ (Succ Zero))                  (Cons Zero                     (Cons (Succ Zero)                        (Cons Zero                           (Cons Zero                              (Cons (Succ (Succ Zero))                                 (Cons Zero                                    (Cons Zero (Cons (Succ Zero) Nil)))))))))))).
Definition lfind_example_30  := ( Cons (Succ (Succ Zero))         (Cons Zero            (Cons (Succ Zero)               (Cons (Succ Zero)                  (Cons (Succ (Succ (Succ (Succ (Succ Zero))))) Nil))))).
Definition lfind_example_31  := ( Cons Zero         (Cons (Succ (Succ (Succ (Succ (Succ (Succ Zero))))))            (Cons Zero (Cons Zero (Cons Zero (Cons Zero (Cons Zero Nil))))))).
Definition lfind_example_32  := ( Cons (Succ Zero) Nil).
Definition lfind_example_33  := ( Cons Zero Nil).
Definition lfind_example_34  := ( Nil).
Definition lfind_example_35  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_36  := ( Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil)))).
Definition lfind_example_37  := ( Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal76_theorem0_52_append_assoc/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 lfind_example_21 lfind_example_22 lfind_example_23 lfind_example_24 lfind_example_25 lfind_example_26 lfind_example_27 lfind_example_28 lfind_example_29 lfind_example_30 lfind_example_31 lfind_example_32 lfind_example_33 lfind_example_34 lfind_example_35 lfind_example_36 lfind_example_37 .