Require Import HoTT.
Require Import Auxiliary.General.
Require Import Auxiliary.Family.
Require Import Auxiliary.Coproduct.
Require Import Syntax.ScopeSystem.
Require Import Syntax.SyntacticClass.
Require Import Syntax.Arity.
Require Import Syntax.Signature.
Require Import Syntax.Expression.
Require Import Syntax.Substitution.

Section MetavariableExtension.

  (* The extension of a signature by symbols representing metavariables, as used
  to write each rule.

  The *arity* here would be the overall argument of the constructor that the
  rule introduces: the metavariable symbols introduced correspond to the
  arguments of the arity.

  E.g. lambda-abstraction has arity < (Ty,•), (Ty,{x}), (Tm,{x}) >. So in the
  metavariable extension by this arity, we add three symbols — call them A, B,
  and b — with arities as follows:

     Symbol Class Arity
     A      Ty    < >
     B      Ty    <(Tm,•)>
     b      Tm    <(Tm,•)>

  allowing us to write judgements like x:A |– b(x) : B(x).
  *)

  Context {σ : scope_system}.

  Local Definition extend (Σ : signature σ) (a : arity σ) : signature σ.
  Proof.
    refine (Family.sum Σ _).
    refine (Family.fmap _ a).
    intros cl_γ.
    exact (fst cl_γ, Arity.simple (snd cl_γ)).
  Defined.

  Definition include_metavariable {Σ : signature σ} {a : arity σ}
    : a -> extend Σ a
  := inr.

  Local Definition include_symbol_carrier {Σ : signature σ} {a : arity σ}
    : Σ -> extend Σ a
  := inl.

  Definition include_symbol {Σ : signature σ} {a : arity σ}
     : (Signature.map Σ (extend Σ a)).
  Proof.
    exists include_symbol_carrier.
    intros; apply idpath.
  Defined.

  (** Functoriality of metavariable extensions w.r.t. signature maps *)

  Context `{Funext}.

  (* Metavariable extension is bifunctorial in both arguments (the signature and the arity).

  We give the general bifunctoriality action as [Metavariable.fmap], and the special cases in each argument individually as [fmap1], [fmap2]. *)
  Local Definition fmap
      {Σ Σ'  : signature σ} (f : Signature.map Σ Σ')
      {a a' : arity σ} (g : Family.map a a')
    : Signature.map (extend Σ a) (extend Σ' a').
  Proof.
    apply Family.sum_fmap.
    - apply f.
    - apply Family.map_fmap, g.
  Defined.

  Local Definition fmap1
      {Σ Σ' : signature σ} (f : Signature.map Σ Σ')
      (a : arity σ)
    : Signature.map (extend Σ a) (extend Σ' a)
  := fmap f (Family.idmap _).

  Local Definition fmap2
      (Σ : signature σ)
      {a a' : arity σ} (f : Family.map a a')
    : Signature.map (extend Σ a) (extend Σ a')
  := fmap (Family.idmap _) f.

  Local Definition fmap_idmap {Σ} {a}
    : fmap (Signature.idmap Σ) (Family.idmap a)
    = Signature.idmap (extend Σ a).
  Proof.
    apply Family.map_eq'.
    intros [S | i]; exists (idpath _); apply idpath.
  Defined.

  Local Definition fmap1_idmap {Σ} {a}
    : fmap1 (Signature.idmap Σ) a
    = Signature.idmap (extend Σ a).
  Proof.
    apply fmap_idmap.
  Defined.

  Local Definition fmap2_idmap {Σ} {a}
    : fmap2 Σ (Family.idmap a)
    = Signature.idmap (extend Σ a).
  Proof.
    apply fmap_idmap.
  Defined.

  Local Definition fmap_compose
    {Σ Σ' Σ''} (f' : Signature.map Σ' Σ'') (f : Signature.map Σ Σ')
    {a a' a''} (g' : Family.map a' a'') (g : Family.map a a')
    : fmap (Signature.compose f' f) (Family.compose g' g)
    = Signature.compose (fmap f' g') (fmap f g).
  Proof.
    apply Family.map_eq'.
    intros [S | i]; exists (idpath _).
    - apply inverse, concat_1p.
    - cbn. apply inverse.
      eapply concat. { apply concat_1p. }
      eapply concat. { apply ap, ap_idmap. }
      apply inverse.
      eapply concat. { apply ap, ap, ap_idmap. }
      refine (ap_pp _ _ _).
  Defined.

  Local Definition fmap1_compose
    {Σ Σ' Σ''} (f' : Signature.map Σ' Σ'') (f : Signature.map Σ Σ')
    (a : _)
    : fmap1 (Signature.compose f' f) a
    = Signature.compose (fmap1 f' a) (fmap1 f a).
  Proof.
    refine (fmap_compose _ _ (Family.idmap _) (Family.idmap _)).
  Defined.

  Local Definition fmap2_compose
    (Σ : _)
    {a a' a''} (g' : Family.map a' a'') (g : Family.map a a')
    : fmap2 Σ (Family.compose g' g)
    = Signature.compose (fmap2 Σ g') (fmap2 Σ g).
  Proof.
    refine (fmap_compose (Signature.idmap _) (Signature.idmap _) _ _).
  Defined.

  (** Naturality of [include_symbol] w.r.t. signature maps *)
  (* TODO: consider naming *)
  Local Lemma include_symbol_after_map
      {Σ Σ' : signature σ} (f : Signature.map Σ Σ')
      (a : arity _)
    : Signature.compose include_symbol f
      = Signature.compose (fmap1 f a) include_symbol.
  Proof.
    apply Family.map_eq'; intros S.
    exists (idpath _); cbn.
    apply ap.
    eapply concat. { apply ap_idmap. }
    apply inverse, concat_p1.
  Defined.

End MetavariableExtension.

Section MetavariableNotations.

(* Arities of symbols will arise in two ways:

  1. Arities we write by hand.

    These will typically use [< … >] notation.

  2. Arities of metavariables, from [Metavariable.extend].

    These will have only (Ty, scope_empty) arguments, and be indexed by the positions of some proto-context, which will itself probably be built up by [scope_extend].

  So we give functions/notations for giving arguments for each of these forms.

  Eventually, one should be able to write e.g.

  [S/ A ; e1 , e2 , e3 /]

  [M/ A ; e1 , e2 , e3 /]

  for the expression consisting of a symbol S (resp. a metavariable symbol M) applied to expressions e1, e2, e3.

  For now we provide the [M/ … /] version, but not yet the general [S/ … /] version.
*)

Context {σ : scope_system}.
Context {Σ : signature σ}.

(* Access functions for supplying arguments to arities specified as finite extensions of the empty scope. *)
Local Definition empty_args {ϵ : σ} (H_ϵ : is_empty ϵ) {γ}
  : arguments Σ (Arity.simple ϵ) γ
  := empty_rect _ H_ϵ _.

Local Definition extend_args {γ δ : σ}
  : arguments Σ (Arity.simple δ) γ
    -> raw_term Σ γ
    -> arguments Σ (Arity.simple (scope_extend _ δ)) γ.
Proof.
  intros ts t.
  simple refine (plusone_rect _ _ (scope_is_extend _ δ) _ _ _); cbn.
  - refine (rename _ t).
    exact (coproduct_inj1 scope_is_sum).
  - exact ts.
Defined.

End MetavariableNotations.

Declare Scope syntax_scope.
Declare Scope raw_syntax_scope.

Notation " '[M/' A /] "
  := (raw_symbol (include_metavariable A) (empty_args scope_is_empty)) : syntax_scope.

Notation " '[M/' A ; x , .. , z /] "
  := (raw_symbol (include_metavariable A)
       (extend_args .. (extend_args (empty_args scope_is_empty) x) .. z))
    : raw_syntax_scope.

Open Scope syntax_scope.

Section Instantiations.

  Context {σ : scope_system}.

  (* To use rules, one *instantiates* their metavariables, as raw syntax of the
     ambient signature, over some context. *)
  Local Definition instantiation (a : @arity σ) (Σ : signature σ) (γ : σ)
    : Type
  := forall i : a,
         raw_expression Σ (argument_class i) (scope_sum γ (argument_scope i)).

  (* TODO: check naming conventions *)
  Definition rename_instantiation {a} {Σ}
    {γ γ' : σ} (f : γ -> γ')
    (I : instantiation a Σ γ)
    : instantiation a Σ γ'.
  Proof.
    intros i. refine (rename _ (I i)).
    exact (Coproduct.fmap scope_is_sum scope_is_sum f idmap).
  Defined.

  (* TODO: check naming conventions *)
  Definition substitute_instantiation {a} {Σ}
    {γ γ' : σ} (f : raw_substitution Σ γ' γ)
    (I : instantiation a Σ γ)
    : instantiation a Σ γ'.
  Proof.
    intros i. refine (substitute _ (I i)).
    exact (Substitution.extend _ _ (argument_scope i) f).
  Defined.

  Definition instantiation_fmap
      {Σ Σ' : signature σ} (f : Signature.map Σ Σ')
      {a} {γ} (I : instantiation a Σ γ)
    : instantiation a Σ' γ
  := fun i => Expression.fmap f (I i).

  Definition instantiation_fmap2
      {Σ : signature σ}
      {a a' : arity σ} (f : Family.map a a')
      {γ} (I : instantiation a' Σ γ)
    : instantiation a Σ γ.
  Proof.
    intros i.
    unfold argument_class, argument_scope.
    refine (transport _ _ _).
    { apply ap, ap, (Family.map_commutes f). }
    eapply (transport (fun cl => _ _ cl _)).
    { apply ap, (Family.map_commutes f). }
    apply I.
  Defined.

  (** Given such an instantiation, one can translate syntax over the extended
     signature into syntax over the base signature. *)
  Fixpoint instantiate_expression
      {cl} {a : @arity σ} {Σ : signature σ} {γ : σ}
      (I : instantiation a Σ γ)
      {δ} (e : raw_expression (extend Σ a) cl δ)
    : raw_expression Σ cl (scope_sum γ δ).
  Proof.
    destruct e as [ δ i | δ [S | M] args].
  - refine (raw_variable _).
    exact (coproduct_inj2 (scope_is_sum) i).
  - refine (raw_symbol S _). intros i.
    refine (rename _
             (instantiate_expression _ _ _ _ I _ (args i))).
    apply scope_assoc_rtol.
  - simpl in M. (* Substitute [args] into the expression [I M]. *)
    refine (substitute _ (I M)).
    refine (coproduct_rect scope_is_sum _ _ _).
    + intros i. apply raw_variable, (coproduct_inj1 scope_is_sum), i.
    + intros i.
      refine (rename _
             (instantiate_expression _ _ _ _ I _ (args i))).
      cbn.
      refine (Coproduct.fmap scope_is_sum scope_is_sum _ _).
      * exact (fun j => j).
      * exact (Coproduct.empty_right scope_is_sum scope_is_empty).
  Defined.

  Arguments instantiate_expression {_ _ _ _} _ [_] _ : simpl nomatch.

  Definition instantiate_raw_substitution {Σ : signature σ}
      {a : arity σ} {γ : σ} (I : instantiation a Σ γ)
      {δ δ' : σ} (f : raw_substitution (extend Σ a) δ' δ)
    : raw_substitution Σ (scope_sum γ δ') (scope_sum γ δ)
  := (coproduct_rect scope_is_sum _
        (fun i => raw_variable (coproduct_inj1 scope_is_sum i))
        (fun i => instantiate_expression I (f i))).

  (** Interaction of metavariable-instantiation with renaming, substitution, transport. *)

  Context `{Funext}.

  Lemma transport_class_instantiate
      {Σ : signature σ} {a}
      {γ} (I : instantiation a Σ γ)
      {cl cl'} (e_cl : cl = cl')
      {δ} (e : raw_expression (extend Σ a) cl δ)
    : transport (fun cl => raw_expression _ cl _) e_cl
                (instantiate_expression I e)
      = instantiate_expression I
          (transport (fun cl => raw_expression _ cl _) e_cl e).
  Proof.
    destruct e_cl; apply idpath.
  Defined.

  Lemma transport_scope_instantiate
      {Σ : signature σ} {a}
      {γ} (I : instantiation a Σ γ)
      {cl} {δ δ'} (e_δ : δ = δ')
      (e : raw_expression (extend Σ a) cl δ)
    : transport _ (ap _ e_δ) (instantiate_expression I e)
      = instantiate_expression I (transport _ e_δ e).
  Proof.
    destruct e_δ; apply idpath.
  Defined.

  Lemma instantiate_rename {Σ : signature σ}
      {cl} {a : @arity σ} {γ : σ}
      (I : instantiation a Σ γ)
      {δ} (e : raw_expression (extend Σ a) cl δ)
      {δ' : σ} (f : δ -> δ')
    : instantiate_expression I (rename f e)
    = rename
        (Coproduct.fmap scope_is_sum scope_is_sum idmap f)
        (instantiate_expression I e).
  Proof.
    revert δ' f.
    induction e as [ θ i | θ [S | M] e_args IH_e_args ]; intros δ' f.
    - (* [e] is a variable *)
      cbn. apply ap, inverse. refine (coproduct_comp_inj2 _).
    - (* [e] is a symbol of [Σ] *)
      simpl. apply ap. apply path_forall; intros i.
      eapply concat. { apply ap, IH_e_args. }
      eapply concat. { apply rename_rename. }
      eapply concat. 2: { apply inverse, rename_rename. }
      apply (ap_2back rename), path_forall.
      repeat refine (coproduct_rect scope_is_sum _ _ _); intros j;
        cbn; unfold Coproduct.fmap, scope_assoc_rtol, Coproduct.assoc_rtol;
        repeat progress rewrite ? coproduct_comp_inj1, ? coproduct_comp_inj2;
        apply idpath.
    - (* [e] is a metavariable from [a] *)
      simpl.
      eapply concat. 2: { apply inverse, Substitution.rename_substitute. }
      apply (ap_2back substitute), path_forall.
      refine (coproduct_rect scope_is_sum _ _ _); intros i.
      + eapply concat. { refine (coproduct_comp_inj1 _). }
        apply inverse.
        eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
        cbn. apply ap. refine (coproduct_comp_inj1 _).
      + eapply concat. { refine (coproduct_comp_inj2 _). }
        eapply concat. { apply ap, IH_e_args. }
        eapply concat. { apply rename_rename. }
        apply inverse.
        eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
        eapply concat. { apply rename_rename. }
        apply (ap_2back rename), path_forall.
        repeat refine (coproduct_rect scope_is_sum _ _ _); intros j.
        * eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
          eapply concat. { refine (coproduct_comp_inj1 _). }
          apply inverse.
          eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
          refine (coproduct_comp_inj1 _).
        * eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
          eapply concat. { apply ap, ap. refine (coproduct_comp_inj1 _). }
          eapply concat. { refine (coproduct_comp_inj2 _). }
          apply inverse.
          eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
          eapply concat. { apply ap, ap. refine (coproduct_comp_inj1 _). }
          eapply concat. { refine (coproduct_comp_inj2 _). }
          apply ap. refine (coproduct_comp_inj1 _).
        * revert j. apply empty_rect, scope_is_empty.
  Defined.

  Lemma instantiate_substitute {Σ : signature σ}
      {cl} {a : @arity σ} {γ : σ}
      (I : instantiation a Σ γ)
      {δ} (e : raw_expression (extend Σ a) cl δ)
      {δ' : σ} (f : raw_substitution _ δ' δ)
    : instantiate_expression I (substitute f e)
    = substitute
        (instantiate_raw_substitution I f)
        (instantiate_expression I e).
  Proof.
    revert δ' f.
    induction e as [ θ i | θ [S | M] e_args IH_e_args ]; intros δ' f.
    - (* [e] is a variable *)
      simpl. apply inverse. refine (coproduct_comp_inj2 _).
    - (* [e] is a symbol of [Σ] *)
      simpl. apply ap. apply path_forall; intros i.
      eapply concat. { apply ap, IH_e_args. }
      eapply concat. { apply Substitution.rename_substitute. }
      apply inverse.
      eapply concat. { apply substitute_rename. }
      apply (ap_2back substitute), path_forall.
      repeat refine (coproduct_rect scope_is_sum _ _ _); intros j.
      + eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
        eapply concat. { refine (coproduct_comp_inj1 _). }
        eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
        apply inverse.
        eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
        simpl; apply ap. refine (coproduct_comp_inj1 _).
      + eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
        eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
        eapply concat. { refine (coproduct_comp_inj1 _). }
        eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
        apply inverse.
        eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
        eapply concat. { apply ap, ap. refine (coproduct_comp_inj1 _). }
        eapply concat. { apply ap, instantiate_rename. }
        eapply concat. { apply rename_rename. }
        apply (ap_2back rename), path_forall.
        refine (coproduct_rect scope_is_sum _ _ _); intros k.
        * eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
          refine (coproduct_comp_inj1 _).
        * eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
          eapply concat. { refine (coproduct_comp_inj2 _). }
          refine (coproduct_comp_inj1 _).
      + eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
        eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
        eapply concat. { refine (coproduct_comp_inj2 _). }
        apply inverse.
        eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
        eapply concat. { apply ap, ap. refine (coproduct_comp_inj2 _). }
        simpl. apply ap.
        eapply concat. { refine (coproduct_comp_inj2 _). }
        refine (coproduct_comp_inj2 _).
    - (* [e] is a metavariable from [a] *)
      simpl.
      eapply concat. 2: { apply inverse, substitute_substitute. }
      apply (ap_2back substitute), path_forall.
      refine (coproduct_rect scope_is_sum _ _ _); intros i.
      + eapply concat. { refine (coproduct_comp_inj1 _). }
        apply inverse.
        eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
        cbn. refine (coproduct_comp_inj1 _).
      + eapply concat. { refine (coproduct_comp_inj2 _). }
        eapply concat. { apply ap, IH_e_args. }
        eapply concat. { apply Substitution.rename_substitute. }
        apply inverse.
        eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
        eapply concat. { apply substitute_rename. }
        apply (ap_2back substitute), path_forall.
        repeat refine (coproduct_rect scope_is_sum _ _ _); intros j.
        * eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
          eapply concat. { refine (coproduct_comp_inj1 _). }
          apply inverse.
          eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
          cbn. apply ap. refine (coproduct_comp_inj1 _).
        * eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
          eapply concat. { apply ap, ap. refine (coproduct_comp_inj1 _). }
          eapply concat. { refine (coproduct_comp_inj2 _). }
          apply inverse.
          eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
          eapply concat. { apply ap, ap. refine (coproduct_comp_inj1 _). }
          eapply concat. { apply ap, instantiate_rename. }
          eapply concat. { apply rename_rename. }
          eapply concat. 2: { apply rename_idmap. }
          apply (ap_2back rename), path_forall.
          refine (coproduct_rect scope_is_sum _ _ _); intros k.
          -- eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
           refine (coproduct_comp_inj1 _).
          -- eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
           eapply concat. { refine (coproduct_comp_inj2 _). }
           apply ap. refine (coproduct_comp_inj1 _).
        * revert j. apply empty_rect, scope_is_empty.
  Defined.

  (* TODO: consider naming of this vs. preceding lemmas about commutation of instantiations with renaming/substitution in the expressions, currently [instantiate_rename] and [instantiate_substitute]. *)
  Lemma instantiate_rename_instantiation {Σ : signature σ}
      {cl} {a : @arity σ} {γ γ': σ}
      (f : γ -> γ')
      (I : instantiation a Σ γ)
      {δ} (e : raw_expression (extend Σ a) cl δ)
    : instantiate_expression (rename_instantiation f I) e
    = rename
        (Coproduct.fmap scope_is_sum scope_is_sum f idmap)
        (instantiate_expression I e).
  Proof.
    induction e as [ θ i | θ [S | M] e_args IH_e_args ].
    - (* [e] is a variable *)
      simpl. apply ap, inverse. refine (coproduct_comp_inj2 _).
    - (* [e] is a symbol of [Σ] *)
      simpl. apply ap. apply path_forall; intros i.
      eapply concat. { apply ap, IH_e_args. }
      eapply concat. { apply rename_rename. }
      eapply concat. 2: { apply inverse, rename_rename. }
      apply (ap_2back rename), path_forall.
      repeat refine (coproduct_rect scope_is_sum _ _ _); intros j;
        cbn; unfold Coproduct.fmap, scope_assoc_rtol, Coproduct.assoc_rtol;
        repeat progress rewrite ? coproduct_comp_inj1, ? coproduct_comp_inj2;
        apply idpath.
    - (* [e] is a metavariable from [a] *)
      simpl. unfold rename_instantiation.
      eapply concat. { apply substitute_rename. }
      eapply concat. 2: { apply inverse, rename_substitute. }
      apply (ap_2back substitute), path_forall.
      refine (coproduct_rect scope_is_sum _ _ _); intros j;
        unfold Coproduct.fmap.
      { repeat rewrite coproduct_comp_inj1; cbn.
        apply ap, inverse. refine (coproduct_comp_inj1 _). }
      repeat rewrite coproduct_comp_inj2.
      rewrite IH_e_args.
      eapply concat. { apply rename_rename. }
      eapply concat. 2: { apply inverse, rename_rename. }
      apply (ap_2back rename), path_forall.
      repeat refine (coproduct_rect scope_is_sum _ _ _); intros k;
        unfold Coproduct.fmap;
        repeat rewrite ? coproduct_comp_inj1, ? coproduct_comp_inj2;
        apply idpath.
  Qed.

  (* TODO: consider naming of this vs. preceding lemmas about commutation of instantiations with renaming/substitution in the expressions, currently [instantiate_rename] and  instantiate_substitute]. *)
  Lemma instantiate_substitute_instantiation {Σ : signature σ}
      {cl} {a : @arity σ} {γ γ': σ}
      (f : raw_substitution Σ γ' γ)
      (I : instantiation a Σ γ)
      {δ} (e : raw_expression (extend Σ a) cl δ)
    : instantiate_expression (substitute_instantiation f I) e
    = substitute
        (Substitution.extend _ _ _ f)
        (instantiate_expression I e).
  Proof.
    induction e as [ θ i | θ [S | M] e_args IH_e_args ].
    - (* [e] is a variable *)
      simpl. apply inverse. refine (coproduct_comp_inj2 _).
    - (* [e] is a symbol of [Σ] *)
      simpl. apply ap. apply path_forall; intros i.
      eapply concat. { apply ap, IH_e_args. }
      eapply concat. { apply rename_substitute. }
      apply inverse.
      eapply concat. { apply substitute_rename. }
      apply (ap_2back substitute), path_forall.
      repeat refine (coproduct_rect scope_is_sum _ _ _); intro;
        cbn; unfold Substitution.extend, scope_assoc_rtol, Coproduct.assoc_rtol;
        repeat progress rewrite ? coproduct_comp_inj1, ? coproduct_comp_inj2.
      + eapply concat. { apply rename_rename. }
        eapply concat. 2: { apply inverse, rename_rename. }
        apply (ap_2back rename), inverse, path_forall; intro.
        refine (coproduct_comp_inj1 _).
      + cbn. apply ap.
        rewrite coproduct_comp_inj2, coproduct_comp_inj1; apply idpath.
      + cbn. apply ap.
        repeat rewrite coproduct_comp_inj2; apply idpath.
    - (* [e] is a metavariable from [a] *)
      simpl. unfold substitute_instantiation.
      eapply concat. { apply substitute_substitute. }
      eapply concat. 2: { apply inverse, substitute_substitute. }
      apply (ap_2back substitute), path_forall.
      refine (coproduct_rect scope_is_sum _ _ _); intros j;
        unfold Substitution.extend.
      { repeat rewrite coproduct_comp_inj1; cbn;
        rewrite coproduct_comp_inj1; cbn.
        eapply concat. { apply substitute_rename. }
        eapply concat. 2: { apply substitute_raw_variable. }
        apply (ap_2back substitute), path_forall; intros k.
        refine (coproduct_comp_inj1 _). }
      repeat rewrite coproduct_comp_inj2; cbn; rewrite coproduct_comp_inj2.
      rewrite IH_e_args.
      eapply concat. { apply rename_substitute. }
      eapply concat. 2: { apply inverse, substitute_rename. }
      apply (ap_2back substitute), path_forall.
      repeat refine (coproduct_rect scope_is_sum _ _ _); intros k;
        unfold Substitution.extend, Coproduct.fmap;
        repeat rewrite ? coproduct_comp_inj1, ? coproduct_comp_inj2.
      + eapply concat. { apply rename_rename. }
        apply (ap_2back rename), path_forall; intro.
        refine (coproduct_comp_inj1 _).
      + cbn. apply ap.
        rewrite coproduct_comp_inj2; apply idpath.
      + cbn. apply ap.
        repeat rewrite coproduct_comp_inj2; apply idpath.
  Qed.

  Lemma fmap_instantiate_expression
      {Σ Σ' : signature σ} (f : Signature.map Σ Σ')
      {a : @arity σ} {γ : σ}
      (I : instantiation a Σ γ)
      {cl} {δ} (e : raw_expression (extend Σ a) cl δ)
    : Expression.fmap f (instantiate_expression I e)
    = instantiate_expression
        (instantiation_fmap f I)
        (Expression.fmap (fmap1 f a) e).
  Proof.
    induction e as [ δ i | δ [S | M] e_args IH_e_args ].
    - apply idpath.
    - simpl instantiate_expression. simpl Expression.fmap.
      assert (instantiate_expression_transport_cl
        : forall γ δ (I : instantiation a Σ' γ)
                 cl cl' (p : cl = cl') (e : raw_expression _ cl δ),
              instantiate_expression I
                 (transport (fun cl => raw_expression _ cl _) p e)
            = transport (fun cl => raw_expression _ cl _) p
                 (instantiate_expression I e)).
      { intros ? ? ? ? ? p ?. destruct p; apply idpath. }
      eapply concat.
      2: { apply inverse, instantiate_expression_transport_cl. }
      clear instantiate_expression_transport_cl.
      apply ap. simpl. apply ap.
      (* Now that we are under [raw_symbol S], we fold/abstract [Σ S], [Σ' (f S)], and then destruct [Family.map_commutes f S], to avoid having to deal explicitly with the transports. Making sure all instances are folded is a little fiddly. *)
      unfold symbol_arity in *. cbn in *.
      set (ΣS := Σ S) in *. set (ΣfS := Σ' (f S)) in *.
      change (Σ' (f.(proj1_sig) S)) with ΣfS.
      change (Family.map_over_commutes f) with (Family.map_commutes f).
      set (e_S := Family.map_commutes f S : ΣfS = ΣS).
      clearbody e_S ΣS ΣfS.
      destruct e_S. simpl transport.
      apply path_forall; intros i.
      eapply concat. { apply fmap_rename. }
      apply ap. apply IH_e_args.
    - simpl instantiate_expression.
      eapply concat. { apply Substitution.fmap_substitute. }
      unfold raw_substitution_fmap, instantiation_fmap.
      apply (ap_2back substitute), path_forall.
      refine (coproduct_rect scope_is_sum _ _ _); intros i.
      + eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
        cbn. apply inverse. refine (coproduct_comp_inj1 _).
      + eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
        eapply concat. { apply fmap_rename. }
        eapply concat. { apply ap, IH_e_args. }
        eapply inverse. { refine (coproduct_comp_inj2 _). }
  Defined.

  (* TODO: rename to e.g. [instantiate_fmap2_instantiation]? *)
  Lemma instantiate_fmap2
      {a a' : arity σ} (f : Family.map a a')
      {Σ} {γ} (I : instantiation a' Σ γ)
      {cl} {δ} (e : raw_expression (extend Σ a) cl δ)
    : instantiate_expression I (Expression.fmap (fmap2 _ f) e)
    = instantiate_expression (instantiation_fmap2 f I) e.
  Proof.
    induction e as [δ i | δ [S | M] e_args IH_e_args ].
    - apply idpath. (* [raw_variable]: easy! *)
    - (* symbol of signature *)
      simpl. apply ap.
      apply path_forall; intros i.
      apply ap, IH_e_args.
    - (* metavariable symbol *)
      simpl.
      (* first, apply IH *)
      eapply concat.
      2: { eapply (ap_2back substitute).
        apply ap, path_forall; intros i.
        eapply (ap (rename _)), IH_e_args.
      }
      clear IH_e_args.
      (* from here, just transport lemmas *)
      eapply concat. { apply inverse, transport_class_instantiate. }
      simpl.
      eapply concat. { apply Substitution.transport_substitute. }
      unfold instantiation_fmap2.
      eapply concat. 2: { apply inverse, substitute_transport_scope. }
      refine (ap_2back substitute _ _ _ @ ap (substitute _) _).
      2: { refine (ap_1back _ _^ _).
           eapply concat. 2: { refine (ap_compose _ _ _). }
           apply idpath.
      }
      set (e_M := Family.map_commutes f M); clearbody e_M.
      unfold argument_scope, argument_class, symbol_arity in *; simpl in e_args.
      set (a_M := a M) in *.
      set (a_fM := a' (f M)) in *.
      simpl; fold a_fM a_M; clearbody a_M a_fM.
      destruct e_M.
      cbn; apply idpath.
  Defined.

End Instantiations.

Section Instantiation_Composition.
(** Instantiations behave something like the Kleisli maps of a monad: there are unit instantiations and composite instantiations, though at the moment we do not quite systematically package them as a well-defined structure. *)

(* TODO: contemplate this, and try to work out what monad-like structure on extensions/instantiations we are really giving in the following. *)

  Context {σ : scope_system} {Σ : signature σ}.
  Context `{Funext}.

  Definition unit_instantiation (a : arity σ)
    : instantiation a (extend Σ a) (scope_empty σ).
  Proof.
    intros A.
    refine (raw_symbol (include_metavariable A) _).
    intros i. apply raw_variable.
    refine (coproduct_inj1 scope_is_sum _).
    refine (coproduct_inj2 scope_is_sum _).
    exact i.
  Defined.

  (* Can also be seen as a composition of instantiations. *)
  Definition instantiate_instantiation
      {γ} {a} (I : instantiation a Σ γ)
      {δ} {b} (J : instantiation b (extend Σ a) δ)
    : instantiation b Σ (scope_sum γ δ).
  Proof.
    intros i.
    refine (rename _ (instantiate_expression I (J i))).
    apply scope_assoc.
  Defined.

  Lemma unit_instantiate_expression {a}
      {cl} {γ} (e : raw_expression (extend Σ a) cl γ)
    : instantiate_expression (unit_instantiation a)
        (Expression.fmap (fmap1 include_symbol _) e)
      = rename (coproduct_inj2 scope_is_sum) e.
  Proof.
    induction e as [ γ i | γ [S | M] args IH ].
    - apply idpath.
    - simpl.
      apply ap, path_forall; intros i.
      eapply concat. { apply ap, IH. }
      eapply concat. { apply rename_rename. }
      apply (ap_2back rename), path_forall.
      refine (coproduct_rect scope_is_sum _ _ _).
      + intros x.
        eapply concat. { refine (coproduct_comp_inj2 _). }
        eapply concat. { refine (coproduct_comp_inj1 _). }
        apply inverse. refine (coproduct_comp_inj1 _).
      + intros x.
        eapply concat. { refine (coproduct_comp_inj2 _). }
        eapply concat. { refine (coproduct_comp_inj2 _). }
        apply inverse. refine (coproduct_comp_inj2 _).
    - simpl.
      apply ap, path_forall; intros i.
      eapply concat. { refine (coproduct_comp_inj1 _). }
      eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
      eapply concat. { apply ap, ap, IH. }
      eapply concat. { apply rename_rename. }
      eapply concat. { apply rename_rename. }
      apply (ap_2back rename), path_forall.
      refine (coproduct_rect scope_is_sum _ _ _).
      + intros x.
        unfold Coproduct.fmap, Coproduct.empty_right;
        repeat progress rewrite ? coproduct_comp_inj1, ? coproduct_comp_inj2.
        apply idpath.
      + apply (empty_rect _ scope_is_empty).
  Defined.

  Lemma instantiate_instantiate_expression
      {γ} {a} (I : instantiation a Σ γ)
      {δ} {b} (J : instantiation b (extend Σ a) δ)
      {cl} {θ} (e : raw_expression (extend Σ b) cl θ)
    : instantiate_expression
        (instantiate_instantiation I J) e
    = rename (scope_assoc _ _ _)
        (instantiate_expression I
          (instantiate_expression J
            (Expression.fmap (fmap1 include_symbol _) e))).
  Proof.
    induction e as [ θ i | θ [S | M] e_args IH_e_args ].
    - (* [e] is a variable *)
      cbn. apply inverse, ap.
      eapply concat. { refine (coproduct_comp_inj2 _). }
      refine (coproduct_comp_inj2 _).
    - (* [e] is a symbol of [Σ] *)
      simpl Expression.fmap.
      simpl instantiate_expression.
      simpl rename.
      apply ap. apply path_forall; intros i.
      eapply concat. { apply ap, IH_e_args. }
      eapply concat. { apply rename_rename. }
      apply inverse.
      eapply concat. { apply ap, ap. apply instantiate_rename. }
      eapply concat. { apply rename_rename. }
      eapply concat. { apply rename_rename. }
      apply (ap_2back rename), path_forall.
      repeat refine (coproduct_rect scope_is_sum _ _ _); intros j;
        cbn; unfold Coproduct.fmap, scope_assoc_rtol, Coproduct.assoc_rtol;
        repeat progress rewrite ? coproduct_comp_inj1, ? coproduct_comp_inj2;
        apply idpath.
    - (* [e] is a metavariable of [b] *)
      simpl Expression.fmap.
      simpl instantiate_expression.
      simpl rename.
      eapply concat.
      { rapply @ap_2back.
        apply ap, path_forall; intros i.
        refine (ap (rename _) _).
        apply IH_e_args.
      } clear IH_e_args.
      unfold instantiate_instantiation.
      eapply concat. { apply substitute_rename. }
      eapply inverse.
      eapply concat. { apply ap, instantiate_substitute. }
      eapply concat. { apply Substitution.rename_substitute. }
      apply (ap_2back substitute), path_forall.
      repeat refine (coproduct_rect scope_is_sum _ _ _); intros j.
      + eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
        simpl rename. eapply concat. { refine (ap _ (coproduct_comp_inj1 _)). }
        apply inverse.
        eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
        refine (coproduct_comp_inj1 _).
      + eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
        eapply concat. { apply ap, ap. refine (coproduct_comp_inj1 _). }
        cbn. eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
        eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
        apply inverse.
        eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
        eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
        refine (coproduct_comp_inj1 _).
      + eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
        eapply concat. { apply ap, ap. refine (coproduct_comp_inj2 _). }
        eapply concat. { apply ap, instantiate_rename. }
        eapply concat. { apply rename_rename. }
        apply inverse.
        eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
        eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
        eapply concat. { refine (coproduct_comp_inj2 _). }
        eapply concat. { apply rename_rename. }
        apply (ap_2back rename), path_forall; clear e_args.
        repeat refine (coproduct_rect scope_is_sum _ _ _); intros k;
          cbn; unfold scope_assoc_rtol, Coproduct.assoc_rtol, Coproduct.fmap;
          repeat progress rewrite ? coproduct_comp_inj1, ? coproduct_comp_inj2;
          apply idpath.
  Defined.

  (** A somewhat technical lemma, useful under [Judgement.eq_by_expressions]
      for instantiations of a metavariable with empty binder. *)
  Lemma instantiate_binderless_metavariable
      {γ : σ} {cl}
      (E : raw_expression Σ cl (scope_sum γ (scope_empty _)))
      {f}
    : substitute
        (coproduct_rect scope_is_sum _
                        (fun i => raw_variable (coproduct_inj1 scope_is_sum i))
                        f)
        E
      = E.
  Proof.
    eapply concat. 2: { apply rename_idmap. }
    eapply concat. 2: { apply substitute_raw_variable. }
    apply (ap_2back substitute), path_forall.
    refine (coproduct_rect scope_is_sum _ _ _).
    - intros i; refine (coproduct_comp_inj1 _).
    - apply (empty_rect _ scope_is_empty).
  Defined.

End Instantiation_Composition.

(** When working with congruence rules, one often wants to combine two instantiations for some metavariables into a single instantiation for two copies of the metavariables. *)
Section Copair_Instantiation.

  Context {σ : scope_system} `{Funext}.

  Definition copair_instantiation
      {Σ} {a b : arity σ} {γ}
      (Ia : instantiation a Σ γ)
      (Ib : instantiation b Σ γ)
    : instantiation (a+b) Σ γ.
  Proof.
    intros [i | j].
    - apply Ia.
    - apply Ib.
  Defined.

  Definition copair_instantiation_inl
      {Σ} {a b : arity σ} {γ}
      (Ia : instantiation a Σ γ)
      (Ib : instantiation b Σ γ)
      {cl} {δ} (e : raw_expression (extend Σ a) cl δ)
    : instantiate_expression
        (copair_instantiation Ia Ib)
        (Expression.fmap (fmap2 _ Family.inl) e)
      = instantiate_expression Ia e.
  Proof.
    apply instantiate_fmap2.
  Defined.

  Definition copair_instantiation_inr
      {Σ} {a b : arity σ} {γ}
      (Ia : instantiation a Σ γ)
      (Ib : instantiation b Σ γ)
      {cl} {δ} (e : raw_expression (extend Σ b) cl δ)
    : instantiate_expression
        (copair_instantiation Ia Ib)
        (Expression.fmap (fmap2 _ Family.inr) e)
      = instantiate_expression Ib e.
  Proof.
    apply instantiate_fmap2.
  Defined.

End Copair_Instantiation.


(*
This project is an attempt at formalising the proof of DRF-SC for the repaired
C11 memory model presented in the article (Repairing Sequential Consistency in
C/C++11; Lahav, Vafeiadis, Kang et al., PLDI 2017)

Author: Quentin Ladeveze, Inria Paris, France
*)

From RelationAlgebra Require Import
  lattice prop monoid rel kat_tac normalisation kleene kat rewriting.
From RC11 Require Import util proprel_classic.
From RC11 Require Import exec.
Require Import Ensembles Classical_Prop.

Open Scope rel_notations.

(** This file defines what it means to be valid on the RC11 memory model *)

Section RC11.

Variable ex: Execution.

(** ** Release sequence *)

(** The release sequence of a write event contains the write itself (if it is
atomic) and all later atomic writes to the same location in the same thread, as
well as all read-modify-write that recursively read from such writes. *)

Definition rs  :=
  [W] ⋅ (res_eq_loc (sb ex)) ? ⋅ [W] ⋅ [Mse Rlx] ⋅ ((rf ex) ⋅ (rmw ex)) ^*.

Lemma rfrmw_rtc_same_loc (x y: Event):
  valid_exec ex ->
  (rf ex⋅rmw ex)^* x y ->
  get_loc x = get_loc y.
Proof.
  intros Hval. generalize x y. eapply rtc_ind.
  - intros z1 z2 [z3 Hrf Hrmw].
    apply (rf_same_loc _ Hval) in Hrf.
    apply (rmw_same_loc _ Hval) in Hrmw.
    congruence.
  - intuition auto.
  - intuition congruence.
Qed.

Lemma rfrmw_rtc_rf_same_loc (x y: Event):
  valid_exec ex ->
  ((rf ex⋅rmw ex)^*⋅(rf ex)) x y ->
  get_loc x = get_loc y.
Proof.
  intros Hval [z Hrel Hrf].
  apply (rfrmw_rtc_same_loc _ _ Hval) in Hrel.
  apply (rf_same_loc _ Hval) in Hrf.
  congruence.
Qed.

Lemma rs_same_loc (x y: Event):
  valid_exec ex ->
  rs x y ->
  get_loc x = get_loc y.
Proof.
  intros Hval Hrs.
  destruct Hrs as [z Hsbloc Hrfrmw].
  destruct Hsbloc as [z2 Hsbloc [Heq1 _]]; rewrite Heq1 in Hsbloc.
  destruct Hsbloc as [z3 Hsbloc [Heq2 _]]; rewrite Heq2 in Hsbloc.
  destruct Hsbloc as [z4 [Heq3 _] Hsbloc]; rewrite <-Heq3 in Hsbloc.
  destruct Hsbloc as [[_ Heq4]|Heq4];
  apply (rfrmw_rtc_same_loc _ _ Hval) in Hrfrmw; congruence.
Qed.

Lemma rsrf_same_loc (x y: Event):
  valid_exec ex ->
  (rs⋅rf ex) x y ->
  get_loc x = get_loc y.
Proof.
  intros Hval [z Hrs Hrf].
  apply (rs_same_loc _ _ Hval) in Hrs.
  apply (rf_same_loc _ Hval) in Hrf.
  congruence.
Qed.

(** ** Synchronises with *)

(** A release event [a] synchronises with an acquire event [b] whenever [b] (or,
in case [b] is a fence, a [sb]-prior read) reads from the release sequence of
[a] *)

Definition sw :=
  [Mse Rel] ⋅ ([F] ⋅ (sb ex)) ? ⋅ rs ⋅ (rf ex) ⋅ [R] ⋅ [Mse Rlx] ⋅ ((sb ex) ⋅ [F]) ? ⋅ [Mse Acq].

(** The synchronises-with relation is included in the transitive closure of the
union of sequenced-before and reads-from *)

Lemma sw_incl_sbrf:
  valid_exec ex ->
  sw ≦ ((sb ex) ⊔ (rf ex))^+.
Proof.
  intros Hval.
  unfold sw, rs. rewrite (rmw_incl_sb _ Hval).
  rewrite res_eq_loc_incl_itself. kat.
Qed.

(** ** Happens-before *)

(** Intuitively, the happens-before relation records when an event is globally
perceived as occurring before another one.
We say that an event happens-before another one if there is a path between the
two events consisting of [sb] and [sw] edges *)

Definition hb  :=
  ((sb ex) ⊔ sw)^+.

(** The happens-before relation is included in the transitive closure of the
union of sequenced-before and reads-from *)

Lemma hb_incl_sbrf:
  valid_exec ex ->
  hb ≦ ((sb ex) ⊔ (rf ex))^+.
Proof.
  intros Hval.
  unfold hb. rewrite (sw_incl_sbrf Hval). kat.
Qed.

(** sequenced-before is included in happens-before *)

Lemma sb_incl_hb:
  sb ex ≦ hb.
Proof.
  unfold hb. kat.
Qed.

(** ** SC-before *)

Definition scb :=
 (sb ex) ⊔  ((res_neq_loc (sb ex)) ⋅ hb ⋅ (res_neq_loc (sb ex))) ⊔ (res_eq_loc hb) ⊔ (mo ex) ⊔  (rb ex).

(** happens-before can be decomposed in a subset of happens-before included in
SC-before, and the rest of happens-before *)

Lemma hb_dcmp:
  valid_exec ex ->
  hb = ((sb ex) ⊔  ((res_neq_loc (sb ex)) ⋅ hb ⋅ (res_neq_loc (sb ex))) ⊔ (res_eq_loc hb)) ⊔
       ((res_eq_loc (sb ex) ⋅ hb) ⊔
        (hb ⋅ res_eq_loc (sb ex)) ⊔
        (sw ⋅ hb) ⊔
        (hb ⋅ sw) ⊔
        sw).
Proof.
  intros Hval. apply ext_rel, antisym.
  - intros x y Hrel.
    unfold hb in Hrel. rewrite tc_inv_dcmp2 in Hrel.
    destruct Hrel as [z Hxz Hhb].
    rewrite rtc_inv_dcmp6 in Hhb.
    destruct Hhb as [Hzy|Hhb].
    { simpl in Hzy. rewrite Hzy in Hxz. destruct Hxz as [Hxz|Hxz].
      - left; left; left. auto.
      - right; right. auto.
    }
    rewrite tc_inv_dcmp in Hhb. destruct Hhb as [w Hhb Hwy].
    rewrite rtc_inv_dcmp6 in Hhb. destruct Hhb as [Hzw|Hzw].
    + simpl in Hzw. rewrite <-Hzw in Hwy.
      destruct Hxz as [Hxz|Hxz]; destruct Hwy as [Hwy|Hwy].
      * left; left; left. apply (sb_trans _ Hval). exists z; auto.
      * right; left; right. exists z; auto.
        unfold hb. incl_rel_kat Hxz.
      * right; left; left; right. exists z; auto.
        unfold hb. incl_rel_kat Hwy.
      * right; left; right. exists z; auto.
        unfold hb. incl_rel_kat Hxz.
    + destruct Hxz as [Hxz|Hxz]; destruct Hwy as [Hwy|Hwy].
      * destruct (classic (get_loc x = get_loc z)) as [Heqxz|Hneqxz].
        { right; left; left; left; left. exists z.
          - split; auto.
          - unfold hb. rewrite tc_inv_dcmp. exists w.
            + incl_rel_kat Hzw.
            + incl_rel_kat Hwy.
        }
        destruct (classic (get_loc w = get_loc y)).
        { right; left; left; left; right. exists w.
          - unfold hb. rewrite tc_inv_dcmp2. exists z.
            + incl_rel_kat Hxz.
            + incl_rel_kat Hzw.
          - split; auto.
        }
        left; left; right.
        { exists w. exists z.
          - split; auto.
          - unfold hb. auto.
          - split; auto.
        }
      * right; left; right.
        exists w; auto.
        unfold hb. rewrite tc_inv_dcmp2. exists z.
        -- incl_rel_kat Hxz.
        -- incl_rel_kat Hzw.
      * right; left; left; right.
        exists z; auto.
        unfold hb. rewrite tc_inv_dcmp. exists w.
        -- incl_rel_kat Hzw.
        -- incl_rel_kat Hwy.
      * right; left; left; right.
        exists z; auto.
        unfold hb. rewrite tc_inv_dcmp. exists w.
        -- incl_rel_kat Hzw.
        -- incl_rel_kat Hwy.
  - unfold hb. intros x y [[[Hrel|Hrel]|Hrel]|
                           [[[[Hrel|Hrel]|Hrel]|Hrel]|Hrel]];
    try (incl_rel_kat Hrel).
    + destruct Hrel as [z [w [Hr1 _] Hr2] [Hr3 _]].
      rewrite tc_inv_dcmp2. exists w.
      { incl_rel_kat Hr1. }
      rewrite rtc_inv_dcmp6. right.
      rewrite tc_inv_dcmp. exists z.
      * incl_rel_kat Hr2.
      * incl_rel_kat Hr3.
    + destruct Hrel as [Hrel _]. auto.
    + destruct Hrel as [z [Hr1 _] Hr2].
      rewrite tc_inv_dcmp2. exists z.
      * incl_rel_kat Hr1.
      * incl_rel_kat Hr2.
    + destruct Hrel as [z Hr1 [Hr2 _]].
      rewrite tc_inv_dcmp. exists z.
      * incl_rel_kat Hr1.
      * incl_rel_kat Hr2.
Qed.

(** ** Partial-SC base *)

(** We give a semantic to SC atomics by enforcing the order in which they should
occur *)

Definition psc_base :=
  ([M Sc] ⊔ (([F] ⋅ [M Sc]) ⋅ (hb ?))) ⋅
  (scb) ⋅
  ([M Sc] ⊔ ((hb ?) ⋅ ([F] ⋅ [M Sc]))).

(** ** Partial-SC fence *)

(** We give a semantic to SC fences by enforcing the order in which they should
occur *)

Definition psc_fence :=
  [F] ⋅ [M Sc] ⋅ (hb ⊔ (hb ⋅ (eco ex) ⋅ hb)) ⋅ [F] ⋅ [M Sc].

(** ** Partial SC *)

Definition psc :=
  psc_base ⊔ psc_fence.

(** * RC11-consistency *)

(** ** Coherence *)

(** The coherence condition is also called SC-per-location. It guarantees that,
if we consider only the events on one location in the execution, the subset of
the execution is sequentially consistent. In practice, it forbids a set of
patterns in executions. These patterns are detailed in proposition 1 of section
3.4 in the article, and we prove that they are indeed forbidden by the coherence
condition *)

Definition coherence :=
  forall x, ~(hb ⋅ (eco ex) ?) x x.

(** In a coherent execution, [hb] is irreflexive. This means that an event
should not occur before itself. *)

Lemma coherence_irr_hb:
  coherence -> (forall x, ~hb x x).
Proof.
  intros H x Hnot.
  apply (H x). exists x.
  - auto.
  - right. simpl; auto.
Qed.

(** In a coherent execution, [rf];[hb] is irreflexive. This means that an event
should not read a value written by a write event occuring in the future. *)

Lemma coherence_no_future_read:
  coherence -> (forall x, ~ ((rf ex) ⋅ hb) x x).
Proof.
  intros H x Hnot.
  destruct Hnot.
  eapply H. exists x.
  - eauto.
  - left. apply tc_incl_itself. left. left. auto.
Qed.

(** In a coherent execution, [mo];[rf];[hb] is irreflexive. This means that a
write [w1] can not occur in modification order before a write [w2], if the value
written by [w2] was read by a read event sequenced before [w1]. It forbids the
following pattern in executions:

<<
     rf
 Wx----->Rx
 ^        |
 |        |sb
 |        v
 +------+Wx
     mo
>>
*)

Lemma coherence_coherence_rw:
  coherence -> (forall x, ~ ((mo ex) ⋅ (rf ex) ⋅ hb) x x).
Proof.
  intros H x Hnot.
  destruct Hnot as [z [z' Hmo Hrf] Hhb].
  apply (H z). exists x.
  - auto.
  - left. apply tc_trans with (y := z'); apply tc_incl_itself.
    + left. right. auto.
    + left. left. auto.
Qed.

(** In a coherent execution, [mo];[hb] is irreflexive. This means that a write
can not modify the memory before a write that precedes it in sequenced-before *)

Lemma coherence_coherence_ww:
  coherence -> (forall x, ~ ((mo ex) ⋅ hb) x x).
Proof.
  intros H x Hnot.
  destruct Hnot as [z Hmo Hhb].
  apply (H z). exists x.
  - auto.
  - left. apply tc_incl_itself. left. right. auto.
Qed.

(** In a coherent execution, [mo];[hb];[rf-1] is irreflexive. This means that
a read event cannot read from a write event whose value has been overwritten
by another write, preceding the read in sequenced before. It forbids the
following pattern in executions:

<<
      mo
  Wx----->Wx
  |        |
  |        | sb
  |        v
  +------>Rx
      rf
>>
*)

Lemma coherence_coherence_wr:
  coherence -> (forall x, ~ ((mo ex) ⋅ hb ⋅ (rf ex)°) x x).
Proof.
  intros H x Hnot.
  destruct Hnot as [z [y Hmo Hhb] Hinvrf].
  apply (H y). exists z.
  - auto.
  - left. apply tc_incl_itself.
    right.
    exists x; auto.
Qed.

(** In a coherent execution, [mo];[rf];[hb];[rf-1] is irreflexive. This means
that if two reads following each other in sequenced-before read values written
by two write events, these two write events must appear in the same order in the
modification order. We forbid the following pattern in executions:

<<
        rf
   Wx-------->Rx
   ^           |
 mo|           |sb
   |           v
   Wx+------->Rx
        rf
>>
*)

Lemma coherence_coherence_rr:
  coherence -> (forall x, ~ ((mo ex) ⋅ (rf ex) ⋅ hb ⋅ (rf ex)°) x x).
Proof.
  intros H x Hnot.
  destruct Hnot as [w [y' [z Hmo Hrf] Hhb] Hinvr].
  apply (H y'). exists w.
  - auto.
  - left. apply tc_trans with (y := z); apply tc_incl_itself.
    + right. exists x; auto.
    + left. left. auto.
Qed.

(** The coherence condition is equivalent to the uniproc condition in some other
memory models *)

Theorem coherence_is_uniproc:
  valid_exec ex -> coherence -> irreflexive ((sb ex) ⋅ (eco ex)).
Proof.
  intros Hval Hco.
  apply seq_refl_incl_left with (r3 := hb).
  - unfold sb, hb. kat.
  - rewrite (eco_rfmorb_seq_rfref _ Hval).
    unfold irreflexive.
    ra_normalise.
    repeat (rewrite union_inter).
    repeat (apply leq_cupx).
    + pose proof (coherence_no_future_read Hco).
      rewrite irreflexive_is_irreflexive in H. unfold irreflexive in H.
      apply refl_shift in H. auto.
    + pose proof (coherence_coherence_wr Hco).
      rewrite irreflexive_is_irreflexive in H. unfold irreflexive in H.
      apply refl_shift in H. rewrite dotA in H. apply refl_shift in H.
      fold rb in H. auto.
    + pose proof (coherence_coherence_ww Hco).
      rewrite irreflexive_is_irreflexive in H. unfold irreflexive in H.
      apply refl_shift in H. auto.
    + pose proof (coherence_coherence_rr Hco).
      rewrite irreflexive_is_irreflexive in H. unfold irreflexive in H.
      do 2 (apply refl_shift in H; repeat (rewrite dotA in H)).
      unfold rb. repeat (rewrite dotA). auto.
    + pose proof (coherence_coherence_rw Hco).
      rewrite irreflexive_is_irreflexive in H. unfold irreflexive in H.
      apply refl_shift in H. rewrite dotA in H. auto.
Qed.

(** ** Atomicity *)

(** Atomicity ensures that the read and the write composing a RMW pair are
adjacent in [eco]: there is no write event in between *)

Definition atomicity :=
  forall x y, ~ ((rmw ex) ⊓ ((rb ex) ⋅ (mo ex))) x y.

(** ** SC *)

(** The SC condition gives a semantic to SC atomics and fences in executions. It
is defined. It is defined  *)

Definition SC :=
  acyclic psc.

(** ** No-thin-air *)

(** We want to forbid out-of-thin-air, which means excluding executions where
the value written by a write event depends on the value read by a read event,
which reads from this same write event. *)

Definition no_thin_air :=
  acyclic ((sb ex) ⊔ (rf ex)).

(** ** RC11-consistent executions *)

(** An execution is RC11-consistent when it verifies the four conditions we just
defined *)

Definition rc11_consistent :=
  coherence /\ atomicity /\ SC /\ no_thin_air.

(** Coherence implies that [rf;rmw] is included in [mo] *)

Lemma coherence_rfrmw_incl_mo:
  valid_exec ex ->
  rc11_consistent ->
  (rf ex⋅rmw ex) ≦ mo ex.
Proof.
  intros Hval Hrc11 x y [z Hrf Hrmw].
  apply (rf_orig_write _ Hval) in Hrf as Hxw.
  apply (rmw_dest_write _ Hval) in Hrmw as Hyw.
  apply (rf_same_loc _ Hval) in Hrf as Hxzloc.
  apply (rmw_same_loc _ Hval) in Hrmw as Hzyloc.
  assert (x <> y).
  { intros Heq. rewrite Heq in Hrf.
    apply (rmw_incl_sb _ Hval) in Hrmw.
    destruct Hrc11 as [_ [_ [_ Hnoota]]]. eapply Hnoota.
    eapply tc_trans; [incl_rel_kat Hrf|incl_rel_kat Hrmw]. }
  destruct (loc_of_write _ Hxw) as [l Heqloc].
  inverse_val_exec Hval. destruct_mo_v Hmo_v.
  edestruct (Hmotot l x y) as [[Hmo _]|[Hmo _]].
  - auto.
  - repeat (apply conj); auto.
    eapply rf_orig_evts; eauto.
  - repeat (apply conj); auto.
    + eapply rmw_dest_evts; eauto.
    + congruence.
  - auto.
  - apply (rmw_incl_sb _ Hval) in Hrmw.
    destruct Hrc11 as [Hco _]. exfalso. apply (Hco z).
    exists y.
    + unfold hb. incl_rel_kat Hrmw.
    + left. eapply tc_trans.
      * incl_rel_kat Hmo.
      * incl_rel_kat Hrf.
Qed.

(** Coherence implies that [rmw] is included in [rb] *)

Lemma rc11_rmw_incl_rb:
  complete_exec ex ->
  rc11_consistent ->
  rmw ex ≦ (rb ex).
Proof.
  intros Hcomp [Hco _] x y Hrmw.
  inversion Hcomp as [Hval _].
  unfold coherence in Hco.
  unfold hb, eco in Hco.
  unfold rb. byabsurd.
  destruct (Hco x).
  assert (exists z, (rf ex) z x) as [z Hrf].
  { destruct Hcomp as [_ Hrf].
    unfold ran in Hrf. apply Hrf.
    split.
    - apply (rmw_orig_evts _ Hval _ y Hrmw).
    - apply (rmw_orig_read _ Hval _ y Hrmw).
  }
  destruct (classic (y = z)) as [Hyz|Hyz].
  - apply (rmw_incl_sb _ Hval) in Hrmw.
    rewrite <-Hyz in Hrf.
    exists y.
    + apply tc_incl_itself. left. auto.
    + left. apply tc_incl_itself. left. left. auto.
  - assert (exists l, (get_loc y = Some l) /\ (get_loc z = Some l))
    as [l [Hl1 Hl2]].
    { apply (rf_dest_read _ Hval) in Hrf as Hxw.
      apply (rf_same_loc _ Hval) in Hrf.
      apply (rmw_same_loc _ Hval) in Hrmw.
      rewrite <-Hrmw, Hrf. destruct x.
      - exists l. intuition auto.
      - exists l. intuition auto.
      - simpl in Hxw. intuition auto.
    }
    edestruct (mo_diff_write _ Hval) as [Hmo|Hmo]; eauto.
    + repeat (apply conj).
      * apply (rmw_dest_evts _ Hval x). auto.
      * apply (rmw_dest_write _ Hval x). auto.
      * eauto.
    + repeat (apply conj).
      * apply (rf_orig_evts _ Hval _ x). auto.
      * apply (rf_orig_write _ Hval _ x). auto.
      * auto.
    + exists y.
      { apply (rmw_incl_sb _ Hval) in Hrmw.
        apply (incl_rel_thm Hrmw). kat. }
      left. apply tc_trans with z.
      * apply (incl_rel_thm Hmo). kat.
      * apply (incl_rel_thm Hrf). kat.
    + destruct Hcontr. exists z.
      * apply (incl_rel_thm Hrf). kat.
      * apply (incl_rel_thm Hmo). kat.
Qed.

Lemma rfrmw_rtc_rf_diff (x y: Event):
  valid_exec ex ->
  rc11_consistent ->
  ((rf ex⋅rmw ex)^*⋅rf ex) x y ->
  x <> y.
Proof.
  intros Hval Hrc11 Hrel Heq.
  destruct Hrc11 as [_ [_ [_ Hnoota]]].
  rewrite <-Heq in Hrel.
  eapply Hnoota. apply (incl_rel_thm Hrel).
  rewrite (rmw_incl_imm_sb _ Hval).
  rewrite imm_rel_incl_rel.
  kat.
Qed.

Lemma rsrf_diff (x y: Event):
  valid_exec ex ->
  rc11_consistent ->
  (rs⋅rf ex) x y ->
  x <> y.
Proof.
  intros Hval Hrc11 Hrsrf Heq.
  destruct Hrc11 as [_ [_ [_ Hnoota]]].
  rewrite <-Heq in Hrsrf.
  eapply Hnoota. apply (incl_rel_thm Hrsrf).
  unfold rs.
  rewrite res_eq_loc_incl_itself.
  rewrite (rmw_incl_imm_sb _ Hval).
  rewrite imm_rel_incl_rel.
  kat.
Qed.

Lemma rsrf_left_write (x y: Event):
  (rs⋅rf ex) x y ->
  is_write x.
Proof.
  intros Hrel.
  unfold rs in Hrel.
  repeat (rewrite seq_assoc in Hrel).
  destruct Hrel as [_ [_ Hw] _]. auto.
Qed.

Lemma rfrmw_rtc_rf_left_write (x y: Event):
  valid_exec ex ->
  ((rf ex⋅rmw ex)^*⋅rf ex) x y ->
  is_write x.
Proof.
  intros Hval [z Hrel Hrf].
  rewrite rtc_inv_dcmp6 in Hrel. destruct Hrel as [Hrel|Hrel].
  - simpl in Hrel. rewrite <-Hrel in Hrf.
    eapply rf_orig_write; eauto.
  - rewrite tc_inv_dcmp2 in Hrel. destruct Hrel as [z2 Hrel _].
    destruct Hrel as [? Hrf2 _].
    eapply rf_orig_write; eauto.
Qed.

(** * SC-consistent executions *)

(** An execution is SC-consistent if:

- The execution respects the atomicity condition
- The communication relation [eco] is compatible with the program order.
*)

Definition sc_consistent :=
  atomicity /\ acyclic ((sb ex) ⊔ (rf ex) ⊔ (mo ex) ⊔ (rb ex)).

Lemma sc_is_rc11:
  valid_exec ex ->
  sc_consistent ->
  rc11_consistent.
Proof.
  intros Hval [Hato Hsc]. split;[|split;[|split]].
  - intros x Hcyc. apply (Hsc x).
    eapply (incl_rel_thm Hcyc).
    unfold hb, eco, sw, rs.
    rewrite (rmw_incl_sb _ Hval).
    rewrite res_eq_loc_incl_itself. kat.
  - auto.
  - intros x Hcyc. apply (Hsc x).
    eapply (incl_rel_thm Hcyc).
    eapply tc_incl_2. unfold psc. eapply union_incl.
    + unfold psc_base, scb, res_eq_loc, res_neq_loc.
      rewrite leq_cap_l. rewrite leq_cap_l.
      unfold hb, eco, sw, rs.
      rewrite (rmw_incl_sb _ Hval).
      rewrite res_eq_loc_incl_itself. kat.
    + unfold psc_fence, hb, sw, rs, eco.
      rewrite (rmw_incl_sb _ Hval).
      rewrite res_eq_loc_incl_itself. kat.
  - intros x Hcyc. apply (Hsc x).
    eapply (incl_rel_thm Hcyc).
    kat.
Qed.

Lemma rc11_is_sc_rf_incl_hbloc:
  valid_exec ex ->
  (forall e, In _ (evts ex) e -> (get_mode e = Sc)) ->
  rf ex ≦ res_eq_loc hb.
Proof.
  intros Hval Hallsc x y.
  split;[|auto using (rf_same_loc _ Hval)].
  apply tc_incl_itself. right.
  apply (rf_orig_evts _ Hval) in H as Hxevts.
  apply (rf_dest_evts _ Hval) in H as Hyevts.
  apply Hallsc in Hxevts. apply Hallsc in Hyevts.
  exists y. exists y. exists y. exists y.
  exists x. exists x. exists x.
  + split; auto.
    destruct x; destruct m; compute in Hxevts;
    compute; intuition auto; congruence.
  + right. simpl; auto.
  + exists x. exists x. exists x. exists x.
    * split; auto. eapply rf_orig_write; eauto.
    * right. simpl. auto.
    * split; auto. eapply rf_orig_write; eauto.
    * split; auto. destruct x; destruct m; compute in Hxevts;
      compute; intuition auto; congruence.
    * rewrite rtc_inv_dcmp6. left. simpl. auto.
  + auto.
  + split; auto. eapply rf_dest_read; eauto.
  + destruct y; destruct m; compute in Hyevts;
    compute; intuition auto; congruence.
  + right. simpl; auto.
  + destruct y; destruct m; compute in Hyevts;
    compute; intuition auto; congruence.
Qed.

Lemma rc11_is_sc_aux:
  valid_exec ex ->
  (forall e, In _ (evts ex) e -> (get_mode e = Sc)) ->
  (sb ex ⊔ (eco ex)) ≦ (hb ? ⋅ scb ⋅ hb ?)^+.
Proof.
  intros Hval Hallsc.
  apply union_incl.
  { unfold scb. kat. }
  eapply tc_incl_2.
  apply union_incl;[apply union_incl|].
  - intros x y H. apply tc_incl_itself.
    exists y; [|right;simpl;auto].
    exists x; [right;simpl;auto|].
    left; left; right. eapply rc11_is_sc_rf_incl_hbloc; eauto.
  - unfold scb. kat.
  - unfold scb. kat.
Qed.

Lemma rc11_is_sc:
  valid_exec ex ->
  (forall e, In _ (evts ex) e -> (get_mode e = Sc)) ->
  rc11_consistent ->
  sc_consistent.
Proof.
  intros Hval Hallsc [_ [Hato [Hpsc _]]].
  split. auto.
  intros x Hcyc. apply (Hpsc x).
  eapply (incl_rel_thm Hcyc).
  eapply tc_incl. eapply incl_union_left.
  intros y z Hrel. exists z. exists y.
  - left. split; auto. unfold M. eapply Hallsc.
    eapply sbrfmorb_in_l; eauto.
  - destruct Hrel as [[[Hrel|Hrel]|Hrel]|Hrel]; eapply (incl_rel_thm Hrel).
    + unfold scb. kat.
    + erewrite rc11_is_sc_rf_incl_hbloc; eauto.
      unfold scb. kat.
    + unfold scb. kat.
    + unfold scb. kat.
  - left. split; auto. unfold M. eapply Hallsc.
    eapply sbrfmorb_in_r; eauto.
Qed.

(** If the modification order of a valid execution is empty (meaning there is
one or zero write), the execution is SC-consistent *)

Lemma empty_mo_atomicity:
  valid_exec ex ->
  (mo ex) = empty ->
  atomicity.
Proof.
  intros Hval Hmoempty.
  intros x y [_ [z _ H]].
  rewrite Hmoempty in H.
  destruct H.
Qed.

Lemma empty_mo_ac_eco:
  valid_exec ex ->
  no_thin_air ->
  (mo ex) = empty ->
  acyclic ((sb ex) ⊔ (rf ex) ⊔ (mo ex) ⊔ (rb ex)).
Proof.
  intros Hval Hnoota Hmoempty x Hcyc.
  unfold rb in Hcyc. rewrite Hmoempty in Hcyc.
  apply (Hnoota x). incl_rel_kat Hcyc.
Qed.

Lemma empty_mo_sc_consistent:
  valid_exec ex ->
  no_thin_air ->
  (mo ex) = empty ->
  sc_consistent.
Proof.
  intros Hval Hnoota Hmoempty.
  split.
  - eapply empty_mo_atomicity; eauto.
  - eapply empty_mo_ac_eco; eauto.
Qed.

Lemma not_sc_not_empty_mo:
  valid_exec ex ->
  no_thin_air ->
  ~sc_consistent ->
  (mo ex) <> empty.
Proof.
  intuition auto using empty_mo_sc_consistent.
Qed.

End RC11.


Require Import Undecidability.Synthetic.Undecidability.

Require Import Undecidability.StringRewriting.SR.
Require Import Undecidability.TM.SBTM_undec.

Require Undecidability.StringRewriting.Reductions.SBTM_HALT_to_SR.
Require Undecidability.StringRewriting.Reductions.SBTM_HALT_to_TSR.

(* String rewriting is undecidable. *)
Lemma SR_undec : undecidable SR.
Proof.
  apply (undecidability_from_reducibility SBTM_HALT_undec).
  exact SBTM_HALT_to_SR.reduction.
Qed.

Check SR_undec.

(* Thue system reachability is undecidable. *)
Lemma TSR_undec : undecidable TSR.
Proof.
  apply (undecidability_from_reducibility SBTM_HALT_undec).
  exact SBTM_HALT_to_TSR.reduction.
Qed.

Check TSR_undec.