(** 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.


From Tealeaves Require Export
  Theory.Algebraic.Decorated.Monad.ToKleisli
  Theory.Algebraic.Decorated.Functor.KleisliTheory.

Import Algebraic.Monad.Notations.
Import Comonad.Notations.
Import Monoid.Notations.
Import Product.Notations.

#[local] Generalizable Variables W.

(** ** Properties *)
(******************************************************************************)

(** ** Kleisli composition *)
(******************************************************************************)
Section decorated_monad_kleisli_operations.

  Context
    (T : Type -> Type)
    `{DecoratedMonad W T}.

  Import
    Algebraic.Decorated.Monad.ToKleisli.Operation
    Algebraic.Monad.ToKleisli.Operation
    Algebraic.Monad.ToKleisli.Instance.

  Definition kcompose_dm {A B C} :
    (W * B -> T C) ->
    (W * A -> T B) ->
    (W * A -> T C) :=
    fun g f =>
      bind T g ∘ shift T ∘ cobind (prod W) (dec T ∘ f).

  Definition prepromote {A B} (w : W) (f : W * A -> T B) :=
    fun '(w', a) => f (w ● w', a).

  Definition kcomposed_alt {A B C} :
    (W * B -> T C) ->
    (W * A -> T B) ->
    (W * A -> T C) := fun g f '(w, a) => bindd T (prepromote w g) (f (w, a)).

  Theorem kcomposed_equiv {A B C}
          (g : W * B -> T C) (f : W * A -> T B) :
    kcomposed_alt g f = kcompose_dm g f.
  Proof.
    unfold kcomposed_alt, kcompose_dm. ext [w a].
    unfold compose; cbn.
    unfold_ops @Bindd_alg @Bind_alg.
    unfold id, compose; cbn.
    unfold shift; cbn.
    fequal. unfold compose; cbn.
    compose near (f (w, a)) on left.
    compose near (dec T (f (w, a))) on right.
    rewrite (fun_fmap_fmap T).
    compose near (dec T (f (w, a))) on right.
    rewrite (fun_fmap_fmap T).
    compose near (f (w, a)) on right. fequal.
    fequal. ext [w' b]. easy.
  Qed.

End decorated_monad_kleisli_operations.

#[local] Notation "g ⋆dm f" := (kcompose_dm _ g f) (at level 40) : tealeaves_scope.

(** *** Kleisli category laws *)
(******************************************************************************)
Section decoratedmonad_kleisli_category.

  Context
    (T : Type -> Type)
    `{DecoratedMonad W T}.

  Existing Instance dmon_monoid.

  Import Algebraic.Monad.ToKleisli.Operation.
  Import Algebraic.Monad.ToKleisli.Instance.

  (** Composition when <<f>> has no substitution *)
  Theorem dm_kleisli_star1 {A B C} : forall (g : W * B -> T C) (f : W * A -> B),
      g ⋆dm (ret T ∘ f) = g co⋆ f.
  Proof.
    intros. unfold kcompose_dm, cokcompose.
    ext [w a]. unfold compose. cbn.
    unfold compose, id; cbn.
    compose near (f (w, a)) on left.
    rewrite (dmon_ret W T).
    unfold compose; cbn.
    rewrite shift_return.
    assert (Monoid W).
    { eapply @dmon_monoid; eauto. }
    rewrite (monoid_id_l).
    compose near (w, f (w, a)) on left.
    now rewrite (kmon_bind0 T).
  Qed.

  (** Composition when <<f>> is context-agnostic *)
  Theorem dm_kleisli_star2 {A B C} : forall (g : W * B -> T C) (f : A -> T B),
      g ⋆dm (f ∘ extract (W ×)) =
      bind T g ∘ shift T ∘ fmap (W ×) (dec T ∘ f).
  Proof.
    intros. unfold kcompose_dm, cokcompose.
    reassociate <- on left.
    now rewrite <- (fmap_to_cobind (prod W)).
  Qed.

  (** Composition when <<g>> has no substitution *)
  Theorem dm_kleisli_star3 {A B C} : forall (g : W * B -> C) (f : W * A -> T B),
      (η T ∘ g) ⋆dm f = fmap T g ∘ shift T ∘ cobind (prod W) (dec T ∘ f).
  Proof.
    intros. unfold kcompose_dm, kcompose.
    now rewrite (fmap_to_bind T).
  Qed.

  (** Composition when <<g>> is context-agnostic *)
  Theorem dm_kleisli_star4 {A B C} : forall (g : B -> T C) (f : W * A -> T B),
      (g ∘ extract (prod W)) ⋆dm f = bind T g ∘ f.
  Proof.
    intros. unfold kcompose_dm, kcompose.
    rewrite <- (bind_fmap T).
    change (?f ∘ fmap T (extract (prod W)) ∘ shift T ∘ ?g) with
        (f ∘ (fmap T (extract (prod W)) ∘ shift T) ∘ g).
    rewrite (shift_extract T).
    repeat reassociate ->. rewrite (extract_cobind (prod W)).
    fequal. reassociate <- on left.
    now rewrite (dfun_dec_extract W T).
  Qed.

  Theorem dm_kleisli_id_r {B C} : forall (g : W * B -> T C),
      g ⋆dm (ret T ∘ extract (prod W)) = g.
  Proof.
    intros. rewrite dm_kleisli_star1.
    now rewrite (Comonad.cokleisli_id_r).
  Qed.

  Theorem dm_kleisli_id_l {A B} : forall (f : W * A -> T B),
      (ret T ∘ extract (prod W)) ⋆dm f = f.
  Proof.
    intros. rewrite dm_kleisli_star4.
    now rewrite (kmon_bind1 T).
  Qed.

  Theorem dm_kleisli_assoc {A B C D} : forall (h : W * C -> T D) (g : W * B -> T C) (f : W * A -> T B),
      h ⋆dm (g ⋆dm f) = (h ⋆dm g) ⋆dm f.
  Proof.
    intros. unfold kcompose_dm at 3.
  Abort.

End decoratedmonad_kleisli_category.

(** *** Specification for sub-operations *)
(******************************************************************************)
Section decoratedmonad_suboperations.

  #[local] Generalizable Variables A B C.

  Context
    (T : Type -> Type)
    `{DecoratedMonad W T}.

  Import Algebraic.Monad.ToKleisli.Operation.
  Import Algebraic.Monad.ToKleisli.Instance.
  Import Algebraic.Decorated.Monad.ToKleisli.Operation.
  Import Algebraic.Decorated.Functor.ToKleisli.Operation.

  Lemma fmapd_to_bindd : forall `(f : W * A -> B),
      fmapd T f = bindd T (ret T ∘ f).
  Proof.
    introv. unfold_ops @Fmapd_alg @Bindd_alg.
    change_right (bind T (ret T ∘ f) ∘ dec T).
    rewrite <- (bind_fmap T).
    now rewrite (kmon_bind1 T).
  Qed.

  Lemma bind_to_bindd : forall `(f : A -> T B),
      bind T f = bindd T (f ∘ extract (prod W)).
  Proof.
    introv. unfold_ops @Bindd_alg.
    change_right (bind T (f ∘ extract (prod W)) ∘ dec T).
    rewrite <- (bind_fmap T).
    reassociate -> on right.
    now rewrite (dfun_dec_extract W T).
  Qed.

  Lemma fmap_to_bindd : forall `(f : A -> B),
      fmap T f = bindd T (ret T ∘ f ∘ extract (prod W)).
  Proof.
    introv.
    Search fmapd fmap.
    now rewrite (fmap_to_fmapd T), fmapd_to_bindd.
  Qed.

End decoratedmonad_suboperations.

(** ** Interaction between [dec] and [bindd], [bind] *)
(******************************************************************************)
Section dec_bindd.

  #[local] Set Keyed Unification.

  Context
    (T : Type -> Type)
    `{DecoratedMonad W T}.

  Import Operation.
  Import Instance.
  Import Algebraic.Monad.ToKleisli.Operation.
  Import Algebraic.Monad.ToKleisli.Instance.

  Theorem dec_bindd : forall A B (f : W * A -> T B),
      dec T ∘ bindd T f =
      bindd T (shift T ∘ cobind (prod W) (dec T ∘ f)).
  Proof.
    intros A ? f. unfold_ops @Bindd_alg.
    do 2 reassociate <- on left.
    rewrite (dmon_join W T).
    reassociate -> near (fmap T f).
    rewrite (fun_fmap_fmap T).
    reassociate -> near (fmap T (dec T ∘ f)).
    rewrite <- (natural (G := T ∘ prod W) (F := T) (ϕ := @dec W T _)).
    reassociate <- on left.
    unfold_ops @Fmap_compose.
    change_left (join T ∘ (fmap T (shift T) ∘ fmap T (fmap (prod W) (dec T ∘ f))) ∘ dec T ∘ dec T).
    rewrite (fun_fmap_fmap T).
    reassociate -> on left.
    rewrite (dfun_dec_dec W T).
    reassociate <- on left.
    reassociate -> near (fmap T (cojoin (A:=A) (prod W))).
    now rewrite (fun_fmap_fmap T).
  Qed.

  Corollary dec_bind : forall A B (f : W * A -> T B),
      dec T ∘ bind T f =
      bindd T (shift T ∘ fmap (prod W) (dec T ∘ f)).
  Proof.
    introv. rewrite (bind_to_bindd T).
    rewrite dec_bindd.
    fequal. now ext [w a].
  Qed.

End dec_bindd.

(** ** Composition laws for sub-operations *)
(******************************************************************************)
Section decoratedmonad_suboperation_composition.

  Context
    (T : Type -> Type)
    `{Algebraic.Decorated.Monad.DecoratedMonad W T}.

  Import Instance.
  Import Operation.
  Import Algebraic.Monad.ToKleisli.Operation.
  Import Algebraic.Monad.ToKleisli.Instance.
  Import Algebraic.Decorated.Monad.ToKleisli.Operation.
  Import Algebraic.Decorated.Functor.ToKleisli.Operation.

  Lemma kcompose_equiv2  {A B C} : forall (g : W * B -> T C) (f : W * A -> T B),
      kcompose_dm T g f = Monad.kcompose_dm g f.
  Proof.
    intros. unfold Monad.kcompose_dm.
    rewrite <- (kcomposed_equiv T).
    unfold kcomposed_alt.
    ext [w a]. fequal. now ext [w' b].
  Qed.

  Lemma bindd_fmapd {A B C} : forall (g : W * B -> T C) (f : W * A -> B),
      bindd T g ∘ fmapd T f = bindd T (g co⋆ f).
  Proof.
    introv. rewrite (fmapd_to_bindd T).
    rewrite (kmond_bindd2 T).
    rewrite <- kcompose_equiv2.
    now rewrite (dm_kleisli_star1 T).
  Qed.

  Corollary bind_bindd {A B C} : forall (g : B -> T C) (f : W * A -> T B),
      bind T g ∘ bindd T f = bindd T (bind T g ∘ f).
  Proof.
    intros. rewrite (bind_to_bindd T).
    rewrite (bindd_bindd T).
    rewrite <- kcompose_equiv2.
    rewrite (dm_kleisli_star4 T).
    fequal. fequal. unfold_ops @Bind_alg @Bindd_alg.
    rewrite <- (fun_fmap_fmap T).
    do 2 reassociate -> on right.
    now rewrite (dfun_dec_extract W T).
  Qed.

  Corollary fmapd_bindd {A B C} : forall (g : W * B -> C) (f : W * A -> T B),
      fmapd T g ∘ bindd T f = bindd T (fmap T g ∘ shift T ∘ cobind (prod W) (dec T ∘ f)).
  Proof.
    intros. rewrite (fmapd_to_bindd T).
    rewrite (bindd_bindd T).
    rewrite <- kcompose_equiv2.
    fequal. unfold kcompose_dm.
    now rewrite (fmap_to_bind T).
  Qed.

  Corollary bindd_bind {A B C} : forall (g : W * B -> T C) (f : A -> T B),
      bindd T g ∘ bind T f = bindd T (bind T g ∘ shift T ∘ fmap (prod W) (dec T ∘ f)).
  Proof.
    introv. rewrite (bind_to_bindd T).
    rewrite (bindd_bindd T).
    rewrite <- kcompose_equiv2.
    unfold kcompose_dm.
    reassociate <-. now rewrite <- (fmap_to_cobind (prod W)).
  Qed.

  Lemma bindd_fmap {A B C} : forall (g : W * B -> T C) (f : A -> B),
      bindd T g ∘ fmap T f = bindd T (g ∘ fmap (prod W) f).
  Proof.
    intros. rewrite (fmap_to_bindd T).
    rewrite (bindd_bindd T).
    reassociate -> on left.
    rewrite <- kcompose_equiv2.
    rewrite (dm_kleisli_star1 T).
    unfold cokcompose. now rewrite (fmap_to_cobind (prod W)).
  Qed.

  Corollary fmap_bindd {A B C} : forall (g : B -> C) (f : W * A -> T B),
      fmap T g ∘ bindd T f = bindd T (fmap T g ∘ f).
  Proof.
    intros. rewrite (fmap_to_bindd T).
    rewrite (bindd_bindd T).
    rewrite <- kcompose_equiv2.
    rewrite <- (fmap_to_bindd T).
    rewrite (dm_kleisli_star4 T).
    now rewrite <- (fmap_to_bind T).
  Qed.

End decoratedmonad_suboperation_composition.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C P Q Q0 Y B0 : Universe, ((wd_ P Q /\ (wd_ B Q /\ (wd_ A B /\ (wd_ P B /\ (wd_ C B /\ (wd_ P Q0 /\ (wd_ C P /\ (wd_ B B0 /\ (wd_ A B0 /\ (wd_ B Q0 /\ (wd_ A Q0 /\ (wd_ A C /\ (wd_ P Y /\ (wd_ B B0 /\ (wd_ P Y /\ (col_ B A P /\ (col_ Q P Q0 /\ (col_ B C Y /\ (col_ P Q0 Y /\ (col_ B P Y /\ col_ B0 P Y)))))))))))))))))))) -> col_ B P Q)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Hendra : DEX big step semantics, looking into BigStepLoad.v as reference *)

  Import DEX_Dom DEX_Prog.

  Open Scope type_scope.
  Definition DEX_InitCallState :=  DEX_Method * DEX_Registers.t.
  Definition DEX_IntraNormalState := DEX_PC * (DEX_Heap.t * DEX_Registers.t).
  Definition DEX_ReturnState := DEX_Heap.t * DEX_ReturnVal.

  Inductive DEX_NormalStep (p:DEX_Program) :
    DEX_Method -> DEX_IntraNormalState -> DEX_IntraNormalState  -> Prop :=
  | nop : forall h m pc pc' regs,

    instructionAt m pc = Some DEX_Nop ->
    next m pc = Some pc' ->

    DEX_NormalStep p m (pc, (h, regs)) (pc', (h, regs))

  | const : forall h m pc pc' regs regs' k rt v,

    instructionAt m pc = Some (DEX_Const k rt v) ->
    In rt (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    (-2^31 <= v < 2^31)%Z ->
    DEX_METHOD.valid_reg m rt ->
    regs' = DEX_Registers.update regs rt (Num (I (Int.const v))) ->

    DEX_NormalStep p m (pc, (h, regs)) (pc', (h, regs'))

  | move_step_ok : forall h m pc pc' regs regs' k rt rs v,

    instructionAt m pc = Some (DEX_Move k rt rs) ->
    In rt (DEX_Registers.dom regs) ->
    In rs (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    Some v = DEX_Registers.get regs rs ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m rs ->
    regs' = DEX_Registers.update regs rt v ->

    DEX_NormalStep p m (pc, (h, regs)) (pc', (h, regs'))

  | goto_step_ok : forall h m pc regs o,

    instructionAt m pc = Some (DEX_Goto o) ->

    DEX_NormalStep p m (pc, (h, regs)) ((DEX_OFFSET.jump pc o), (h, regs))

  | packedswitch_step_ok1 : forall h m pc l v r firstKey size list_offset n o,

    instructionAt m pc = Some (DEX_PackedSwitch r firstKey size list_offset) ->
    Some (Num (I v)) = DEX_Registers.get l r ->
    (firstKey <= Int.toZ v < firstKey + (Z_of_nat size))%Z ->
    length list_offset = size ->
    Z_of_nat n = ((Int.toZ v) - firstKey)%Z ->
    nth_error list_offset n = Some o ->
    DEX_METHOD.valid_reg m r ->

    DEX_NormalStep p m (pc, (h, l)) ((DEX_OFFSET.jump pc o), (h, l))

  | packedswitch_step_ok2 : forall h m pc pc' l v r firstKey size list_offset,

    instructionAt m pc = Some (DEX_PackedSwitch r firstKey size list_offset) ->
    Some (Num (I v)) = DEX_Registers.get l r ->
    length list_offset = size ->
    (Int.toZ v < firstKey \/ firstKey + (Z_of_nat size) <= Int.toZ v)%Z ->
    next m pc = Some pc' ->
    DEX_METHOD.valid_reg m r ->

    DEX_NormalStep p m (pc, (h, l)) (pc', (h, l))

  | sparseswitch_step_ok1 : forall h m pc l v v' o r size listkey,

    instructionAt m pc = Some (DEX_SparseSwitch r size listkey) ->
    length listkey = size ->
    Some (Num (I v)) = DEX_Registers.get l r ->
    List.In (pair v' o) listkey ->
    v' = Int.toZ v ->
    DEX_METHOD.valid_reg m r ->

    DEX_NormalStep p m (pc, (h, l)) ((DEX_OFFSET.jump pc o), (h, l))

  | sparseswitch_step_ok2 : forall h m pc pc' l v r size listkey,

    instructionAt m pc = Some (DEX_SparseSwitch r size listkey) ->
    length listkey = size ->
    Some (Num (I v)) = DEX_Registers.get l r ->
    (forall v' o, List.In (pair v' o) listkey ->  v' <> Int.toZ v) ->
    next m pc = Some pc' ->
    DEX_METHOD.valid_reg m r ->

    DEX_NormalStep p m (pc, (h, l)) (pc', (h, l))

  | ifcmp_step_jump : forall h m pc regs va vb cmp ra rb o,

    instructionAt m pc = Some (DEX_Ifcmp cmp ra rb o) ->
    In ra (DEX_Registers.dom regs) ->
    In rb (DEX_Registers.dom regs) ->
    Some (Num (I va)) = DEX_Registers.get regs ra ->
    Some (Num (I vb)) = DEX_Registers.get regs rb ->
    SemCompInt cmp (Int.toZ va) (Int.toZ vb) ->
    DEX_METHOD.valid_reg m ra ->
    DEX_METHOD.valid_reg m rb ->

    DEX_NormalStep p m (pc, (h, regs)) ((DEX_OFFSET.jump pc o), (h, regs))

  | ifcmp_step_continue : forall h m pc pc' regs va vb cmp ra rb o,

    instructionAt m pc = Some (DEX_Ifcmp cmp ra rb o) ->
    In ra (DEX_Registers.dom regs) ->
    In rb (DEX_Registers.dom regs) ->
    Some (Num (I va)) = DEX_Registers.get regs ra ->
    Some (Num (I vb)) = DEX_Registers.get regs rb ->
    ~SemCompInt cmp (Int.toZ va) (Int.toZ vb) ->
    next m pc = Some pc' ->
    DEX_METHOD.valid_reg m ra ->
    DEX_METHOD.valid_reg m rb ->

    DEX_NormalStep p m (pc, (h, regs)) (pc', (h, regs))

  | ifz_step_jump : forall h m pc regs v cmp r o,

    instructionAt m pc = Some (DEX_Ifz cmp r o) ->
    In r (DEX_Registers.dom regs) ->
    Some (Num (I v)) = DEX_Registers.get regs r ->
    SemCompInt cmp (Int.toZ v) (0) ->
    DEX_METHOD.valid_reg m r ->

    DEX_NormalStep p m (pc, (h, regs)) ((DEX_OFFSET.jump pc o), (h, regs))

  | ifz_step_continue : forall h m pc pc' regs v cmp r o,

    instructionAt m pc = Some (DEX_Ifz cmp r o) ->
    In r (DEX_Registers.dom regs) ->
    Some (Num (I v)) = DEX_Registers.get regs r ->
    ~SemCompInt cmp (Int.toZ v) (0) ->
    next m pc = Some pc' ->

    DEX_NormalStep p m (pc, (h, regs)) (pc', (h, regs))

  (** <addlink>ineg</addlink>: Negate [int] *)
  | ineg_step : forall h m pc regs regs' pc' rt rs v,

    instructionAt m pc = Some (DEX_Ineg rt rs) ->
    In rt (DEX_Registers.dom regs) ->
    In rs (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    Some (Num (I v)) = DEX_Registers.get regs rs ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m rs ->
    regs' = DEX_Registers.update regs rt (Num (I (Int.neg v))) ->

    DEX_NormalStep p m (pc, (h, regs)) (pc', (h, regs'))

  (** <addlink>ineg</addlink>: Not [int] (one's complement) *)
  | inot_step : forall h m pc regs regs' pc' rt rs v,

    instructionAt m pc = Some (DEX_Inot rt rs) ->
    In rt (DEX_Registers.dom regs) ->
    In rs (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    Some (Num (I v)) = DEX_Registers.get regs rs ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m rs ->
    regs' = DEX_Registers.update regs rt (Num (I (Int.not v))) ->

    DEX_NormalStep p m (pc, (h, regs)) (pc', (h, regs'))

  (** <addlink>i2b</addlink>: Convert [int] to [byte] *)
  | i2b_step_ok : forall h m pc pc' regs regs' rt rs v,

    instructionAt m pc = Some (DEX_I2b rt rs) ->
    In rt (DEX_Registers.dom regs) ->
    In rs (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    Some (Num (I v)) = DEX_Registers.get regs rs ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m rs ->
    regs' = DEX_Registers.update regs rt (Num (I (b2i (i2b v)))) ->

    DEX_NormalStep p m (pc, (h, regs)) (pc', (h, regs'))

 (** <addlink>i2s</addlink>: Convert [int] to [short] *)
  | i2s_step_ok : forall h m pc pc' regs regs' rt rs v,

    instructionAt m pc = Some (DEX_I2s rt rs) ->
    In rt (DEX_Registers.dom regs) ->
    In rs (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    Some (Num (I v)) = DEX_Registers.get regs rs ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m rs ->
    regs' = DEX_Registers.update regs rt (Num (I (s2i (i2s v)))) ->

    DEX_NormalStep p m (pc, (h, regs)) (pc', (h, regs'))

  | ibinop_step_ok : forall h m pc pc' regs regs' op rt ra rb va vb,

    instructionAt m pc = Some (DEX_Ibinop op rt ra rb) ->
    In rt (DEX_Registers.dom regs) ->
    In ra (DEX_Registers.dom regs) ->
    In rb (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    (*(op = DivInt \/ op = RemInt -> ~ Int.toZ i2 = 0) -> at this moment there is no exception*)
    Some (Num (I va)) = DEX_Registers.get regs ra ->
    Some (Num (I vb)) = DEX_Registers.get regs rb ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m ra ->
    DEX_METHOD.valid_reg m rb ->
    regs' = DEX_Registers.update regs rt (Num (I (SemBinopInt op va vb))) ->

    DEX_NormalStep p m (pc, (h, regs)) (pc', (h, regs'))

  | ibinopconst_step_ok : forall h m pc pc' regs regs' op rt r va v,

    instructionAt m pc = Some (DEX_IbinopConst op rt r v) ->
    In r (DEX_Registers.dom regs) ->
    In rt (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    (*(op = DivInt \/ op = RemInt -> ~ Int.toZ i2 = 0) -> at this moment there is no exception*)
    Some (Num (I va)) = DEX_Registers.get regs r ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m r ->
    regs' = DEX_Registers.update regs rt (Num (I (SemBinopInt op va (Int.const v)))) ->

    DEX_NormalStep p m (pc, (h, regs)) (pc', (h, regs'))

  | new : forall h m pc pc' regs regs' c rt loc h',

    instructionAt m pc = Some (DEX_New rt c) ->
    In rt (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    DEX_Heap.new h p (DEX_Heap.DEX_LocationObject c) = Some (pair loc h') ->
    regs' = DEX_Registers.update regs rt (Ref loc) ->

    DEX_NormalStep p m (pc,(h,regs)) (pc',(h',regs'))

  | iput : forall h m pc pc' regs f rs ro loc cn k v,

    instructionAt m pc = Some (DEX_Iput k rs ro f) ->
    In rs (DEX_Registers.dom regs) ->
    In ro (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    Some (Ref loc) = DEX_Registers.get regs ro ->
    Some v = DEX_Registers.get regs rs ->
    DEX_Heap.typeof h loc = Some (DEX_Heap.DEX_LocationObject cn) ->
    defined_field p cn f ->
    assign_compatible p h v (DEX_FIELDSIGNATURE.type (snd f)) ->

    DEX_NormalStep p m (pc,(h,regs))
      (pc',(DEX_Heap.update h (DEX_Heap.DEX_DynamicField loc f) v, regs))

  | getfield : forall h m pc pc' regs regs' rt ro loc f k v cn,

    instructionAt m pc = Some (DEX_Iget k rt ro f) ->
    In rt (DEX_Registers.dom regs) ->
    In ro (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    Some (Ref loc) = DEX_Registers.get regs ro ->
    DEX_Heap.typeof h loc = Some (DEX_Heap.DEX_LocationObject cn) ->
    defined_field p cn f ->
    DEX_Heap.get h (DEX_Heap.DEX_DynamicField loc f) = Some v ->
    regs' = DEX_Registers.update regs rt v ->

    DEX_NormalStep p m (pc,(h, regs)) (pc',(h, regs'))
.

  Inductive DEX_ReturnStep (p:DEX_Program) : DEX_Method -> DEX_IntraNormalState -> DEX_ReturnState -> Prop :=
  | void_return : forall h m pc regs,

    instructionAt m pc = Some DEX_Return ->
    DEX_METHODSIGNATURE.result (DEX_METHOD.signature m) = None ->

    DEX_ReturnStep p m (pc, (h, regs)) (h, Normal None)

  | vreturn : forall h m pc regs val t k rs,
    (* Implicit in the assumption is that the register has a value in it *)
    instructionAt m pc = Some (DEX_VReturn k rs) ->
    In rs (DEX_Registers.dom regs) ->
    DEX_METHODSIGNATURE.result (DEX_METHOD.signature m) = Some t ->
    assign_compatible p h val t ->
    compat_ValKind_value k val ->
    Some val = DEX_Registers.get regs rs ->

    DEX_ReturnStep p m (pc, (h, regs)) (h, Normal (Some val))
.

  Inductive DEX_exec_intra (p:DEX_Program) (m:DEX_Method) : DEX_IntraNormalState -> DEX_IntraNormalState -> Prop :=
  | exec_intra_normal : forall s1 s2,
     DEX_NormalStep p m s1 s2 ->
     DEX_exec_intra p m s1 s2.

  Inductive DEX_exec_return (p:DEX_Program) (m:DEX_Method) : DEX_IntraNormalState -> DEX_ReturnState -> Prop :=
  | exec_return_normal : forall s h ov,
     DEX_ReturnStep p m s (h, Normal ov) ->
     DEX_exec_return p m s (h, Normal ov)
.

 Inductive DEX_IntraStep (p:DEX_Program) :
    DEX_Method -> DEX_IntraNormalState -> DEX_IntraNormalState + DEX_ReturnState -> Prop :=
  | IntraStep_res :forall m s ret,
     DEX_exec_return p m s ret ->
     DEX_IntraStep p m s (inr _ ret)
  | IntraStep_intra_step:forall m s1 s2,
     DEX_exec_intra p m s1 s2 ->
     DEX_IntraStep p m s1 (inl _ s2) .

 Definition DEX_IntraStepStar p m s r := TransStep_l (DEX_IntraStep p m) s r.

 Definition DEX_IntraStepStar_intra p m s s' := DEX_IntraStepStar p m s (inl _ s').

 Definition DEX_BigStep  p m s ret := DEX_IntraStepStar p m s (inr _ ret).

 Inductive DEX_ReachableStep (P:DEX_Program) :
      (DEX_Method*DEX_IntraNormalState)->(DEX_Method*DEX_IntraNormalState) ->Prop :=
   | ReachableIntra : forall M s s',
       DEX_IntraStep P M s (inl _ s') ->
       DEX_ReachableStep P (M,s) (M,s').

 Definition DEX_Reachable P M s s' :=
   exists M',  ClosReflTrans (DEX_ReachableStep P) (M,s) (M',s').


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export DistributedReferenceCounting.machine2.alternate.
Require Export DistributedReferenceCounting.machine2.invariant0.
Require Export DistributedReferenceCounting.machine2.invariant1.
Require Export DistributedReferenceCounting.machine2.invariant2.
Require Export DistributedReferenceCounting.machine2.invariant3.
Require Export DistributedReferenceCounting.machine2.invariant4.

Unset Standard Proposition Elimination Names.

(* Changes
   - proof of  1  for false_rt_D_queue.
   - proof of  1  for  legal_alternate.
   - owner_st_positive and its proof.
*)

Section INVARIANT5.

(* In this file, we establish the following inequality
   Int + Sum copy + Sum dec - Sum inc_dec >= 0

*)

(* The message queue between a site and the owner has a particular
structure.  Messages dec and inc_dec are alternated.
 *)

Lemma false_rt_D_queue :
 forall (c : Config) (s : Site),
 legal c -> rt c s = false -> D_queue (bm c s owner).
Proof.
   intros c s H; elim H.
   simpl in |- *.
   intro.
   apply D_empty.

   simple induction t; simpl in |- *; intros.

   (*  1 *)

   case (eq_queue_dec s1 s s2 owner); intro.
   decompose [and] a0.
   generalize a; rewrite H3; unfold access in |- *.
   rewrite H2; intro.
   discriminate.

   apply D_post_elsewhere; auto.

   (*  2 *)
   apply D_collect; auto.

   (*  3 *)

   apply D_post_elsewhere.
   right.
   apply (not_owner_inc3 c0 s1 owner H0 s3).
   apply first_in.
   auto.
   apply D_collect.
   auto.

   (*  4 *)

   case (eq_queue_dec s2 s s1 owner); intros; simpl in |- *.
   decompose [and] a.
   rewrite H3; rewrite H4.
   apply D_post_dec.

   apply D_post_elsewhere.
   auto.

   apply D_collect; auto.

   (* 5 *)

   case (eq_site_dec s s2); intro.
   generalize H2; rewrite e1; unfold Set_rec_table in |- *; rewrite that_site.
   intro; discriminate.

   apply D_collect.
   apply H1.
   generalize H2; unfold Set_rec_table in |- *; rewrite other_site; auto.

   (*  6 *)

   case (eq_site_dec s s2); intro.
   generalize H2; rewrite e1; unfold Set_rec_table in |- *; rewrite that_site;
    intro; discriminate.

   apply D_post_elsewhere; auto.
   apply D_collect; auto.
   apply H1; generalize H2; unfold Set_rec_table in |- *; rewrite other_site;
    auto.

   (*  7 *)

   case (eq_site_dec s0 s); intro.
   rewrite e1; apply D_post_dec.

   apply D_post_elsewhere; auto.
   apply H1; generalize H2; unfold Reset_rec_table in |- *;
    rewrite other_site; auto.
Qed.

Lemma legal_alternate :
 forall (s : Site) (c : Config), legal c -> alternate (bm c s owner).
Proof.
  intros; elim H.
  apply alt_null.

  simple induction t; simpl in |- *; intros.

  (* 1 *)

  case (eq_queue_dec s1 s s2 owner); intro.
  decompose [and] a0.
  rewrite H2; rewrite H3; rewrite post_here.
  apply alt_any_alt; auto.
  intro; discriminate.

  rewrite post_elsewhere.
  auto.

  auto.

  (* 2 *)
  apply alt_collect; auto.

  (* 3 *)
  apply alt_post_elsewhere.
  right.
  apply (not_owner_inc3 c0 s1 owner H0 s3).
  apply first_in.
  auto.
  apply alt_collect; auto.

  (* 4 *)

  case (eq_queue_dec s2 s s1 owner); intros.
  decompose [and] a.
  rewrite H2; rewrite H3.
  apply alt_post_any.
  intro; discriminate.

  apply alt_collect; auto.

  apply alt_post_elsewhere; auto.
  apply alt_collect; auto.

  (* 5 *)

  apply alt_collect; trivial.

  (* 6 *)

  case (eq_site_dec s2 s); intro.
  rewrite e1; apply alt_post_inc.
  apply alt_collect; trivial.
  rewrite collect_elsewhere.
  generalize (false_rt_D_queue c0 s2 H0 e); intro.
  rewrite e1 in H2.
  elim H2.
  auto.
  auto.
  case (eq_site_dec s1 s); intro.
  rewrite e2 in n; auto.
  auto.
  apply alt_post_elsewhere; auto.
  apply alt_collect; trivial.

  (* 7 *)

  case (eq_site_dec s0 s); intro.
  rewrite e1; apply alt_post_any; auto.
  intro; discriminate.

  apply alt_post_elsewhere; auto.
Qed.

Lemma count_inc_and_dec_alt_queue :
 forall q : queue Message,
 alternate q ->
 (reduce Message dec_count q + 1 >= reduce Message new_inc_count q)%Z.
Proof.
  intros.
  elim H.
  simpl in |- *; omega.

  intro; simpl in |- *; omega.

  simpl in |- *; intros.
  generalize H0; case m; simpl in |- *.
  intro; omega.

  intros.
  elim (H3 s); auto.

  intro; omega.

  simpl in |- *; intros.
  omega.
Qed.

Lemma count_inc_and_dec_D_queue :
 forall q : queue Message,
 alternate q ->
 D_queue q ->
 (reduce Message dec_count q >= reduce Message new_inc_count q)%Z.
Proof.
  intros q H.
  elim H; intros.
  simpl in |- *; omega.

  absurd (D_queue (input Message (inc_dec s0) (empty Message))).
  apply not_D_queue.
  discriminate.
  auto.

  generalize H3.
  case m.
  intro; simpl in |- *.
  generalize (count_inc_and_dec_alt_queue qm H1); intro; omega.

  intros.
  absurd (D_queue (input Message (inc_dec s) qm)).
  apply not_D_queue.
  discriminate.
  auto.

  intros.
  absurd (D_queue (input Message copy qm)).
  apply not_D_queue.
  discriminate.
  auto.

  absurd (D_queue (input Message (inc_dec s0) (input Message dec qm))).
  apply not_D_queue.
  discriminate.

  auto.
Qed.

Lemma copy_count_is_positive :
 forall q : queue Message, (reduce Message copy_count q >= 0)%Z.
Proof.
  intros.
  apply reduce_positive_or_null.
  intro.
  elim a; simpl in |- *; intros; omega.
Qed.

Lemma dec_count_is_positive :
 forall q : queue Message, (reduce Message dec_count q >= 0)%Z.
Proof.
  intros.
  apply reduce_positive_or_null.
  intro.
  elim a; simpl in |- *; intros; omega.
Qed.

Lemma invariant5 :
 forall c : Config,
 legal c ->
 forall s : Site,
 (Int (rt c s) + reduce Message dec_count (bm c s owner) +
  reduce Message copy_count (bm c owner s) -
  reduce Message new_inc_count (bm c s owner) >= 0)%Z.

Proof.
  intros.
  generalize (copy_count_is_positive (bm c owner s)); intro.
  generalize (legal_alternate s c H); intro.
  case (eq_bool_dec (rt c s)); intro; rewrite e; unfold Int in |- *.
  generalize (count_inc_and_dec_alt_queue (bm c s owner) H1); intro.
  omega.

  generalize (false_rt_D_queue c s H e); intro.
  generalize (count_inc_and_dec_D_queue (bm c s owner) H1 H2); intro.
  omega.
Qed.

Let Recv_T := Site -> bool.

Lemma other_definition_for_sigma_receive_table :
 forall t : Recv_T,
 sigma_receive_table t =
 sigma_table Site LS Z (Z_id Site) (fun s : Site => Int (t s)).
Proof.
  intros.
  unfold sigma_receive_table in |- *.
  unfold sigma_table in |- *.
  unfold Z_id in |- *.
  auto.
Qed.

Remark add_reduce : forall x : Z, (x + 1 - 1)%Z = x.
Proof.
  intro; omega.
Qed.

Lemma owner_st_positive : forall c : Config, legal c -> (st c owner >= 0)%Z.
Proof.
  intros.
  rewrite (invariant4 c H).
  rewrite other_definition_for_sigma_receive_table.
  rewrite <- sigma_same_table.
  rewrite <- sigma_same_table.
  rewrite <- sigma_same_table2.
  unfold Z_id in |- *.
  unfold fun_minus in |- *.
  unfold fun_sum in |- *.
  rewrite sigma_sigma_but_owner.
  rewrite owner_rt_true.
  rewrite empty_q_to_me.
  simpl in |- *.
  simpl in |- *.
  rewrite add_reduce.
  unfold sigma_table_but_owner in |- *.
  apply sigma_but_pos.
  exact (invariant5 c H).
  auto.
  auto.
Qed.

End INVARIANT5.


(*
 * Copyright © 2013 http://io7m.com
 *
 * Permission to use, copy, modify, and/or distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)
(** Virtual paths. *)
Require Coq.Lists.List.
Require Coq.Strings.String.
Require ListAux.
Require ListMapWeak.
Require ListSetWeak.
Require MapWeak.
Require Names.
Require SetWeak.

Import ListAux.Notations.

Open Scope string_scope.
Open Scope list_scope.

(** A virtual path represents a path in the virtual filesystem.

Virtual paths are always absolute.

The concrete syntax of virtual paths is given by the following EBNF
grammar (where [name] indicates a string representing a
valid [Names.name]):

<<
path = "/" , [ name , ("/" , name)* ] ;
>>

A virtual path is conceptually a list of [Names.name],
with the empty list representing the root directory. *)
Definition t := list Names.t.

Definition root : t := nil.

(** Some example virtual paths include: [/bin], and
[/usr/bin/ps]. *)
Example bin        : t := Names.bin :: nil.

Example usr_bin_ps : t := Names.usr :: Names.bin :: Names.ps :: nil.

(** Because equality of [Names.name] is decidable, equality
    of [t] is too. *)
Theorem eq_decidable : forall (p0 p1 : t),
  {p0 = p1}+{~p0 = p1}.
Proof.
  apply List.list_eq_dec.
  apply Names.eq_decidable.
Qed.

(** The property of [p0] being an ancestor of [p1]. [p0] is an ancestor
of [p1] iff:
- [p0] is not equal to [p1], and
- [p0] is a prefix of [p1]
*)
Definition is_ancestor_of (p0 p1 : t) : Prop :=
  (p0 <> p1) /\ (ListAux.is_prefix p0 p1).

(** The property of [p0] being the parent of [p1]. [p0] is the parent
of [p1] iff:
- [p0] is an ancestor of [p1], and
- There exists some [x] such that [p0 @@ x = p1]
*)
Definition is_parent_of (p0 p1 : t) : Prop :=
  (is_ancestor_of p0 p1) /\ (exists x, p0 @@ x = p1).

(** The [root] path is an ancestor of any non-[root] path. *)
Theorem is_ancestor_of_root : forall (p : t),
  p <> root -> is_ancestor_of root p.
Proof.
  unfold is_ancestor_of.
  intros p Hn.
  split.
    apply not_eq_sym.
    assumption.
    induction p as [|px pr].
      contradict Hn; reflexivity.
      exact I.
Qed.

(** The [root] path has no ancestors. *)
Theorem is_ancestor_of_root_false : forall (p : t),
  ~is_ancestor_of p root.
Proof.
  unfold is_ancestor_of.
  induction p; intuition.
Qed.

(** The [root] path has no parent. *)
Theorem is_parent_of_root_false : forall (p : t),
  ~is_parent_of p root.
Proof.
  unfold root.
  unfold is_parent_of.
  induction p; intuition.
    inversion H1.
    contradict H. apply ListAux.append_element_not_equal.
    inversion H0.
    contradict H3.
Qed.

(** Iff a path has a single element, then its parent is the [root]. *)
Theorem is_parent_of_root_single : forall (x : Names.t),
  is_parent_of root (x :: nil).
Proof.
  unfold root.
  unfold is_parent_of.
  unfold is_ancestor_of.
  intro x.
  split.
  split.
    discriminate.
    exact I.
    exists x; reflexivity.
Qed.

(** Being an ancestor is decidable. *)
Theorem is_ancestor_of_decidable : forall (p0 p1 : t),
  {is_ancestor_of p0 p1}+{~is_ancestor_of p0 p1}.
Proof.
  unfold is_ancestor_of.
  intros p0 p1.
  destruct (eq_decidable p0 p1).
    right; rewrite e; intuition.
    destruct (ListAux.is_prefix_decidable Names.eq_decidable p0 p1).
      left; intuition.
      right; intuition.
Qed.

(** Being a parent is decidable. *)
Theorem is_parent_of_decidable : forall (p0 p1 : t),
  {is_parent_of p0 p1}+{~is_parent_of p0 p1}.
Proof.
  intros p0 p1.
  unfold is_parent_of   in *.
  unfold is_ancestor_of in *.
  destruct (is_ancestor_of_decidable p0 p1).
    destruct i.
    destruct (ListAux.append_element_decidable Names.eq_decidable p0 p1).
      left; intuition.
      right; intuition.
    unfold is_parent_of   in *.
    unfold is_ancestor_of in *.
    right; intuition.
Qed.

(** Being an ancestor is transitive. *)
Theorem is_ancestor_of_transitive : forall (p0 p1 p2 : t),
  is_ancestor_of p0 p1 -> is_ancestor_of p1 p2 -> is_ancestor_of p0 p2.
Proof.
Admitted.

(** The property of [p0] containing [p1]. The path [p0] is said to
contain [p1] iff:
- [p0 = p1], or
- [p0] is an ancestor of [p1] *)
Definition contains (p0 p1 : t) :=
  (p0 = p1) \/ (is_ancestor_of p0 p1).

(** [contains] is decidable. *)
Theorem contains_decidable : forall (p0 p1 : t),
  {contains p0 p1}+{~contains p0 p1}.
Proof.
  unfold contains.
  intros p0 p1.
  destruct (eq_decidable p0 p1).
  destruct (is_ancestor_of_decidable p0 p1).
    left; left; assumption.
    left; left; assumption.
  destruct (is_ancestor_of_decidable p0 p1).
    left; right; assumption.
    right; tauto.
Qed.

(** All paths contain themselves. *)
Theorem contains_self : forall (p : t),
  contains p p.
Proof.
  left; reflexivity.
Qed.

(** If [p] is contained by [root], then [p = root]. *)
Theorem contains_is_root : forall (p : t),
  contains p root -> p = root.
Proof.
  unfold contains.
  unfold is_ancestor_of.
  intros p Hc.
  induction p as [|ph pr].
    reflexivity.
    destruct Hc as [HL|HR].
      assumption.
      destruct HR as [HRL HRR].
        inversion HRR.
Qed.

(** Containment is transitive. *)
Theorem contains_trans : forall (p q r : t),
  contains p q -> contains q r -> contains p r.
Proof.
  intros p q r Hpq Hqr.
  unfold contains in *.
  unfold is_ancestor_of in *.
  destruct Hpq as [HpqL|HpqR].
    destruct Hqr as [HqrL|HqrR].
      left; apply (eq_trans HpqL HqrL).
      rewrite HpqL.
      right; assumption.
    destruct Hqr as [HqrL|HqrR].
      rewrite <- HqrL.
      right; assumption.
Admitted.

(** Paths can be "subtracted" to remove common prefixes. This
is useful for calculating the paths of files inside archives mounted
into a filesystem. As an example, if an archive [A] is mounted at
[/usr] and [A] contains the path [/bin/ps], then
[subtract /usr/bin/ps /usr = /bin/ps].

So, if [contains p1 p0], then subtraction removes the first
[length p1] elements of [p0]. *)
Definition subtract (p0 p1 : t) : t :=
  match contains_decidable p1 p0 with
  | left _  => List.skipn (length p1) p0
  | right _ => p0
  end.

(** As stated, [subtract /usr/bin/ps /usr = /bin/ps]. *)
Example subtract_usr : subtract usr_bin_ps (Names.usr :: nil) = Names.bin :: Names.ps :: nil.
Proof.
  compute.
  destruct contains_decidable as [Hc|Hnc].
    reflexivity.
    contradict Hnc.
      right; compute; intuition.
      inversion H.
Qed.

(** Attempting to subtract [p1] from [p0] when [p1] does not contain [p0]
does nothing. *)
Theorem contains_subtract_false : forall (p0 p1 : t),
  ~contains p1 p0 -> subtract p0 p1 = p0.
Proof.
  intros p0 p1 Hna.
  unfold subtract.
  destruct (contains_decidable p1 p0).
    contradiction.
    reflexivity.
Qed.

(** If [p1] contains [p0], then subtracting [p1] from [p0] reduces
the length of [p0] by [length p1]. *)
Theorem contains_subtract_length : forall (p0 p1 : t),
  contains p1 p0 -> length (subtract p0 p1) = length p0 - length p1.
Proof.
  intros p0 p1.
  unfold subtract.
  destruct (contains_decidable p1 p0).
    intros; apply ListAux.skipn_length.
    intros; contradiction.
Qed.

(** If [p0 = p1], then [subtract p0 p1 = root]. *)
Theorem contains_subtract_is_root : forall (p0 p1 : t),
  p0 = p1 -> subtract p0 p1 = root.
Proof.
  intros p0 p1 H_eq.
  unfold subtract.
  rewrite H_eq.
  destruct (contains_decidable p1 p1) as [Hc|Hnc].
    apply ListAux.skipn_0.
    contradict Hnc.
    left; reflexivity.
Qed.

(** Subtracting anything from [root] results in [root]. *)
Theorem subtract_root : forall (p : t),
  subtract root p = root.
Proof.
  intros p.
  unfold subtract.
  destruct (contains_decidable p root).
    destruct p; reflexivity.
    reflexivity.
Qed.

(** Subtracting anything from [root] results in [root]. *)
Theorem subtract_from_root : forall (p : t),
   subtract root p = root.
 Proof.
   intros p.
   unfold subtract.
   destruct (contains_decidable p root).
     destruct p; reflexivity.
     reflexivity.
 Qed.

(** Subtracting [root] from [p] results in [p]. *)
Theorem subtract_root_from : forall p,
  subtract p root = p.
Proof.
  intros p.
  unfold subtract.
  destruct (contains_decidable root p); reflexivity.
Qed.

(** Subtracting [p] from itself results in [root]. *)
Theorem subtract_self : forall p,
  subtract p p = root.
Proof.
  intros p.
  unfold subtract.
  destruct (contains_decidable p p) as [Hc|Hnc].
    induction p.
      reflexivity.
      apply IHp.
      left; reflexivity.
    contradict Hnc.
      left; reflexivity.
Qed.

Theorem contains_subtract_id : forall (p0 p1 : t),
  contains p0 p1 -> p0 ++ (subtract p1 p0) = p1.
Proof.
  unfold contains.
  unfold is_ancestor_of.
  induction p0 as [|p0h p0r].
    destruct p1 as [|p1h p1r].
      intros; simpl. apply subtract_from_root.
      intros; simpl. apply subtract_root_from.
    intros p1 H.
    destruct H as [HL|HR].
      rewrite HL.
      rewrite subtract_self.
      unfold root.
      auto with *.
    destruct p1 as [|p1h p1r].
      destruct HR as [HRL HRR].
        contradict HRR.
      destruct HR as [HRL HRR].
        destruct HRR as [HRRL HRRR].
          simpl in *.
          rewrite HRRL.
Admitted.

(** The sequential enumeration of the ancestors of [p] is
a list of the ancestors of [p] starting with the most distant
ancestor first.

As an example, given a path [/usr/bin/ps], a sequential
enumeration of the ancestors would result in a list
[/ :: /usr :: /usr/bin :: nil].

The [Enumeration] module provides a function to calculate the
enumeration. *)
Module Type EnumerationSignature.
Parameter enumeration : t -> list t.

(** The [enumeration] of the [root] is empty. *)
Parameter enumeration_root : enumeration root = nil.

(** Therefore, if the enumeration of [p] is empty, then [p = root]. *)
Parameter enumeration_is_root : forall (p : t),
  enumeration p = nil -> p = root.

(** All paths returned by [enumeration] are ancestors of the original non-empty path. *)
Parameter enumeration_ancestors : forall (p q : t),
  p <> root -> (List.In q (enumeration p) <-> is_ancestor_of q p).
End EnumerationSignature.

(** The actual implementation of the [enumeration] function. *)
Module Enumeration <: EnumerationSignature.

Definition enumeration (e : t) :=
  match e with
  | nil    => nil
  | _ :: _ => ListAux.prefixes e
  end.

(** The [enumeration] of the [root] is empty. *)
Theorem enumeration_root :
  enumeration nil = nil.
Proof.
  reflexivity.
Qed.

(** Therefore, if the enumeration of [p] is empty, then [p = root]. *)
Theorem enumeration_is_root : forall (p : t),
  enumeration p = nil -> p = root.
Proof.
  induction p as [|ph pr].
    auto.
    intros.
    simpl in H.
    inversion H.
Qed.

(** All paths returned by [enumeration] are ancestors of the original non-empty path. *)
Theorem enumeration_ancestors : forall (p q : t),
  p <> root -> (List.In q (enumeration p) <-> is_ancestor_of q p).
Proof.
  intros p q H.
  destruct p.
    contradict H; reflexivity.
    unfold enumeration.
    unfold is_ancestor_of.
    apply ListAux.prefixes_correct.
Qed.

End Enumeration.

(** As stated, [enumeration /usr/bin/ps = [/, /usr, /usr/bin]]. *)
Theorem enum_example : Enumeration.enumeration usr_bin_ps =
  nil :: (Names.usr :: nil) :: (Names.usr :: Names.bin :: nil) :: nil.
Proof.
  compute.
  reflexivity.
Qed.

(** A map with virtual paths as keys. *)
Module PathVirtualMapsKey : MapWeak.Parameters with Definition key := t.
  Definition key              := t.
  Definition key_eq_decidable := eq_decidable.
End PathVirtualMapsKey.

Module Maps := ListMapWeak.Make(PathVirtualMapsKey).

(** A finite set of virtual paths. *)
Module PathVirtualSetParameters : SetWeak.Parameters with Definition t := t.
  Definition t              := t.
  Definition t_eq_decidable := eq_decidable.
End PathVirtualSetParameters.

Module Sets := ListSetWeak.Make(PathVirtualSetParameters).


(** This module proves Theorem 4.3 from the paper. *)

From Coq Require Import Program.Equality Omega.
From Rattus Require Export Streams FundamentalProperty.

From Rattus Require Import Tactics.

Import ListNotations.

(* We start with the two central lemmas that prove the essence of the
causality property. *)

Lemma causality1 A B nu t vs :
  closed_type A -> (forall n, isvalue (vs n)) -> (forall n, ctx_empty ⊢ (vs n) ∶ A) ->
  ctx_empty ⊢ t ∶ Arrow (Str A) (Str B) ->
  trrel B nu vs (app t (adv (ref thel)),heap_empty).
Proof.
  intros CTA VT' Cvs' Ty.
  assert (forall n, vrel_vtype A (vs n)) as VT
      by (intros; apply trel_vrel;eauto using fund_prop_closed).
  assert (forall n, closed_term (vs n)) as Cvs
      by (intros n; eapply typed_closed;eauto).
  constructor; eauto using closed_heap_empty, typed_closed, heap_empty_fresh.
  intros s Ts Cs.
  pose Ty as Ty'.
  eapply fund_prop with (g:= nil) (Hs := (str_heapseq (tl (tl vs))))
                        (s := (Some (heap_single thel (vs 0 ∷ ref thel)),
                                         heap_single thel (vs 1 ∷ ref thel)))
    in Ty';eauto. rewrite sub_empty_app in Ty' by auto.
  eapply trel_app; eauto using typed_closed. eauto using str_heapseq_closed.
  eapply trel_adv. auto using mapsto_heap_cons.
  apply vrel_trel. autorewrite with vrel. eexists. split. reflexivity. simpl.
  autorewrite with vrel. do 2 eexists. split. reflexivity. split.
  rewrite closed_tsubst by auto. eauto using vtype_vrel.
  apply trel_vrel;eauto.  constructor; eauto using closed_heap_alloc, typed_closed.

  apply  fund_prop_closed;eauto.
  eauto using str_heapseq_closed, closed_heapseq_tail.
  constructor; eauto using closed_heap_alloc, typed_closed.

  eapply vrel_mono; try eapply thel_vrel;eauto.
  eauto using str_heapseq_closed.
  eauto using str_heapseq_closed.
  constructor;  eauto using vtype_vrel_closed,closed_heap_alloc, closed_heap_empty.
Qed.

(** This is part (ii) of Theorem 3.2 in the paper. *)
Lemma causality2 A B nu s vs :
  vtype B -> (forall n, isvalue (vs n)) -> (forall n, ctx_empty ⊢ (vs n) ∶ A) ->
  trrel B (S nu) vs s -> exists v' s', tred s (vs 0) v' s' /\ trrel B nu (tl vs) s' /\ ctx_empty ⊢ v' ∶ B.
Proof.
  intros VTB V Ty TR. inversion TR;subst.
  assert (vrel_vtype A (vs 0))  as Ty' by (apply trel_vrel;eauto using fund_prop_closed).

  assert (exists (v' : term) (s : store),
  {t, (Some (heap_cons h thel (vs 0 ∷ ref thel)), heap_single thel (vs 1 ∷ ref thel))}⇓ {v', s} /\
  vrel (S nu) (Str B) (str_heapseq (tl (tl vs))) s v') as Red.
  eapply H1; try eassumption;eauto using tick_le_refl,str_heapseq_closed, tick_le_refl.
  constructor; eauto using vtype_vrel_closed,closed_heap_alloc,closed_heap_empty,typed_closed.
  destruct Red as (v'& s&R&VR).

  pose (red_extensive _ _ _ _ R) as SL. dependent destruction SL.
  eapply red_not_later with (u:=unit) in R; eauto using heap_dom_cons'.
  rewrite heap_cons_eq in R.
  autorewrite with vrel in VR. simpl in VR. destruct VR as (v'' & E & VR). subst.
  autorewrite with vrel in VR. simpl in VR. destruct VR as (v1 & v2 & E & VR). subst.

  destruct VR as (VR1 & VR2). autorewrite with vrel' in VR2.
  destruct VR2 as (l & u & E & M & LR). subst.

  do 2 eexists. split. econstructor. apply R. split. constructor.
  - assert (heap_mapsto thel (vs 1 ∷ ref thel) h2') by eauto using mapsto_heap_cons.
    assert (closed_term (vs 1 ∷ ref thel)) by eauto using vtype_vrel_closed, typed_closed.
    assert (closed_heap (heap_cons h2' thel unit)). apply red_closed in R;eauto.
    destruct R as [C1 C2]. inversion C2. auto.
    constructor;eauto using closed_heap_empty,
                closed_heap_alloc,vtype_vrel_closed.
    eauto using closed_heap_alloc, typed_closed.
    eauto using closed_heap_delete, closed_heap_cons_rev.
  - eauto using vrel_delay_closed.
  - rewrite heap_cons_delete'. rewrite heap_cons_eq.
    inversion M. subst. simpl in LR.
    rewrite heap_overwrite'; eauto using mapsto_heap_cons.
    eapply trel_adv; try eassumption.
  - rewrite tsubst_vtype in VR1. eauto using vtype_typing. assumption.
Qed.

(* Finally we use the above two lemmas to prove the causality
property. In particular we construct infinite reduction sequences of
the form

  (t0,h0) --[v0/v'0]--> (t1,h1) --[v1/v'1]--> (t2,h2) --[v2/v'2]-->
  ...

where vi is the input value (of type A) given at the ith step and
each v'i is the corresponding output value (of type B). Such infinite
reduction sequences are represented by the coinductive type [Sred B vs
(t0,h0)] defined below, where vs maps i to vi.  *)

(* [Tred A vs s] indicates that there is an infinite stream transducer
reduction that takes inputs [vs], starts with state [s], and produces
well-typed output of type A. *)

CoInductive Tred (A : type) (vs : nat -> term) (s : state) : Prop :=
  mkSred (nextState : state) (output : term) :
         ctx_empty ⊢ output ∶ A ->
         tred s (vs 0) output nextState ->
         Tred A (tl vs) nextState -> Tred A vs s.

(* [Tred' A vs n s] represents finitary approximations of [Tred A vs
s] of length n, i.e. the first n reductions. This type is used for
constructing the proof of [Tred]. *)

Inductive Tred' (A : type) (vs : nat -> term) :  nat -> state -> Prop :=
| mkSred' n s (nextState' : state)
          (output' : term) :
    ctx_empty ⊢ output' ∶ A ->
    tred s (vs 0) output' nextState' ->
    Tred' A (tl vs) n nextState' -> Tred' A vs (S n) s
| doneSred' s : Tred' A vs 0 s.

#[global] Hint Constructors Tred' : core.

Lemma tred_determ s v v1 v2 s1 s2 : tred s v v1 s1 -> tred s v v2 s2 -> v1 = v2 /\ s1 = s2.
Proof.
  intros SR1. intros SR2. dependent destruction SR1. dependent destruction SR2.
  eapply red_determ in H; eauto. destruct H as (H1 & H2).
  inversion H1. inversion H2. subst. eauto.
Qed.

Lemma tred'_tred' A s vs :
  (forall n vs, Tred' A vs n s) -> Tred A vs s.
Proof.
  generalize dependent s. generalize dependent vs. cofix IH. intros vs s SR.

  pose (SR 1 vs) as S1. dependent destruction S1. subst.
  econstructor;try eassumption.
  apply IH. intros n vs'.

  pose (SR (S n) (cons (vs 0) vs')) as Sn. dependent destruction Sn.
  eapply tred_determ in H0;eauto. destruct H0; subst. assumption.
Qed.

Lemma tred'_tred A s vs P : (forall n, P (vs n)) ->
  (forall n vs, (forall n, P (vs n)) -> Tred' A vs n s) ->  Tred A vs s.
Proof.
  generalize dependent s. generalize dependent vs. cofix IH. intros vs s PS SR .

  pose (SR 1 vs) as S1. dependent destruction S1. subst. auto.
  econstructor;try eassumption.
  apply IH. eauto. intros n vs' PS'.
  assert (forall n : nat, P (cons (vs 0) vs' n)) as PS''.
  intros. destruct n0; simpl; eauto.
  pose (SR (S n) (cons (vs 0) vs') PS'') as Sn. dependent destruction Sn.
  eapply tred_determ in H0;eauto. destruct H0; subst. assumption.
Qed.

Lemma causality' A B t vs:
  closed_type A -> vtype B -> ctx_empty ⊢ t ∶ Arrow (Str A) (Str B) ->
  (forall n, isvalue (vs n)) -> (forall n, ctx_empty ⊢ (vs n) ∶ A) ->
  forall n, Tred' B vs n (app t (adv (ref thel)), heap_empty).
Proof.
  intros CTA VTB Ty Vs Ts n.
  apply causality1 with (nu := n) (vs :=vs) in Ty; eauto.
  generalize dependent (app t (adv (ref thel)),heap_empty).
  clear t. generalize dependent vs. induction n;intros.
  - constructor.
  - eapply causality2 in Ty;eauto. autodest.
Qed.

(* Theorem 4.2 from the paper *)
Theorem causality A B t vs :
  closed_type A -> vtype B -> ctx_empty ⊢ t ∶ Arrow (Str A) (Str B) ->
  (forall n, isvalue (vs n)) -> (forall n, ctx_empty ⊢ (vs n) ∶ A) ->
  Tred B vs (app t (adv (ref thel)), heap_empty).
Proof.
  intros. remember (fun v => isvalue v /\ ctx_empty ⊢ v ∶ A) as P.
  assert (forall n, P (vs n)) as Pn by (subst;split;eauto).

  eapply tred'_tred with (P:=P). apply Pn. subst. intros.
  eapply causality'. apply H. eauto. eauto.
  intros m. pose (H4 m). tauto. intros m. pose (H4 m). tauto.
Qed.