(* Deep embedding of a subset of SigmaHCOL *)

Require Import Coq.Strings.String.
Require Import Coq.Arith.Compare_dec.

Require Import Helix.Tactics.HelixTactics.
Require Import Helix.Util.Misc.

Require Import Helix.MSigmaHCOL.Memory.
Require Import Helix.MSigmaHCOL.MemSetoid.
Require Import Helix.MSigmaHCOL.CType.

Require Import MathClasses.interfaces.abstract_algebra.
Require Import MathClasses.interfaces.canonical_names.
Require Import MathClasses.implementations.peano_naturals.
Require Import MathClasses.misc.decision.

Require Import Helix.DSigmaHCOL.NType.

Global Open Scope nat_scope.

Module Type MDSigmaHCOL (Import CT: CType) (Import NT: NType).

  Include MMemSetoid CT.

  (* Variable on stack (De-Brujn index) *)
  Definition var_id := nat.

  Inductive DSHType :=
  | DSHnat : DSHType
  | DSHCType : DSHType
  (* pointer to memory block of size [n] *)
  | DSHPtr (n:NT.t) : DSHType.

  Inductive DSHVal :=
  | DSHnatVal (n:NT.t): DSHVal
  | DSHCTypeVal (a:CT.t): DSHVal
  | DSHPtrVal (a:nat) (size:NT.t): DSHVal.

  (* Expressions which evaluate to `NT.t` *)
  Inductive NExpr : Type :=
  | NVar  : var_id -> NExpr
  | NConst: NT.t -> NExpr
  | NDiv  : NExpr -> NExpr -> NExpr
  | NMod  : NExpr -> NExpr -> NExpr
  | NPlus : NExpr -> NExpr -> NExpr
  | NMinus: NExpr -> NExpr -> NExpr
  | NMult : NExpr -> NExpr -> NExpr
  | NMin  : NExpr -> NExpr -> NExpr
  | NMax  : NExpr -> NExpr -> NExpr.

  (* Expressions which evaluate to [mem_block]  *)
  Inductive PExpr: Type :=
  | PVar:  var_id -> PExpr
  (*  | PConst:  constant memory addresses are not implemneted *)
  .

  (* Expressions which evaluate to [mem_block] *)
  Inductive MExpr: Type :=
  | MPtrDeref:  PExpr -> MExpr (* Dereference operator *)
  | MConst: mem_block -> NT.t -> MExpr. (* constant block with size *)

  (* Expressions which evaluate to `CType` *)
  Inductive AExpr : Type :=
  | AVar  : var_id -> AExpr
  | AConst: CT.t -> AExpr
  | ANth  : MExpr -> NExpr -> AExpr
  | AAbs  : AExpr -> AExpr
  | APlus : AExpr -> AExpr -> AExpr
  | AMinus: AExpr -> AExpr -> AExpr
  | AMult : AExpr -> AExpr -> AExpr
  | AMin  : AExpr -> AExpr -> AExpr
  | AMax  : AExpr -> AExpr -> AExpr
  | AZless: AExpr -> AExpr -> AExpr.

  (* Memory variable along with offset *)
  Definition MemRef: Type := (PExpr * NExpr).

  Inductive DSHOperator :=
  | DSHNop (* no-op. *)
  | DSHAssign (src dst: MemRef) (* formerly [Pick] and [Embed] *)
  | DSHIMap (n: nat) (x_p y_p: PExpr) (f: AExpr) (* formerly [Pointwise] *)
  | DSHBinOp (n: nat) (x_p y_p: PExpr) (f: AExpr) (* formerly [BinOp] *)
  | DSHMemMap2 (n: nat) (x0_p x1_p y_p: PExpr) (f: AExpr) (* No direct correspondance in SHCOL *)
  | DSHPower (n:NExpr) (src dst: MemRef) (f: AExpr) (initial: CT.t) (* formely [Inductor] *)
  | DSHLoop (n:nat) (body: DSHOperator) (* Formerly [IUnion] *)
  | DSHAlloc (size:NT.t) (body: DSHOperator) (* allocates new uninitialized memory block and puts pointer to it on stack. The new block will be visible in the scope of [body] *)
  | DSHMemInit (y_p: PExpr) (value: CT.t) (* Initialize memory block with given value *)
  | DSHSeq (f g: DSHOperator) (* execute [g] after [f] *)
  .

  Definition DSHType_of_DSHVal (v:DSHVal) :=
    match v with
    | DSHnatVal _ => DSHnat
    | DSHCTypeVal _ => DSHCType
    | DSHPtrVal _ size => DSHPtr size
    end.

  (* Some Setoid stuff below *)

  Inductive DSHType_equiv: Equiv DSHType :=
  | DSHnat_equiv: DSHType_equiv DSHnat DSHnat
  | DSHCType_equiv: DSHType_equiv DSHCType DSHCType
  | DSHPtr_equiv {s0 s1:NT.t}: s0 = s1 -> DSHType_equiv (DSHPtr s0) (DSHPtr s1).

  Existing Instance DSHType_equiv.

  Instance DSHType_equiv_Decision (a b:DSHType):
    Decision (equiv a b).
  Proof.
    simpl_relation.
    destruct a,b.
    1,5: left;constructor.
    7:{
      destruct (NTypeEqDec n n0).
      left;constructor;assumption.
      right; intros H; inv H; congruence.
    }
    all: right; intros H; inversion H.
  Qed.

  Inductive DSHVal_equiv: Equiv DSHVal :=
  | DSHnatVal_equiv {n0 n1:NT.t}: n0=n1 -> DSHVal_equiv (DSHnatVal n0) (DSHnatVal n1)
  | DSHCTypeVal_equiv {a b: CT.t}: a=b -> DSHVal_equiv (DSHCTypeVal a) (DSHCTypeVal b)
  | DSHPtrVal_equiv {p0 p1: nat} {s0 s1:NT.t}: s0 = s1 /\ p0=p1 -> DSHVal_equiv (DSHPtrVal p0 s0) (DSHPtrVal p1 s1).

  Existing Instance DSHVal_equiv.

  Instance DSHVar_Equivalence:
    Equivalence DSHVal_equiv.
  Proof.
    split.
    -
      intros x.
      destruct x; constructor; auto.
    -
      intros x y E.
      inversion E; constructor; try split; symmetry; apply H.
    -
      intros x y z Exy Eyz.
      inversion Exy; inversion Eyz; subst y; try inversion H3.
      +
        constructor.
        rewrite H.
        rewrite <- H5.
        apply H2.
      +
        constructor.
        rewrite <- H2.
        rewrite H5.
        apply H.
      +
        subst.
        constructor.
        destruct H as [Hs Hp].
        destruct H2 as [H2s H2p].
        split.
        * rewrite Hs; auto.
        * rewrite Hp; auto.
  Qed.

  Instance DSHVar_Setoid:
    @Setoid DSHVal DSHVal_equiv.
  Proof.
    apply DSHVar_Equivalence.
  Qed.

  Inductive NExpr_equiv: NExpr -> NExpr -> Prop :=
  | NVar_equiv  {n1 n2}: n1=n2 -> NExpr_equiv (NVar n1)  (NVar n2)
  | NConst_equiv {a b}: a=b -> NExpr_equiv (NConst a) (NConst b)
  | NDiv_equiv  {a a' b b'}: NExpr_equiv a a' -> NExpr_equiv b b' -> NExpr_equiv (NDiv a b)   (NDiv a' b')
  | NMod_equiv  {a a' b b'}: NExpr_equiv a a' -> NExpr_equiv b b' -> NExpr_equiv (NMod a b)   (NMod a' b')
  | NPlus_equiv {a a' b b'}: NExpr_equiv a a' -> NExpr_equiv b b' -> NExpr_equiv (NPlus a b)  (NPlus a' b')
  | NMinus_equiv {a a' b b'}: NExpr_equiv a a' -> NExpr_equiv b b' -> NExpr_equiv (NMinus a b) (NMinus a' b')
  | NMult_equiv {a a' b b'}: NExpr_equiv a a' -> NExpr_equiv b b' -> NExpr_equiv (NMult a b)  (NMult a' b')
  | NMin_equiv  {a a' b b'}: NExpr_equiv a a' -> NExpr_equiv b b' -> NExpr_equiv (NMin a b)   (NMin a' b')
  | NMax_equiv  {a a' b b'}: NExpr_equiv a a' -> NExpr_equiv b b' -> NExpr_equiv (NMax a b)   (NMax a' b').

  Instance NExpr_Equiv: Equiv NExpr  := NExpr_equiv.

  Instance NExpr_Equivalence:
    Equivalence NExpr_equiv.
  Proof.
    split.
    -
      intros x.
      induction x; constructor; auto.
    -
      intros x y E.
      induction E; constructor; try symmetry; assumption.
    -

      intros x y z.
      dependent induction x;
        dependent induction y;
        dependent induction z; intros Exy Eyz; try inversion Exy; try inversion Eyz; subst.
      + constructor; auto.
      + constructor; auto.
      + constructor; [apply IHx1 with (y:=y1); auto | apply IHx2 with (y:=y2); auto].
      + constructor; [apply IHx1 with (y:=y1); auto | apply IHx2 with (y:=y2); auto].
      + constructor; [apply IHx1 with (y:=y1); auto | apply IHx2 with (y:=y2); auto].
      + constructor; [apply IHx1 with (y:=y1); auto | apply IHx2 with (y:=y2); auto].
      + constructor; [apply IHx1 with (y:=y1); auto | apply IHx2 with (y:=y2); auto].
      + constructor; [apply IHx1 with (y:=y1); auto | apply IHx2 with (y:=y2); auto].
      + constructor; [apply IHx1 with (y:=y1); auto | apply IHx2 with (y:=y2); auto].
  Qed.

  Inductive PExpr_equiv : PExpr -> PExpr -> Prop :=
  | PVar_equiv {n0 n1}: n0=n1 -> PExpr_equiv (PVar n0) (PVar n1).

  Instance PExpr_Equiv: Equiv PExpr := PExpr_equiv.

  Instance PExpr_Equivalence:
    Equivalence PExpr_equiv.
  Proof.
    split.
    -
      intros x.
      induction x; constructor; auto.
    -
      intros x y E.
      induction E; constructor; try symmetry; assumption.
    -
      intros x y z Exy Eyz.
      induction Exy; inversion Eyz; subst;
        constructor; auto.
  Qed.

  Inductive MExpr_equiv : MExpr -> MExpr -> Prop :=
  | MPtrDeref_equiv {p0 p1}: p0=p1 -> MExpr_equiv (MPtrDeref p0) (MPtrDeref p1)
  | MConst_equiv {a b: mem_block} (asize bsize:NT.t) : (a=b /\ asize=bsize) -> MExpr_equiv (MConst a asize) (MConst b bsize).

  Instance MExpr_Equiv: Equiv MExpr := MExpr_equiv.

  Instance MExpr_Equivalence:
    Equivalence MExpr_equiv.
  Proof.
    split.
    -
      intros x.
      induction x; constructor; auto.
    -
      intros x y E.
      induction E.
      +
        constructor.
        symmetry.
        assumption.
      +
        constructor.
        destruct H.
        split;try symmetry; auto.
    -
      intros x y z Exy Eyz.

      induction Exy; inversion Eyz; subst.
      +
        destruct H1.
        constructor.
        rewrite <- H0.
        auto.
      +
        destruct H3.
        constructor.
        rewrite <- H0, <- H1.
        auto.
  Qed.

  Inductive AExpr_equiv: AExpr -> AExpr -> Prop :=
  | AVar_equiv  {n0 n1}: n0=n1 -> AExpr_equiv (AVar n0) (AVar n1)
  | AConst_equiv {a b}: a=b -> AExpr_equiv (AConst a) (AConst b)
  | ANth_equiv {v1 v2:MExpr} {n1 n2:NExpr} :
      NExpr_equiv n1 n2 ->
      MExpr_equiv v1 v2 ->
      AExpr_equiv (ANth v1 n1)  (ANth v2 n2)
  | AAbs_equiv  {a b}: AExpr_equiv a b -> AExpr_equiv (AAbs a)  (AAbs b)
  | APlus_equiv {a a' b b'}: AExpr_equiv a a' -> AExpr_equiv b b' -> AExpr_equiv (APlus a b) (APlus a' b')
  | AMinus_equiv{a a' b b'}: AExpr_equiv a a' -> AExpr_equiv b b' -> AExpr_equiv (AMinus a b) (AMinus a' b')
  | AMult_equiv {a a' b b'}: AExpr_equiv a a' -> AExpr_equiv b b' -> AExpr_equiv (AMult a b) ( AMult a' b')
  | AMin_equiv  {a a' b b'}: AExpr_equiv a a' -> AExpr_equiv b b' -> AExpr_equiv (AMin a b) (  AMin a' b')
  | AMax_equiv  {a a' b b'}: AExpr_equiv a a' -> AExpr_equiv b b' -> AExpr_equiv (AMax a b) (  AMax a' b')
  | AZless_equiv {a a' b b'}: AExpr_equiv a a' -> AExpr_equiv b b' -> AExpr_equiv (AZless a b) (AZless a' b').

  Instance AExpr_Equiv: Equiv AExpr := AExpr_equiv.

  Instance AExpr_Equivalence:
    Equivalence AExpr_equiv.
  Proof.
    split.
    -
      intros x.
      induction x; constructor; auto; reflexivity.
    -
      intros x y.
      dependent induction x; dependent induction y; intros E; try inversion E; subst.
      + constructor; auto.
      + constructor; auto.
      + constructor.
        * symmetry; auto.
        *
          inversion E.
          inv_exitstT.
          subst.
          symmetry.
          auto.
      + constructor; apply IHx; auto.
      + constructor;[ apply IHx1; auto | apply IHx2; auto].
      + constructor;[ apply IHx1; auto | apply IHx2; auto].
      + constructor;[ apply IHx1; auto | apply IHx2; auto].
      + constructor;[ apply IHx1; auto | apply IHx2; auto].
      + constructor;[ apply IHx1; auto | apply IHx2; auto].
      + constructor;[ apply IHx1; auto | apply IHx2; auto].
    -
      intros x y z.
      dependent induction x;
        dependent induction y;
        dependent induction z; intros Exy Eyz; try inversion Exy; try inversion Eyz; subst.
      + constructor; auto.
      + constructor; auto.
      +
        inversion Exy. inversion Eyz.
        inv_exitstT; subst.
        constructor.
        apply transitivity with (y:=n0); auto.
        eapply transitivity with (y:=m0); auto.
      + constructor; apply IHx with (y:=y); auto.
      + constructor; [apply IHx1 with (y:=y1); auto | apply IHx2 with (y:=y2); auto].
      + constructor; [apply IHx1 with (y:=y1); auto | apply IHx2 with (y:=y2); auto].
      + constructor; [apply IHx1 with (y:=y1); auto | apply IHx2 with (y:=y2); auto].
      + constructor; [apply IHx1 with (y:=y1); auto | apply IHx2 with (y:=y2); auto].
      + constructor; [apply IHx1 with (y:=y1); auto | apply IHx2 with (y:=y2); auto].
      + constructor; [apply IHx1 with (y:=y1); auto | apply IHx2 with (y:=y2); auto].
  Qed.

  Inductive DSHOperator_equiv: relation DSHOperator :=
  | heq_DSHNop: DSHOperator_equiv DSHNop DSHNop
  | heq_DSHAssign:
      forall src_p src_n dst_p dst_n src_p' src_n' dst_p' dst_n',
        src_n = src_n' ->
        dst_n = dst_n' ->
        src_p = src_p' ->
        dst_p = dst_p' ->
        DSHOperator_equiv (DSHAssign (src_p,src_n) (dst_p, dst_n))
                          (DSHAssign (src_p',src_n') (dst_p', dst_n'))
  | heq_DSHIMap:
      forall n x_p y_p f n' x_p' y_p' f',
        n=n' ->
        x_p = x_p' ->
        y_p = y_p' ->
        f = f' ->
        DSHOperator_equiv (DSHIMap n x_p y_p f) (DSHIMap n' x_p' y_p' f')

  | heq_DSHBinOp:
      forall n x_p y_p f n' x_p' y_p' f',
        n=n' ->
        x_p = x_p' ->
        y_p = y_p' ->
        f = f' ->
        DSHOperator_equiv (DSHBinOp n x_p y_p f) (DSHBinOp n' x_p' y_p' f')
  | heq_DSHMemMap2:
      forall n x0_p x1_p y_p f n' x0_p' x1_p' y_p' f',
        n=n' ->
        x0_p = x0_p' ->
        x1_p = x1_p' ->
        y_p = y_p' ->
        f = f' ->
        DSHOperator_equiv (DSHMemMap2 n x0_p x1_p y_p f) (DSHMemMap2 n' x0_p' x1_p' y_p' f')
  | heq_DSHPower:
      forall n src_p src_n dst_p dst_n f ini n' src_p' src_n' dst_p' dst_n' f' ini',
        n = n' ->
        src_n = src_n' ->
        dst_n = dst_n' ->
        src_p = src_p' ->
        dst_p = dst_p' ->
        f = f' ->
        ini = ini' ->
        DSHOperator_equiv
          (DSHPower n (src_p,src_n) (dst_p, dst_n) f ini)
          (DSHPower n' (src_p',src_n') (dst_p', dst_n') f' ini')
  | heq_DSHLoop:
      forall n n' body body',
        n=n' ->
        DSHOperator_equiv body body' ->
        DSHOperator_equiv (DSHLoop n body) (DSHLoop n' body')
  | heq_DSHAlloc:
      forall n n' body body',
        n = n' ->
        DSHOperator_equiv body body' ->
        DSHOperator_equiv (DSHAlloc n body) (DSHAlloc n' body')
  | heq_DSHMemInit:
      forall p p' v v',
        p = p' ->
        v = v' ->
        DSHOperator_equiv (DSHMemInit p v) (DSHMemInit p' v')
  | heq_DSHSeq:
      forall f f' g g',
        DSHOperator_equiv f f' ->
        DSHOperator_equiv g g' ->
        DSHOperator_equiv (DSHSeq f g) (DSHSeq f' g').

  Instance DSHOperator_Equiv : Equiv DSHOperator := DSHOperator_equiv.

  Instance DSHOperator_equiv_Equivalence :
    Equivalence DSHOperator_Equiv.
  Proof.
    unfold DSHOperator_Equiv.
    constructor.
    -
      intros op.
      induction op;
        try destruct src, dst;
        now constructor.
    -
      intros op1 op2 E.
      induction E; now constructor.
    -
      intros op1 op2 op3 E1 E2.
      generalize dependent op3.
      induction E1;
        intros.
      all: inv E2.
      all: repeat constructor.
      all: auto.
  Qed.

  Definition incrPVar (skip:nat) (p: PExpr): PExpr :=
    match p with
    | PVar var_id =>
      PVar (if le_dec skip var_id then (S var_id) else var_id)
    end.

  Definition incrMVar (skip:nat) (m: MExpr): MExpr :=
    match m with
    | MPtrDeref p => MPtrDeref (incrPVar skip p)
    | _ => m
    end.

  Fixpoint incrNVar (skip:nat) (p: NExpr): NExpr :=
    match p with
    | NVar var_id => NVar (if le_dec skip var_id then (S var_id) else var_id)
    | NConst _ => p
    | NDiv  a b => NDiv (incrNVar skip a) (incrNVar skip b)
    | NMod  a b => NMod (incrNVar skip a) (incrNVar skip b)
    | NPlus a b => NPlus (incrNVar skip a) (incrNVar skip b)
    | NMinus a b => NMinus (incrNVar skip a) (incrNVar skip b)
    | NMult a b => NMult (incrNVar skip a) (incrNVar skip b)
    | NMin  a b => NMin (incrNVar skip a) (incrNVar skip b)
    | NMax  a b => NMax (incrNVar skip a) (incrNVar skip b)
    end.

  Fixpoint incrAVar (skip:nat) (p: AExpr) : AExpr :=
    match p with
    | AVar var_id => AVar (if le_dec skip var_id then (S var_id) else var_id)
    | AConst _ => p
    | ANth m n =>  ANth (incrMVar skip m) (incrNVar skip n)
    | AAbs a => AAbs (incrAVar skip a)
    | APlus  a b => APlus (incrAVar skip a) (incrAVar skip b)
    | AMinus a b => AMinus (incrAVar skip a) (incrAVar skip b)
    | AMult  a b => AMult (incrAVar skip a) (incrAVar skip b)
    | AMin   a b => AMin (incrAVar skip a) (incrAVar skip b)
    | AMax   a b => AMax (incrAVar skip a) (incrAVar skip b)
    | AZless a b => AZless (incrAVar skip a) (incrAVar skip b)
    end.

  Definition incrDSHIUnCType (skip:nat) := incrAVar (skip + 2).
  Definition incrDSHIBinCType (skip:nat) := incrAVar (skip + 3).
  Definition incrDSHBinCType (skip:nat) := incrAVar (skip + 2).

  Fixpoint incrOp (skip:nat) (d:DSHOperator) : DSHOperator
    := match d with
       | DSHNop => DSHNop
       | DSHAssign (src_p,src_o) (dst_p,dst_o) => DSHAssign (incrPVar skip src_p, incrNVar skip src_o) (incrPVar skip dst_p, incrNVar skip dst_o)
       | DSHIMap n x_p y_p f => DSHIMap n (incrPVar skip x_p) (incrPVar skip y_p) (incrDSHIUnCType skip f)
       | DSHBinOp n x_p y_p f => DSHBinOp n (incrPVar skip x_p) (incrPVar skip y_p) (incrDSHIBinCType skip f)
       | DSHMemMap2 n x0_p x1_p y_p f => DSHMemMap2 n (incrPVar skip x0_p) (incrPVar skip x1_p) (incrPVar skip y_p) (incrDSHBinCType skip f)
       | DSHPower n (src_p,src_o) (dst_p,dst_o) f initial =>
         DSHPower (incrNVar skip n) (incrPVar skip src_p, incrNVar skip src_o) (incrPVar skip dst_p, incrNVar skip dst_o) (incrDSHBinCType skip f) initial
       | DSHLoop n body => DSHLoop n (incrOp (S skip) body)
       | DSHAlloc size body => DSHAlloc size (incrOp (S skip) body)
       | DSHMemInit y_p value => DSHMemInit (incrPVar skip y_p) value
       | DSHSeq f g => DSHSeq (incrOp skip f) (incrOp skip g)
       end.

  Section Printing.

    Local Open Scope string_scope.

    Variable string_of_ct : CT.t -> string.

    (* List of keys of elements in memblock as string.
       E.g. "{1,2,5}"
     *)
    Definition string_of_mem_block_keys (m:mem_block) : string
      :=
        "{"++(concat "," (List.map string_of_nat (mem_keys_lst m)))++"}".

    Definition string_of_PExpr (p:PExpr) : string :=
      match p with
      | PVar x => "(PVar " ++ string_of_nat x ++ ")"
      end.

    (* Coq [string] is extracted as [char list] in OCaml,
       and ["\n"] seems to become ['\\' :: 'n' :: nil] *)
    Definition newline := String (Ascii.ascii_of_nat 10) EmptyString.

    (* Notation "++" not recognized in [let] for some reason *)
    Definition string_of_mem_block (mb : mem_block) : string :=
      let append_pair (k : nat) (v : CT.t) (acc : string) : string :=
        acc ++
            "  " ++
            string_of_nat k ++ " -> " ++
            string_of_ct v ++ newline in
      NM.fold append_pair mb "".

    Definition string_of_memory (mb : memory) : string :=
      let append_pair (k : nat) (v : mem_block) (acc : string) :=
        acc ++
            string_of_nat k ++ " ==>" ++ newline ++
            string_of_mem_block v ++ newline in
      NM.fold append_pair mb "".

    Definition string_of_DSHVal (v : DSHVal) : string :=
      match v with
      | DSHnatVal n => string_of_nat (to_nat n)
      | DSHCTypeVal c => string_of_ct c
      | DSHPtrVal i _ => "ptr " ++ string_of_nat i
      end.

    Definition string_of_evalContext (σ : list (DSHVal * bool)) : string :=
      "[" ++
          concat ", " (List.map (fun '(v, _) => string_of_DSHVal v) σ) ++
          "]".

    Definition string_of_MExpr (m:MExpr) : string :=
      match m with
      | MPtrDeref p => "(MPtrDeref" ++ string_of_PExpr p ++ ")"
      | MConst _ _ => "MConst (printing not implemented)" (* TODO *)
      end.

    Fixpoint string_of_NExpr (n:NExpr) : string :=
      let binary op x y :=
        "(" ++ string_of_NExpr x ++ op ++ string_of_NExpr y ++ ")"
      in
      match n with
      | NVar v => "(NVar " ++ string_of_nat v ++ ")"
      | NConst c => NT.to_string c
      | NDiv   x y => binary " / " x y
      | NMod   x y => binary " % " x y
      | NPlus  x y => binary " + " x y
      | NMinus x y => binary " - " x y
      | NMult  x y => binary " * " x y
      | NMin   x y => binary " `min` " x y
      | NMax   x y => binary " `max` " x y
      end.

    Fixpoint string_of_AExpr (a:AExpr) : string :=
      let binary op x y :=
        "(" ++ string_of_AExpr x ++ op ++ string_of_AExpr y ++ ")"
      in
      match a with
      | AVar v => "(AVar " ++ string_of_nat v ++ ")"
      | AConst c => "(AConst " ++ string_of_ct c ++ ")"
      | ANth m n => "(ANth " ++ string_of_MExpr m ++ " " ++ string_of_NExpr n ++ ")"
      | AAbs x => "abs (" ++ string_of_AExpr x ++ ")"
      | APlus  x y => binary " + " x y
      | AMinus x y => binary " - " x y
      | AMult  x y => binary " * " x y
      | AMin   x y => binary " `min` " x y
      | AMax   x y => binary " `max` " x y
      | AZless x y => binary " <? " x y
      end.

    Definition string_of_MemRef (m:MemRef) : string :=
      let '(p,n) := m in
      "(" ++ string_of_PExpr p ++ "," ++ string_of_NExpr n ++ ")".

    Fixpoint string_of_DSHOperator (d : DSHOperator) : string :=
      "(" ++
      match d with
      | DSHNop => "DSHNop"
      | DSHAssign src dst =>
        "DSHAssign " ++
                     string_of_MemRef src ++ " " ++
                     string_of_MemRef dst ++ " "
      | DSHIMap n x_p y_p f =>
        "DSHIMap " ++
                   string_of_nat n ++ " " ++
                   string_of_PExpr x_p ++ " " ++
                   string_of_PExpr y_p ++ " " ++
                   string_of_AExpr f
      | DSHBinOp n x_p y_p f =>
        "DSHBinOp " ++
                    string_of_nat n ++ " " ++
                    string_of_PExpr x_p ++ " " ++
                    string_of_PExpr y_p ++ " " ++
                    string_of_AExpr f
      | DSHMemMap2 n x0_p x1_p y_p f =>
        "DSHMemMap2 " ++
                      string_of_nat n ++ " " ++
                      string_of_PExpr x0_p ++ " " ++
                      string_of_PExpr x1_p ++ " " ++
                      string_of_PExpr y_p ++ " " ++
                      string_of_AExpr f
      | DSHPower n src dst f initial =>
        "DSHPower " ++
                    string_of_NExpr n ++ " " ++
                    string_of_MemRef src ++ " " ++
                    string_of_MemRef dst ++ " " ++
                    string_of_AExpr f ++ " " ++
                    string_of_ct initial
      | DSHLoop n body =>
        "DSHLoop " ++
                   string_of_nat n ++ " " ++
                   string_of_DSHOperator body
      | DSHAlloc size body =>
        "DSHAlloc " ++
                    NT.to_string size ++ " " ++
                    string_of_DSHOperator body
      | DSHMemInit y_p value =>
        "DSHMemInit " ++
                      string_of_PExpr y_p ++ " " ++
                      string_of_ct value
      | DSHSeq f g => "DSHSeq " ++
                               string_of_DSHOperator f ++ " " ++
                               string_of_DSHOperator g
      end ++ ")".

  End Printing.

  Module DSHNotation.

    Notation "A ; B" := (DSHSeq A B) (at level 99, right associativity, only printing).
    Notation "A * B" := (AMult A B) (only printing).
    Notation "A - B" := (AMinus A B) (only printing).
    Notation "A + B" := (APlus A B) (only printing).
    Notation "A * B" := (NMult A B) (only printing).
    Notation "A - B" := (NMinus A B) (only printing).
    Notation "A + B" := (NPlus A B) (only printing).
    Notation "A %'N'" := (NConst A) (at level 99, only printing,
                                     format "A %'N'").

  End DSHNotation.

End MDSigmaHCOL.


Require Import Iron.Data.List.Base.

Fixpoint catOptions {A} (xs : list (option A)) : list A
 := match xs with
    | nil             => nil
    | Some x :: rest  => x :: catOptions rest
    | None   :: rest  => catOptions rest
    end.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2013-09-24

* Alternative definitions of alpha-equivalence
*)

Set Implicit Arguments.

From CoLoR Require Import LogicUtil LAlpha RelUtil BoolUtil.
From Coq Require Import Morphisms.

(***********************************************************************)
(** * Other definitions of alpha-equivalence. *)

Module Export Def.

  Section aeq.

    (** We assume given decidable sets [F] and [X] for function
    symbols and variables respectively. *)

    Variables (F X : Type)
      (eq_fun_dec : forall f g : F, {f=g}+{~f=g})
      (eq_var_dec : forall x y : X, {x=y}+{~x=y}).

    Notation Te := (@Te F X).
    Notation Var := (@Var F X).
    Notation Fun := (@Fun F X).
    Notation rename1 := (@rename1 F X eq_var_dec).

    (** We assume given a structure for finite sets on [X]. *)

    Variable ens_X : Ens X.

    Notation In := (@Ens_In X ens_X).
    Notation add := (@Ens_add X ens_X).
    Notation union := (@Ens_union X ens_X).
    Notation fv := (@fv F X ens_X).
    Notation bv := (@bv F X ens_X).

    (** We assume that [X] is infinite. *)

    Variable var_notin : Ens_type ens_X -> X.

    Notation rename := (@rename F X eq_fun_dec eq_var_dec ens_X var_notin).

(***********************************************************************)
(** Replace every occurrence of a variable [x] by [y], including
binding occurrences. *)

    Definition replace_var x y z :=
      match eq_var_dec z x with left _ => y | _ => z end.

    Fixpoint replace_all x y u :=
      match u with
        | Def.Var z => Var (replace_var x y z)
        | Def.Fun _ => u
        | Def.App u1 u2 => App (replace_all x y u1) (replace_all x y u2)
        | Def.Lam z v => Lam (replace_var x y z) (replace_all x y v)
      end.

    Lemma size_replace_all : forall x y t, size (replace_all x y t) = size t.

    Proof.
      intros x y. induction t; simpl. refl. refl.
      rewrite IHt1, IHt2. refl. rewrite IHt. refl.
    Qed.

(***********************************************************************)
(** Action of a function on variables, including binding occurrences. *)

  Fixpoint action (f : X -> X) u :=
    match u with
      | Def.Var x => Var (f x)
      | Def.Fun f => Fun f
      | Def.App u1 u2 => App (action f u1) (action f u2)
      | Def.Lam x v => Lam (f x) (action f v)
    end.

(***********************************************************************)
(** Permutation of x and y. *)

    Definition transpose_var x y z :=
      match eq_var_dec z x with
        | left _ => y
        | _ => match eq_var_dec z y with left _ => x | _ => z end
      end.

    Definition transpose x y := action (transpose_var x y).

(***********************************************************************)
(** ** Church's definition (1932)

in his first paper on lambda-calculus, "A set of postulates for the
foundations of logic", Annals of Mathematics, 33(2):346–366, 1932. *)

    Inductive aeq_ch_top : relation Te :=
    | aeq_ch_top_intro : forall L x y, ~In x (fv L) -> ~In y (fv L) ->
      ~In y (bv L) -> aeq_ch_top L (replace_all x y L).

    Definition aeq_ch : relation Te := clos_refl_trans (clos_mon aeq_ch_top).

(***********************************************************************)
(** ** Krivine's definition (1993)

in his book (in French) "Lambda-calcul, types et modèles", Ellis
Horwood, 1993. English translation due to René Cori available on
http://cel.archives-ouvertes.fr/cel-00574575/fr/ . *)

    Inductive aeq_kr : relation Te :=
    | aeq_kr_fun : forall f, aeq_kr (Fun f) (Fun f)
    | aeq_kr_var : forall x, aeq_kr (Var x) (Var x)
    | aeq_kr_app : forall u v u' v',
      aeq_kr u u' -> aeq_kr v v' -> aeq_kr (App u v) (App u' v')
    | aeq_kr_lam : forall x u x' u' xs,
      (forall y, ~In y xs -> aeq_kr (rename1 x y u) (rename1 x' y u')) ->
      aeq_kr (Lam x u) (Lam x' u').

(***********************************************************************)
(** ** Gabbay and Pitts's definition (1999)

in their paper "A New Approach to Abstract Syntax Involving Binders",
Proceedings of the 14th IEEE Symposium on Logic in Computer Science
(LICS), 1999. *)

    Inductive aeq_gp : relation Te :=
    | aeq_gp_refl_fun : forall f, aeq_gp (Fun f) (Fun f)
    | aeq_gp_refl_var : forall x, aeq_gp (Var x) (Var x)
    | aeq_gp_app : forall u v u' v',
      aeq_gp u u' -> aeq_gp v v' -> aeq_gp (App u v) (App u' v')
    | aeq_gp_lam : forall x u x' u' z,
      ~In z (union (add x (union (fv u) (bv u)))
                   (add x' (union (fv u') (bv u')))) ->
      aeq_gp (transpose z x u) (transpose z x' u') ->
      aeq_gp (Lam x u) (Lam x' u').

  End aeq.

End Def.

(***********************************************************************)
(** * Properties of and relations between these different definitions. *)

Module Make (Export L : L_Struct).

  Module Export A := LAlpha.Make L.

  Notation replace_var := (@replace_var X XOrd.eq_dec).
  Notation replace_all := (@replace_all F X XOrd.eq_dec).
  Notation transpose_var := (@transpose_var X XOrd.eq_dec).
  Notation transpose := (@transpose F X XOrd.eq_dec).
  Notation aeq_ch_top := (@aeq_ch_top F X XOrd.eq_dec ens_X).
  Notation aeq_ch := (@aeq_ch F X XOrd.eq_dec ens_X).
  Notation aeq_kr := (@aeq_kr F X XOrd.eq_dec ens_X).
  Notation aeq_gp := (@aeq_gp F X XOrd.eq_dec ens_X).
  Notation action := (@action F X).

(***********************************************************************)
(** ** Properties of [replace_var]. *)

  Lemma replace_var_eq x y : replace_var x y x = y.

  Proof. unfold Def.replace_var. eq_dec x x; fo. Qed.

  Lemma replace_var_id x y : replace_var x x y = y.

  Proof. unfold Def.replace_var. eq_dec y x; fo. Qed.

  Lemma replace_var2 x y z :
    x = z \/ y <> z -> replace_var y x (replace_var x y z) = z.

  Proof.
    intro h. unfold Def.replace_var. eq_dec z x.
    subst. eq_dec y y. refl. cong.
    eq_dec z y. subst. fo. refl.
  Qed.

(***********************************************************************)
(** ** Properties of [replace_all]. *)

  Lemma replace_all_id x : forall u, replace_all x x u = u.

  Proof.
    induction u; simpl.
    rewrite replace_var_id. refl.
    refl.
    rewrite IHu1, IHu2. refl.
    rewrite replace_var_id, IHu. refl.
  Qed.

  Lemma replace_all2 x y : forall u, ~In y (fv u) -> ~In y (bv u) ->
    replace_all y x (replace_all x y u) = u.

  Proof.
    induction u; simpl; set_iff; intros h1 h2.
    rewrite replace_var2. refl. fo.
    refl. f_equal; fo. f_equal. rewrite replace_var2. refl. fo. fo.
  Qed.

  Lemma notin_fv_replace_all x y : x <> y ->
    forall u, ~In x (fv (replace_all x y u)).

  Proof.
    intro n.
    induction u; simpl; set_iff; unfold Def.replace_var; try (eq_dec x0 x); fo.
  Qed.

  Lemma notin_bv_replace_all x y : x <> y ->
    forall u, ~In x (bv (replace_all x y u)).

  Proof.
    intro n.
    induction u; simpl; set_iff; unfold Def.replace_var; try (eq_dec x0 x); fo.
  Qed.

  Lemma fv_replace_all x y : forall u,
    ~In y (bv u) -> ~In y (fv u) -> fv (replace_all x y u)
      [=] if mem x (fv u) then add y (remove x (fv u)) else fv u.

  Proof.
    induction u; simpl; set_iff; intros h1 h2; mem.
    (* var *)
    unfold Def.replace_var. eq_dec x0 x. subst. fset. refl.
    (* fun *)
    refl.
    (* app *)
    rewrite IHu1; [idtac|fo|fo]. rewrite IHu2; [idtac|fo|fo].
    case_eq (mem x (fv u1)); case_eq (mem x (fv u2)); simpl;
      try (rewrite <- mem_iff); try (rewrite <- not_mem_iff); intros i1 i2.
    rewrite remove_union, !add_union_singleton, union_assoc,
      <- union_assoc with (s:=remove x (fv u1)),
      union_sym with (s:=remove x (fv u1)), union_assoc, union_idem_1. refl.
    rewrite remove_union, remove_equal with (s:=fv u2), union_add; fo.
    rewrite remove_union, remove_equal with (s:=fv u1),
      union_sym, union_add, union_sym; fo.
    refl.
    (* lam *)
    rewrite IHu; [idtac|fo|fo]. unfold Def.replace_var.
    eq_dec x0 x; simpl; bool.
    subst. case_eq (mem x (fv u)); try (rewrite <- mem_iff);
      try (rewrite <- not_mem_iff); intro h.
    rewrite remove_add. refl. set_iff. fo.
    rewrite !remove_equal. refl. fo. fo.
    case_eq (mem x (fv u)); try (rewrite <- mem_iff);
      try (rewrite <- not_mem_iff); intro h.
    rewrite <- remove_add_com, remove_com; fo.
    refl.
  Qed.

  Lemma replace_all_aeq_rename x y : forall u,
    ~In y (fv u) -> ~In y (bv u) -> replace_all x y u ~~ rename x y u.

  Proof.
    induction u; simpl; set_iff; intros h1 h2.
    (* var *)
    rewrite rename_var. unfold Def.replace_var. eq_dec x0 x; refl.
    (* fun *)
    refl.
    (* app *)
    rewrite rename_app, IHu1, IHu2; firstorder auto with crelations.
    (* lam *)
    rewrite IHu; [idtac|fo|fo]. unfold Def.replace_var. eq_dec x0 x.
    subst x0. rewrite rename_notin_fv with (u:=Lam x u). 2: simpl; set_iff; fo.
    sym. apply aeq_alpha. fo.
    rewrite rename_lam. eq_dec y x0. firstorder auto with exfalso. bool. eq_dec x0 x. fo. refl.
  Qed.

(***********************************************************************)
(** ** Properties of [action]. *)

  Lemma action_eq f g : forall u,
    (forall x, In x (fv u) \/ In x (bv u) -> f x = g x) ->
    action f u = action g u.

  Proof.
    induction u; intro h; simpl; f_equal.
    apply h. left. simpl. set_iff. refl.
    apply IHu1. intros x hx. apply h. simpl. set_iff. destruct hx; tauto.
    apply IHu2. intros x hx. apply h. simpl. set_iff. destruct hx; tauto.
    apply h. simpl. set_iff. tauto.
    apply IHu. intros y hy. apply h. simpl. set_iff. destruct hy; tauto.
  Qed.

  Lemma size_action f : forall u, size (action f u) = size u.

  Proof.
    induction u; simpl. refl. refl. rewrite IHu1, IHu2. refl. rewrite IHu. refl.
  Qed.

  Lemma action_comp f g :
    forall u, action f (action g u) = action (fun x => f (g x)) u.

  Proof.
    induction u; simpl. refl. refl. rewrite IHu1, IHu2. refl. rewrite IHu. refl.
  Qed.

(***********************************************************************)
(** ** Properties of [transpose_var]. *)

  Lemma transpose_var_id x z : transpose_var x x z = z.

  Proof. unfold Def.transpose_var. eq_dec z x; subst; refl. Qed.

  Lemma transpose_var_sym x y z : transpose_var x y z = transpose_var y x z.

  Proof. unfold Def.transpose_var. eq_dec z x; eq_dec z y; subst; auto. Qed.

  Lemma transpose_var_com a b c d z : a <> c -> a <> d -> b <> c -> b <> d ->
    transpose_var a b (transpose_var c d z)
    = transpose_var c d (transpose_var a b z).

  Proof.
    intros nac nad nbc nbd. unfold Def.transpose_var.
    eq_dec z c; subst. eq_dec d a; subst. cong. eq_dec d b; subst. cong.
    eq_dec c a; subst. cong. eq_dec c b; subst. cong. eq_dec c c; subst.
    refl. cong. eq_dec z d; subst. eq_dec c a; subst. cong.
    eq_dec c b; subst. cong. eq_dec d a; subst. cong. eq_dec d b; subst.
    cong. eq_dec d c; subst. refl. eq_dec d d; subst. refl. cong.
    eq_dec z a; subst. eq_dec b c; subst. cong. eq_dec b d; subst. cong.
    refl. eq_dec z b; subst. eq_dec a c; subst. cong. eq_dec a d; subst.
    cong. refl. eq_dec z c; subst. cong. eq_dec z d; subst. cong. refl.
  Qed.

  Lemma transpose_var_idem x y z : transpose_var x y (transpose_var x y z) = z.

  Proof.
    unfold Def.transpose_var. eq_dec z x; subst.
    eq_dec y x; subst. refl. eq_dec y y; subst. refl. cong.
    eq_dec z y; subst. eq_dec x x; subst. refl. cong.
    eq_dec z x; subst. cong. eq_dec z y; subst. cong. refl.
  Qed.

  Lemma transpose_var_comp a b c z : b <> z -> c <> z ->
    transpose_var b c (transpose_var a b z) = transpose_var a c z.

  Proof.
    intros nbz ncz. unfold Def.transpose_var. eq_dec z a; subst.
    eq_dec b b; subst. refl. cong. eq_dec z b; subst. cong.
    eq_dec z b; subst. cong. eq_dec z c; subst. cong. refl.
  Qed.

(***********************************************************************)
(** ** Properties of [transpose]. *)

  Lemma transpose_id x : forall u, transpose x x u = u.

  Proof.
    unfold Def.transpose. induction u; simpl; repeat rewrite transpose_var_id.
    refl. refl. rewrite IHu1, IHu2. refl. rewrite IHu. refl.
  Qed.

  Lemma transpose_sym x y : forall u, transpose x y u = transpose y x u.

  Proof.
    unfold Def.transpose. induction u; simpl.
    rewrite transpose_var_sym. refl.
    refl.
    rewrite IHu1, IHu2. refl.
    rewrite IHu, transpose_var_sym, transpose_var_sym with (x:=y). refl.
  Qed.

  Lemma transpose_comp a b c : forall u, ~In b (fv u) -> ~In b (bv u) ->
                                         ~In c (fv u) -> ~In c (bv u) ->
    transpose b c (transpose a b u) = transpose a c u.

  Proof.
    unfold Def.transpose.
    induction u; simpl; set_iff; intros h1 h2 h3 h4; f_equal;
      try apply transpose_var_comp; fo.
  Qed.

(***********************************************************************)
(** ** Substitution corresponding to [transpose_var]. *)

  Definition subs_transpose a b x := Var (transpose_var a b x).

  Lemma domain_subs_transpose a b : forall xs, domain xs (subs_transpose a b)
    [=] if eqb a b then empty else inter xs (add a (singleton b)).

  Proof.
    apply set_induction_bis.
    (* Equal *)
    intros xs xs' xsxs'. destruct (eqb a b); rewrite xsxs'; auto.
    (* empty *)
    rewrite domain_empty. destruct (eqb a b). refl. rewrite inter_empty_l. refl.
    (* add *)
    intros x xs n IH. rewrite domain_add, IH. 2: hyp. unfold Def.domain_fun.
    ens. unfold subs_transpose, Def.transpose_var. rewrite beq_term_var.
    eq_dec x a. subst. eq_dec a b; eq_dec b a. refl. firstorder auto with exfalso. firstorder auto with exfalso.
    intro; set_iff; tauto.
    eq_dec x b. subst. eq_dec a b. refl. intro; set_iff; tauto.
    eq_dec x x. 2: cong. eq_dec a b. refl.
    intro y. set_iff. split_all; subst; cong.
  Qed.

  Lemma fvcod_subs_transpose a b : forall xs, fvcod xs (subs_transpose a b)
    [=] union (remove a (remove b xs))
              (union (if mem a xs then singleton b else empty)
                     (if mem b xs then singleton a else empty)).

  Proof.
    apply set_induction_bis.
    (* Equal *)
    intros xs xs' xsxs'. (*SLOW*)rewrite xsxs'. auto.
    (* empty *)
    mem. rewrite fvcod_empty. intro; set_iff; tauto.
    (* add *)
    intros x xs n IH. rewrite fvcod_add, IH. 2: hyp. mem. unfold Def.fvcod_fun.
    ens. rewrite remove_add_if, eqb_sym.
    unfold subs_transpose, Def.transpose_var, eqb.
    eq_dec x a; eq_dec x b; do 2 subst; simpl.
    rewrite !union_idem, !remove_idem.
    destruct (mem b xs); intro; set_iff; tauto.
    rewrite not_mem_iff in n.
    rewrite n, remove_add_eq, union_empty_l, union_sym_2. refl.
    rewrite not_mem_iff in n. rewrite n.
    destruct (mem a xs); intro; set_iff; tauto.
    rewrite remove_add_if. eq_dec a x. subst. cong.
    rewrite add_union_singleton, union_assoc. refl.
  Qed.

  Lemma fvcodom_subs_transpose a b xs :
    fvcodom xs (subs_transpose a b) [=] if eqb a b then empty
      else union (if mem a xs then singleton b else empty)
                 (if mem b xs then singleton a else empty).

  Proof.
    unfold Def.fvcodom. rewrite domain_subs_transpose.
    eq_dec a b. rewrite fvcod_empty. refl.
    rewrite fvcod_subs_transpose. mem. bool.
    rewrite !remove_inter, <- remove_add_com. 2: hyp.
    rewrite remove_singleton, remove_add_eq, remove_empty, inter_empty_r,
      union_empty_l. refl.
  Qed.

  Lemma transpose_subs a b : forall u, ~In a (bv u) -> ~In b (bv u) ->
    transpose a b u = subs (subs_transpose a b) u.

  Proof.
    unfold Def.transpose. induction u; simpl Def.bv; simpl Def.fv;
      simpl Def.action; set_iff; intros h1 h2.
    simpl. unfold subs_transpose, Def.transpose_var.
    eq_dec x a; eq_dec x b; do 2 subst; refl.
    refl.
    rewrite IHu1, IHu2; fo.
    (* Lam *)
    rewrite IHu; [idtac|fo|fo].

    assert (h : transpose_var a b x = x).
    unfold Def.transpose_var. eq_dec x a. fo. eq_dec x b. fo. refl.

    rewrite h, subs_lam_no_alpha.
    2:{ rewrite fvcodom_subs_transpose. eq_dec a b. set_iff. fo.
    mem. eq_dec x a. fo. eq_dec x b. fo. bool.
    destruct (mem a (fv u)); destruct (mem b (fv u)); set_iff; fo. }

    f_equal. rewrite update_id. refl. unfold subs_transpose. rewrite h. refl.
  Qed.

  Lemma transpose_rename x y :
    forall u, ~In y (fv u) -> ~In y (bv u) -> transpose x y u ~~ rename x y u.

  Proof.
    unfold Def.transpose.
    induction u; simpl; set_iff; intros h1 h2; unfold Def.rename.
    unfold Def.transpose_var, Def.single, Def.update; simpl.
    eq_dec x0 x. refl. eq_dec x0 y. subst. cong. refl.
    refl.
    rewrite IHu1; [idtac|fo|fo]. rewrite IHu2; [idtac|fo|fo]. refl.
    rewrite IHu; [idtac|fo|fo]. rewrite subs_lam_no_alpha.
    2:{ rewrite fvcodom_single.
    destruct (mem x (remove x0 (fv u)) && negb (beq_term (Var y) (Var x))).
    simpl. set_iff. fo. set_iff. fo. }
    unfold Def.transpose_var. eq_dec x0 x. subst.
    rewrite <- aeq_alpha. 2: fo. rewrite update_single_eq, single_id. refl.
    eq_dec x0 y. fo. rewrite update_id_single. 2: fo. refl.
  Qed.

  (** [transpose] is invariant by [aeq]. *)

  Global Instance transpose_aeq a b : Proper (aeq ==> aeq) (transpose a b).

  Proof.
    unfold Def.transpose.
    intro u; revert u. ind_size1 u; intros u' uu'; inv_aeq uu'; subst; simpl.
    refl. refl.
    rewrite hu with (y:=u), hv with (y:=u1). refl. hyp. hyp.
    (* Lam *)
    rename x0 into y. rename u0 into v.
    rewrite hu with (u':=v) (y:=rename x y u).
    2: rewrite i0, size_rename; refl. 2: hyp.
    eq_dec x y. subst. rewrite rename_id. refl.
    eq_dec a b. subst.
    fold (transpose b b u). fold (transpose b b (rename x y u)).
    rewrite !transpose_var_id, !transpose_id. apply aeq_alpha. fo.

    destruct (aeq_notin_bv (add y (add a (singleton b))) u) as [u' [h1 h2]].
    rewrite inter_sym, inter_empty in h2.
    assert (ha : ~In a (bv u')). apply h2. set_iff. auto.
    assert (hb : ~In b (bv u')). apply h2. set_iff. auto.
    assert (hy : ~In y (bv u')). apply h2. set_iff. auto.

    rewrite hu with (u':=u) (y:=u'). 2: refl. 2: hyp.
    rewrite hu with (u':=rename x y u) (y:=rename x y u').
    2: rewrite size_rename; refl. 2: rewrite h1; refl.
    fold (transpose a b u'). fold (transpose a b (rename x y u')).
    rewrite transpose_subs; auto. rewrite transpose_subs.
    2: rewrite bv_rename; auto. 2: rewrite bv_rename; auto.
    rewrite <- h1, <- i0.

    clear u' h1 h2 ha hb hy.
    set (x' := transpose_var a b x). set (y' := transpose_var a b y).
    set (u' := subs (subs_transpose a b) u).
    set (v' := subs (subs_transpose a b) v).
    set (xs := union (fv u') (fv v')). gen (var_notin_ok xs).
    set (z := var_notin xs). unfold xs. set_iff. split_all. cong.
    rewrite aeq_alpha with (y:=z). 2: hyp.
    rewrite aeq_alpha with (x:=y') (y:=z). 2: hyp.
    unfold u', v'. rewrite i0. unfold Def.rename. rewrite !subs_comp.
    apply aeq_refl_eq. f_equal. apply subs_seq.
    intros c hc. do 2 (unfold Def.comp at 1). unfold subs_transpose at 1.
    unfold x', y'. unfold Def.transpose_var. simpl. unfold Def.single.
    unfold Def.update at 3. eq_dec c x.
    (* c = x *)
    subst. rewrite update_eq. unfold Def.comp, subs_transpose. simpl.
    unfold Def.transpose_var. rewrite update_eq. refl.
    (* c <> x *)
    unfold Def.id at 3. unfold Def.comp, subs_transpose. simpl.
    unfold Def.transpose_var. eq_dec c y. subst. fo.
    eq_dec c a. subst. eq_dec x a. subst. cong.
    eq_dec y a. subst. cong. eq_dec x b. subst. rewrite update_neq. 2: hyp.
    eq_dec y b. subst. cong. rewrite update_neq; auto.
    rewrite update_neq. 2: hyp. eq_dec y b. subst.
    rewrite update_neq; auto. rewrite update_neq; auto.
    eq_dec x a. subst. eq_dec c b. subst. eq_dec y b. subst. cong.
    rewrite update_neq. 2: hyp. eq_dec y a. rewrite update_neq; auto.
    rewrite update_neq; auto. rewrite update_neq. 2: auto.
    eq_dec y a. subst. cong. eq_dec y b. rewrite update_neq; auto.
    unfold Def.update. eq_dec c y. subst. cong. refl.
    eq_dec x b. subst. eq_dec c b. subst. cong. rewrite update_neq. 2: auto.
    eq_dec y a. subst. rewrite update_neq; auto. eq_dec y b.
    rewrite update_neq; auto. unfold Def.update. eq_dec c y.
    subst. cong. refl. eq_dec c b. subst. rewrite update_neq. 2: hyp.
    eq_dec y a. subst. rewrite update_neq; auto. eq_dec y b. subst. cong.
    rewrite update_neq; auto. eq_dec y a. subst. rewrite !update_neq; auto.
    eq_dec y b. subst. rewrite !update_neq; auto. rewrite !update_neq; auto.
  Qed.

(***********************************************************************)
(** ** Properties of Church's definition. *)

  (** [aeq_ch] is a congruence relation. *)

  Global Instance aeq_ch_refl : Reflexive aeq_ch.

  Proof. unfold Def.aeq_ch. class. Qed.

  Global Instance aeq_ch_trans : Transitive aeq_ch.

  Proof. unfold Def.aeq_ch. class. Qed.

  Global Instance aeq_ch_top_sym : Symmetric aeq_ch_top.

  Proof.
    intros u v uv. inversion uv; clear uv; subst; unfold Ens_In in *.
    rewrite not_mem_iff in H. set (v := replace_all x y u).
    rewrite <- replace_all2 with (x:=x) (y:=y); auto.
    apply aeq_ch_top_intro; ens; unfold v.
    rewrite fv_replace_all; [idtac|fo|fo]. rewrite H. hyp.
    rewrite fv_replace_all; [idtac|fo|fo]. rewrite H, not_mem_iff. hyp.
    eq_dec x y. subst y. rewrite replace_all_id. hyp.
    apply notin_bv_replace_all. hyp.
  Qed.

  Global Instance aeq_ch_sym : Symmetric aeq_ch.

  Proof. apply rtc_sym. apply clos_mon_sym. class. Qed.

  Global Instance aeq_ch_mon : Monotone aeq_ch.

  Proof. unfold Def.aeq_ch. class. Qed.

  (** [aeq_ch] is equivalent to [aeq]. *)

  Lemma aeq_ch_le_aeq : aeq_ch << aeq.

  Proof.
    apply rtc_min. constructor; class. apply clos_mon_min. class.
    intros u v uv; inversion uv; clear uv; subst.
    rewrite replace_all_aeq_rename; [idtac|fo|fo]. rewrite rename_notin_fv; firstorder auto with crelations.
  Qed.

  Lemma aeq_le_aeq_ch : aeq << aeq_ch.

  Proof.
    intro u; revert u.
    ind_size1 u; intros u' uu'; inv_aeq uu'; subst; ens. refl. refl.
    trans (App u v).
    apply mon_app_l. class. firstorder auto with crelations. fo. apply mon_app_r. class. fo. firstorder auto with crelations.
    rename x0 into y. rename u0 into v.
    set (xs := union
      (add x (union (fv u) (bv u))) (add y (union (fv v) (bv v)))).
    gen (var_notin_ok xs). set (z := var_notin xs).
    unfold xs. set_iff. intro hz.
    trans (replace_all x z (Lam x u)).
    apply rt_step. apply m_step. apply aeq_ch_top_intro; simpl; set_iff; fo.
    trans (replace_all y z (Lam y v)).
    2:{ sym. apply rt_step. apply m_step.
    apply aeq_ch_top_intro; simpl; set_iff; fo. }
    simpl. rewrite !replace_var_eq. apply mon_lam. class. refl.
    apply hu. rewrite size_replace_all. refl.
    rewrite !replace_all_aeq_rename, i0, rename2; firstorder auto with crelations.
  Qed.

(***********************************************************************)
(** ** Properties of Krivine's definition. *)

  (** [aeq_kr] is an equivalence relation. *)

  Global Instance aeq_kr_refl : Reflexive aeq_kr.

  Proof.
    intro u; revert u. ind_size1 u.
    apply aeq_kr_var.
    apply aeq_kr_fun.
    apply aeq_kr_app; hyp.
    apply aeq_kr_lam with (xs:=empty); simpl.
    intros y hy. apply hu. rewrite size_rename1. refl.
  Qed.

  Global Instance aeq_kr_sym : Symmetric aeq_kr.

  Proof.
    intro u; revert u. ind_size1 u; intros t' h; inversion h; clear h; subst.
    refl. refl. apply aeq_kr_app; fo.
    apply aeq_kr_lam with (xs:=xs). intros y hy. apply hu.
    rewrite size_rename1. refl. fo.
  Qed.

  Global Instance aeq_kr_trans : Transitive aeq_kr.

  Proof.
    intro u; revert u. ind_size1 u; intros b c tb bc;
      inversion tb; clear tb; subst; inversion bc; clear bc; subst.
    refl. refl. apply aeq_kr_app; fo.
    apply aeq_kr_lam with (xs:=union xs xs0). intro y. set_iff. intro hy.
    apply hu with (y:=rename1 x' y u'). rewrite size_rename1; refl. fo. fo.
  Qed.

  (** [aeq_kr] is equivalent to [aeq]. *)

  Lemma aeq_le_aeq_kr : aeq << aeq_kr.

  Proof.
    intro u; revert u. ind_size1 u; intros t' tt'; inv_aeq tt'; subst.
    refl. refl. apply aeq_kr_app; firstorder auto with crelations. clear tt'.
    pose (xs := union (bv u) (bv u0)).
    apply aeq_kr_lam with (xs := xs); ens. intro y.
    unfold xs. set_iff. intro hy.
    apply hu. rewrite size_rename1. refl.
    rewrite <- !rename1_no_alpha, i0, rename2. refl. hyp.
    right. right. fo. right. right. fo.
  Qed.

  Lemma aeq_kr_le_aeq : aeq_kr << aeq.

  Proof.
    intro u; revert u; induction 1.
    refl. refl. rewrite IHaeq_kr1, IHaeq_kr2. refl.
    pose (xs' := union xs (union (bv u) (union (bv u') (union (fv u)
      (fv u'))))). gen (var_notin_ok xs'). set (y := var_notin xs').
    unfold xs'. set_iff. intro hy.
    rewrite aeq_alpha with (y:=y), aeq_alpha with (x:=x') (y:=y). 2: fo. 2: fo.
    apply Lam_aeq. refl. rewrite !rename1_no_alpha. fo.
    right. right. fo. right. right. fo.
  Qed.

(***********************************************************************)
(** ** Properties of Gabbay and Pitts's definition. *)

  (** [aeq_gp] is reflexive. *)

  Global Instance aeq_gp_refl : Reflexive aeq_gp.

  Proof.
    intro u; revert u. ind_size1 u.
    apply aeq_gp_refl_var.
    apply aeq_gp_refl_fun.
    apply aeq_gp_app; hyp.
    set (xs := union (add x (union (fv u) (bv u)))
                     (add x (union (fv u) (bv u)))).
    gen (var_notin_ok xs). set (z := var_notin xs). intro hz.
    apply aeq_gp_lam with z. hyp. apply hu.
    unfold Def.transpose. rewrite size_action. refl.
  Qed.

  (** [aeq_gp] is symmetric. *)

  Global Instance aeq_gp_sym : Symmetric aeq_gp.

  Proof.
    intro u; revert u. ind_size1 u; intros t' h; inversion h; clear h; subst.
    refl. refl. apply aeq_gp_app; fo. ens.
    apply aeq_gp_lam with z. ens. rewrite union_sym. hyp.
    apply hu. unfold Def.transpose. rewrite size_action. refl. hyp.
  Qed.

  (** [aeq_gp] is included in [aeq]. *)

  Lemma aeq_gp_incl_aeq : aeq_gp << aeq.

  Proof.
    intros u v; revert u v; induction 1.
    refl. refl. rewrite IHaeq_gp1, IHaeq_gp2. refl. ens. revert IHaeq_gp.
    rewrite transpose_sym, transpose_sym with (x:=z).
    rewrite transpose_rename. 2-3: firstorder auto with set.
    rewrite transpose_rename. 2-3: firstorder auto with set.
    intro IH.
    rewrite aeq_alpha with (y:=z). 2: firstorder auto with set. rewrite IH, <- aeq_alpha; firstorder auto with crelations set.
  Qed.

  (** [transpose] is invariant by [aeq_gp]. *)

  Global Instance transpose_aeq_gp a b : Proper (aeq_gp ==> aeq_gp) (transpose a b).

  Proof.
    unfold Def.transpose. intros u v uv; revert u v uv a b.
    ind_size1 u; intros u' uu' a b; inversion uu'; subst.
    refl. refl. apply aeq_gp_app; fo.

    ens. revert H1; set_iff; intro H1.
    rename x' into y. rename u'0 into v. simpl.
    set (x' := transpose_var a b x). set (u' := transpose a b u).
    set (y' := transpose_var a b y). set (v' := transpose a b v).
    set (xs := add z (add a (add b (union
              (union (add x (union (fv u) (bv u)))
                     (add y (union (fv v) (bv v))))
              (union (add x' (union (fv u') (bv u')))
                     (add y' (union (fv v') (bv v')))))))).
    gen (var_notin_ok xs). set (z' := var_notin xs).
    unfold xs. (*SLOW*)set_iff. intro hz'. split_hyps.

    apply aeq_gp_lam with (z:=z'). ens. set_iff. split_all.
    unfold Def.transpose. do 2 rewrite action_comp.
    rewrite action_eq with
      (g := fun x0 => transpose_var a b (transpose_var z' x x0)).
    rewrite action_eq with (u := v)
      (g := fun x0 => transpose_var a b (transpose_var z' y x0)).
    rewrite <- action_comp, <- action_comp with (u:=v).
    apply hu. rewrite size_action. refl.

    rewrite action_eq with
      (g := fun x0 => transpose_var z' z (transpose_var z x x0)).
    rewrite action_eq with (u := v)
      (g := fun x0 => transpose_var z' z (transpose_var z y x0)).
    rewrite <- action_comp, <- action_comp with (u:=v).
    apply hu. rewrite size_action. refl. hyp.

    intros x0 h0. unfold Def.transpose_var. eq_dec x0 z. subst. fo.
    eq_dec x0 y. subst. eq_dec z z. 2: congruence. eq_dec y z'. congruence.
    eq_dec z z'; congruence. eq_dec x0 z'. subst. fo. eq_dec x0 z; congruence.

    intros x0 h0. unfold Def.transpose_var. eq_dec x0 z. subst. fo.
    eq_dec x0 x. subst. eq_dec z z. 2: congruence. eq_dec x z'. congruence.
    eq_dec z z'; congruence. eq_dec x0 z'. subst. fo. eq_dec x0 z; congruence.

    intros x0 h0. unfold y', x', Def.transpose_var. eq_dec x0 z'. subst.
    eq_dec z' a. congruence. eq_dec z' b. congruence. eq_dec z' z'.
    2: congruence. eq_dec y a. refl. eq_dec y b; refl. eq_dec x0 y. subst.
    eq_dec z' a. congruence. eq_dec z' b. congruence. eq_dec y a. eq_dec b z'.
    hyp. eq_dec b b; congruence. eq_dec y b. eq_dec a z'. hyp.
    eq_dec a a; congruence. eq_dec y z'. hyp. eq_dec y y; congruence.
    eq_dec x0 a. subst. eq_dec b z'. congruence. eq_dec y b. eq_dec y a.
    eq_dec b b; congruence. eq_dec b a; congruence. eq_dec y a.
    eq_dec b b; congruence. eq_dec b y; congruence. eq_dec x0 b. subst.
    eq_dec a z'. congruence. eq_dec y a. eq_dec a b; congruence. eq_dec y b.
    eq_dec a a; congruence. eq_dec a y; congruence. eq_dec x0 z'. congruence.
    eq_dec y a. eq_dec x0 b; congruence. eq_dec y b. eq_dec x0 a; congruence.
    eq_dec x0 y; congruence.

    intros x0 h0. unfold x', Def.transpose_var. eq_dec x0 z'. subst. fo.
    eq_dec x0 x. subst. eq_dec x a. eq_dec b z'. congruence. eq_dec b b.
    2: congruence. eq_dec z' a. congruence. eq_dec z' b; congruence.
    eq_dec x b. eq_dec a a. 2: congruence. eq_dec a z'. congruence.
    eq_dec z' a. congruence. eq_dec z' b; congruence. eq_dec x x.
    2: congruence. eq_dec z' a. congruence. eq_dec x z'. congruence.
    eq_dec z' b; congruence. eq_dec x0 a. subst. eq_dec b z'. congruence.
    eq_dec x a. congruence. eq_dec x b. eq_dec b a; congruence.
    eq_dec b x; congruence. eq_dec x0 b. subst. eq_dec a z'. congruence.
    eq_dec x a. eq_dec a b; congruence. eq_dec x b. eq_dec a a; congruence.
    eq_dec a x; congruence. eq_dec x0 z'. congruence. eq_dec x a.
    eq_dec x0 b; congruence. eq_dec x b. eq_dec x0 a; congruence.
    eq_dec x0 x; congruence.
  (*SLOW*)Qed.

  (** [aeq_gp] is transitive. *)

  Global Instance aeq_gp_trans : Transitive aeq_gp.

  Proof.
    intro u; revert u. ind_size1 u; intros b c tb bc;
      inversion tb; clear tb; subst; inversion bc; clear bc; subst.
    refl. refl. apply aeq_gp_app; fo. ens.
    rename x' into y. rename u' into v. rename z into a.
    rename x'0 into z. rename u'0 into w. rename z0 into b.
    set (xs := union (union (add x (union (fv u) (bv u)))
                            (add y (union (fv v) (bv v))))
                            (add z (union (fv w) (bv w)))).
    gen (var_notin_ok xs). set (c := var_notin xs).
    unfold xs. revert H1 H2. (*SLOW*)set_iff. split_all.
    apply aeq_gp_lam with (z:=c). ens. set_iff. split_all.
    apply hu with (y := transpose c y v).
    unfold Def.transpose. rewrite size_action. refl.

    rewrite transpose_sym.
    erewrite <- transpose_comp with (b:=a); auto.
    rewrite transpose_sym with (x:=c).
    erewrite <- transpose_comp with (u:=v) (b:=a); auto.
    rewrite transpose_sym with (x:=x), transpose_sym with (x:=y).
    apply transpose_aeq_gp. hyp.

    rewrite transpose_sym.
    erewrite <- transpose_comp with (b:=b); auto.
    rewrite transpose_sym with (x:=c).
    erewrite <- transpose_comp with (u:=w) (b:=b); auto.
    rewrite transpose_sym with (x:=y), transpose_sym with (x:=z).
    apply transpose_aeq_gp. hyp.
  Qed.

  (** [aeq] is included in [aeq_gp]. *)

  Lemma aeq_incl_aeq_gp : aeq << aeq_gp.

  Proof.
    intro u; revert u. ind_size1 u; intros u' uu'; inv_aeq uu'; subst.
    refl. refl. apply aeq_gp_app; firstorder auto with crelations.
    set (xs := union (union (add x (union (fv u) (bv u)))
                            (add x0 (union (fv u0) (bv u0))))
                     (union (fv (rename x x0 u)) (bv (rename x x0 u)))).
    gen (var_notin_ok xs). set (z := var_notin xs).
    unfold xs. set_iff. split_all.

    apply aeq_gp_lam with (z:=z). ens. set_iff. split_all. apply hu.
    unfold Def.transpose. rewrite size_action. refl.
    rewrite i0, transpose_sym. rewrite transpose_rename; auto.
    rewrite transpose_sym. rewrite transpose_rename; auto.
    rewrite rename2. refl. auto.

    apply aeq_gp_lam with (z:=z). ens. set_iff. split_all. apply hu.
    unfold Def.transpose. rewrite size_action. refl.
    rewrite i0, transpose_sym. rewrite transpose_rename; auto.
    rewrite transpose_sym. rewrite transpose_rename; auto.
    rewrite rename2. refl. auto.
  Qed.

End Make.


From prelude Require Export co_pset.
From program_logic Require Export model.
From algebra Require Export cmra_big_op cmra_tactics.
Local Hint Extern 10 (_ ≤ _) => omega.
Local Hint Extern 10 (✓{_} _) => solve_validN.
Local Hint Extern 1 (✓{_} gst _) => apply gst_validN.
Local Hint Extern 1 (✓{_} wld _) => apply wld_validN.

Record wsat_pre {Λ Σ} (n : nat) (E : coPset)
    (σ : state Λ) (rs : gmap positive (iRes Λ Σ)) (r : iRes Λ Σ) := {
  wsat_pre_valid : ✓{S n} r;
  wsat_pre_state : pst r ≡ Excl σ;
  wsat_pre_dom i : is_Some (rs !! i) → i ∈ E ∧ is_Some (wld r !! i);
  wsat_pre_wld i P :
    i ∈ E →
    wld r !! i ≡{S n}≡ Some (to_agree (Next (iProp_unfold P))) →
    ∃ r', rs !! i = Some r' ∧ P n r'
}.
Arguments wsat_pre_valid {_ _ _ _ _ _ _} _.
Arguments wsat_pre_state {_ _ _ _ _ _ _} _.
Arguments wsat_pre_dom {_ _ _ _ _ _ _} _ _ _.
Arguments wsat_pre_wld {_ _ _ _ _ _ _} _ _ _ _ _.

Definition wsat {Λ Σ}
  (n : nat) (E : coPset) (σ : state Λ) (r : iRes Λ Σ) : Prop :=
  match n with 0 => True | S n => ∃ rs, wsat_pre n E σ rs (r ⋅ big_opM rs) end.
Instance: Params (@wsat) 5.
Arguments wsat : simpl never.

Section wsat.
Context {Λ : language} {Σ : iFunctor}.
Implicit Types σ : state Λ.
Implicit Types r : iRes Λ Σ.
Implicit Types rs : gmap positive (iRes Λ Σ).
Implicit Types P : iProp Λ Σ.
Implicit Types m : iGst Λ Σ.

Instance wsat_ne' : Proper (dist n ==> impl) (@wsat Λ Σ n E σ).
Proof.
  intros [|n] E σ r1 r2 Hr; first done; intros [rs [Hdom Hv Hs Hinv]].
  exists rs; constructor; intros until 0; setoid_rewrite <-Hr; eauto.
Qed.
Global Instance wsat_ne n : Proper (dist n ==> iff) (@wsat Λ Σ n E σ) | 1.
Proof. by intros E σ w1 w2 Hw; split; apply wsat_ne'. Qed.
Global Instance wsat_proper n : Proper ((≡) ==> iff) (@wsat Λ Σ n E σ) | 1.
Proof. by intros E σ w1 w2 Hw; apply wsat_ne, equiv_dist. Qed.
Lemma wsat_le n n' E σ r : wsat n E σ r → n' ≤ n → wsat n' E σ r.
Proof.
  destruct n as [|n], n' as [|n']; simpl; try by (auto with lia).
  intros [rs [Hval Hσ HE Hwld]] ?; exists rs; constructor; auto.
  intros i P ? HiP; destruct (wld (r ⋅ big_opM rs) !! i) as [P'|] eqn:HP';
    [apply (inj Some) in HiP|inversion_clear HiP].
  assert (P' ≡{S n}≡ to_agree $ Next $ iProp_unfold $
                       iProp_fold $ later_car $ P' (S n)) as HPiso.
  { rewrite iProp_unfold_fold later_eta to_agree_car //.
    apply (map_lookup_validN _ (wld (r ⋅ big_opM rs)) i); rewrite ?HP'; auto. }
  assert (P ≡{n'}≡ iProp_fold (later_car (P' (S n)))) as HPP'.
  { apply (inj iProp_unfold), (inj Next), (inj to_agree).
    by rewrite -HiP -(dist_le _ _ _ _ HPiso). }
  destruct (Hwld i (iProp_fold (later_car (P' (S n))))) as (r'&?&?); auto.
  { by rewrite HP' -HPiso. }
  assert (✓{S n} r') by (apply (big_opM_lookup_valid _ rs i); auto).
  exists r'; split; [done|apply HPP', uPred_weaken with n r'; auto].
Qed.
Lemma wsat_valid n E σ r : n ≠ 0 → wsat n E σ r → ✓{n} r.
Proof.
  destruct n; first done.
  intros _ [rs ?]; eapply cmra_validN_op_l, wsat_pre_valid; eauto.
Qed.
Lemma wsat_init k E σ m : ✓{S k} m → wsat (S k) E σ (Res ∅ (Excl σ) m).
Proof.
  intros Hv. exists ∅; constructor; auto.
  - rewrite big_opM_empty right_id.
    split_and!; try (apply cmra_valid_validN, ra_empty_valid);
      constructor || apply Hv.
  - by intros i; rewrite lookup_empty=>-[??].
  - intros i P ?; rewrite /= left_id lookup_empty; inversion_clear 1.
Qed.
Lemma wsat_open n E σ r i P :
  wld r !! i ≡{S n}≡ Some (to_agree (Next (iProp_unfold P))) → i ∉ E →
  wsat (S n) ({[i]} ∪ E) σ r → ∃ rP, wsat (S n) E σ (rP ⋅ r) ∧ P n rP.
Proof.
  intros HiP Hi [rs [Hval Hσ HE Hwld]].
  destruct (Hwld i P) as (rP&?&?); [set_solver +|by apply lookup_wld_op_l|].
  assert (rP ⋅ r ⋅ big_opM (delete i rs) ≡ r ⋅ big_opM rs) as Hr.
  { by rewrite (comm _ rP) -assoc big_opM_delete. }
  exists rP; split; [exists (delete i rs); constructor; rewrite ?Hr|]; auto.
  - intros j; rewrite lookup_delete_is_Some Hr.
    generalize (HE j); set_solver +Hi.
  - intros j P'; rewrite Hr=> Hj ?.
    setoid_rewrite lookup_delete_ne; last (set_solver +Hi Hj).
    apply Hwld; [set_solver +Hj|done].
Qed.
Lemma wsat_close n E σ r i P rP :
  wld rP !! i ≡{S n}≡ Some (to_agree (Next (iProp_unfold P))) → i ∉ E →
  wsat (S n) E σ (rP ⋅ r) → P n rP → wsat (S n) ({[i]} ∪ E) σ r.
Proof.
  intros HiP HiE [rs [Hval Hσ HE Hwld]] ?.
  assert (rs !! i = None) by (apply eq_None_not_Some; naive_solver).
  assert (r ⋅ big_opM (<[i:=rP]> rs) ≡ rP ⋅ r ⋅ big_opM rs) as Hr.
  { by rewrite (comm _ rP) -assoc big_opM_insert. }
  exists (<[i:=rP]>rs); constructor; rewrite ?Hr; auto.
  - intros j; rewrite Hr lookup_insert_is_Some=>-[?|[??]]; subst.
    + split. set_solver. rewrite !lookup_op HiP !op_is_Some; eauto.
    + destruct (HE j) as [Hj Hj']; auto; set_solver +Hj Hj'.
  - intros j P'; rewrite Hr elem_of_union elem_of_singleton=>-[?|?]; subst.
    + rewrite !lookup_wld_op_l ?HiP; auto=> HP.
      apply (inj Some), (inj to_agree), (inj Next), (inj iProp_unfold) in HP.
      exists rP; split; [rewrite lookup_insert|apply HP]; auto.
    + intros. destruct (Hwld j P') as (r'&?&?); auto.
      exists r'; rewrite lookup_insert_ne; naive_solver.
Qed.
Lemma wsat_update_pst n E σ1 σ1' r rf :
  pst r ≡{S n}≡ Excl σ1 → wsat (S n) E σ1' (r ⋅ rf) →
  σ1' = σ1 ∧ ∀ σ2, wsat (S n) E σ2 (update_pst σ2 r ⋅ rf).
Proof.
  intros Hpst_r [rs [(?&?&?) Hpst HE Hwld]]; simpl in *.
  assert (pst rf ⋅ pst (big_opM rs) = ∅) as Hpst'.
  { by apply: (excl_validN_inv_l (S n) _ σ1); rewrite -Hpst_r assoc. }
  assert (σ1' = σ1) as ->.
  { apply leibniz_equiv, (timeless _), dist_le with (S n); auto.
    apply (inj Excl).
    by rewrite -Hpst_r -Hpst -assoc Hpst' right_id. }
  split; [done|exists rs].
  by constructor; first split_and!; try rewrite /= -assoc Hpst'.
Qed.
Lemma wsat_update_gst n E σ r rf m1 (P : iGst Λ Σ → Prop) :
  m1 ≼{S n} gst r → m1 ~~>: P →
  wsat (S n) E σ (r ⋅ rf) → ∃ m2, wsat (S n) E σ (update_gst m2 r ⋅ rf) ∧ P m2.
Proof.
  intros [mf Hr] Hup [rs [(?&?&?) Hσ HE Hwld]].
  destruct (Hup (S n) (mf ⋅ gst (rf ⋅ big_opM rs))) as (m2&?&Hval'); try done.
  { by rewrite /= (assoc _ m1) -Hr assoc. }
  exists m2; split; [exists rs|done].
  by constructor; first split_and!; auto.
Qed.
Lemma wsat_alloc n E1 E2 σ r P rP :
  ¬set_finite E1 → P n rP → wsat (S n) (E1 ∪ E2) σ (rP ⋅ r) →
  ∃ i, wsat (S n) (E1 ∪ E2) σ
         (Res {[i := to_agree (Next (iProp_unfold P))]} ∅ ∅ ⋅ r) ∧
       wld r !! i = None ∧ i ∈ E1.
Proof.
  intros HE1 ? [rs [Hval Hσ HE Hwld]].
  assert (∃ i, i ∈ E1 ∧ wld r !! i = None ∧ wld rP !! i = None ∧
                        wld (big_opM rs) !! i = None) as (i&Hi&Hri&HrPi&Hrsi).
  { exists (coPpick (E1 ∖
      (dom _ (wld r) ∪ (dom _ (wld rP) ∪ dom _ (wld (big_opM rs)))))).
    rewrite -!not_elem_of_dom -?not_elem_of_union -elem_of_difference.
    apply coPpick_elem_of=>HE'; eapply HE1, (difference_finite_inv _ _), HE'.
    by repeat apply union_finite; apply dom_finite. }
  assert (rs !! i = None).
  { apply eq_None_not_Some=>?; destruct (HE i) as [_ Hri']; auto; revert Hri'.
    rewrite /= !lookup_op !op_is_Some -!not_eq_None_Some; tauto. }
  assert (r ⋅ big_opM (<[i:=rP]> rs) ≡ rP ⋅ r ⋅ big_opM rs) as Hr.
  { by rewrite (comm _ rP) -assoc big_opM_insert. }
  exists i; split_and?; [exists (<[i:=rP]>rs); constructor| |]; auto.
  - destruct Hval as (?&?&?);  rewrite -assoc Hr.
    split_and!; rewrite /= ?left_id; [|eauto|eauto].
    intros j; destruct (decide (j = i)) as [->|].
    + by rewrite !lookup_op Hri HrPi Hrsi !right_id lookup_singleton.
    + by rewrite lookup_op lookup_singleton_ne // left_id.
  - by rewrite -assoc Hr /= left_id.
  - intros j; rewrite -assoc Hr; destruct (decide (j = i)) as [->|].
    + intros _; split; first set_solver +Hi.
      rewrite /= !lookup_op lookup_singleton !op_is_Some; eauto.
    + rewrite lookup_insert_ne //.
      rewrite lookup_op lookup_singleton_ne // left_id; eauto.
  - intros j P'; rewrite -assoc Hr; destruct (decide (j=i)) as [->|].
    + rewrite /= !lookup_op Hri HrPi Hrsi right_id lookup_singleton=>? HP.
      apply (inj Some), (inj to_agree), (inj Next), (inj iProp_unfold) in HP.
      exists rP; rewrite lookup_insert; split; [|apply HP]; auto.
    + rewrite /= lookup_op lookup_singleton_ne // left_id=> ??.
      destruct (Hwld j P') as [r' ?]; auto.
      by exists r'; rewrite lookup_insert_ne.
Qed.
End wsat.


(******************************************************************************)
(** * Definition of execution graph events and labels *)
(******************************************************************************)

Require Import List.
From hahn Require Import Hahn.
From PromisingLib Require Import Basic Loc.
Require Import CountabilityHelpers.

Set Implicit Arguments.

Definition thread_id := Basic.Ident.t.
Definition tid_init := Coq.Numbers.BinNums.xH.

Definition location := Loc.t.
Definition value := nat.

(******************************************************************************)
(** ** Execution graph events  *)
(******************************************************************************)

Inductive actid :=
  | InitEvent (l : location)
  | ThreadEvent (thread : thread_id) (index : nat).

Definition tid a :=
  match a with
    | InitEvent l => tid_init
    | ThreadEvent i _ => i
  end.

Definition is_tid i a : Prop := tid a = i.

Definition index a :=
  match a with
    | InitEvent l => 0
    | ThreadEvent _ n => n
  end.

Definition is_init a :=
  match a with
    | InitEvent _ => true
    | ThreadEvent _ _ => false
  end.

Lemma tid_set_dec thread :
  (fun x => tid x = thread) ∪₁ (fun x => tid x <> thread) ≡₁ (fun x => True).
Proof using. unfolder; split; ins; desf; tauto. Qed.

(******************************************************************************)
(** ** Same tid restriction *)
(******************************************************************************)

Definition same_tid := (fun x y => tid x = tid y).

Lemma restr_eq_rel_same_tid r :  restr_eq_rel tid r  ≡ r ∩ same_tid.
Proof using. unfold same_tid; basic_solver. Qed.

Lemma loceq_same_tid (r: relation actid) (H: funeq tid r):
 r ⊆ r ∩ same_tid.
Proof using.
unfold same_tid; basic_solver.
Qed.

Lemma same_tid_loceq (r: relation actid) (H: r ⊆ r ∩ same_tid):
 funeq tid r.
Proof using.
unfold same_tid; unfolder; firstorder.
Qed.

(******************************************************************************)
(** ** Decidable equality *)
(******************************************************************************)

Lemma eq_dec_actid :
  forall x y : actid, {x = y} + {x <> y}.
Proof using.
repeat decide equality.
Qed.

(******************************************************************************)
(** ** Labels  *)
(******************************************************************************)

Inductive mode :=
  | Opln
  | Orlx
  | Oacq
  | Orel
  | Oacqrel
  | Osc.

Definition mode_le lhs rhs :=
  match lhs, rhs with
    | Opln, _ => true
    | _, Opln => false
    | Orlx, _ => true
    | _, Orlx => false
    | Oacq, Oacq
    | Oacq, Oacqrel
    | Orel, Orel
    | Orel, Oacqrel
    | Oacqrel, Oacqrel
    | _, Osc => true
    | _ , _ => false
  end.

Inductive x_mode :=
  | Xpln
  | Xacq.

Inductive label :=
  | Aload  (ex:bool) (o:mode) (l:location) (v:value)
  | Astore (s:x_mode) (o:mode) (l:location) (v:value)
  | Afence (o:mode).

(*
   The meaning of the modes in each case:
   (currently Opln is redundant, easy to remove in the future)

                  IMM        POWER      ARM
   =================================================
   Aload Opln       rlx       ld         ldr
   Aload Orlx       rlx       ld         ldr
   Aload Oacq       acq       ld         ldapr (?)
   Aload Orel       rlx       ld         ldr
   Aload Oacqrel    acq       ld         ldapr (?)
   Aload Osc        acq       ld         ldapr (?)

   Astore Opln      rlx       st         str
   Astore Orlx      rlx       st         str
   Astore Oacq      rlx       st         str
   Astore Orel      rel       st         stlr
   Astore Oacqrel   rel       st         stlr
   Astore Osc       rel       st         stlr

   Afence Opln      no-op     no-op      no-op
   Afence Orlx      no-op     isync      F-ld
   Afence Oacq      acq       lwsync     F-ld
   Afence Orel      rel       lwsync     F-sy
   Afence Oacqrel   acq-rel   lwsync     F-sy
   Afence Osc       sc        sync       F-sy

 *)

Section Labels.

Variable A : Type.
Variable lab : A -> label.

Definition loc a :=
  match lab a with
  | Aload _ _ l _
  | Astore _ _ l _ => Some l
  | _ => None
  end.

Definition val a :=
  match lab a with
  | Aload  _ _ _ v
  | Astore _ _ _ v => Some v
  | _ => None
  end.

Definition mod a :=
  match lab a with
  | Aload  _ o _ _
  | Astore _ o _ _
  | Afence o => o
  end.

Definition xmod a :=
  match lab a with
  | Astore x _ _ _ => Some x
  | _ => None
  end.

Definition is_r a :=
  match lab a with
  | Aload  _ _ _ _ => true
  | _ => false
  end.

Definition is_w a :=
  match lab a with
  | Astore _ _ _ _ => true
  | _ => false
  end.

Definition is_f a :=
  match lab a with
  | Afence _ => true
  | _ => false
  end.

Definition is_only_pln a : bool :=
  match mod a with
  | Opln => true
  | _ => false
  end.

Definition is_only_rlx a : bool :=
  match mod a with
  | Orlx => true
  | _ => false
  end.

Definition is_rlx a : bool := mode_le Orlx (mod a).
Definition is_acq a : bool := mode_le Oacq (mod a).
Definition is_rel a : bool := mode_le Orel (mod a).
Definition is_acqrel a : bool := mode_le Oacqrel (mod a).
Definition is_sc a : bool :=
  match mod a with
  | Osc => true
  | _ => false
  end.

Definition is_ra a : bool := is_acq a || is_rel a.

Lemma lab_rwf a : is_r a \/ is_w a \/ is_f a.
Proof using. unfold is_r, is_w, is_f; destruct (lab a); auto. Qed.

Definition is_xacq a :=
  match xmod a with
  | Some Xacq => true
  | _ => false
  end.

Definition R_ex a :=
  match lab a with
  | Aload r _ _ _ => r
  | _ => false
  end.

Lemma R_ex_in_R : R_ex ⊆₁ is_r.
Proof using.
unfold R_ex, is_r; basic_solver.
Qed.

Definition rmwmod a :=
  match lab a with
  | Aload r _ _ _ => Some r
  | _ => None
  end.

(******************************************************************************)
(** ** Same location restriction *)
(******************************************************************************)

Definition same_loc := (fun x y => loc x = loc y).

Lemma restr_eq_rel_same_loc r :  restr_eq_rel loc r  ≡ r ∩ same_loc.
Proof using. unfold same_loc; basic_solver. Qed.

Lemma loceq_same_loc (r: relation A) (H: funeq loc r):
 r ⊆ r ∩ same_loc.
Proof using.
unfold same_loc; basic_solver.
Qed.

Lemma same_loc_loceq (r: relation A) (H: r ⊆ r ∩ same_loc):
 funeq loc r.
Proof using.
unfold same_loc; unfolder; firstorder.
Qed.

Lemma same_loc_trans : transitive same_loc.
Proof using. unfold same_loc; red; ins. by rewrite H. Qed.

Lemma same_loc_sym : symmetric same_loc.
Proof using. unfold same_loc; red; ins. Qed.

(******************************************************************************)
(** ** Values and locations getters  *)
(******************************************************************************)

Lemma is_w_val x (WX : is_w x) : exists v, val x = Some v.
Proof using. unfold is_w, val in *; desf. eexists; eauto. Qed.

Lemma is_w_loc x (WX : is_w x) : exists l, loc x = Some l.
Proof using. unfold is_w, loc in *; desf. eexists; eauto. Qed.

Lemma is_r_val x (WX : is_r x) : exists v, val x = Some v.
Proof using. unfold is_r, val in *; desf. eexists; eauto. Qed.

Lemma is_r_loc x (WX : is_r x) : exists l, loc x = Some l.
Proof using. unfold is_r, loc in *; desf. eexists; eauto. Qed.

Lemma is_f_val x (FX : is_f x) : val x = None.
Proof using. unfold is_f, val in *; desf. Qed.

Lemma is_f_loc x  (FX: is_f x): loc x = None.
Proof using. unfold is_f, loc in *; desf. Qed.

End Labels.

(******************************************************************************)
(** ** Identical labeling up to value  *)
(******************************************************************************)

Definition same_mod {A} (lab : A -> label) : relation A :=
  (fun x y => mod lab x = mod lab y).

Definition same_val {A} (lab : A -> label) : relation A :=
  (fun x y => val lab x = val lab y).

Definition same_label_u2v label1 label2 :=
  match label1, label2 with
  | Aload  r1 o1 l1 _, Aload  r2 o2 l2 _ => r1 = r2 /\ o1 = o2 /\ l1 = l2
  | Astore s1 o1 l1 _, Astore s2 o2 l2 _ => s1 = s2 /\ o1 = o2 /\ l1 = l2
  | Afence o1, Afence o2 => o1 = o2
  | _,_ => False
  end.

Section SameFunsSet.

Variable A : Type.
Variable s : A -> Prop.
Variable lab1 lab2 : A -> label.

Definition same_lab_u2v_dom  :=
  forall e (EE : s e),
    same_label_u2v (lab1 e) (lab2 e).

#[local]
Hint Unfold eq_dom loc mod xmod is_r is_w is_f is_acq is_rel is_rlx is_acqrel R_ex
     is_only_pln is_only_rlx is_sc is_ra is_xacq
     same_lab_u2v_dom same_label_u2v :
  same_lab_unfoldDb.

Ltac same_lab_set_solver_f SAME :=
  repeat (autounfold with same_lab_unfoldDb in *);
          intros a HH; specialize (SAME a HH);
          desf; desf.

Lemma same_lab_u2v_dom_loc (SAME: same_lab_u2v_dom) :
  eq_dom s (loc lab1) (loc lab2).
Proof using. same_lab_set_solver_f SAME. Qed.

Lemma same_lab_u2v_dom_mod (SAME: same_lab_u2v_dom) :
  eq_dom s (mod lab1) (mod lab2).
Proof using. same_lab_set_solver_f SAME. Qed.

Lemma same_lab_u2v_dom_xmod (SAME: same_lab_u2v_dom) :
  eq_dom s (xmod lab1) (xmod lab2).
Proof using. same_lab_set_solver_f SAME. Qed.

Ltac same_lab_set_solver_s SAME :=
  repeat (autounfold with same_lab_unfoldDb in *); unfolder;
          split; intros a HH; desf; split; auto; specialize (SAME a HH); desf.

Lemma same_lab_u2v_dom_is_r (SAME: same_lab_u2v_dom) :
  s ∩₁ is_r lab1 ≡₁ s ∩₁ is_r lab2.
Proof using. same_lab_set_solver_s SAME. Qed.

Lemma same_lab_u2v_dom_is_w (SAME: same_lab_u2v_dom) :
  s ∩₁ is_w lab1 ≡₁ s ∩₁ is_w lab2.
Proof using. same_lab_set_solver_s SAME. Qed.

Lemma same_lab_u2v_dom_is_f (SAME: same_lab_u2v_dom) :
  s ∩₁ is_f lab1 ≡₁ s ∩₁ is_f lab2.
Proof using. same_lab_set_solver_s SAME. Qed.

Lemma same_lab_u2v_dom_R_ex (SAME: same_lab_u2v_dom) :
  s ∩₁ R_ex lab1 ≡₁ s ∩₁ R_ex lab2.
Proof using. same_lab_set_solver_s SAME; desf. Qed.

Lemma same_lab_u2v_dom_is_only_pln (SAME: same_lab_u2v_dom) :
  s ∩₁ is_only_pln lab1 ≡₁ s ∩₁ is_only_pln lab2.
Proof using. same_lab_set_solver_s SAME; desf. Qed.

Lemma same_lab_u2v_dom_is_only_rlx (SAME: same_lab_u2v_dom) :
  s ∩₁ is_only_rlx lab1 ≡₁ s ∩₁ is_only_rlx lab2.
Proof using. same_lab_set_solver_s SAME; desf. Qed.

Lemma same_lab_u2v_dom_is_rlx (SAME: same_lab_u2v_dom) :
  s ∩₁ is_rlx lab1 ≡₁ s ∩₁ is_rlx lab2.
Proof using. same_lab_set_solver_s SAME; desf. Qed.

Lemma same_lab_u2v_dom_is_acq (SAME: same_lab_u2v_dom) :
  s ∩₁ is_acq lab1 ≡₁ s ∩₁ is_acq lab2.
Proof using. same_lab_set_solver_s SAME; desf. Qed.

Lemma same_lab_u2v_dom_is_rel (SAME: same_lab_u2v_dom) :
  s ∩₁ is_rel lab1 ≡₁ s ∩₁ is_rel lab2.
Proof using. same_lab_set_solver_s SAME; desf. Qed.

Lemma same_lab_u2v_dom_is_acqrel (SAME: same_lab_u2v_dom) :
  s ∩₁ is_acqrel lab1 ≡₁ s ∩₁ is_acqrel lab2.
Proof using. same_lab_set_solver_s SAME; desf. Qed.

Lemma same_lab_u2v_dom_is_sc (SAME: same_lab_u2v_dom) :
  s ∩₁ is_sc lab1 ≡₁ s ∩₁ is_sc lab2.
Proof using. same_lab_set_solver_s SAME; desf. Qed.

Lemma same_lab_u2v_dom_is_ra (SAME: same_lab_u2v_dom) :
  s ∩₁ is_ra lab1 ≡₁ s ∩₁ is_ra lab2.
Proof using. same_lab_set_solver_s SAME; desf. all: by rewrite Bool.orb_true_r. Qed.

Lemma same_lab_u2v_dom_is_xacq (SAME: same_lab_u2v_dom) :
  s ∩₁ is_xacq lab1 ≡₁ s ∩₁ is_xacq lab2.
Proof using. same_lab_set_solver_s SAME; desf. Qed.

Lemma same_lab_u2v_dom_same_loc (SAME: same_lab_u2v_dom) :
  restr_rel s (same_loc lab1) ≡ restr_rel s (same_loc lab2).
Proof using.
  unfolder. split.
  all: ins; desf; splits; auto.
  all: unfold same_loc, loc, same_lab_u2v_dom, same_label_u2v in *.
  all: set (SAMEY := SAME); specialize (SAMEY y H1).
  all: specialize (SAME x H0); desf; desf.
Qed.

End SameFunsSet.

Lemma same_label_u2v_val {A} (lab lab' : A -> label) x
      (U2V : same_label_u2v (lab x) (lab' x))
      (VAL : val lab x = val lab' x) :
  lab x = lab' x.
Proof using. unfold same_label_u2v, val in *. desf; desf. Qed.

Section SameFuns.

Variable A : Type.
Variable lab1 lab2 : A -> label.

Definition same_lab_u2v :=
  same_lab_u2v_dom (fun _ => True) lab1 lab2.

Lemma same_lab_u2v_loc (SAME: same_lab_u2v) :
  loc lab1 = loc lab2.
Proof using. apply eq_dom_full_eq. by apply same_lab_u2v_dom_loc. Qed.

Lemma same_lab_u2v_mod (SAME: same_lab_u2v) :
  mod lab1 = mod lab2.
Proof using. apply eq_dom_full_eq. by apply same_lab_u2v_dom_mod. Qed.

Lemma same_lab_u2v_xmod (SAME: same_lab_u2v) :
  xmod lab1 = xmod lab2.
Proof using. apply eq_dom_full_eq. by apply same_lab_u2v_dom_xmod. Qed.

Lemma same_lab_u2v_is_r (SAME: same_lab_u2v) :
  is_r lab1 ≡₁ is_r lab2.
Proof using. generalize (same_lab_u2v_dom_is_r SAME). relsf. Qed.

Lemma same_lab_u2v_is_w (SAME: same_lab_u2v) :
  is_w lab1 ≡₁ is_w lab2.
Proof using. generalize (same_lab_u2v_dom_is_w SAME). relsf. Qed.

Lemma same_lab_u2v_is_f (SAME: same_lab_u2v) :
  is_f lab1 ≡₁ is_f lab2.
Proof using. generalize (same_lab_u2v_dom_is_f SAME). relsf. Qed.

Lemma same_lab_u2v_R_ex (SAME: same_lab_u2v) :
  R_ex lab1 ≡₁ R_ex lab2.
Proof using. generalize (same_lab_u2v_dom_R_ex SAME). relsf. Qed.

Lemma same_lab_u2v_is_only_pln (SAME: same_lab_u2v) :
  is_only_pln lab1 ≡₁ is_only_pln lab2.
Proof using. generalize (same_lab_u2v_dom_is_only_pln SAME). relsf. Qed.

Lemma same_lab_u2v_is_only_rlx (SAME: same_lab_u2v) :
  is_only_rlx lab1 ≡₁ is_only_rlx lab2.
Proof using. generalize (same_lab_u2v_dom_is_only_rlx SAME). relsf. Qed.

Lemma same_lab_u2v_is_rlx (SAME: same_lab_u2v) :
  is_rlx lab1 ≡₁ is_rlx lab2.
Proof using. generalize (same_lab_u2v_dom_is_rlx SAME). relsf. Qed.

Lemma same_lab_u2v_is_acq (SAME: same_lab_u2v) :
  is_acq lab1 ≡₁ is_acq lab2.
Proof using. generalize (same_lab_u2v_dom_is_acq SAME). relsf. Qed.

Lemma same_lab_u2v_is_rel (SAME: same_lab_u2v) :
  is_rel lab1 ≡₁ is_rel lab2.
Proof using. generalize (same_lab_u2v_dom_is_rel SAME). relsf. Qed.

Lemma same_lab_u2v_is_acqrel (SAME: same_lab_u2v) :
  is_acqrel lab1 ≡₁ is_acqrel lab2.
Proof using. generalize (same_lab_u2v_dom_is_acqrel SAME). relsf. Qed.

Lemma same_lab_u2v_is_sc (SAME: same_lab_u2v) :
  is_sc lab1 ≡₁ is_sc lab2.
Proof using. generalize (same_lab_u2v_dom_is_sc SAME). relsf. Qed.

Lemma same_lab_u2v_is_ra (SAME: same_lab_u2v) :
  is_ra lab1 ≡₁ is_ra lab2.
Proof using. generalize (same_lab_u2v_dom_is_ra SAME). relsf. Qed.

Lemma same_lab_u2v_is_xacq (SAME: same_lab_u2v) :
  is_xacq lab1 ≡₁ is_xacq lab2.
Proof using. generalize (same_lab_u2v_dom_is_xacq SAME). relsf. Qed.

Lemma same_lab_u2v_same_loc (SAME: same_lab_u2v) :
  same_loc lab1 ≡ same_loc lab2.
Proof using. generalize (same_lab_u2v_dom_same_loc SAME). by rewrite !restr_full. Qed.
End SameFuns.

Section SameFuns2.

Lemma same_lab_u2v_comm {A} (lab1 lab2 : A -> label)
      (S1 : same_lab_u2v lab1 lab2) :
  same_lab_u2v lab2 lab1.
Proof using.
  unfold same_lab_u2v, same_lab_u2v_dom. ins.
  specialize (S1 e EE).
  unfold same_label_u2v in *.
  desf; desf.
Qed.

Lemma same_lab_u2v_follows_set {A} s (lab1 lab2 : A -> label)
      (S1 : same_lab_u2v lab1 lab2) :
  same_lab_u2v_dom s lab1 lab2.
Proof using. unfold same_lab_u2v, same_lab_u2v_dom in *. ins. by apply S1. Qed.

Lemma same_lab_u2v_dom_inclusion {A} s s' (lab lab' : A -> label)
      (SS : s' ⊆₁ s)
      (S1 : same_lab_u2v_dom s lab lab') :
  same_lab_u2v_dom s' lab lab'.
Proof using. red. ins. apply S1. by apply SS. Qed.

Lemma same_label_u2v_trans lbl1 lbl2 lbl3
      (S1 : same_label_u2v lbl1 lbl2)
      (S2 : same_label_u2v lbl2 lbl3) :
  same_label_u2v lbl1 lbl3.
Proof using. unfold same_label_u2v in *. desf; desf. Qed.

Lemma same_label_u2v_comm lbl1 lbl2
      (S1 : same_label_u2v lbl1 lbl2) :
  same_label_u2v lbl2 lbl1.
Proof using. unfold same_label_u2v in *. desf; desf. Qed.

Lemma same_lab_u2v_dom_trans {A} (s : A -> Prop) lab1 lab2 lab3
      (S1 : same_lab_u2v_dom s lab1 lab2)
      (S2 : same_lab_u2v_dom s lab2 lab3) :
  same_lab_u2v_dom s lab1 lab3.
Proof using.
  red. ins.
  specialize (S1 e EE).
  specialize (S2 e EE).
  eapply same_label_u2v_trans; eauto.
Qed.

Lemma same_lab_u2v_dom_comm {A} (s : A -> Prop) lab1 lab2
      (S2 : same_lab_u2v_dom s lab1 lab2) :
  same_lab_u2v_dom s lab2 lab1.
Proof using.
  red. ins. specialize (S2 e EE).
    by apply same_label_u2v_comm.
Qed.

Lemma same_lab_u2v_dom_same_mod {A} (lab lab' : A -> label) (s : A -> Prop)
      (SAME: same_lab_u2v_dom s lab lab') :
  restr_rel s (same_mod lab) ≡ restr_rel s (same_mod lab').
Proof using.
  unfolder. split.
  all: ins; desf; splits; auto.
  all: unfold same_mod, mod, same_lab_u2v_dom, same_label_u2v in *.
  all: set (SAMEY := SAME); specialize (SAMEY y H1).
  all: specialize (SAME x H0); desf; desf.
Qed.

End SameFuns2.

(******************************************************************************)
(** ** Sequenced-Before *)
(******************************************************************************)

Require Import Lia.

Definition ext_sb a b :=
  match a, b with
    | _, InitEvent _ => False
    | InitEvent _, ThreadEvent _ _ => True
    | ThreadEvent t i, ThreadEvent t' i' => t = t' /\ i < i'
   end.

Lemma ext_sb_trans : transitive ext_sb.
Proof using.
unfold ext_sb; red; ins.
destruct x,y,z; ins; desf; splits; eauto.
by rewrite H2.
Qed.

Lemma ext_sb_irr : irreflexive ext_sb.
Proof using.
unfold ext_sb; red; ins.
destruct x; firstorder. lia.
Qed.

Lemma ext_sb_to_non_init : ext_sb ⊆ ext_sb ⨾  ⦗fun x => ~ is_init x⦘.
Proof using.
unfold is_init, ext_sb; basic_solver.
Qed.

Lemma ext_sb_semi_total_l x y z
  (N: ~ is_init x) (NEQ: index y <> index z) (XY: ext_sb x y) (XZ: ext_sb x z):
  ext_sb y z \/ ext_sb z y.
Proof using.
unfold ext_sb in *.
destruct x,y,z; ins; desf.
cut(index1 < index2 \/ index2 < index1).
tauto.
lia.
Qed.

Lemma ext_sb_semi_total_r x y z
  (NEQ: index y <> index z) (XY: ext_sb y x) (XZ: ext_sb z x):
  ext_sb y z \/ ext_sb z y.
Proof using.
unfold ext_sb in *.
destruct x,y,z; ins; desf; eauto.
cut(index1 < index2 \/ index2 < index1).
tauto.
lia.
Qed.

Lemma ext_sb_tid_init x y (SB : ext_sb x y): tid x = tid y \/ is_init x.
Proof using.
unfold ext_sb in *; desf; ins; desf; eauto.
Qed.

Lemma ext_sb_tid_init': ext_sb ⊆ ext_sb ∩ same_tid ∪ ⦗is_init⦘ ⨾ ext_sb.
Proof using.
generalize ext_sb_tid_init; firstorder.
Qed.

Lemma tid_ext_sb: same_tid ⊆ ext_sb^? ∪ ext_sb^{-1} ∪ (is_init × is_init).
Proof using.
unfold ext_sb, same_tid, tid, is_init, cross_rel; unfolder.
ins; destruct x, y; desf; eauto.
cut(index0 < index1 \/ index1 < index0 \/ index0 = index1).
by ins; desf; eauto.
lia.
Qed.

Lemma tid_n_init_ext_sb: same_tid ⨾ ⦗set_compl is_init⦘ ⊆ ext_sb^? ∪ ext_sb^{-1}.
Proof using.
rewrite tid_ext_sb at 1.
unfold cross_rel.
basic_solver 12.
Qed.

(******************************************************************************)
(** ** is_init properties *)
(******************************************************************************)

Lemma is_init_tid :
  is_init ⊆₁ fun x => tid x = tid_init.
Proof using. unfolder. unfold is_init. ins. desf. Qed.

Lemma initninit_in_ext_sb : is_init × (set_compl is_init) ⊆ ext_sb.
Proof using. unfold ext_sb. basic_solver. Qed.

(******************************************************************************)
(** ** Tactics *)
(******************************************************************************)

#[global]
Hint Unfold set_union set_inter is_r is_w is_f R_ex : type_unfolderDb.
Tactic Notation "type_unfolder" :=  repeat autounfold with type_unfolderDb in *.

Tactic Notation "type_solver" int_or_var(index) :=
  type_unfolder; basic_solver index.

Tactic Notation "type_solver" :=  type_solver 4.

#[global]
Hint Unfold set_union set_inter is_r is_w is_f R_ex : mode_unfolderDb.
#[global]
Hint Unfold is_only_pln is_only_rlx is_rlx is_rel is_acq is_acqrel is_sc is_ra is_xacq : mode_unfolderDb.
Tactic Notation "mode_unfolder" :=  repeat autounfold with mode_unfolderDb in *.

Tactic Notation "mode_solver" int_or_var(index) :=
  mode_unfolder; basic_solver index.

Tactic Notation "mode_solver" :=  mode_solver 4.

Section EventsCountability.
  Definition actid_alt: Type := location + thread_id * nat.

  Lemma actid_alt_isomorphic:
    isomorphism (fun e => match e with
                       | InitEvent l => inl l
                       | ThreadEvent t i => inr (t, i)
                       end)
                (fun ae => match ae with
                        | inl l => InitEvent l
                        | inr (t, i) => ThreadEvent t i
                        end).
  Proof using. split; ins; [destruct a | destruct b as [? | [? ?]]]; auto. Qed.

  Lemma actid_countable: countable (@set_full actid).
  Proof using.
    eapply countable_isomorphic.
    { eapply isomorphism_sym, actid_alt_isomorphic. }
    apply countable_sum.
    { Set Printing All.
      unfold location, Loc.Loc.t. apply pos_countable. }
    apply countable_prod.
    { unfold thread_id, Basic.Ident.t. apply pos_countable. }
    apply nat_countable.
  Qed.

End EventsCountability.


(** Commutation of groupoid quotient with constant and identity *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Groupoids.

Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.

Require Import signature.hit_signature.
Require Import prelude.all.
Require Import algebra.one_types_polynomials.
Require Import algebra.groupoid_polynomials.

Local Open Scope cat.

Opaque comp_psfunctor.

(** Commutation of groupoid quotient with constant *)
Section GQuotConstant.
  Variable (A : one_types).

  Definition const_gquot_data
    : pstrans_data
        (comp_psfunctor (⟦ C A ⟧) gquot_psfunctor)
        (comp_psfunctor gquot_psfunctor ⦃ C A ⦄).
  Proof.
    use make_pstrans_data.
    - exact (λ _, gcl (poly_act_groupoid (C A) _)).
    - intros X Y f.
      use make_invertible_2cell.
      + intro z ; apply idpath.
      + apply one_type_2cell_iso.
  Defined.

  Definition const_gquot_is_pstrans
    : is_pstrans const_gquot_data.
  Proof.
    repeat split.
    - intros X Y f g p.
      use funextsec.
      intros z.
      exact (pathscomp0rid _ @ ge _ _).
    - intros.
      use funextsec.
      intros z.
      exact (pathscomp0rid _ @ ge _ _).
    - intros.
      use funextsec.
      intros z.
      exact (pathscomp0rid _ @ ge (poly_act_groupoid (C A) Z) z).
  Qed.

  Definition const_gquot
    : pstrans
        (comp_psfunctor (⟦ C A ⟧) gquot_psfunctor)
        (comp_psfunctor gquot_psfunctor ⦃ C A ⦄).
  Proof.
    use make_pstrans.
    - exact const_gquot_data.
    - exact const_gquot_is_pstrans.
  Defined.
End GQuotConstant.

(** Commutation of path groupoid with identity *)
Definition id_gquot_comp
           (G : groupoid)
  : gquot G → gquot (poly_act_groupoid I G).
Proof.
  use gquot_rec.
  - exact (λ x, gcl (poly_act_groupoid I G) x).
  - exact (λ x y f, gcleq (poly_act_groupoid I G) f).
  - exact (λ x, ge (poly_act_groupoid I G) x).
  - exact (λ _ _ _ g₁ g₂, gconcat (poly_act_groupoid I G) g₁ g₂).
  - exact (gtrunc (poly_act_groupoid I G)).
Defined.

Definition id_gquot_nat
           (G₁ G₂ : groupoid)
           (F : G₁ ⟶ G₂)
  : ∏ (x : gquot G₁),
    gquot_functor_map (poly_act_functor I F) (id_gquot_comp G₁ x)
    =
    id_gquot_comp G₂ (gquot_functor_map F x).
Proof.
  use gquot_ind_set.
  - exact (λ _, idpath _).
  - abstract (refine (λ a₁ a₂ g, _) ; simpl ;
    apply map_PathOver ;
    refine (whisker_square
              (idpath _)
              _
              _
              (idpath _)
              _) ;
      [ refine (!((!(maponpathscomp _ _ _))
                    @ maponpaths
                        (maponpaths (gquot_functor_map (poly_act_functor I F)))
                        (gquot_rec_beta_gcleq G₁ _ _ _ _ _ _ _ _ g)
                    @ _)) ;
      exact (gquot_rec_beta_gcleq (poly_act_groupoid I G₁) _ _ _ _ _ _ _ _ _)
      | refine (!(!(maponpathscomp _ _ _)
                     @ maponpaths
                         (maponpaths (id_gquot_comp G₂))
                         (gquot_rec_beta_gcleq G₁ _ _ _ _ _ _ _ _ g)
                     @ _)) ;
      exact (gquot_rec_beta_gcleq G₂ _ _ _ _ _ _ _ _ (#F g))
      | exact (vrefl (gcleq (poly_act_groupoid I G₂) (# F g))) ]).
  - exact (λ _, gtrunc _ _ _).
Defined.

Definition id_gquot_data
  : pstrans_data
      (comp_psfunctor (⟦ I ⟧) gquot_psfunctor)
      (comp_psfunctor gquot_psfunctor ⦃ I ⦄).
Proof.
  use make_pstrans_data.
  - exact id_gquot_comp.
  - intros G₁ G₂ F.
    use make_invertible_2cell.
    + exact (id_gquot_nat G₁ G₂ F).
    + apply one_type_2cell_iso.
Defined.

Definition id_gquot_is_pstrans
  : is_pstrans id_gquot_data.
Proof.
  repeat split.
  - intros X Y f g p.
    use funextsec.
    use gquot_ind_prop.
    + intros a.
      exact (pathscomp0rid _ @ !(gquot_rec_beta_gcleq Y _ _ _ _ _ _ _ _ (pr1 p a))).
    + intro.
      exact (gtrunc _ _ _ _ _).
  - intros X.
    use funextsec.
    use gquot_ind_prop.
    + intros a.
      exact (pathscomp0rid _ @ ge _ _).
    + intro.
      exact (gtrunc _ _ _ _ _).
  - intros X Y Z f g.
    use funextsec.
    use gquot_ind_prop.
    + intros a.
      exact (pathscomp0rid _ @ ge _ _).
    + intro.
      exact (gtrunc _ _ _ _ _).
Qed.

Definition id_gquot
  : pstrans
      (comp_psfunctor (⟦ I ⟧) gquot_psfunctor)
      (comp_psfunctor gquot_psfunctor ⦃ I ⦄).
Proof.
  use make_pstrans.
  - exact id_gquot_data.
  - exact id_gquot_is_pstrans.
Defined.


From iris.proofmode Require Import tactics.
From iris.algebra Require Export auth.
From iris.algebra Require Import gmap.
From iris.base_logic.lib Require Export invariants.
From iris Require Import options.
Import uPred.

(* The CMRA we need. *)
Class authG Σ (A : ucmraT) := AuthG {
  auth_inG :> inG Σ (authR A);
  auth_cmra_discrete :> CmraDiscrete A;
}.
Definition authΣ (A : ucmraT) : gFunctors := #[ GFunctor (authR A) ].

Instance subG_authΣ Σ A : subG (authΣ A) Σ → CmraDiscrete A → authG Σ A.
Proof. solve_inG. Qed.

Section definitions.
  Context `{!invG Σ, !authG Σ A} {T : Type} (γ : gname).

  Definition auth_own (a : A) : iProp Σ :=
    own γ (◯ a).
  Definition auth_inv (f : T → A) (φ : T → iProp Σ) : iProp Σ :=
    ∃ t, own γ (● f t) ∗ φ t.
  Definition auth_ctx (N : namespace) (f : T → A) (φ : T → iProp Σ) : iProp Σ :=
    inv N (auth_inv f φ).

  Global Instance auth_own_ne : NonExpansive auth_own.
  Proof. solve_proper. Qed.
  Global Instance auth_own_proper : Proper ((≡) ==> (⊣⊢)) auth_own.
  Proof. solve_proper. Qed.
  Global Instance auth_own_timeless a : Timeless (auth_own a).
  Proof. apply _. Qed.
  Global Instance auth_own_core_id a : CoreId a → Persistent (auth_own a).
  Proof. apply _. Qed.

  Global Instance auth_inv_ne n :
    Proper (pointwise_relation T (dist n) ==>
            pointwise_relation T (dist n) ==> dist n) auth_inv.
  Proof. solve_proper. Qed.
  Global Instance auth_inv_proper :
    Proper (pointwise_relation T (≡) ==>
            pointwise_relation T (⊣⊢) ==> (⊣⊢)) auth_inv.
  Proof. solve_proper. Qed.
  Global Instance auth_ctx_ne N n :
    Proper (pointwise_relation T (dist n) ==>
            pointwise_relation T (dist n) ==> dist n) (auth_ctx N).
  Proof. solve_proper. Qed.
  Global Instance auth_ctx_proper N :
    Proper (pointwise_relation T (≡) ==>
            pointwise_relation T (⊣⊢) ==> (⊣⊢)) (auth_ctx N).
  Proof. solve_proper. Qed.
  Global Instance auth_ctx_persistent N f φ : Persistent (auth_ctx N f φ).
  Proof. apply _. Qed.
End definitions.

Typeclasses Opaque auth_own auth_inv auth_ctx.
Instance: Params (@auth_own) 4 := {}.
Instance: Params (@auth_inv) 5 := {}.
Instance: Params (@auth_ctx) 7 := {}.

Section auth.
  Context `{!invG Σ, !authG Σ A}.
  Context {T : Type} `{!Inhabited T}.
  Context (f : T → A) (φ : T → iProp Σ).
  Implicit Types N : namespace.
  Implicit Types P Q R : iProp Σ.
  Implicit Types a b : A.
  Implicit Types t u : T.
  Implicit Types γ : gname.

  Lemma auth_own_op γ a b : auth_own γ (a ⋅ b) ⊣⊢ auth_own γ a ∗ auth_own γ b.
  Proof. by rewrite /auth_own -own_op auth_frag_op. Qed.

(*
  Global Instance from_and_auth_own γ a b1 b2 :
    IsOp a b1 b2 →
    FromAnd false (auth_own γ a) (auth_own γ b1) (auth_own γ b2) | 90.
  Proof. rewrite /IsOp /FromAnd=> ->. by rewrite auth_own_op. Qed.
  Global Instance from_and_auth_own_persistent γ a b1 b2 :
    IsOp a b1 b2 → Or (CoreId b1) (CoreId b2) →
    FromAnd true (auth_own γ a) (auth_own γ b1) (auth_own γ b2) | 91.
  Proof.
    intros ? Hper; apply mk_from_and_persistent; [destruct Hper; apply _|].
    by rewrite -auth_own_op -is_op.
  Qed.

  Global Instance into_and_auth_own p γ a b1 b2 :
    IsOp a b1 b2 →
    IntoAnd p (auth_own γ a) (auth_own γ b1) (auth_own γ b2) | 90.
  Proof. intros. apply mk_into_and_sep. by rewrite (is_op a) auth_own_op. Qed.
*)

  Lemma auth_own_mono γ a b : a ≼ b → auth_own γ b ⊢ auth_own γ a.
  Proof. intros [? ->]. by rewrite auth_own_op sep_elim_l. Qed.
  Lemma auth_own_valid γ a : auth_own γ a ⊢ ✓ a.
  Proof. by rewrite /auth_own own_valid auth_frag_validI. Qed.
  Global Instance auth_own_sep_homomorphism γ :
    WeakMonoidHomomorphism op uPred_sep (≡) (auth_own γ).
  Proof. split; try apply _. apply auth_own_op. Qed.

  Lemma big_opL_auth_own {B} γ (g : nat → B → A) (l : list B) :
    l ≠ [] →
    auth_own γ ([^op list] k↦x ∈ l, g k x) ⊣⊢
             [∗ list] k↦x ∈ l, auth_own γ (g k x).
  Proof. apply (big_opL_commute1 _). Qed.
  Lemma big_opM_auth_own `{Countable K} {B} γ (g : K → B → A) (m : gmap K B) :
    m ≠ ∅ →
    auth_own γ ([^op map] k↦x ∈ m, g k x) ⊣⊢
             [∗ map] k↦x ∈ m, auth_own γ (g k x).
  Proof. apply (big_opM_commute1 _). Qed.
  Lemma big_opS_auth_own `{Countable B} γ (g : B → A) (X : gset B) :
    X ≠ ∅ →
    auth_own γ ([^op set] x ∈ X, g x) ⊣⊢ [∗ set] x ∈ X, auth_own γ (g x).
  Proof. apply (big_opS_commute1 _). Qed.
  Lemma big_opMS_auth_own `{Countable B} γ (g : B → A) (X : gmultiset B) :
    X ≠ ∅ →
    auth_own γ ([^op mset] x ∈ X, g x) ⊣⊢ [∗ mset] x ∈ X, auth_own γ (g x).
  Proof. apply (big_opMS_commute1 _). Qed.

  Global Instance auth_own_cmra_sep_entails_homomorphism γ :
    MonoidHomomorphism op uPred_sep (⊢) (auth_own γ).
  Proof.
    split; [split|]; try apply _.
    - intros. by rewrite auth_own_op.
    - apply (affine _).
  Qed.

  Lemma big_opL_auth_own_1 {B} γ (g : nat → B → A) (l : list B) :
    auth_own γ ([^op list] k↦x ∈ l, g k x) ⊢
             [∗ list] k↦x ∈ l, auth_own γ (g k x).
  Proof. apply (big_opL_commute _). Qed.
  Lemma big_opM_auth_own_1 `{Countable K} {B} γ (g : K → B → A)
        (m : gmap K B) :
    auth_own γ ([^op map] k↦x ∈ m, g k x) ⊢ [∗ map] k↦x ∈ m, auth_own γ (g k x).
  Proof. apply (big_opM_commute _). Qed.
  Lemma big_opS_auth_own_1 `{Countable B} γ (g : B → A) (X : gset B) :
    auth_own γ ([^op set] x ∈ X, g x) ⊢ [∗ set] x ∈ X, auth_own γ (g x).
  Proof. apply (big_opS_commute _). Qed.
  Lemma big_opMS_auth_own_1 `{Countable B} γ (g : B → A)
        (X : gmultiset B) :
    auth_own γ ([^op mset] x ∈ X, g x) ⊢ [∗ mset] x ∈ X, auth_own γ (g x).
  Proof. apply (big_opMS_commute _). Qed.

  Global Instance own_mono' γ : Proper (flip (≼) ==> (⊢)) (auth_own γ).
  Proof. intros a1 a2. apply auth_own_mono. Qed.

  Lemma auth_alloc_strong N E t (I : gname → Prop) :
    pred_infinite I →
    ✓ (f t) → ▷ φ t ={E}=∗ ∃ γ, ⌜I γ⌝ ∗ auth_ctx γ N f φ ∗ auth_own γ (f t).
  Proof.
    iIntros (??) "Hφ". rewrite /auth_own /auth_ctx.
    iMod (own_alloc_strong (● f t ⋅ ◯ f t) I) as (γ) "[% [Hγ Hγ']]";
      [done|by apply auth_both_valid_discrete|].
    iMod (inv_alloc N _ (auth_inv γ f φ) with "[-Hγ']") as "#?".
    { iNext. rewrite /auth_inv. iExists t. by iFrame. }
    eauto.
  Qed.

  Lemma auth_alloc_cofinite N E t (G : gset gname) :
    ✓ (f t) → ▷ φ t ={E}=∗ ∃ γ, ⌜γ ∉ G⌝ ∗ auth_ctx γ N f φ ∗ auth_own γ (f t).
  Proof.
    intros ?. apply auth_alloc_strong=>//.
    apply (pred_infinite_set (C:=gset gname)) => E'.
    exists (fresh (G ∪ E')). apply not_elem_of_union, is_fresh.
  Qed.

  Lemma auth_alloc N E t :
    ✓ (f t) → ▷ φ t ={E}=∗ ∃ γ, auth_ctx γ N f φ ∗ auth_own γ (f t).
  Proof.
    iIntros (?) "Hφ".
    iMod (auth_alloc_cofinite N E t ∅ with "Hφ") as (γ) "[_ ?]"; eauto.
  Qed.

  Lemma auth_empty γ : ⊢ |==> auth_own γ ε.
  Proof. by rewrite /auth_own -own_unit. Qed.

  Lemma auth_inv_acc E γ a :
    ▷ auth_inv γ f φ ∗ auth_own γ a ={E}=∗ ∃ t,
      ⌜a ≼ f t⌝ ∗ ▷ φ t ∗ ∀ u b,
      ⌜(f t, a) ~l~> (f u, b)⌝ ∗ ▷ φ u ={E}=∗ ▷ auth_inv γ f φ ∗ auth_own γ b.
  Proof using Type*.
    iIntros "[Hinv Hγf]". rewrite /auth_inv /auth_own.
    iDestruct "Hinv" as (t) "[>Hγa Hφ]".
    iModIntro. iExists t.
    iDestruct (own_valid_2 with "Hγa Hγf") as % [? ?]%auth_both_valid_discrete.
    iSplit; first done. iFrame. iIntros (u b) "[% Hφ]".
    iMod (own_update_2 with "Hγa Hγf") as "[Hγa Hγf]".
    { eapply auth_update; eassumption. }
    iModIntro. iFrame. iExists u. iFrame.
  Qed.

  Lemma auth_acc E N γ a :
    ↑N ⊆ E →
    auth_ctx γ N f φ ∗ auth_own γ a ={E,E∖↑N}=∗ ∃ t,
      ⌜a ≼ f t⌝ ∗ ▷ φ t ∗ ∀ u b,
      ⌜(f t, a) ~l~> (f u, b)⌝ ∗ ▷ φ u ={E∖↑N,E}=∗ auth_own γ b.
  Proof using Type*.
    iIntros (?) "[#? Hγf]". rewrite /auth_ctx. iInv N as "Hinv" "Hclose".
    (* The following is essentially a very trivial composition of the accessors
       [auth_inv_acc] and [inv_acc] -- but since we don't have any good support
       for that currently, this gets more tedious than it should, with us having
       to unpack and repack various proofs.
       TODO: Make this mostly automatic, by supporting "opening accessors
       around accessors". *)
    iMod (auth_inv_acc with "[$Hinv $Hγf]") as (t) "(?&?&HclAuth)".
    iModIntro. iExists t. iFrame. iIntros (u b) "H".
    iMod ("HclAuth" $! u b with "H") as "(Hinv & ?)". by iMod ("Hclose" with "Hinv").
  Qed.
End auth.

Arguments auth_acc {_ _ _} [_] {_} [_] _ _ _ _ _ _ _.