(** STG in COQ by Maciej Piróg, University of Wrocław, 2010 *)

(** This library contains proofs of equivalence of semantics created
by merging and splitting some rules of the DCPS semantics.
In the paper it is done a little different, since it was easier
(but less readable) to do it in Coq before switching to an
abstract machine. *)

Require Export Sem05.

(** * Defunctionalized Continuation Passing Style Semantics 2 *)

Reserved Notation "($ x $ a $ b $ g $ e $ s ^\\ c $ d $ h $ f )"
  (at level 70, no associativity).

Inductive DCPS2 : action -> heapB -> expr -> env -> vars -> stack ->
  heapB -> expr -> env -> vars -> Prop :=

| D2_Halt : forall Gamma w sigma ps,
  ($ A $ Gamma $ w $ sigma $ ps $ nil ^\\ Gamma $ w $ sigma $ ps)

| D2_Con : forall Gamma Delta C pi w sigma rho qs Ss,
  ($ A $ Gamma $ Constr C pi $ sigma $ nil $ Ss ^\\ Delta $ w $ rho $ qs) ->
  ($ E $ Gamma $ Constr C pi $ sigma $ nil $ Ss ^\\ Delta $ w $ rho $ qs)

| D2_Accum : forall Gamma Delta x xm sigma_xm qn w rs sigma rho Ss,
  xm <> nil ->
  env_map sigma xm = Some sigma_xm ->
  ($ E $ Gamma $ App x nil $ sigma $ sigma_xm ++ qn $ Ss ^\\ Delta $ w $ rho $ rs) ->
  ($ E $ Gamma $ App x xm  $ sigma $ qn             $ Ss ^\\ Delta $ w $ rho $ rs)

| D2_App1 : forall Gamma tau p x pn m e sigma ,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_n m e, tau) ->
  m > length pn ->
  ($ E $ Gamma $ App x nil $ sigma $ pn $ nil ^\\ Gamma $ App x nil $ sigma $ pn)

| D2_App2_5 : forall Gamma Delta m e x tau p pn w rs sigma rho Ss,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_n m e, tau) ->
  m <= length pn ->
  ($ E $ Gamma $ e         $ zip_var_list m (firstn m pn) ++ shift m tau $ skipn m pn $ Ss ^\\ Delta $ w $ rho $ rs) ->
  ($ E $ Gamma $ App x nil $ sigma                                          $ pn         $ Ss ^\\ Delta $ w $ rho $ rs)

| D2A_App4 : forall Delta rho C xs p Theta w nu qs Ss,
  ($ E $ setB Delta p (Lf_n 0 (Constr C xs), trim rho xs) $ Constr C xs $ rho $ nil $ Ss ^\\ Theta $ w $ nu $ qs) ->
  ($ A $ Delta $ Constr C xs $ rho $ nil $ S_upd (Atom p) nil :: Ss ^\\ Theta $ w $ nu $ qs)

| D2E_App4_5 : forall Gamma Theta x p w e tau sigma nu rs qs Ss,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_u e, tau) ->
  ($ E $ Gamma $ e         $ tau   $ nil $ S_upd (Atom p) rs :: Ss ^\\ Theta $ w $ nu $ qs) ->
  ($ E $ Gamma $ App x nil $ sigma $ rs $ Ss ^\\ Theta $ w $ nu $ qs)

| D2A_App5 : forall EA Delta Theta x p pn y q qk f n w sigma rho nu mu qs Ss,
  env_find sigma x = Some (Atom p) ->
  env_find rho y = Some (Atom q) ->
  Delta q = Some (Lf_n n f, mu) ->
  length qk < n ->
  ($ E  $ setB Delta p (Lf_n (n - length qk) f, trim (zip_var_list (length qk) qk ++ shift (length qk) mu) (fv (Lf_n (n - length qk) f))) $
             App y nil $ rho $ qk ++ pn $ Ss    ^\\ Theta $ w $ nu $ qs) ->
  ($ EA $ Delta $ App y nil $ rho $ qk $ S_upd (Atom p) pn :: Ss ^\\ Theta $ w $ nu $ qs)

| D2_Let : forall Gamma Delta sigma rho lfs e w (ats : list nat) rs qs Ss,
  length ats = length lfs ->
  (forall a : nat, In a ats -> Gamma a = None) ->
  ($ E $ allocB Gamma ats
      (map (fun lf => (lf, trim (zip_var_list (length lfs) (map Atom ats) ++ shift (length lfs) sigma) (fv lf))) lfs)
    $ e $ zip_var_list (length lfs) (map Atom ats) ++ shift (length lfs) sigma $ rs $ Ss
    ^\\ Delta $ w $ rho $ qs) ->
  ($ E $ Gamma $ Letrec lfs e $ sigma $ rs $ Ss ^\\ Delta $ w $ rho $ qs)

| D2E_Case_of : forall Gamma Theta e als w rs qs sigma nu Ss,
  ($ E $ Gamma $ e          $ sigma $ nil $ S_alt als sigma qs :: Ss ^\\ Theta $ w $ nu $ rs) ->
  ($ E $ Gamma $ Case e als $ sigma $ qs $ Ss ^\\ Theta $ w $ nu $ rs)

| D2A_Case_of : forall Delta Theta b e0 als ys w c c0 rho_ys rs qs
  sigma rho nu Ss,
  length ys = b ->
  env_map rho ys = Some rho_ys ->
  select_case als c = Some (Alt c0 b e0) ->
  ($ E $ Delta $ e0          $ zip_var_list b rho_ys ++ shift b sigma $ qs $ Ss ^\\ Theta $ w $ nu $ rs) ->
  ($ A $ Delta $ Constr c ys $ rho $ nil $ S_alt als sigma qs :: Ss                ^\\ Theta $ w $ nu $ rs)

where "($ x $ a $ b $ g $ e $ s ^\\ c $ d $ h $ f )" :=
  (DCPS2 x a b g e s c d h f).

Hint Constructors DCPS2.

Lemma DCPS2_complete :
forall EA Gamma e sigma pn Ss Delta f rho qn,
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^\  Delta $ f $ rho $ qn) ->
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^\\ Delta $ f $ rho $ qn).
Proof with isa; eauto.
intros.
induction H...
destruct Ss.
  (* nil *)
inversion H2; subst...
  (* cons *)
inversion IHDCPS; subst...
Qed.

Lemma DCPS2_sound :
forall EA Gamma e sigma pn Ss Delta f rho qn,
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^\\ Delta $ f $ rho $ qn) ->
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^\  Delta $ f $ rho $ qn).
Proof with isa; eauto.
intros.
induction H...
destruct EA...
Qed.

(** * Defunctionalized Continuation Passing Style Semantics 3 *)

Reserved Notation "($ x $ a $ b $ g $ e $ s ^\\\ c $ d $ h $ f )"
  (at level 70, no associativity).

Inductive DCPS3 : action -> heapB -> expr -> env -> vars -> stack ->
  heapB -> expr -> env -> vars -> Prop :=

| D3_Halt : forall Gamma w sigma ps,
  ($ A $ Gamma $ w $ sigma $ ps $ nil ^\\\ Gamma $ w $ sigma $ ps)

| D3_Con : forall Gamma Delta C pi w sigma rho qs Ss,
  ($ A $ Gamma $ Constr C pi $ sigma $ nil $ Ss ^\\\ Delta $ w $ rho $ qs) ->
  ($ E $ Gamma $ Constr C pi $ sigma $ nil $ Ss ^\\\ Delta $ w $ rho $ qs)

| D3_Accum : forall Gamma Delta x xm sigma_xm qn w rs sigma rho Ss,
  xm <> nil ->
  env_map sigma xm = Some sigma_xm ->
  ($ E $ Gamma $ App x nil $ sigma $ sigma_xm ++ qn $ Ss ^\\\ Delta $ w $ rho $ rs) ->
  ($ E $ Gamma $ App x xm  $ sigma $ qn             $ Ss ^\\\ Delta $ w $ rho $ rs)

| D3_App1 : forall Gamma tau p x pn m e sigma ,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_n m e, tau) ->
  m > length pn ->
  ($ E $ Gamma $ App x nil $ sigma $ pn $ nil ^\\\ Gamma $ App x nil $ sigma $ pn)

| D3_App2_5 : forall Gamma Delta m e x tau p pn w rs sigma rho Ss,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_n m e, tau) ->
  m <= length pn ->
  ($ E $ Gamma $ e         $ zip_var_list m (firstn m pn) ++ shift m tau $ skipn m pn $ Ss ^\\\ Delta $ w $ rho $ rs) ->
  ($ E $ Gamma $ App x nil $ sigma                                          $ pn         $ Ss ^\\\ Delta $ w $ rho $ rs)

| D3A_App4 : forall Delta rho C xs p Theta w nu qs Ss,
  ($ E $ setB Delta p (Lf_n 0 (Constr C xs), trim rho xs) $ Constr C xs $ rho $ nil $ Ss ^\\\ Theta $ w $ nu $ qs) ->
  ($ A $ Delta $ Constr C xs $ rho $ nil $ S_upd (Atom p) nil :: Ss ^\\\ Theta $ w $ nu $ qs)

| D3E_App4_5 : forall Gamma Theta x p w e tau sigma nu rs qs Ss,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_u e, tau) ->
  ($ E $ Gamma $ e         $ tau   $ nil $ S_upd (Atom p) rs :: Ss ^\\\ Theta $ w $ nu $ qs) ->
  ($ E $ Gamma $ App x nil $ sigma $ rs $ Ss ^\\\ Theta $ w $ nu $ qs)

| D3A_App5 : forall EA Delta Theta x p pn y q qk f n w sigma rho nu mu qs Ss,
  env_find sigma x = Some (Atom p) ->
  env_find rho y = Some (Atom q) ->
  Delta q = Some (Lf_n n f, mu) ->
  length qk < n ->
  ($ E $ setB Delta p (Lf_n (n - length qk) f, trim (zip_var_list (length qk) qk ++ shift (length qk) mu) (fv (Lf_n (n - length qk) f))) $
             App y nil $ rho $ qk ++ pn $ Ss    ^\\\ Theta $ w $ nu $ qs) ->
  ($ EA $ Delta $ App y nil $ rho $ qk $ S_upd (Atom p) pn :: Ss ^\\\ Theta $ w $ nu $ qs)

| D3_Let : forall Gamma Delta sigma rho lfs e w (ats : list nat) rs qs Ss,
  length ats = length lfs ->
  (forall a : nat, In a ats -> Gamma a = None) ->
  ($ E $ allocB Gamma ats
      (map (fun lf => (lf, trim (zip_var_list (length lfs) (map Atom ats) ++ shift (length lfs) sigma) (fv lf))) lfs)
    $ e $ zip_var_list (length lfs) (map Atom ats) ++ shift (length lfs) sigma $ rs $ Ss
    ^\\\ Delta $ w $ rho $ qs) ->
  ($ E $ Gamma $ Letrec lfs e $ sigma $ rs $ Ss ^\\\ Delta $ w $ rho $ qs)

| D3E_Case_of : forall Gamma Theta e als w rs qs sigma nu Ss,
  ($ E $ Gamma $ e          $ sigma $ nil $ S_alt als sigma qs :: Ss ^\\\ Theta $ w $ nu $ rs) ->
  ($ E $ Gamma $ Case e als $ sigma $ qs $ Ss ^\\\ Theta $ w $ nu $ rs)

| D3A_Case_of : forall Delta Theta b e0 als ys w c c0 rho_ys rs qs
  sigma rho nu Ss,
  length ys = b ->
  env_map rho ys = Some rho_ys ->
  select_case als c = Some (Alt c0 b e0) ->
  ($ E $ Delta $ e0          $ zip_var_list b rho_ys ++ shift b sigma $ qs $ Ss ^\\\ Theta $ w $ nu $ rs) ->
  ($ A $ Delta $ Constr c ys $ rho $ nil $ S_alt als sigma qs :: Ss                ^\\\ Theta $ w $ nu $ rs)

where "($ x $ a $ b $ g $ e $ s ^\\\ c $ d $ h $ f )" :=
  (DCPS3 x a b g e s c d h f).

Hint Constructors DCPS3.

Lemma DCPS3_complete :
forall EA Gamma e sigma pn Ss Delta f rho qn,
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^\\  Delta $ f $ rho $ qn) ->
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^\\\ Delta $ f $ rho $ qn).
Proof.
intros.
induction H; eauto.
Qed.

Lemma DCPS3_sound :
forall EA Gamma e sigma pn Ss Delta f rho qn,
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^\\\ Delta $ f $ rho $ qn) ->
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^\\  Delta $ f $ rho $ qn).
Proof.
intros.
induction H; eauto.
Qed.

(** * Defunctionalized Continuation Passing Style Semantics 3 N *)

Reserved Notation "($ x $ a $ b $ g $ e $ s ^^\\\ c $ d $ h $ f ^^ n )"
  (at level 70, no associativity).

Inductive DCPS3N : action -> heapB -> expr -> env -> vars -> stack ->
  heapB -> expr -> env -> vars -> nat -> Prop :=

| D3N_Halt : forall Gamma w sigma ps,
  ($ A $ Gamma $ w $ sigma $ ps $ nil ^^\\\ Gamma $ w $ sigma $ ps ^^ 0)

| D3N_Con : forall Gamma Delta C pi w sigma rho qs Ss N,
  ($ A $ Gamma $ Constr C pi $ sigma $ nil $ Ss ^^\\\ Delta $ w $ rho $ qs ^^ N) ->
  ($ E $ Gamma $ Constr C pi $ sigma $ nil $ Ss ^^\\\ Delta $ w $ rho $ qs ^^ S N)

| D3N_Accum : forall Gamma Delta x xm sigma_xm qn w rs sigma rho Ss N,
  xm <> nil ->
  env_map sigma xm = Some sigma_xm ->
  ($ E $ Gamma $ App x nil $ sigma $ sigma_xm ++ qn $ Ss ^^\\\ Delta $ w $ rho $ rs ^^ N) ->
  ($ E $ Gamma $ App x xm  $ sigma $ qn             $ Ss ^^\\\ Delta $ w $ rho $ rs ^^ S N)

| D3N_App1 : forall Gamma tau p x pn m e sigma,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_n m e, tau) ->
  m > length pn ->
  ($ E $ Gamma $ App x nil $ sigma $ pn $ nil ^^\\\ Gamma $ App x nil $ sigma $ pn ^^ 0)

| D3N_App2_5 : forall Gamma Delta m e x tau p pn w rs sigma rho Ss N,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_n m e, tau) ->
  m <= length pn ->
  ($ E $ Gamma $ e         $ zip_var_list m (firstn m pn) ++ shift m tau $ skipn m pn $ Ss ^^\\\ Delta $ w $ rho $ rs ^^ N) ->
  ($ E $ Gamma $ App x nil $ sigma                                          $ pn         $ Ss ^^\\\ Delta $ w $ rho $ rs ^^ S N)

| D3NA_App4 : forall Delta rho C xs p Theta w nu qs Ss N,
  ($ E $ setB Delta p (Lf_n 0 (Constr C xs), trim rho xs) $ Constr C xs $ rho $ nil $ Ss ^^\\\ Theta $ w $ nu $ qs ^^ N) ->
  ($ A $ Delta $ Constr C xs $ rho $ nil $ S_upd (Atom p) nil :: Ss ^^\\\ Theta $ w $ nu $ qs ^^ S N)

| D3NE_App4_5 : forall Gamma Theta x p w e tau sigma nu rs qs Ss N,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_u e, tau) ->
  ($ E $ Gamma $ e         $ tau   $ nil $ S_upd (Atom p) rs :: Ss ^^\\\ Theta $ w $ nu $ qs ^^ N) ->
  ($ E $ Gamma $ App x nil $ sigma $ rs $ Ss ^^\\\ Theta $ w $ nu $ qs ^^ S N)

| D3NA_App5 : forall EA Delta Theta x p pn y q qk f n w sigma rho nu mu qs Ss N,
  env_find sigma x = Some (Atom p) ->
  env_find rho y = Some (Atom q) ->
  Delta q = Some (Lf_n n f, mu) ->
  length qk < n ->
  ($ E $ setB Delta p (Lf_n (n - length qk) f, trim (zip_var_list (length qk) qk ++ shift (length qk) mu) (fv (Lf_n (n - length qk) f))) $
             App y nil $ rho $ qk ++ pn $ Ss    ^^\\\ Theta $ w $ nu $ qs ^^ N) ->
  ($ EA $ Delta $ App y nil $ rho $ qk $ S_upd (Atom p) pn :: Ss ^^\\\ Theta $ w $ nu $ qs ^^ S N)

| D3N_Let : forall Gamma Delta sigma rho lfs e w (ats : list nat) rs qs Ss N,
  length ats = length lfs ->
  (forall a : nat, In a ats -> Gamma a = None) ->
  ($ E $ allocB Gamma ats
      (map (fun lf => (lf, trim (zip_var_list (length lfs) (map Atom ats) ++ shift (length lfs) sigma) (fv lf))) lfs)
    $ e $ zip_var_list (length lfs) (map Atom ats) ++ shift (length lfs) sigma $ rs $ Ss
    ^^\\\ Delta $ w $ rho $ qs ^^ N) ->
  ($ E $ Gamma $ Letrec lfs e $ sigma $ rs $ Ss ^^\\\ Delta $ w $ rho $ qs ^^ S N)

| D3NE_Case_of : forall Gamma Theta e als w rs qs sigma nu Ss N,
  ($ E $ Gamma $ e          $ sigma $ nil $ S_alt als sigma qs :: Ss ^^\\\ Theta $ w $ nu $ rs ^^ N) ->
  ($ E $ Gamma $ Case e als $ sigma $ qs $ Ss ^^\\\ Theta $ w $ nu $ rs ^^ S N)

| D3NA_Case_of : forall Delta Theta b e0 als ys w c c0 rho_ys rs qs
  sigma rho nu Ss N,
  length ys = b ->
  env_map rho ys = Some rho_ys ->
  select_case als c = Some (Alt c0 b e0) ->
  ($ E $ Delta $ e0          $ zip_var_list b rho_ys ++ shift b sigma $ qs $ Ss ^^\\\ Theta $ w $ nu $ rs ^^ N) ->
  ($ A $ Delta $ Constr c ys $ rho $ nil $ S_alt als sigma qs :: Ss                ^^\\\ Theta $ w $ nu $ rs ^^ S N)

where "($ x $ a $ b $ g $ e $ s ^^\\\ c $ d $ h $ f ^^ n )" :=
  (DCPS3N x a b g e s c d h f n).

Hint Constructors DCPS3N.

Lemma DCPS3N_complete :
forall EA Gamma e sigma pn Ss Delta f rho qn,
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^\\\  Delta $ f $ rho $ qn) ->
  exists N,
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^^\\\ Delta $ f $ rho $ qn ^^ N).
Proof with eauto.
intros.
induction H; try eauto;
  destruct IHDCPS3 as [N]; exists (S N); try constructor...
Qed.

Lemma DCPS3N_sound :
forall EA N Gamma e sigma pn Ss Delta f rho qn,
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^^\\\ Delta $ f $ rho $ qn ^^ N) ->
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^\\\  Delta $ f $ rho $ qn).
Proof with isa; eauto.
intros.
induction H...
Qed.

(** * Defunctionalized Continuation Passing Style Semantics 4 *)

Reserved Notation "($ x $ a $ b $ g $ e $ s ^\\/ c $ d $ h $ f )"
  (at level 70, no associativity).

Inductive DCPS4 : action -> heapB -> expr -> env -> vars -> stack ->
  heapB -> expr -> env -> vars -> Prop :=

| D4_Halt : forall Gamma w sigma ps,
  ($ A $ Gamma $ w $ sigma $ ps $ nil ^\\/ Gamma $ w $ sigma $ ps)

| D4_Con : forall Gamma Delta C pi w sigma rho qs Ss,
  ($ A $ Gamma $ Constr C pi $ sigma $ nil $ Ss ^\\/ Delta $ w $ rho $ qs) ->
  ($ E $ Gamma $ Constr C pi $ sigma $ nil $ Ss ^\\/ Delta $ w $ rho $ qs)

| D4_Accum : forall Gamma Delta x xm sigma_xm qn w rs sigma rho Ss,
  xm <> nil ->
  env_map sigma xm = Some sigma_xm ->
  ($ E $ Gamma $ App x nil $ sigma $ sigma_xm ++ qn $ Ss ^\\/ Delta $ w $ rho $ rs) ->
  ($ E $ Gamma $ App x xm  $ sigma $ qn             $ Ss ^\\/ Delta $ w $ rho $ rs)

| D4_App1 : forall Gamma tau p x pn m e sigma ,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_n m e, tau) ->
  m > length pn ->
  ($ E $ Gamma $ App x nil $ sigma $ pn $ nil ^\\/ Gamma $ App x nil $ sigma $ pn)

| D4_App2_5 : forall Gamma Delta m e x tau p pn w rs sigma rho Ss,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_n m e, tau) ->
  m <= length pn ->
  ($ E $ Gamma $ e         $ zip_var_list m (firstn m pn) ++ shift m tau $ skipn m pn $ Ss ^\\/ Delta $ w $ rho $ rs) ->
  ($ E $ Gamma $ App x nil $ sigma                                          $ pn         $ Ss ^\\/ Delta $ w $ rho $ rs)

| D4A_App4 : forall Delta rho C xs p Theta w nu qs Ss,
  ($ E $ setB Delta p (Lf_n 0 (Constr C xs), trim rho xs) $ Constr C xs $ rho $ nil $ Ss ^\\/ Theta $ w $ nu $ qs) ->
  ($ A $ Delta $ Constr C xs $ rho $ nil $ S_upd (Atom p) nil :: Ss ^\\/ Theta $ w $ nu $ qs)

| D4E_App4_5 : forall Gamma Theta x p w e tau sigma nu rs qs Ss,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_u e, tau) ->
  ($ E $ Gamma $ e         $ tau   $ nil $ S_upd (Atom p) rs :: Ss ^\\/ Theta $ w $ nu $ qs) ->
  ($ E $ Gamma $ App x nil $ sigma $ rs $ Ss ^\\/ Theta $ w $ nu $ qs)

| D4A_App5 : forall Delta Theta x p pn y q qk f n w sigma rho nu mu qs Ss,
  env_find sigma x = Some (Atom p) ->
  env_find rho y = Some (Atom q) ->
  Delta q = Some (Lf_n n f, mu) ->
  length qk < n ->
  ($ E $ setB Delta p (Lf_n (n - length qk) f, trim (zip_var_list (length qk) qk ++ shift (length qk) mu) (fv (Lf_n (n - length qk) f))) $
             App y nil $ rho $ qk ++ pn $ Ss    ^\\/ Theta $ w $ nu $ qs) ->
  ($ E $ Delta $ App y nil $ rho $ qk $ S_upd (Atom p) pn :: Ss ^\\/ Theta $ w $ nu $ qs)

| D4_Let : forall Gamma Delta sigma rho lfs e w (ats : list nat) rs qs Ss,
  length ats = length lfs ->
  (forall a : nat, In a ats -> Gamma a = None) ->
  ($ E $ allocB Gamma ats
      (map (fun lf => (lf, trim (zip_var_list (length lfs) (map Atom ats) ++ shift (length lfs) sigma) (fv lf))) lfs)
    $ e $ zip_var_list (length lfs) (map Atom ats) ++ shift (length lfs) sigma $ rs $ Ss
    ^\\/ Delta $ w $ rho $ qs) ->
  ($ E $ Gamma $ Letrec lfs e $ sigma $ rs $ Ss ^\\/ Delta $ w $ rho $ qs)

| D4E_Case_of : forall Gamma Theta e als w rs qs sigma nu Ss,
  ($ E $ Gamma $ e          $ sigma $ nil $ S_alt als sigma qs :: Ss ^\\/ Theta $ w $ nu $ rs) ->
  ($ E $ Gamma $ Case e als $ sigma $ qs $ Ss ^\\/ Theta $ w $ nu $ rs)

| D4A_Case_of : forall Delta Theta b e0 als ys w c c0 rho_ys rs qs
  sigma rho nu Ss,
  length ys = b ->
  env_map rho ys = Some rho_ys ->
  select_case als c = Some (Alt c0 b e0) ->
  ($ E $ Delta $ e0          $ zip_var_list b rho_ys ++ shift b sigma $ qs $ Ss ^\\/ Theta $ w $ nu $ rs) ->
  ($ A $ Delta $ Constr c ys $ rho $ nil $ S_alt als sigma qs :: Ss                ^\\/ Theta $ w $ nu $ rs)

where "($ x $ a $ b $ g $ e $ s ^\\/ c $ d $ h $ f )" :=
  (DCPS4 x a b g e s c d h f).

Hint Constructors DCPS4.

Lemma DCPS4_complete :
forall N Gamma e sigma pn Ss Delta f rho qn,
  ($ E $ Gamma $ e $ sigma $ pn $ Ss ^^\\\ Delta $ f $ rho $ qn ^^ N) ->
  ($ E $ Gamma $ e $ sigma $ pn $ Ss ^\\/  Delta $ f $ rho $ qn).
Proof with eauto.
intro N.
induction N using lt_wf_ind; isa.
inversion H0; subst...
inversion H0; subst...
constructor.
inversion H7; subst...
Qed.

Lemma DCPS4_sound :
forall EA Gamma e sigma pn Ss Delta f rho qn,
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^\\/ Delta $ f $ rho $ qn) ->
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^\\\  Delta $ f $ rho $ qn).
Proof.
intros.
induction H; eauto.
Qed.

(** * Defunctionalized Continuation Passing Style Semantics 5 *)

Reserved Notation "($ x $ a $ b $ g $ e $ s ^\/ c $ d $ h $ f )"
  (at level 70, no associativity).

Inductive DCPS5 : action -> heapB -> expr -> env -> vars -> stack ->
  heapB -> expr -> env -> vars -> Prop :=

| D5_Halt : forall Gamma w sigma ps,
  ($ A $ Gamma $ w $ sigma $ ps $ nil ^\/ Gamma $ w $ sigma $ ps)

| D5_Con : forall Gamma Delta C pi w sigma rho qs Ss,
  ($ A $ Gamma $ Constr C pi $ sigma $ nil $ Ss ^\/ Delta $ w $ rho $ qs) ->
  ($ E $ Gamma $ Constr C pi $ sigma $ nil $ Ss ^\/ Delta $ w $ rho $ qs)

| D5_Accum : forall Gamma Delta x xm sigma_xm qn w rs sigma rho Ss,
  xm <> nil ->
  env_map sigma xm = Some sigma_xm ->
  ($ E $ Gamma $ App x nil $ sigma $ sigma_xm ++ qn $ Ss ^\/ Delta $ w $ rho $ rs) ->
  ($ E $ Gamma $ App x xm  $ sigma $ qn             $ Ss ^\/ Delta $ w $ rho $ rs)

| D5_App1 : forall Gamma tau p x pn m e sigma ,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_n m e, tau) ->
  m > length pn ->
  ($ E $ Gamma $ App x nil $ sigma $ pn $ nil ^\/ Gamma $ App x nil $ sigma $ pn)

| D5_App2_5 : forall Gamma Delta m e x tau p pn w rs sigma rho Ss,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_n m e, tau) ->
  m <= length pn ->
  ($ E $ Gamma $ e         $ zip_var_list m (firstn m pn) ++ shift m tau $ skipn m pn $ Ss ^\/ Delta $ w $ rho $ rs) ->
  ($ E $ Gamma $ App x nil $ sigma                                          $ pn         $ Ss ^\/ Delta $ w $ rho $ rs)

| D5A_App4 : forall Delta rho C xs p Theta w nu qs Ss,
  ($ A $ setB Delta p (Lf_n 0 (Constr C xs), trim rho xs) $ Constr C xs $ rho $ nil $ Ss ^\/ Theta $ w $ nu $ qs) ->
  ($ A $ Delta $ Constr C xs $ rho $ nil $ S_upd (Atom p) nil :: Ss ^\/ Theta $ w $ nu $ qs)

| D5E_App4_5 : forall Gamma Theta x p w e tau sigma nu rs qs Ss,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_u e, tau) ->
  ($ E $ Gamma $ e         $ tau   $ nil $ S_upd (Atom p) rs :: Ss ^\/ Theta $ w $ nu $ qs) ->
  ($ E $ Gamma $ App x nil $ sigma $ rs $ Ss ^\/ Theta $ w $ nu $ qs)

| D5A_App5 : forall Delta Theta x p pn y q qk f n w sigma rho nu mu qs Ss,
  env_find sigma x = Some (Atom p) ->
  env_find rho y = Some (Atom q) ->
  Delta q = Some (Lf_n n f, mu) ->
  length qk < n ->
  ($ E $ setB Delta p (Lf_n (n - length qk) f, trim (zip_var_list (length qk) qk ++ shift (length qk) mu) (fv (Lf_n (n - length qk) f))) $
             App y nil $ rho $ qk ++ pn $ Ss    ^\/ Theta $ w $ nu $ qs) ->
  ($ E $ Delta $ App y nil $ rho $ qk $ S_upd (Atom p) pn :: Ss ^\/ Theta $ w $ nu $ qs)

| D5_Let : forall Gamma Delta sigma rho lfs e w (ats : list nat) rs qs Ss,
  length ats = length lfs ->
  (forall a : nat, In a ats -> Gamma a = None) ->
  ($ E $ allocB Gamma ats
      (map (fun lf => (lf, trim (zip_var_list (length lfs) (map Atom ats) ++ shift (length lfs) sigma) (fv lf))) lfs)
    $ e $ zip_var_list (length lfs) (map Atom ats) ++ shift (length lfs) sigma $ rs $ Ss
    ^\/ Delta $ w $ rho $ qs) ->
  ($ E $ Gamma $ Letrec lfs e $ sigma $ rs $ Ss ^\/ Delta $ w $ rho $ qs)

| D5E_Case_of : forall Gamma Theta e als w rs qs sigma nu Ss,
  ($ E $ Gamma $ e          $ sigma $ nil $ S_alt als sigma qs :: Ss ^\/ Theta $ w $ nu $ rs) ->
  ($ E $ Gamma $ Case e als $ sigma $ qs $ Ss ^\/ Theta $ w $ nu $ rs)

| D5A_Case_of : forall Delta Theta b e0 als ys w c c0 rho_ys rs qs
  sigma rho nu Ss,
  length ys = b ->
  env_map rho ys = Some rho_ys ->
  select_case als c = Some (Alt c0 b e0) ->
  ($ E $ Delta $ e0          $ zip_var_list b rho_ys ++ shift b sigma $ qs $ Ss ^\/ Theta $ w $ nu $ rs) ->
  ($ A $ Delta $ Constr c ys $ rho $ nil $ S_alt als sigma qs :: Ss                ^\/ Theta $ w $ nu $ rs)

where "($ x $ a $ b $ g $ e $ s ^\/ c $ d $ h $ f )" :=
  (DCPS5 x a b g e s c d h f).

Hint Constructors DCPS5.

Lemma DCPS5_complete :
forall EA Gamma e sigma pn Ss Delta f rho qn,
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^\\/ Delta $ f $ rho $ qn) ->
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^\/  Delta $ f $ rho $ qn).
Proof with eauto.
intros.
induction H...
inversion IHDCPS4; subst...
Qed.

Lemma DCPS5_sound :
forall EA Gamma e sigma pn Ss Delta f rho qn,
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^\/  Delta $ f $ rho $ qn) ->
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^\\/ Delta $ f $ rho $ qn).
Proof.
intros.
induction H; eauto.
Qed.

(** * The STG Almost-Machine *)

Inductive instruction := Eval | Enter | ReturnCon.

Reserved Notation "($ x $ a $ b $ g $ e $ s ^^^ c $ d $ h $ f )"
  (at level 70, no associativity).

Inductive ASTG : instruction -> heapB -> expr -> env -> vars -> stack ->
  heapB -> expr -> env -> vars -> Prop :=

| ASTG_Halt : forall Gamma w sigma ps,
  ($ ReturnCon $ Gamma $ w $ sigma $ ps $ nil ^^^ Gamma $ w $ sigma $ ps)

| ASTG_Con : forall Gamma Delta C pi w sigma rho qs Ss,
  ($ ReturnCon $ Gamma $ Constr C pi $ sigma $ nil $ Ss ^^^ Delta $ w $ rho $ qs) ->
  ($ Eval      $ Gamma $ Constr C pi $ sigma $ nil $ Ss ^^^ Delta $ w $ rho $ qs)

| ASTG_Accum : forall Gamma Delta x xm sigma_xm qn w rs sigma rho Ss,
  (* We abandon xm <> nil *)
  env_map sigma xm = Some sigma_xm ->
  ($ Enter $ Gamma $ App x nil $ sigma $ sigma_xm ++ qn $ Ss ^^^ Delta $ w $ rho $ rs) ->
  ($ Eval  $ Gamma $ App x xm  $ sigma $ qn             $ Ss ^^^ Delta $ w $ rho $ rs)

| ASTG_App1 : forall Gamma tau p x pn m e sigma ,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_n m e, tau) ->
  m > length pn ->
  ($ Enter $ Gamma $ App x nil $ sigma $ pn $ nil ^^^ Gamma $ App x nil $ sigma $ pn)

| ASTG_App2_5 : forall Gamma Delta m e x tau p pn w rs sigma rho Ss,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_n m e, tau) ->
  m <= length pn ->
  ($ Eval  $ Gamma $ e         $ zip_var_list m (firstn m pn) ++ shift m tau $ skipn m pn $ Ss ^^^ Delta $ w $ rho $ rs) ->
  ($ Enter $ Gamma $ App x nil $ sigma                                          $ pn         $ Ss ^^^ Delta $ w $ rho $ rs)

| ASTGA_App4 : forall Delta rho C xs p Theta w nu qs Ss,
  ($ ReturnCon $ setB Delta p (Lf_n 0 (Constr C xs), trim rho xs) $ Constr C xs $ rho $ nil $ Ss ^^^ Theta $ w $ nu $ qs) ->
  ($ ReturnCon $ Delta $ Constr C xs $ rho $ nil $ S_upd (Atom p) nil :: Ss ^^^ Theta $ w $ nu $ qs)

| ASTGE_App4_5 : forall Gamma Theta x p w e tau sigma nu rs qs Ss,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_u e, tau) ->
  ($ Eval  $ Gamma $ e         $ tau   $ nil $ S_upd (Atom p) rs :: Ss ^^^ Theta $ w $ nu $ qs) ->
  ($ Enter $ Gamma $ App x nil $ sigma $ rs $ Ss ^^^ Theta $ w $ nu $ qs)

| ASTGA_App5 : forall Delta Theta x p pn y q qk f n w sigma rho nu mu qs Ss,
  env_find sigma x = Some (Atom p) ->
  env_find rho y = Some (Atom q) ->
  Delta q = Some (Lf_n n f, mu) ->
  length qk < n ->
  ($ Enter $ setB Delta p (Lf_n (n - length qk) f, trim (zip_var_list (length qk) qk ++ shift (length qk) mu) (fv (Lf_n (n - length qk) f))) $
             App y nil $ rho $ qk ++ pn $ Ss    ^^^ Theta $ w $ nu $ qs) ->
  ($ Enter $ Delta $ App y nil $ rho $ qk $ S_upd (Atom p) pn :: Ss ^^^ Theta $ w $ nu $ qs)

| ASTG_Let : forall Gamma Delta sigma rho lfs e w (ats : list nat) rs qs Ss,
  length ats = length lfs ->
  (forall a : nat, In a ats -> Gamma a = None) ->
  ($ Eval $ allocB Gamma ats
      (map (fun lf => (lf, trim (zip_var_list (length lfs) (map Atom ats) ++ shift (length lfs) sigma) (fv lf))) lfs)
    $ e $ zip_var_list (length lfs) (map Atom ats) ++ shift (length lfs) sigma $ rs $ Ss
    ^^^ Delta $ w $ rho $ qs) ->
  ($ Eval $ Gamma $ Letrec lfs e $ sigma $ rs $ Ss ^^^ Delta $ w $ rho $ qs)

| ASTGE_Case_of : forall Gamma Theta e als w rs qs sigma nu Ss,
  ($ Eval $ Gamma $ e          $ sigma $ nil $ S_alt als sigma qs :: Ss ^^^ Theta $ w $ nu $ rs) ->
  ($ Eval $ Gamma $ Case e als $ sigma $ qs $ Ss ^^^ Theta $ w $ nu $ rs)

| ASTGA_Case_of : forall Delta Theta b e0 als ys w c c0 rho_ys rs qs
  sigma rho nu Ss,
  length ys = b ->
  env_map rho ys = Some rho_ys ->
  select_case als c = Some (Alt c0 b e0) ->
  ($ Eval $ Delta $ e0          $ zip_var_list b rho_ys ++ shift b sigma $ qs $ Ss ^^^ Theta $ w $ nu $ rs) ->
  ($ ReturnCon $ Delta $ Constr c ys $ rho $ nil $ S_alt als sigma qs :: Ss                ^^^ Theta $ w $ nu $ rs)

where "($ x $ a $ b $ g $ e $ s ^^^ c $ d $ h $ f )" :=
  (ASTG x a b g e s c d h f).

Hint Constructors ASTG.

Definition action_to_instruction (a : action) (e : expr) : instruction :=
match a with
| A => ReturnCon
| E => match e with
  | App _ nil => Enter
  | _         => Eval
  end
end.

Lemma ASTG_complete_aux :
forall EA Gamma e sigma pn Ss Delta f rho qn,
  ($ EA $ Gamma $ e $ sigma $ pn $ Ss ^\/  Delta $ f $ rho $ qn) ->
  ($ action_to_instruction EA e $ Gamma $ e $ sigma $ pn $ Ss ^^^ Delta $ f $ rho $ qn).
Proof with isa.
intros.
induction H...
(* Case *)
destruct xm...
case H...
econstructor; eauto.
(* Case *)
econstructor; eauto.
(* Case *)
destruct e; econstructor; eauto.
destruct v0; eauto.
apply ASTG_Accum with (sigma_xm := nil); eauto.
(* Case *)
destruct e; econstructor 7; eauto.
destruct v0; eauto.
apply ASTG_Accum with (sigma_xm := nil); eauto.
(* Case *)
econstructor 8; eauto.
(* Case *)
destruct e; econstructor; eauto.
destruct v0; eauto.
apply ASTG_Accum with (sigma_xm := nil); eauto.
(* Case *)
destruct e; econstructor; eauto.
destruct v0; eauto.
apply ASTG_Accum with (sigma_xm := nil); eauto.
(* Case *)
destruct e0; econstructor; eauto.
destruct v0; eauto.
apply ASTG_Accum with (sigma_xm := nil); eauto.
Qed.

Lemma ASTG_complete :
forall Gamma e sigma pn Ss Delta f rho qn,
  ($ E    $ Gamma $ e $ sigma $ pn $ Ss ^\/ Delta $ f $ rho $ qn) ->
  ($ Eval $ Gamma $ e $ sigma $ pn $ Ss ^^^ Delta $ f $ rho $ qn).
Proof with isa.
intros.
destruct e.
(* Case *)
destruct v0.
  (* Subcase *)
apply ASTG_Accum with (sigma_xm := nil)...
fold (action_to_instruction E (App v nil)).
apply ASTG_complete_aux...
  (* Subcase *)
fold (action_to_instruction E (App v (v0 :: v1))).
apply ASTG_complete_aux...
(* Case *)
fold (action_to_instruction E (Constr c v)).
apply ASTG_complete_aux...
(* Case *)
fold (action_to_instruction E (Letrec l e)).
apply ASTG_complete_aux...
(* Case *)
fold (action_to_instruction E (Case e l)).
apply ASTG_complete_aux...
Qed.

Definition instruction_to_action (i : instruction) : action :=
match i with
| ReturnCon => A
| _ => E
end.

Lemma ASTG_sound_aux :
forall REE Gamma e sigma pn Ss Delta f rho qn,
  ($ REE $ Gamma $ e $ sigma $ pn $ Ss ^^^ Delta $ f $ rho $ qn) ->
  ($ instruction_to_action REE $ Gamma $ e $ sigma $ pn $ Ss ^\/ Delta $ f $ rho $ qn).
Proof with isa.
intros.
induction H...
(* Case *)
destruct xm.
  (* Subcase *)
simpl in H.
inversion H; subst...
  (* Subcase *)
eapply D5_Accum; eauto.
discriminate.
(* Case *)
eapply D5_App1; eauto.
(* Case *)
eapply D5_App2_5; eauto.
(* Case *)
eapply D5E_App4_5; eauto.
(* Case *)
eapply D5A_App5; eauto.
(* Case *)
econstructor; eauto.
(* Case *)
econstructor; eauto.
Qed.

Lemma ASTG_sound :
forall Gamma e sigma pn Ss Delta f rho qn,
  ($ Eval $ Gamma $ e $ sigma $ pn $ Ss ^^^ Delta $ f $ rho $ qn) ->
  ($ E    $ Gamma $ e $ sigma $ pn $ Ss ^\/ Delta $ f $ rho $ qn).
Proof with isa.
intros.
fold (instruction_to_action Eval).
apply ASTG_sound_aux...
Qed.


(** Properties of substitutions *)

Lemma subst_tau_core:
  forall t0 t1 t v v' ,
    v <> v' ->
    (subst_tau t0 v t) = (subst_tau t1 v' (subst_tau t0 v t)) ->
     t = (subst_tau t1 v' t).
Proof.
  induction t; introv Neq Equ; simpls; inversion* Equ; fequals*.
  case_var*.
  case_var*.
Qed.

Lemma subst_tau_v_core:
  forall t0 t1 t v v',
    v <> v' ->
    (subst_tau_v t0 v t) = (subst_tau_v t1 v' (subst_tau_v t0 v t)) ->
     t = (subst_tau_v t1 v' t).
Proof.
  induction t;
  introv Neq Equ;
  simpls*.
Qed.

Lemma subst_tau_st_core:
  forall s v v',
    v <> v' ->
    forall s0 s1,
      (subst_tau_st s0 v s) = (subst_tau_st s1 v' (subst_tau_st s0 v s)) ->
      s = (subst_tau_st s1 v' s).
Proof.
  apply (St_ind_mutual
           (fun s : St =>
              forall v v',
                v <> v' ->
              forall s0 s1,
                (subst_tau_st s0 v s) = (subst_tau_st s1 v' (subst_tau_st s0 v s)) ->
                s = (subst_tau_st s1 v' s))
           (fun e : E  =>
              forall v v',
                v <> v' ->
              forall e0 e1,
                (subst_tau_e e0 v e) = (subst_tau_e e1 v' (subst_tau_e e0 v e)) ->
                e = (subst_tau_e e1 v' e))
           (fun f : F  =>
              forall v v',
                v <> v' ->
              forall f0 f1,
                (subst_tau_f f0 v f) = (subst_tau_f f1 v' (subst_tau_f f0 v f)) ->
                f = (subst_tau_f f1 v' f)));
  intros;
  simpl;
  fequals;
  try solve[
        try inversion H4 as [I4];
        try inversion H3 as [I3];
        try inversion H2 as [I2];
        try inversion H1 as [I1];
        try solve[applys* H];
        try solve[applys* H0];
        try solve[applys* H1];
        try solve[applys* H2];
        try solve[applys* H3];
        try solve[applys* subst_tau_core]].

  destruct v; simpl; reflexivity.
Qed.

Lemma subst_tau_e_core:
  forall e v v',
    v <> v' ->
    forall e0 e1,
      (subst_tau_e e0 v e) = (subst_tau_e e1 v' (subst_tau_e e0 v e)) ->
      e = (subst_tau_e e1 v' e).
Proof.
  apply (E_ind_mutual
           (fun s : St =>
              forall v v',
                v <> v' ->
              forall s0 s1,
                (subst_tau_st s0 v s) = (subst_tau_st s1 v' (subst_tau_st s0 v s)) ->
                s = (subst_tau_st s1 v' s))
           (fun e : E  =>
              forall v v',
                v <> v' ->
              forall e0 e1,
                (subst_tau_e e0 v e) = (subst_tau_e e1 v' (subst_tau_e e0 v e)) ->
                e = (subst_tau_e e1 v' e))
           (fun f : F  =>
              forall v v',
                v <> v' ->
              forall f0 f1,
                (subst_tau_f f0 v f) = (subst_tau_f f1 v' (subst_tau_f f0 v f)) ->
                f = (subst_tau_f f1 v' f)));
  intros;
  simpl;
  fequals;
  try solve[
        try inversion H4 as [I4];
        try inversion H3 as [I3];
        try inversion H2 as [I2];
        try inversion H1 as [I1];
        try solve[applys* H];
        try solve[applys* H0];
        try solve[applys* H1];
        try solve[applys* H2];
        try solve[applys* H3];
        try solve[applys* subst_tau_core]].
  destruct v; simpl; reflexivity.
Qed.

Lemma subst_tau_f_core:
  forall f v v',
    v <> v' ->
    forall f0 f1,
      (subst_tau_f f0 v f) = (subst_tau_f f1 v' (subst_tau_f f0 v f)) ->
      f = (subst_tau_f f1 v' f).
Proof.
  apply (F_ind_mutual
           (fun s : St =>
              forall v v',
                v <> v' ->
              forall s0 s1,
                (subst_tau_st s0 v s) = (subst_tau_st s1 v' (subst_tau_st s0 v s)) ->
                s = (subst_tau_st s1 v' s))
           (fun e : E  =>
              forall v v',
                v <> v' ->
              forall e0 e1,
                (subst_tau_e e0 v e) = (subst_tau_e e1 v' (subst_tau_e e0 v e)) ->
                e = (subst_tau_e e1 v' e))
           (fun f : F  =>
              forall v v',
                v <> v' ->
              forall f0 f1,
                (subst_tau_f f0 v f) = (subst_tau_f f1 v' (subst_tau_f f0 v f)) ->
                f = (subst_tau_f f1 v' f)));
  intros;
  simpl;
  fequals;
  try solve[
        try inversion H4 as [I4];
        try inversion H3 as [I3];
        try inversion H2 as [I2];
        try inversion H1 as [I1];
        try solve[applys* H];
        try solve[applys* H0];
        try solve[applys* H1];
        try solve[applys* H2];
        try solve[applys* H3];
        try solve[applys* subst_tau_core]].
  destruct v; simpl; reflexivity.
Qed.

Lemma open_rec_term_core_term:
  forall v v',
    v <> v' ->
    forall t0 t1 t,
      (subst_tau_term t0 v t) = (subst_tau_term t1 v' (subst_tau_term t0 v t)) ->
      t = (subst_tau_term t1 v' t).
Proof.
  intros; destruct t; inversion H0; simpl; fequals*.
  apply subst_tau_st_core with (v:=v) (s0:=t0); try assumption.
  apply subst_tau_e_core with  (v:=v) (e0:=t0); try assumption.
  apply subst_tau_f_core with  (v:=v) (f0:=t0); try assumption.
Qed.


(******************************************************************************)
(** * Definition of the JSMM memory model *)
(******************************************************************************)
From hahn Require Import Hahn.
From imm Require Import Events.
Require Import Execution_m.
(*Require Import Execution_eco.*)

Set Implicit Arguments.
Remove Hints plus_n_O.

Section JSMM_m.

Variable G : execution_m.

Notation "'E'" := G.(acts_set).
Notation "'acts'" := G.(acts).
Notation "'lab'" := G.(lab).
Notation "'range_value'" := G.(range_value).
Notation "'rf_on'" := G.(rf_on).
Notation "'overlap_on'" := G.(overlap_on).
Notation "'no_overlap'" := G.(no_overlap).
Notation "'rfb'" := G.(rfb).
Notation "'cob'" := G.(cob).
Notation "'sb'" := G.(sb).
Notation "'rf'" := G.(rf).
Notation "'co'" := G.(co).
Notation "'rmw'" := G.(rmw).
(* Notation "'fr'" := G.(fr). *)
(* Notation "'eco'" := G.(eco). *)
Notation "'same_range'" := G.(same_range).
Notation "'same_loc'" := (same_loc lab).

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).

Notation "'Pln'" := (fun a => is_true (is_only_pln lab a)).
Notation "'Rlx'" := (fun a => is_true (is_rlx lab a)).
Notation "'Rel'" := (fun a => is_true (is_rel lab a)).
Notation "'Acq'" := (fun a => is_true (is_acq lab a)).
Notation "'Acqrel'" := (fun a => is_true (is_acqrel lab a)).
Notation "'Acq/Rel'" := (fun a => is_true (is_ra lab a)).
Notation "'Sc'" := (fun a => is_true (is_sc lab a)).

Definition sw := ⦗ Sc ⦘ ⨾ (rf ∩ same_range) ⨾ ⦗ Sc ⦘.
Definition hb := (sb ∪ sw)⁺.

(******************************************************************************)
(** ** Consistency  *)
(******************************************************************************)

Definition jsmm_m_consistent (tot : relation actid) (tearfree : actid -> Prop) :=
  ⟪ Ctot   : strict_total_order E tot ⟫ /\
  ⟪ Chbtot : hb ⊆ tot ⟫ /\
  ⟪ Chbrf : irreflexive (hb ⨾ rf) ⟫ /\
  ⟪ Chbrfhb : forall n,
      irreflexive (hb ⨾ (rf_on n)⁻¹ ⨾ (hb ∩ overlap_on n) ⨾ ⦗ W ⦘) ⟫ /\
  ⟪ Cirr1 :
      irreflexive (⦗W∩₁Sc⦘ ⨾ tot ⨾ sw⁻¹ ⨾ (tot ∩ same_range)) ⟫ /\
  ⟪ Cirr2 :
      irreflexive (⦗W∩₁Sc⦘ ⨾ hb ⨾
                   (hb ∩ rf)⁻¹ ⨾ ⦗W∩₁Sc⦘ ⨾ (tot ∩ same_range)) ⟫ /\
  ⟪ Cirr3 :
      irreflexive (⦗W∩₁Sc⦘ ⨾ (tot ∩ same_range) ⨾ ⦗R∩₁Sc⦘ ⨾
                   (hb ∩ rf)⁻¹ ⨾ hb) ⟫ /\
  ⟪ Ctf :
      functional (⦗tearfree⦘ ⨾ (rf⁻¹ ∩ same_range) ⨾ ⦗tearfree⦘) ⟫.

Lemma sw_E x y :
  Wf_m G -> sw x y -> (E x /\ E y).
Proof.
  intros WF H.
  unfold sw in H.
  destruct H as [x_ [[H11 H12] [y_ [[H21 H22] [H31 H32]]]]].
  rewrite <- H11 in H21,H22.
  rewrite H31 in H21, H22, H32.
  pose (wf_rfE WF) as Hp.
  apply Hp in H21.
  destruct H21 as [x__ [H21_ [y__ [H221_ H222_]]]].
  destruct H21_.
  destruct H222_.
  rewrite H1 in H2.
  split; assumption.
Qed.

Lemma hb_E x y :
  Wf_m G -> hb x y -> (E x /\ E y).
Proof.
  intros WF H.
  unfold hb in H.
  split.
  - eapply ct_doma.
    + assert (doma (sb ∪ sw) E) as Ha. {
        unfold doma. intros a b Ha. destruct Ha as [Ha | Ha].
        - apply sb_E in Ha. apply Ha.
        - apply sw_E in Ha. apply Ha. apply WF.
      }
      apply Ha.
    + apply H.
  - eapply ct_domb.
    + assert (domb (sb ∪ sw) E) as Ha. {
        unfold domb. intros a b Ha. destruct Ha as [Ha | Ha].
        - apply sb_E in Ha. apply Ha.
        - apply sw_E in Ha. apply Ha. apply WF.
      }
      apply Ha.
    + apply H.
Qed.

(******************************************************************************)
(** ** SC-DRF  *)
(******************************************************************************)

Definition data_race_free :=
  forall x y,
    hb x y \/ hb y x \/
    (~(W x) /\ ~(W y)) \/
    no_overlap x y \/
   (same_range x y /\ Sc x /\ Sc y).

Definition seqcst tot :=
  irreflexive (rf ⨾ tot) /\
  (forall n,
     irreflexive (⦗W⦘ ⨾ (tot ∩ overlap_on n) ⨾ (rf_on n)⁻¹ ⨾ tot)).

Lemma hb_tot_inconsist tot x y :
  strict_total_order E tot ->
  hb ⊆ tot->
  tot x y ->
  hb y x ->
  False.
Proof.
  intros H1 H2 H3 H4.
  destruct H1 as [[H111 H112] H12].
  apply H111 with x.
  pose (H2 _ _ H4) as H.
  apply (H112 x y x H3 H).
Qed.

Lemma spo_hb tot :
  strict_total_order E tot ->
  hb ⊆ tot->
  strict_partial_order hb.
Proof.
  intros H1 H2.
  split.
  - unfold strict_total_order in H1.
    apply irreflexive_inclusion with tot.
    + assumption.
    + apply H1.
  - unfold hb. intuition.
Qed.

Lemma rf_sw x y :
  rf x y ->
  same_range x y ->
  Sc x ->
  Sc y ->
  sw x y.
Proof.
  unfold sw.
  exists x.
  split. { intuition. }
  unfold inter_rel.
  exists y.
  intuition.
Qed.

Lemma sw_hb x y :
  sw x y ->
  hb x y.
Proof.
  unfold hb.
  intuition.
Qed.

Lemma sw_sc :
  Wf_m G ->
  sw = ⦗W∩₁Sc⦘ ⨾ sw ⨾ ⦗R∩₁Sc⦘.
Proof.
  intros Hwf.
  apply functional_extensionality.
  intros x.
  apply functional_extensionality.
  intros y.
  apply PropExtensionality.propositional_extensionality.
  split.
  - intros H.
    unfold sw.
    unfold sw in H.
    destruct H as [x_ [H1 [y_ [H21 H22]]]].
    destruct H1 as [H11 H12].
    rewrite <- H11 in H21.
    destruct H22 as [H221 H222].
    rewrite H221 in H21, H222.
    assert (W x /\ R y) as Wx_Ry. { apply rf_w_r. apply Hwf. apply H21. }
    econstructor.
    split. { econstructor. reflexivity. econstructor. apply Wx_Ry. apply H12. }
    econstructor.
    split. {
      econstructor.
      split. { econstructor. reflexivity. assumption. }
      econstructor.
      split. { apply H21. }
      econstructor. reflexivity. assumption.
    }
    econstructor. { reflexivity. }
    econstructor; easy.
  - intros H.
    unfold sw.
    unfold sw in H.
    destruct H as [x_ [H1 [y_ [[x__ [H21 [y__ [H221 H222]]]] H3]]]].
    destruct H1 as [H1a H1b].
    rewrite <- H1a in H21.
    destruct H21 as [H21a H21b].
    rewrite <- H21a in H221.
    destruct H3 as [H3a H3b].
    rewrite H3a in H3b, H222.
    destruct H222 as [H222a H222b].
    rewrite H222a in H222b, H221.
    econstructor.
    split. { econstructor. reflexivity. assumption. }
    econstructor.
    split. { apply H221. }
    econstructor. { reflexivity. }
    assumption.
Qed.

Lemma sw_sc_inv :
  Wf_m G ->
  sw⁻¹ = ⦗R∩₁Sc⦘ ⨾ sw⁻¹ ⨾ ⦗W∩₁Sc⦘.
Proof.
  intros Hwf.
  apply functional_extensionality.
  intros x.
  apply functional_extensionality.
  intros y.
  apply PropExtensionality.propositional_extensionality.
  split.
  - intros H.
    rewrite sw_sc in H.
    apply transp_seq in H.
    rewrite (rel_extensionality ((transp_seq sw (⦗R ∩₁ Sc⦘)))) in H.
    apply seqA in H.
    rewrite (rel_extensionality (transp_eqv_rel (R ∩₁ Sc))) in H.
    rewrite (rel_extensionality (transp_eqv_rel (W ∩₁ Sc))) in H.
    assumption.
    apply Hwf.
  - intros H.
    rewrite sw_sc.
    apply transp_seq.
    rewrite (rel_extensionality ((transp_seq sw (⦗R ∩₁ Sc⦘)))).
    apply seqA in H.
    rewrite (rel_extensionality (transp_eqv_rel (R ∩₁ Sc))).
    rewrite (rel_extensionality (transp_eqv_rel (W ∩₁ Sc))).
    assumption.
    apply Hwf.
Qed.

Lemma sw_rf_Cirr1_left x y :
  Wf_m G ->
  (sw⁻¹) x y -> (⦗R∩₁Sc⦘ ⨾ (rf ∩ same_range)⁻¹ ⨾ ⦗W∩₁Sc⦘) x y.
Proof.
  intros Hwf H.
  rewrite sw_sc_inv in H.
  unfold sw in H.
  destruct H as [x_ [H1 H2]].
  destruct H1 as [x_is H11].
  rewrite <- x_is in H2.
  econstructor.
  split. { econstructor. reflexivity. assumption. }
  destruct H2 as [y_ [[y__ [[H21211 H21212] [x__ [H212221 [H2122221 H2122222]]]]] [H221 H222]]].
  econstructor.
  split. { econstructor; rewrite <- H2122221; apply H212221. }
  econstructor. { rewrite <- H21211. rewrite H221. reflexivity. }
  rewrite <- H21211. apply H222.
  apply Hwf.
Qed.

Lemma sw_rf_Cirr1_right x y :
  Wf_m G ->
  (⦗R∩₁Sc⦘ ⨾ (rf ∩ same_range)⁻¹ ⨾ ⦗W∩₁Sc⦘) x y -> (sw⁻¹) x y.
Proof.
  intros Hwf H.
  rewrite sw_sc_inv.
  unfold sw.
  destruct H as [x_ [H1 H2]].
  destruct H1 as [x_is H11].
  rewrite <- x_is in H2.
  econstructor.
  split. { econstructor. reflexivity. assumption. }
  destruct H2 as [y_ [H21 [H221 H222]]].
  rewrite H221 in H222, H21.
  econstructor.
  split. {
    econstructor.
    split. { econstructor. apply H221. rewrite H221. apply H222. }
    econstructor.
    split. { apply H21. }
    econstructor. reflexivity. apply H11.
  }
  rewrite H221.
  econstructor. reflexivity. apply H222.
  apply Hwf.
Qed.

Lemma sw_rf_Cirr1 :
  Wf_m G ->
  (sw⁻¹) = (⦗R∩₁Sc⦘ ⨾ (rf ∩ same_range)⁻¹ ⨾ ⦗W∩₁Sc⦘).
Proof.
  intros Hwf.
  apply functional_extensionality.
  intros x.
  apply functional_extensionality.
  intros y.
  apply PropExtensionality.propositional_extensionality.
  split.
  apply sw_rf_Cirr1_left.
  apply Hwf.
  apply sw_rf_Cirr1_right.
  apply Hwf.
Qed.

Lemma Cirr1_alt tot :
  Wf_m G ->
  irreflexive (⦗W∩₁Sc⦘ ⨾ tot ⨾ sw⁻¹ ⨾ (tot ∩ same_range)) = irreflexive (⦗W∩₁Sc⦘ ⨾ tot ⨾ ⦗R∩₁Sc⦘ ⨾ (rf ∩ same_range)⁻¹ ⨾ ⦗W∩₁Sc⦘ ⨾ (tot ∩ same_range)).
Proof.
  intros Hwf.
  rewrite sw_rf_Cirr1.
  repeat rewrite (rel_extensionality (seqA _ _ _)).
  reflexivity.
  apply Hwf.
Qed.

Lemma drf_tot__hb_sc x y tot :
  data_race_free ->
  strict_total_order E tot ->
  hb ⊆ tot ->
  tot x y ->
  is_overlap G x y ->
  W x \/ W y ->
  hb x y \/ (same_range x y /\ Sc x /\ Sc y).
Proof.
  intros DRF tot_wf hb_in_tot H1 H2 H3.
  unfold data_race_free in DRF.
  destruct DRF with x y as [hbXY | [hbYX | [[nWX nWY] | [novrlpXY | [slXY [scX scY]]]]]]; auto.
  - exfalso.
    assert (tot y x). { apply hb_in_tot. apply hbYX. }
    unfold strict_total_order in tot_wf.
    destruct tot_wf as [[tot_wf11 tot_wf12] tot_wf2].
    apply tot_wf11 with x.
    unfold transitive in tot_wf12.
    apply (tot_wf12 x y x H1 H).
  - exfalso.
    destruct H3; contradiction.
  - exfalso.
    destruct H2.
    apply novrlpXY.
Qed.

End JSMM_m.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal21.

Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj2synthconj5 : forall  (lv0 : lst) (lv1 : lst), (@eq lst (append lv0 lv1) (append (append lv0 lv1) lv0)).
Admitted.
QuickChick conj2synthconj5.