Library expr_semantics

Require Import base.

Require Import nominal.
Require Import syntax.
Require Import basic_semantics.

Definition eval_ops (p:OPS) (c1 c2:Z) : lift Z :=
  match p with
  | PLUS => into (c1 + c2)%Z
  | MINUS => into (c1 - c2)%Z
  | MULT => into (c1 * c2)%Z
  | DIV => if (Z_eq_dec c2 0%Z) then mho _
                    else into (Zdiv c1 c2)
  | MOD => if (Z_eq_dec c2 0%Z) then mho _
                    else into (Zmod c1 c2)
  | EQ => into (if (Z_eq_dec c1 c2) then 1%Z else 0%Z)
  | NEQ => into (if (Z_eq_dec c1 c2) then 0%Z else 1%Z)
  | LE => into (if (Z_le_dec c1 c2) then 1%Z else 0%Z)
  | LT => into (if (Z_lt_dec c1 c2) then 1%Z else 0%Z)
  | GE => into (if (Z_ge_dec c1 c2) then 1%Z else 0%Z)
  | GT => into (if (Z_gt_dec c1 c2) then 1%Z else 0%Z)
  end.

Inductive CXT :=
  | cxt_hole
  | cxt_op_l : OPS -> CXT -> EXPR -> CXT
  | cxt_op_r : OPS -> EXPR -> CXT -> CXT
  | cxt_assign : VAR -> CXT -> CXT
  | cxt_cond : CXT -> EXPR -> EXPR -> CXT.

Inductive redex : EXPR -> option OBS -> lift EXPR -> Prop :=
  | rdx_read : forall v c,
      redex (var v)
            (Some (read v (var_determ c)))
            (into (const c))

  | rdx_read_fail : forall v,
      redex (var v)
            (Some (read v var_indeterm))
            (mho _)

  | rdx_write : forall v c,
      redex (assign v (const c))
            (Some (write v (var_determ c)))
            (into (const c))

  | rdx_op : forall p c1 c2,
      redex (op p (const c1) (const c2))
            None
            (lift_map const (eval_ops p c1 c2))

  | rdx_cond_true : forall c e1 e2,
      c <> 0%Z ->
      redex (cond (const c) e1 e2)
            None
            (into e1)

  | rdx_cond_false : forall c e1 e2,
      c = 0%Z ->
      redex (cond (const c) e1 e2)
            None
            (into e2).

Inductive is_redex : EXPR -> Prop :=
  | is_rdx_var : forall v, is_redex (var v)
  | is_rdx_assign : forall v z, is_redex (assign v (const z))
  | is_rdx_op : forall p z1 z2, is_redex (op p (const z1) (const z2))
  | is_rdx_cond : forall z e1 e2, is_redex (cond (const z) e1 e2).

Lemma is_redex_iff_redex : forall e,
  is_redex e <-> exists o, exists e', redex e o e'.

Fixpoint cxt_compose (E1 E2:CXT) : CXT :=
  match E1 with
  | cxt_hole => E2
  | cxt_op_l p E e => cxt_op_l p (cxt_compose E E2) e
  | cxt_op_r p e E => cxt_op_r p e (cxt_compose E E2)
  | cxt_assign v E => cxt_assign v (cxt_compose E E2)
  | cxt_cond E e1 e2 => cxt_cond (cxt_compose E E2) e1 e2
  end.

Fixpoint cxt_plug (E:CXT) (e0:EXPR) : EXPR :=
  match E with
  | cxt_hole => e0
  | cxt_op_l p E e => op p (cxt_plug E e0) e
  | cxt_op_r p e E => op p e (cxt_plug E e0)
  | cxt_assign v E => assign v (cxt_plug E e0)
  | cxt_cond E e1 e2 => cond (cxt_plug E e0) e1 e2
  end.

Lemma plug_compose : forall E1 E2 e,
  cxt_plug (cxt_compose E1 E2) e =
  cxt_plug E1 (cxt_plug E2 e).

Inductive expr_st :=
  | expr_select : EXPR -> expr_st
  | expr_redex : CXT -> EXPR -> expr_st
  | expr_finish.

Inductive expr_step : expr_st -> option OBS -> lift expr_st -> Prop :=
  | expr_step_finish : forall z,
        expr_step (expr_select (const z)) (Some (obs_val z)) (into expr_finish)

  | expr_step_select : forall e E e',
        e = cxt_plug E e' ->
        is_redex e' ->
        expr_step (expr_select e) None (into (expr_redex E e'))

  | expr_step_redex : forall E e1 o e2 z,
        redex e1 o e2 ->
        z = lift_map (fun x => expr_select (cxt_plug E x)) e2 ->
        expr_step (expr_redex E e1) o z.

Definition expr_lts := Build_LTS expr_st expr_step.
Definition expr_prog (e:EXPR) : prog := Build_prog expr_lts (expr_select e).


Inductive expr_bad_st :=
  | expr_bad_run : EXPR -> expr_bad_st
  | expr_bad_finish .

Inductive expr_bad_step : expr_bad_st -> option OBS -> lift expr_bad_st -> Prop :=
  | expr_bad_step_redex : forall C e o e',
       redex e o e' ->
       expr_bad_step
         (expr_bad_run (cxt_plug C e))
         o
         (lift_map (fun e => expr_bad_run (cxt_plug C e)) e')

  | expr_bad_step_dome : forall z,
       expr_bad_step
         (expr_bad_run (const z))
         (Some (obs_val z))
         (into expr_bad_finish).

Definition expr_bad_lts := Build_LTS expr_bad_st expr_bad_step.
Definition expr_bad_prog e := Build_prog expr_bad_lts (expr_bad_run e).


Inductive lr_expr_red : EXPR -> option OBS -> lift EXPR -> Prop :=
  | lr_red_op1 : forall p e1 e1' o e2,
     lr_expr_red e1 o e1' ->
     lr_expr_red (op p e1 e2) o (lift_map (fun x => op p x e2) e1')

  | lr_red_op2 : forall p z e2 o e2',
     lr_expr_red e2 o e2' ->
     lr_expr_red (op p (const z) e2) o (lift_map (fun x => (op p (const z) x)) e2')

  | lr_red_op3 : forall p z1 z2 z,
     eval_ops p z1 z2 = z ->
     lr_expr_red (op p (const z1) (const z2)) None (lift_map const z)

  | lr_cond1 : forall e1 o e1' e2 e3,
     lr_expr_red e1 o e1' ->
     lr_expr_red (cond e1 e2 e3) o (lift_map (fun x => cond x e2 e3) e1')

  | lr_cond_true : forall z e2 e3,
     z <> 0%Z ->
     lr_expr_red (cond (const z) e2 e3) None (into e2)

  | lr_cond_false : forall z e2 e3,
     z = 0%Z ->
     lr_expr_red (cond (const z) e2 e3) None (into e3)

  | lr_read_var : forall v z,
     lr_expr_red (var v) (Some (read v (var_determ z))) (into (const z))

  | lr_read_var_fail : forall v,
     lr_expr_red (var v) (Some (read v var_indeterm)) (mho _)

  | lr_assign_var1 : forall v e1 o e1',
     lr_expr_red e1 o e1' ->
     lr_expr_red (assign v e1) o (lift_map (assign v) e1')

  | lr_assign_var2 : forall v z,
     lr_expr_red (assign v (const z)) (Some (write v (var_determ z))) (into (const z)).

Inductive lr_expr_step : option EXPR -> option OBS -> lift (option EXPR) -> Prop :=
  | lr_expr_finish : forall z,
        lr_expr_step (Some (const z)) (Some (obs_val z)) (into None)
  | lr_expr_redex : forall e o e',
        lr_expr_red e o e' ->
        lr_expr_step (Some e) o (lift_map (@Some _) e').

Lemma lr_red_determ : forall e o ex ey,
  lr_expr_red e o ex ->
  lr_expr_red e o ey ->
  ex = ey.

Lemma lr_expr_determ : forall e o ex ey,
  lr_expr_step e o ex ->
  lr_expr_step e o ey ->
  ex = ey.

Fixpoint is_lr_cxt (E:CXT) :=
  match E with
  | cxt_hole => True
  | cxt_op_l p E' e2 => is_lr_cxt E'
  | cxt_op_r p (const _) E' => is_lr_cxt E'
  | cxt_op_r _ _ _ => False
  | cxt_assign v E' => is_lr_cxt E'
  | cxt_cond E' _ _ => is_lr_cxt E'
  end.

Lemma lr_red_cxt_redex : forall e o e',
  lr_expr_red e o e' ->
  exists E, exists e0, exists e0',
    is_lr_cxt E /\
    redex e0 o e0' /\
    cxt_plug E e0 = e /\
    lift_map (cxt_plug E) e0' = e'.

Lemma lr_red_cxt_redex2 : forall e o e',
  lr_expr_red e o e' ->
  forall E e0,
  is_lr_cxt E -> is_redex e0 ->
  e = cxt_plug E e0 ->
  exists e0',
    redex e0 o e0' /\
    lift_map (cxt_plug E) e0' = e'.

Lemma lr_cxt_red : forall E e o e',
  is_lr_cxt E ->
  redex e o e' ->
  lr_expr_red (cxt_plug E e) o (lift_map (cxt_plug E) e').

Lemma lr_expr_red_no_val : forall e o e' z,
  lr_expr_red e o e' -> o = Some (obs_val z) -> False.

Definition lr_expr_lts := Build_LTS (option EXPR) lr_expr_step.
Definition lr_expr_prog (e:EXPR) : prog := Build_prog lr_expr_lts (Some e).

Theorem bad_expr_no_choice_refine :
  ~(forall e, choice_pacc (expr_bad_prog e) (lr_expr_prog e)).

Definition strict_lift A B (R:state A -> state B -> Prop) (a:lstate A) (b:lstate B) : Prop :=
  match a, b with
  | mho, mho => True
  | into a', into b' => R a' b'
  | _, _ => False
  end.

Definition lr_expr_match (x:expr_st) (y:option EXPR) :=
  match x, y with
  | expr_finish, None => True
  | expr_select e, Some e' => e = e'
  | expr_redex E e0, Some e =>
      is_redex e0 /\ is_lr_cxt E /\ cxt_plug E e0 = e
  | _, _ => False
  end.

Lemma is_redex_dec : forall e,
  is_redex e \/ ~is_redex e.

Lemma has_redex_dec : forall e,
  (exists E, exists e0, e = cxt_plug E e0 /\ is_redex e0) \/
  (exists z, e = const z).

Lemma find_lr_cxt : forall e E e0,
  e = cxt_plug E e0 -> is_redex e0 ->
  exists E', exists e0',
    e = cxt_plug E' e0' /\ is_redex e0' /\ is_lr_cxt E'.

Lemma lr_expr_match_choice_refinement :
  refinement choice expr_lts lr_expr_lts (strict_lift expr_lts lr_expr_lts lr_expr_match).

Lemma lr_expr_choice_ref : forall x y,
  lr_expr_match x y ->
  refines choice expr_lts lr_expr_lts (into x) (into y).

Theorem lr_expr_choice_pacc : forall e,
  choice_pacc (expr_prog e) (lr_expr_prog e).

Fixpoint cxt_papp (p:perm) (E:CXT) :=
  match E with
  | cxt_hole => cxt_hole
  | cxt_op_l q E e => cxt_op_l q (cxt_papp p E) (papp p e)
  | cxt_op_r q e E => cxt_op_r q (papp p e) (cxt_papp p E)
  | cxt_assign v E => cxt_assign (papp p v) (cxt_papp p E)
  | cxt_cond E e1 e2 => cxt_cond (cxt_papp p E) (papp p e1) (papp p e2)
  end.

Fixpoint cxt_idents (E:CXT) : list VAR :=
  match E with
  | cxt_hole => nil
  | cxt_op_l q E e => cxt_idents E ++ expr_idents e
  | cxt_op_r q e E => expr_idents e ++ cxt_idents E
  | cxt_assign v E => v :: cxt_idents E
  | cxt_cond E e1 e2 =>
      cxt_idents E ++ expr_idents e1 ++ expr_idents e2
  end.

Definition expr_st_idents (st:expr_st) :=
  match st with
  | expr_finish => nil
  | expr_select e => expr_idents e
  | expr_redex E e => cxt_idents E ++ expr_idents e
  end.

Lemma papp_cxt_idents : forall p E,
  cxt_idents (cxt_papp p E) = papp p (cxt_idents E).

Program Instance cxt_nominal : Nominal CXT eq :=
  {| papp := cxt_papp
   ; support E v := In v (cxt_idents E)
  |}.
Opaque papp.
Transparent papp.

Definition expr_st_papp (p:perm) (st:expr_st) :=
  match st with
  | expr_finish => expr_finish
  | expr_select e => expr_select (papp p e)
  | expr_redex E e => expr_redex (papp p E) (papp p e)
  end.

Program Instance expr_st_nominal : Nominal expr_st eq :=
 {| papp := expr_st_papp
  ; support st v := In v (expr_st_idents st)
  |}.

Lemma cxt_plug_papp : forall p E e,
  papp p (cxt_plug E e) = cxt_plug (papp p E) (papp p e).

Ltac apply_app_or :=
  match goal with
  [ H: In _ (_ ++ _) |- _ ] => apply in_app_or in H
  end.

Lemma cxt_plug_idents1 : forall E e v,
  In v (expr_idents (cxt_plug E e)) ->
    In v (cxt_idents E) \/ In v (expr_idents e).

Lemma cxt_plug_idents2 : forall E e v,
  In v (cxt_idents E) \/ In v (expr_idents e) ->
  In v (expr_idents (cxt_plug E e)).

Lemma cxt_plug_support : forall E e v,
  support (cxt_plug E e) v <->
  support E v \/ support e v.

Lemma expr_redex_idents : forall e1 o e2,
  redex e1 o (into e2) ->
  forall v, In v (expr_idents e2) -> In v (expr_idents e1).

Lemma redex_support : forall e o e' v,
  redex e o e' ->
  support o v ->
  In v (expr_idents e).

Lemma idents_cxt1 : forall E e v,
  In v (expr_idents e) ->
  In v (expr_idents (cxt_plug E e)).

Lemma idents_cxt2 : forall E e1 e2,
  (forall v, In v (expr_idents e1) ->
             In v (expr_idents e2)) ->

  (forall v, In v (expr_idents (cxt_plug E e1)) ->
             In v (expr_idents (cxt_plug E e2))).

Lemma expr_reachable_free_vars : forall q1 q2 ,
  reachable' expr_lts q1 q2 ->
  forall e1 e2, contains q1 e1 -> contains q2 e2 ->
  forall v, In v (expr_st_idents e2) -> In v (expr_st_idents e1).

Lemma expr_support : forall e v,
  support (expr_prog e) v ->
  In v (expr_idents e).

Lemma expr_papp_strong_birefinement : forall p e,
  strong_birefinement
    (psys (expr_prog (papp p e)))
    (psys (papp p (expr_prog e)))
    (fun x y => x = lift_map (papp p) y).

Theorem expr_papp_commute_peq :
  forall e p,
    peq (expr_prog (papp p e)) (papp p (expr_prog e)).

Theorem expr_papp_commute1 :
  forall e p,
    pacc (expr_prog (papp p e)) (papp p (expr_prog e)).

Theorem expr_papp_commute2 :
  forall e p,
    pacc (papp p (expr_prog e)) (expr_prog (papp p e)).

Lemma expr_lts_mho_obs_crashes : mho_obs_crashes expr_lts.

Lemma expr_lts_read_receptive : read_receptive expr_lts.