Library config_semantics

Require Import base.

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

Inductive KCTL :=
  | kstmt : STMT -> KCTL
  | kwhile : EXPR -> STMT -> KCTL
  | kif : STMT -> STMT -> KCTL
  | kenv : VAR -> KCTL.

Definition ENV := list (VAR * nat).

Fixpoint env_lookup (v:VAR) (e:ENV) : option nat :=
  match e with
  | nil => None
  | (v',x)::e' =>
      if eq_nat_dec v v' then Some x else env_lookup v e'
  end.

Record config :=
  mk_config
  { c_dom : list nat
  ; c_mem : nat -> var_state
  ; c_env : ENV
  ; c_stack : list KCTL
  ; c_expr : expr_st
  }.

Inductive config_step : config -> option OBS -> lift config -> Prop :=

  
  | cstp_terminate : forall dom m ev z,
      config_step
        (mk_config dom m ev nil (expr_select (const z)))
        (Some (obs_val z))
        (into (mk_config dom m ev nil expr_finish))

  

  | cstp_expr_none : forall dom m ev st ex ex',
      expr_step ex None ex' ->
      config_step
        (mk_config dom m ev st ex)
        None
        (lift_map (mk_config dom m ev st) ex')

  | cstp_expr_read_global : forall dom m ev st ex v z ex',
      expr_step ex (Some (read v z)) ex' ->
      env_lookup v ev = None ->
      config_step
        (mk_config dom m ev st ex)
        (Some (read v z))
        (lift_map (mk_config dom m ev st) ex')

  | cstp_expr_read_local : forall dom m ev st ex v l z ex',
      expr_step ex (Some (read v z)) ex' ->
      env_lookup v ev = Some l ->
      m l = z ->
      config_step
        (mk_config dom m ev st ex)
        None
        (lift_map (mk_config dom m ev st) ex')

  | cstp_expr_write_global : forall dom m ev st ex v z ex',
      expr_step ex (Some (write v z)) ex' ->
      env_lookup v ev = None ->
      config_step
        (mk_config dom m ev st ex)
        (Some (write v z))
        (lift_map (mk_config dom m ev st) ex')

  | cstp_expr_write_local : forall dom m m' ev st ex v z l ex',
      expr_step ex (Some (write v z)) ex' ->
      env_lookup v ev = Some l ->
      (forall x, m' x = if eq_nat_dec x l then z else m x) ->
      config_step
        (mk_config dom m ev st ex)
        None
        (lift_map (mk_config dom m' ev st) ex')

  

  | cstp_kwhile_false : forall dom m e s ev st z,
      z = 0%Z ->
      config_step
        (mk_config dom m ev (kwhile e s :: st) (expr_select (const z)))
        None
        (into (mk_config dom m ev st (expr_select (const z))))

  | cstp_kwhile_true : forall dom m e s ev st z,
      z <> 0%Z ->
      config_step
        (mk_config dom m ev (kwhile e s :: st) (expr_select (const z)))
        None
        (into (mk_config dom m ev (kstmt s :: kstmt (expr e) :: kwhile e s :: st) (expr_select (const z))))

  | cstp_kif_false : forall dom m s1 s2 ev st z,
      z = 0%Z ->
      config_step
        (mk_config dom m ev (kif s1 s2 :: st) (expr_select (const z)))
        None
        (into (mk_config dom m ev (kstmt s2 :: st) (expr_select (const z))))

  | cstp_kif_true : forall dom m s1 s2 ev st z,
      z <> 0%Z ->
      config_step
        (mk_config dom m ev (kif s1 s2 :: st) (expr_select (const z)))
        None
        (into (mk_config dom m ev (kstmt s1 :: st) (expr_select (const z))))

  | cstp_kenv : forall dom m ev v l st z,
      config_step
        (mk_config dom m ((v,l)::ev) (kenv v :: st) (expr_select (const z)))
        None
        (into (mk_config dom m ev st (expr_select (const z))))


  

  | cstp_kstmt_expr : forall dom m ev e st z,
      config_step
        (mk_config dom m ev (kstmt (expr e) :: st) (expr_select (const z)))
        None
        (into (mk_config dom m ev st (expr_select e)))

  | cstp_kstmt_seq : forall dom m ev s1 s2 st z,
      config_step
        (mk_config dom m ev (kstmt (seq s1 s2) :: st) (expr_select (const z)))
        None
        (into (mk_config dom m ev (kstmt s1 :: kstmt s2 :: st) (expr_select (const z))))

  | cstp_kstmt_local : forall dom m ev v s st z l,
      
      ~In l dom ->

      config_step
        (mk_config dom m ev (kstmt (local v s) :: st) (expr_select (const z)))
        None
        (into (mk_config (l::dom) m ((v,l)::ev) (kstmt s :: kenv v :: st) (expr_select (const z))))

  | cstp_kstmt_ifte : forall dom m ev e s1 s2 st z,
      config_step
        (mk_config dom m ev (kstmt (ifte e s1 s2) :: st) (expr_select (const z)))
        None
        (into (mk_config dom m ev (kif s1 s2 :: st) (expr_select e)))

  | cstp_kstmt_while : forall dom m ev e s st z,
      config_step
        (mk_config dom m ev (kstmt (while e s) :: st) (expr_select (const z)))
        None
        (into (mk_config dom m ev (kwhile e s :: st) (expr_select e))).

Definition config_lts := Build_LTS config config_step.
Definition init_config (s:STMT) :=
  mk_config nil (fun _ => var_indeterm) nil (kstmt s :: nil) (expr_select (const 0)).

Definition config_prog (s:STMT) : prog :=
  Build_prog config_lts (init_config s).

Fixpoint stk_env_agree (s:list KCTL) (e:ENV) :=
  match s, e with
  | nil, nil => True

  | kenv v :: s', (v',l)::e' =>
      v = v' /\ stk_env_agree s' e'

  | kenv v :: _, nil => False

  | _ :: s', _ => stk_env_agree s' e

  | _, _ => False
  end.

Inductive stk_env_agree' : list KCTL -> ENV -> Prop :=
  | agree_nil : stk_env_agree' nil nil
  | agree_kenv : forall stk env v l,
        stk_env_agree' stk env ->
        stk_env_agree' (kenv v::stk) ((v,l)::env)
  | agree_kstmt : forall stk env s,
        stk_env_agree' stk env ->
        stk_env_agree' (kstmt s::stk) env
  | agree_kif : forall stk env s1 s2,
        stk_env_agree' stk env ->
        stk_env_agree' (kif s1 s2::stk) env
  | agree_kwhile : forall stk env e s,
        stk_env_agree' stk env ->
        stk_env_agree' (kwhile e s::stk) env.

Lemma stk_env_agree_eq : forall stk env,
  stk_env_agree stk env <-> stk_env_agree' stk env.

Lemma stk_env_agree_app : forall s1 s2 e1 e2,
  stk_env_agree s1 e1 ->
  stk_env_agree s2 e2 ->
  stk_env_agree (s1 ++ s2) (e1 ++ e2).

Inductive config_invariants : list nat -> (nat -> var_state) -> ENV -> list KCTL -> Prop :=
  | config_inv_intro : forall dom m env stk,
      stk_env_agree stk env ->
      NoDup (map (@snd _ _) env) ->
      (forall v l, In (v,l) env -> In l dom) ->
      (forall x, ~In x dom -> m x = var_indeterm) ->
      config_invariants dom m env stk.

Lemma expr_step_const : forall z o ex',
  expr_step (expr_select (const z)) o ex' ->
  o = Some (obs_val z) /\ ex' = into expr_finish.

Inductive config_rel (env:ENV) (stk:list KCTL) : config -> config -> Prop :=
  | config_rel_intro : forall dom m1 m2 env1 env2 stk1 stk2 ex,

    config_invariants dom m1 env1 stk1 ->

    config_invariants dom m2 env2 stk2 ->
    
    (forall v l, In (v,l) env2 -> m1 l = m2 l) ->

    env1 ++ env = env2 ->

    stk1 ++ stk = stk2 ->

    config_rel env stk
      (mk_config dom m1 env1 stk1 ex)
      (mk_config dom m2 env2 stk2 ex).

Definition binds_var (v:VAR) (e:ENV) :=
  exists l, In (v,l) e.

Definition binds_loc (l:nat) (e:ENV) :=
  exists v, In (v,l) e.

Lemma env_lookup_app_tail : forall v env1 env2 l,
  env_lookup v env1 = None ->
  env_lookup v (env1 ++ env2) = Some l ->
  env_lookup v env2 = Some l.

Lemma env_lookup_none_app2 : forall v env1 env2,
  env_lookup v env1 = None ->
  env_lookup v (env1 ++ env2) = env_lookup v env2.

Lemma env_lookup_none_app : forall v env1 env2,
  env_lookup v (env1 ++ env2) = None ->
  env_lookup v env1 = None.

Lemma binds_var_lookup_none : forall env v,
  binds_var v env ->
  env_lookup v env = None -> False.

Lemma env_lookup_some_app : forall env env' v l,
  env_lookup v env = Some l ->
  env_lookup v (env ++ env') = Some l.

Lemma env_lookup_in : forall env v l,
  env_lookup v env = Some l ->
  In (v,l) env.

Lemma env_lookup_binds_loc : forall env v l,
  env_lookup v env = Some l ->
  binds_loc l env.

Lemma config_invariants_step : forall dom1 dom2 m1 m2 e1 e2 k1 k2 ex1 ex2 o,
  config_step (mk_config dom1 m1 e1 k1 ex1) o (into (mk_config dom2 m2 e2 k2 ex2)) ->
  config_invariants dom1 m1 e1 k1 ->
  config_invariants dom2 m2 e2 k2.

Lemma config_rel_step1 : forall env stk c1 o c1' c2,
  steps config_lts c1 o c1' ->
  config_rel env stk c1 c2 ->
  (exists c2',
    steps config_lts c2 o c2' /\
    (forall v, support o v -> binds_var v (c_env c2) -> False) /\
    strict_lift config_lts config_lts (config_rel env stk) c1' c2' /\
    match c1' with mho => True | into c1'' =>
      forall l, ~binds_loc l (c_env c1) -> c_mem c1 l = c_mem c1'' l end)
  \/
  (exists ex', exists v, exists l, exists z,
    env_lookup v env = Some l /\
    o = Some (read v z) /\
    expr_step (c_expr c1) (Some (read v z)) ex' /\
    env_lookup v (c_env c1) = None /\
    c1' = lift_map (mk_config (c_dom c1) (c_mem c1) (c_env c1) (c_stack c1)) ex')
  \/
  (exists ex', exists z, exists v, exists l,
    env_lookup v env = Some l /\
    o = Some (write v (var_determ z)) /\
    expr_step (c_expr c1) (Some (write v (var_determ z))) ex' /\
    env_lookup v (c_env c1) = None /\
    c1' = lift_map (mk_config (c_dom c1) (c_mem c1) (c_env c1) (c_stack c1)) ex')
  \/
  (exists z, o = Some (obs_val z)
    /\ c_expr c1 = expr_select (const z)
    /\ c_env c1 = nil
    /\ c_stack c1 = nil
    /\ c1' = into (mk_config (c_dom c1) (c_mem c1) nil nil expr_finish)
    /\ c_expr c2 = expr_select (const z)
    /\ c_stack c2 = stk
    /\ c_env c2 = env).

Lemma config_rel_step2 : forall env stk c1 c2 o c2',
  steps config_lts c2 o c2' ->
  config_rel env stk c1 c2 ->
  
  (exists c1',
    steps config_lts c1 o c1' /\
    strict_lift config_lts config_lts (config_rel env stk) c1' c2' /\
    (forall v, support o v -> binds_var v (c_env c2) -> False) /\
    match c1' with mho => True | into c1'' =>
      forall l, ~binds_loc l (c_env c1) -> c_mem c1 l = c_mem c1'' l end /\
    (forall z, o = Some (obs_val z) -> stk = nil))
  \/
  (exists ex', exists v, exists l,
    env_lookup v env = Some l /\
    o = None /\
    expr_step (c_expr c1) (Some (read v (c_mem c2 l))) ex' /\
    env_lookup v (c_env c1) = None /\
    c2' = lift_map (mk_config (c_dom c2) (c_mem c2) (c_env c2) (c_stack c2)) ex')
  \/
  (exists ex', exists z, exists m', exists v, exists l,
    env_lookup v env = Some l /\
    o = None /\
    expr_step (c_expr c1) (Some (write v (var_determ z))) ex' /\
    env_lookup v (c_env c1) = None /\
    (forall x : nat, m' x = (if eq_nat_dec x l then var_determ z else c_mem c2 x)) /\
    c2' = lift_map (mk_config (c_dom c2) m' (c_env c2) (c_stack c2)) ex')
  \/
  (exists z, o = None
    /\ c_expr c1 = expr_select (const z)
    /\ c_env c1 = nil
    /\ c_stack c1 = nil
    /\ c_expr c2 = expr_select (const z)
    /\ c_stack c2 = stk
    /\ c_env c2 = env
    /\ steps config_lts c2 o c2').

Lemma related_config_mho_refinement : forall env stk,
  refinement branch_ind config_lts void_lts
  (fun cfg _ => exists cfg',
    strict_lift config_lts config_lts (config_rel env stk) cfg' cfg /\
    refines branch_ind config_lts void_lts cfg' (mho _)).

Lemma related_config_mho : forall env stk c1 c2,
  config_rel env stk c1 c2 ->
  refines branch_ind config_lts void_lts (into c1) (mho _) ->
  refines branch_ind config_lts void_lts (into c2) (mho _).

Lemma config_invariants_unstmt : forall dom m env k s,
 config_invariants dom m env (k ++ kstmt s :: nil) ->
 config_invariants dom m env k.

Lemma config_invariants_unenv : forall stk dom m env v l,
  config_invariants dom m (env ++ (v,l)::nil) (stk ++ kenv v :: nil) ->
  config_invariants dom m env stk.

Lemma config_invariants_bind_loc : forall l1 l2 dom m e1 e2 stk,
  config_invariants dom m (e1++e2) stk ->
  binds_loc l1 e1 ->
  binds_loc l2 e2 ->
  l1 = l2 -> False.