From Equations Require Import Init.
Require Export HoTT.Basics.Overture.
Set Warnings "-notation-overridden".
Set Universe Polymorphism.

(** Fixes to the HoTT library *)

Register idpath as core.identity.refl.
Register paths_rect as core.identity.ind.
Register paths as core.identity.type.
Register inverse as core.identity.sym.

(** This allows [rewrite] to both in left-to-right and right-to left directions. *)
Definition paths_rect_r (A : Type) (x : A) (P : A -> Type) (p : P x) (y : A) (e : paths y x) : P y :=
  paths_rect A x (fun y e => P y) p y (inverse e).
Register concat as core.identity.trans.

Register ap as core.identity.congr.

(** [path_inspect x] allows to pattern-match x while retaining a propositional equality with [x] *)

Definition path_inspect {A : Type} (x : A) : { y | paths x y } := (x ; idpath).

Require Import HoTT.Types.Bool.
(* For compatibility with Coq's [induction] *)
Definition Bool_rect := Bool_ind.

(** /End of fixes to the HoTT library *)

(** The polymorphic equality type used by Equations when working with equality in Type. *)

Definition transport_r {A} (P : A -> Type) {x y : A} (e : y = x) : P x -> P y :=
  fun x => match (inverse e) with 1%path => x end.

Lemma paths_rect_dep_r {A} (x : A) (P : forall a, a = x -> Type) (p : P x 1%path)
      (y : A) (e : y = x) : P y e.
Proof. destruct e. apply p. Defined.


From Coq.Unicode Require Import Utf8.
From stdpp Require Import base.
From trace_program_logic.prelude Require Import classical.
From Coq.ssr Require Import ssreflect.

Lemma sig_eq {A} (P : A → Prop) (x y : sig P) :
  proj1_sig x = proj1_sig y → x = y.
Proof.
  destruct x as [x Px]; simpl.
  destruct y as [y Py]; simpl.
  intros ->.
  rewrite (ProofIrrelevance _ Px Py); trivial.
Qed.

Definition sig_prod_and {A B P Q} (a : {x : A | P x}) (b : {x : B | Q x}) :
    {x : A * B | P (fst x) ∧ Q (snd x)} :=
  (proj1_sig a, proj1_sig b) ↾ (conj (proj2_sig a) (proj2_sig b)).

Definition sig_prod_or_l {A P Q} (a : {x : A | P x}) :
  {x : A | P x ∨ Q x} := (proj1_sig a) ↾ (or_introl (proj2_sig a)).

Definition sig_prod_or_r {A P Q} (a : {x : A | Q x}) :
    {x : A | P x ∨ Q x} := (proj1_sig a) ↾ (or_intror (proj2_sig a)).

Definition sig_and {A} {P Q : A -> Prop} (a : {x : A | P x}) (HQ: Q (proj1_sig a)) :
    { x : A | P x ∧ Q x } := (proj1_sig a) ↾ (conj (proj2_sig a) (HQ)).


Require Import Coq.Lists.List.
Require Export ParDB.Spec.
Require Export ParDB.Lemmas.
Require Export ParDB.Inst.

Require Export SpecSyntax.
Require Export SpecTyping.
Require Export LemmasTyping.

Record WfEnv (Γ: Env) : Prop :=
  { wfenv_covar_kind_left : ∀ c σ τ k, ⟨ c : σ ~ τ ∷ k ∈ Γ ⟩ → ⟨ Γ ⊢ σ ∷ k ⟩;
    wfenv_covar_kind_right : ∀ c σ τ k, ⟨ c : σ ~ τ ∷ k ∈ Γ ⟩ → ⟨ Γ ⊢ τ ∷ k ⟩;
    wfenv_tmvar_ty : ∀ x τ, ⟨ x : τ ∈ Γ ⟩ → ⟨ Γ ⊢ τ ∷ kstar ⟩
  }.

Ltac crushAgreement :=
  match goal with
    | [IH: WfEnv ?Γ → _ |- _] =>
      let H := fresh in
        assert (WfEnv Γ) as H by eauto with ws;
        specialize (IH H); clear H
    | [IH: ⟨ ?Γ ⊢ ?σ ∷ ?k ⟩ → _ |- _] =>
      let H := fresh in
        assert ⟨ Γ ⊢ σ ∷ k ⟩ as H by trivial;
        specialize (IH H); clear H
    | [ |- _ ∧ _ ] => split
  end.

Local Ltac crush :=
  intros;
  repeat
    (cbn in *;
      (* repeat crushStlcSyntaxMatchH; *)
     repeat crushAgreement;
     repeat crushDbSyntaxMatchH;
     repeat crushDbLemmasRewriteH;
     repeat crushSyntaxRefold;
     repeat crushTypingMatchH;
     subst*;
     try discriminate;
     eauto 3 with ws;
     trivial;
     idtac
    ).

Lemma red_co {Γ γ σ τ k} :
  ⟨ Γ ⊢ γ : σ ↝ τ ∷ k ⟩ →
  ⟨ Γ ⊢ γ : σ ~ τ ∷ k ⟩.
Proof. induction 1; eauto with ws. Qed.
(* Hint Resolve red_co : ws. *)

Definition cofromredstar (σ: Exp) (γs: list Exp) : Exp :=
  fold_right (fun γ2 γ1 => cotrans γ1 γ2) (corefl σ) γs.

Lemma redstar_co {Γ γs σ τ k} :
  ⟨ Γ ⊢ γs : σ ↝* τ ∷ k ⟩ →
  ⟨ Γ ⊢ cofromredstar σ γs : σ ~ τ ∷ k ⟩.
Proof. induction 1; crush; eauto using red_co. Qed.
(* Hint Resolve redstar_co : ws. *)

Section WfEnv.

  Hint Resolve wfenv_covar_kind_left : ws.
  Hint Resolve wfenv_covar_kind_right : ws.
  Hint Resolve wfenv_tmvar_ty : ws.

  Lemma WfEnv_nil : WfEnv nil.
  Proof. constructor; inversion 1. Qed.

  Lemma wfenv_snoc_tyvar {Γ} (wΓ: WfEnv Γ) : ∀ k, WfEnv (Γ ► k).
  Proof. constructor; crush. Qed.

  Lemma wfenv_snoc_tmvar {Γ} (wΓ: WfEnv Γ) :
    ∀ τ, ⟨ Γ ⊢ τ ∷ kstar ⟩ → WfEnv (Γ ▻ τ).
  Proof. constructor; crush. Qed.

  Lemma wfenv_snoc_covar {Γ} (wΓ: WfEnv Γ) :
    ∀ σ τ k, ⟨ Γ ⊢ σ ∷ k ⟩ → ⟨ Γ ⊢ τ ∷ k ⟩ → WfEnv (Γ ◅ σ ~ τ ∷ k).
  Proof. constructor; crush. Qed.

End WfEnv.

Hint Resolve WfEnv_nil : ws.
Hint Resolve wfenv_snoc_tyvar : ws.
Hint Resolve wfenv_snoc_tmvar : ws.
Hint Resolve wfenv_snoc_covar : ws.

Section Agreement.

  Hint Resolve wfenv_covar_kind_left : ws.
  Hint Resolve wfenv_covar_kind_right : ws.
  Hint Resolve wfenv_tmvar_ty : ws.

  Lemma co_agreement {Γ γ σ τ k} (wΓ: WfEnv Γ) (wγ: ⟨ Γ ⊢ γ : σ ~ τ ∷ k ⟩) :
    ⟨ Γ ⊢ σ ∷ k ⟩ ∧ ⟨ Γ ⊢ τ ∷ k ⟩.
  Proof. induction wγ; crush. Qed.

  Lemma co_agreement_left {Γ γ σ τ k} (wΓ: WfEnv Γ) (wγ: ⟨ Γ ⊢ γ : σ ~ τ ∷ k ⟩) :
    ⟨ Γ ⊢ σ ∷ k ⟩.
  Proof. eapply co_agreement; eauto with ws. Qed.
  Hint Resolve co_agreement_left : ws.

  Lemma co_agreement_right {Γ γ σ τ k} (wΓ: WfEnv Γ) (wγ: ⟨ Γ ⊢ γ : σ ~ τ ∷ k ⟩) :
    ⟨ Γ ⊢ τ ∷ k ⟩.
  Proof. eapply co_agreement; eauto with ws. Qed.
  Hint Resolve co_agreement_right : ws.

  Lemma tm_agreement_ty {Γ t σ} (wΓ: WfEnv Γ) (wt: ⟨ Γ ⊢ t : σ ⟩) :
    ⟨ Γ ⊢ σ ∷ kstar ⟩.
  Proof. induction wt; crush. Qed.

End Agreement.

(******************************************************************************)

Fixpoint redrefl (τ: Exp) : Exp :=
  match τ with
    | var α           => corefl (var α)
    | τabs k τ        => coτabs k (redrefl τ)
    | τapp τ1 τ2      => coτapp (redrefl τ1) (redrefl τ2)
    | arr τ1 τ2       => coarr (redrefl τ1) (redrefl τ2)
    | arrτ k τ        => coarrτ k (redrefl τ)
    | arrγ τ1 τ2 k τ3 => coarrγ (redrefl τ1) (redrefl τ2) k (redrefl τ3)
    | _ => var 0
  end.

Lemma RedRefl {Γ τ k} (wτ: ⟨ Γ ⊢ τ ∷ k ⟩) :
  ⟨ Γ ⊢ redrefl τ : τ ↝ τ ∷ k ⟩.
Proof. induction wτ; crush. Qed.
Hint Resolve RedRefl : ws.

Definition rstrans (γs1 γs2: list Exp) : list Exp :=
  List.app γs2 γs1.
Lemma RsTrans {Γ γs1 γs2 τ1 τ2 τ3 k} :
  ⟨ Γ ⊢ γs1 : τ1 ↝* τ2 ∷ k ⟩ →
  ⟨ Γ ⊢ γs2 : τ2 ↝* τ3 ∷ k ⟩ →
  ⟨ Γ ⊢ rstrans γs1 γs2 : τ1 ↝* τ3 ∷ k ⟩.
Proof. intros wγs1 wγs2; induction wγs2; crush. Qed.

Definition rsτabs (k: Kind) (γs: list Exp) : list Exp :=
  List.map (coτabs k) γs.
Lemma RsTAbs {Γ γs σ τ k1 k2} :
  ⟨ Γ ► k1 ⊢ γs : σ ↝* τ ∷ k2 ⟩ →
  ⟨ Γ ⊢ rsτabs k1 γs : τabs k1 σ ↝* τabs k1 τ ∷ karr k1 k2 ⟩.
Proof. intros wγs; depind wγs; crush. Qed.

Definition rsτapp₁ (γs: list Exp) (τ: Exp) : list Exp :=
  List.map (fun γ => coτapp γ (redrefl τ)) γs.
Definition rsτapp₂ (σ: Exp) (γs: list Exp)  : list Exp :=
  List.map (coτapp (redrefl σ)) γs.
Definition rsτapp (σγs: list Exp) (σ1 σ2: Exp) (τγs: list Exp) (τ1 τ2 : Exp) : list Exp :=
  rstrans (rsτapp₁ σγs τ1) (rsτapp₂ σ2 τγs).

Lemma RsTApp₁ {Γ γs σ1 σ2 τ k1 k2} :
  ⟨ Γ ⊢ γs : σ1 ↝* σ2 ∷ karr k1 k2 ⟩ →
  ⟨ Γ ⊢ τ ∷ k1 ⟩ →
  ⟨ Γ ⊢ rsτapp₁ γs τ : τapp σ1 τ ↝* τapp σ2 τ ∷ k2 ⟩.
Proof. intros wγs wτ; unfold rsτapp₁; depind wγs; crush. Qed.
Lemma RsTApp₂ {Γ γs τ1 τ2 σ k1 k2} :
  ⟨ Γ ⊢ σ ∷ karr k1 k2 ⟩ →
  ⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ k1 ⟩ →
  ⟨ Γ ⊢ rsτapp₂ σ γs: τapp σ τ1 ↝* τapp σ τ2 ∷ k2 ⟩.
Proof. intros wσ wγs; unfold rsτapp₂; depind wγs; crush. Qed.

Lemma RsTApp {Γ σγs τγs σ1 σ2 τ1 τ2 k1 k2} :
  ⟨ Γ ⊢ σ2 ∷ karr k1 k2 ⟩ →
  ⟨ Γ ⊢ σγs : σ1 ↝* σ2 ∷ karr k1 k2 ⟩ →
  ⟨ Γ ⊢ τ1 ∷ k1 ⟩ →
  ⟨ Γ ⊢ τγs : τ1 ↝* τ2 ∷ k1 ⟩ →
  ⟨ Γ ⊢ rsτapp σγs σ1 σ2 τγs τ1 τ2 : τapp σ1 τ1 ↝* τapp σ2 τ2 ∷ k2 ⟩.
Proof.
  intros.
  eapply RsTrans.
  - eapply RsTApp₁; crush.
  - eapply RsTApp₂; crush.
Qed.

Definition rsarr₁ (γs: list Exp) (τ: Exp) : list Exp :=
  List.map (fun γ => coarr γ (redrefl τ)) γs.
Definition rsarr₂ (σ: Exp) (γs: list Exp)  : list Exp :=
  List.map (coarr (redrefl σ)) γs.
Definition rsarr (σγs: list Exp) (σ1 σ2: Exp) (τγs: list Exp) (τ1 τ2 : Exp) : list Exp :=
  rstrans (rsarr₁ σγs τ1) (rsarr₂ σ2 τγs).

Lemma RsArr₁ {Γ σγs σ1 σ2 τ} :
  ⟨ Γ ⊢ σγs : σ1 ↝* σ2 ∷ kstar ⟩ →
  ⟨ Γ ⊢ τ ∷ kstar ⟩ →
  ⟨ Γ ⊢ rsarr₁ σγs τ : arr σ1 τ ↝* arr σ2 τ ∷ kstar ⟩.
Proof. intros wσγs wτ; unfold rsarr₁; depind wσγs; crush. Qed.
Lemma RsArr₂ {Γ σ τγs τ1 τ2} :
  ⟨ Γ ⊢ σ ∷ kstar ⟩ →
  ⟨ Γ ⊢ τγs : τ1 ↝* τ2 ∷ kstar ⟩ →
  ⟨ Γ ⊢ rsarr₂ σ τγs: arr σ τ1 ↝* arr σ τ2 ∷ kstar ⟩.
Proof. intros wσ wτγs; unfold rsarr₂; depind wτγs; crush. Qed.

Lemma RsArr {Γ σγs σ1 σ2 τγs τ1 τ2} :
  ⟨ Γ ⊢ σ2 ∷ kstar ⟩ →
  ⟨ Γ ⊢ σγs : σ1 ↝* σ2 ∷ kstar ⟩ →
  ⟨ Γ ⊢ τ1 ∷ kstar ⟩ →
  ⟨ Γ ⊢ τγs : τ1 ↝* τ2 ∷ kstar ⟩ →
  ⟨ Γ ⊢ rsarr σγs σ1 σ2 τγs τ1 τ2 : arr σ1 τ1 ↝* arr σ2 τ2 ∷ kstar ⟩.
Proof.
  intros.
  eapply RsTrans.
  - eapply RsArr₁; crush.
  - eapply RsArr₂; crush.
Qed.

Definition rsarrτ (k: Kind) (γs: list Exp) : list Exp :=
  List.map (coarrτ k) γs.
Lemma RsArrT {Γ γs σ τ k} :
  ⟨ Γ ► k ⊢ γs : σ ↝* τ ∷ kstar ⟩ →
  ⟨ Γ ⊢ rsarrτ k γs : arrτ k σ ↝* arrτ k τ ∷ kstar ⟩.
Proof. intros wγs; depind wγs; crush. Qed.

Definition rsarrγ₁ (σγs: list Exp) (τ: Exp) (k: Kind) (ν: Exp) : list Exp :=
  List.map (fun σγ => coarrγ σγ (redrefl τ) k (redrefl ν)) σγs.
Definition rsarrγ₂ (σ: Exp) (τγs: list Exp) (k: Kind) (ν: Exp) : list Exp :=
  List.map (fun τγ => coarrγ (redrefl σ) τγ k (redrefl ν)) τγs.
Definition rsarrγ₃ (σ: Exp) (τ: Exp) (k: Kind) (νγs: list Exp) : list Exp :=
  List.map (fun νγ => coarrγ (redrefl σ) (redrefl τ) k νγ) νγs.
Definition rsarrγ (σγs: list Exp) (σ σ': Exp) (τγs: list Exp) (τ τ': Exp) k (νγs: list Exp) (ν ν': Exp) : list Exp :=
  rstrans (rsarrγ₁ σγs τ k ν) (rstrans (rsarrγ₂ σ' τγs k ν) (rsarrγ₃ σ' τ' k νγs)).

Lemma RsArrG₁ {Γ σγs σ σ' τ k ν} :
  ⟨ Γ ⊢ σγs : σ ↝* σ' ∷ k ⟩ →
  ⟨ Γ ⊢ τ ∷ k ⟩ →
  ⟨ Γ ⊢ ν ∷ kstar ⟩ →
  ⟨ Γ ⊢ rsarrγ₁ σγs τ k ν : arrγ σ τ k ν ↝* arrγ σ' τ k ν ∷ kstar ⟩.
Proof. intros wσγs wτ wν; unfold rsarrγ₁; depind wσγs; crush. Qed.
Lemma RsArrG₂ {Γ σ τγs τ τ' k ν} :
  ⟨ Γ ⊢ σ ∷ k ⟩ →
  ⟨ Γ ⊢ τγs : τ ↝* τ' ∷ k ⟩ →
  ⟨ Γ ⊢ ν ∷ kstar ⟩ →
  ⟨ Γ ⊢ rsarrγ₂ σ τγs k ν : arrγ σ τ k ν ↝* arrγ σ τ' k ν ∷ kstar ⟩.
Proof. intros wσ wτγs wν; unfold rsarrγ₂; depind wτγs; crush. Qed.
Lemma RsArrG₃ {Γ σ τ k νγs ν ν'} :
  ⟨ Γ ⊢ σ ∷ k ⟩ →
  ⟨ Γ ⊢ τ ∷ k ⟩ →
  ⟨ Γ ⊢ νγs : ν ↝* ν' ∷ kstar ⟩ →
  ⟨ Γ ⊢ rsarrγ₃ σ τ k νγs : arrγ σ τ k ν ↝* arrγ σ τ k ν' ∷ kstar ⟩.
Proof. intros wσ wτ wνγs; unfold rsarrγ₃; depind wνγs; crush. Qed.

Lemma RsArrG {Γ σγs σ σ' τγs τ τ' k νγs ν ν'} :
  ⟨ Γ ⊢ σ' ∷ k ⟩ →
  ⟨ Γ ⊢ σγs : σ ↝* σ' ∷ k ⟩ →
  ⟨ Γ ⊢ τ ∷ k ⟩ →
  ⟨ Γ ⊢ τ' ∷ k ⟩ →
  ⟨ Γ ⊢ τγs : τ ↝* τ' ∷ k ⟩ →
  ⟨ Γ ⊢ ν ∷ kstar ⟩ →
  ⟨ Γ ⊢ νγs : ν ↝* ν' ∷ kstar ⟩ →
  ⟨ Γ ⊢ rsarrγ σγs σ σ' τγs τ τ' k νγs ν ν' : arrγ σ τ k ν ↝* arrγ σ' τ' k ν' ∷ kstar ⟩.
Proof.
  intros.
  eapply RsTrans.
  eapply RsArrG₁; crush.
  eapply RsTrans.
  eapply RsArrG₂; crush.
  eapply RsArrG₃; crush.
Qed.

Definition rsbeta (k: Kind) (σγs: list Exp) (σ σ': Exp) (τγs: list Exp) (τ τ': Exp) : list Exp :=
  cons (cobeta k (redrefl σ') (redrefl τ')) (rsτapp (rsτabs k σγs) (τabs k σ) (τabs k σ') τγs τ τ').

Lemma RsBeta {Γ σγs σ σ' τγs τ τ' k1 k2} :
  ⟨ Γ ► k1 ⊢ σ' ∷ k2 ⟩ →
  ⟨ Γ ► k1 ⊢ σγs : σ ↝* σ' ∷ k2 ⟩ →
  ⟨ Γ ⊢ τ ∷ k1 ⟩ →
  ⟨ Γ ⊢ τ' ∷ k1 ⟩ →
  ⟨ Γ ⊢ τγs : τ ↝* τ' ∷ k1 ⟩ →
  ⟨ Γ ⊢ rsbeta k1 σγs σ σ' τγs τ τ' : τapp (τabs k1 σ) τ ↝* σ'[beta1 τ'] ∷ k2 ⟩.
Proof.
  intros. unfold rsbeta.
  econstructor.
  - eapply RsTApp; eauto.
    + constructor; auto.
    + eapply RsTAbs; eauto.
  - constructor; eauto.
    + eapply RedRefl; eauto.
    + eapply RedRefl; eauto.
Qed.

(* Definition coredstarbeta₁ (k: Kind) (γs: list Exp) (τ: Exp) : list Exp := *)
(*   List.map (fun γ => cobeta k γ (redrefl τ)) γs. *)
(* Lemma RedStarBeta₁ {Γ γsσ σ σ' γsτ τ τ' k1 k2} : *)
(*   ⟨ Γ ► k1 ⊢ γsσ : σ ↝* σ' ∷ k2 ⟩ → *)
(*   ⟨ Γ ⊢ γsτ : τ ~ τ' ∷ k1 ⟩ → *)
(*   ∃ ηs, ⟨ Γ ⊢ ηs : τapp (τabs k1 σ) τ ↝* σ'[beta1 τ'] ∷ k2 ⟩. *)
(* Proof.   *)
(*   unfold coredstarbeta₁; depind rσ; crush. *)
(* Qed. *)

(* Definition coredstarbeta₂ (σ: Exp) (γs: list Exp)  : list Exp := *)
(*   List.map (cobeta (redrefl σ)) γs. *)
(* Lemma RedStarBeta₂ {Γ γs τ1 τ2} (rτ: ⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ kstar ⟩) : *)
(*   ∀ {σ}, ⟨ Γ ⊢ σ ∷ kstar ⟩ → ⟨ Γ ⊢ coredstarbeta₂ σ γs: beta σ τ1 ↝* beta σ τ2 ∷ kstar ⟩. *)
(* Proof. unfold coredstarbeta₂; depind rτ; crush. Qed. *)

(* Definition coredstarbeta (σγs: list Exp) (σ1 σ2: Exp) (τγs: list Exp) (τ1 τ2 : Exp) : list Exp := *)
(*   rstrans (coredstarbeta₁ σγs τ1) (coredstarbeta₂ σ2 τγs). *)
(* Lemma RedStarBeta {Γ σγs τγs σ1 σ2 τ1 τ2} (wΓ: WfEnv Γ) *)
(*   (wσγs: ⟨ Γ ⊢ σγs : σ1 ↝* σ2 ∷ kstar ⟩) *)
(*   (wτγs: ⟨ Γ ⊢ τγs : τ1 ↝* τ2 ∷ kstar ⟩) : *)
(*   ⟨ Γ ⊢ coredstarbeta σγs σ1 σ2 τγs τ1 τ2 : beta σ1 τ1 ↝* beta σ2 τ2 ∷ kstar ⟩. *)
(* Proof. *)
(*   eapply RsTrans. *)
(*   - eapply RedStarBeta₁; crush. *)
(*   - eapply RedStarBeta₂; crush. *)
(* Qed. *)

(*
Definition rstrans (γs1 γs2: list Exp) : list Exp :=
  List.app γs2 γs1.

Lemma RsTrans {Γ γs1 γs2 τ1 τ2 ν k} :
  ⟨ Γ ⊢ γs1 : τ1 ↝* τ2 ∷ k ⟩ →
  ⟨ Γ ⊢ γs2 : τ2 ↝* ν ∷ k ⟩ →
  ⟨ Γ ⊢ rstrans γs1 γs2 : τ1 ↝* τ3 ∷ k ⟩.
Proof. intros r q; revert τ1 r; induction q; crush. Qed.

Fixpoint redrefl (τ: Exp) : Exp :=
  match τ with
    | var α           => corefl (var α)
    | τabs k τ        => coτabs k (redrefl τ)
    | τapp τ1 τ2      => coτapp (redrefl τ1) (redrefl τ2)
    | arr τ1 τ2       => coarr (redrefl τ1) (redrefl τ2)
    | arrτ k τ        => coarrτ k (redrefl τ)
    | arrγ τ1 τ2 k τ3 => coarrγ (redrefl τ1) (redrefl τ2) k (redrefl τ3)
    | _ => var 0
  end.

Lemma RedRefl {Γ τ k} (wτ: ⟨ Γ ⊢ τ ∷ k ⟩) :
  ⟨ Γ ⊢ redrefl τ : τ ↝ τ ∷ k ⟩.
Proof. induction wτ; crush. Qed.
Hint Resolve RedRefl : ws.

Definition rsτapp₁ (γs: list Exp) (τ: Exp) : list Exp :=
  List.map (fun γ => coτapp γ (redrefl τ)) γs.
Lemma RsTApp₁ {Γ γs σ1 σ2 k1 k2} (rσ: ⟨ Γ ⊢ γs : σ1 ↝* σ2 ∷ karr k1 k2 ⟩) :
  ∀ {τ}, ⟨ Γ ⊢ τ ∷ k1 ⟩ → ⟨ Γ ⊢ rsτapp₁ γs τ : τapp σ1 τ ↝* τapp σ2 τ ∷ k2 ⟩.
Proof. unfold rsτapp₁; depind rσ; crush. Qed.
Definition rsτapp₂ (σ: Exp) (γs: list Exp)  : list Exp :=
  List.map (coτapp (redrefl σ)) γs.
Lemma RsTApp₂ {Γ γs τ1 τ2 k1} (rτ: ⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ k1 ⟩) :
  ∀ {σ k2}, ⟨ Γ ⊢ σ ∷ karr k1 k2 ⟩ → ⟨ Γ ⊢ rsτapp₂ σ γs: τapp σ τ1 ↝* τapp σ τ2 ∷ k2 ⟩.
Proof. unfold rsτapp₂; depind rτ; crush. Qed.

Definition rsτapp (σγs: list Exp) (σ1 σ2: Exp) (τγs: list Exp) (τ1 τ2 : Exp) : list Exp :=
  rstrans (rsτapp₁ σγs τ1) (rsτapp₂ σ2 τγs).
Lemma RsTApp {Γ σγs τγs σ1 σ2 τ1 τ2 k1 k2} (wΓ: WfEnv Γ)
  (wσγs: ⟨ Γ ⊢ σγs : σ1 ↝* σ2 ∷ karr k1 k2 ⟩)
  (wτγs: ⟨ Γ ⊢ τγs : τ1 ↝* τ2 ∷ k1 ⟩) :
  ⟨ Γ ⊢ rsτapp σγs σ1 σ2 τγs τ1 τ2 : τapp σ1 τ1 ↝* τapp σ2 τ2 ∷ k2 ⟩.
Proof.
  eapply RsTrans.
  - eapply RsTApp₁; crush.
  - eapply RsTApp₂; crush.
Qed.

Definition rsτabs (k: Kind) (γs: list Exp) : list Exp :=
  List.map (coτabs k) γs.
Lemma RsTAbs {Γ γs σ τ k1 k2} :
  ⟨ Γ ► k1 ⊢ γs : σ ↝* τ ∷ k2 ⟩ →
  ⟨ Γ ⊢ rsτabs k1 γs : τabs k1 σ ↝* τabs k1 τ ∷ karr k1 k2 ⟩.
Proof. intros wγs; depind wγs; crush. Qed.

Definition rsarr₁ (γs: list Exp) (τ: Exp) : list Exp :=
  List.map (fun γ => coarr γ (redrefl τ)) γs.
Lemma RsArr₁ {Γ γs σ1 σ2} (rσ: ⟨ Γ ⊢ γs : σ1 ↝* σ2 ∷ kstar ⟩) :
  ∀ {τ}, ⟨ Γ ⊢ τ ∷ kstar ⟩ → ⟨ Γ ⊢ rsarr₁ γs τ : arr σ1 τ ↝* arr σ2 τ ∷ kstar ⟩.
Proof. unfold rsarr₁; depind rσ; crush. Qed.
Definition rsarr₂ (σ: Exp) (γs: list Exp)  : list Exp :=
  List.map (coarr (redrefl σ)) γs.
Lemma RsArr₂ {Γ γs τ1 τ2} (rτ: ⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ kstar ⟩) :
  ∀ {σ}, ⟨ Γ ⊢ σ ∷ kstar ⟩ → ⟨ Γ ⊢ rsarr₂ σ γs: arr σ τ1 ↝* arr σ τ2 ∷ kstar ⟩.
Proof. unfold rsarr₂; depind rτ; crush. Qed.

Definition rsarr (σγs: list Exp) (σ1 σ2: Exp) (τγs: list Exp) (τ1 τ2 : Exp) : list Exp :=
  rstrans (rsarr₁ σγs τ1) (rsarr₂ σ2 τγs).
Lemma RsArr {Γ σγs τγs σ1 σ2 τ1 τ2} (wΓ: WfEnv Γ)
  (wσγs: ⟨ Γ ⊢ σγs : σ1 ↝* σ2 ∷ kstar ⟩)
  (wτγs: ⟨ Γ ⊢ τγs : τ1 ↝* τ2 ∷ kstar ⟩) :
  ⟨ Γ ⊢ rsarr σγs σ1 σ2 τγs τ1 τ2 : arr σ1 τ1 ↝* arr σ2 τ2 ∷ kstar ⟩.
Proof.
  eapply RsTrans.
  - eapply RsArr₁; crush.
  - eapply RsArr₂; crush.
Qed.

(* Definition rsarrτ (k: Kind) (γs: list Exp) : list Exp := *)
(*   List.map (coarrτ k) γs. *)
(* Lemma RsArrT {Γ γs σ τ k} : *)
(*   ⟨ Γ ► k ⊢ γs : σ ↝* τ ∷ kstar ⟩ → *)
(*   ⟨ Γ ⊢ rsarrτ k γs : arrτ k σ ↝* arrτ k τ ∷ kstar ⟩. *)
(* Proof. intros wγs; depind wγs; crush. Qed. *)

(* Definition coredstarbeta₁ (k: Kind) (γs: list Exp) (τ: Exp) : list Exp := *)
(*   List.map (fun γ => cobeta k γ (redrefl τ)) γs. *)
(* Lemma RedStarBeta₁ {Γ γsσ σ σ' γsτ τ τ' k1 k2} : *)
(*   ⟨ Γ ► k1 ⊢ γsσ : σ ↝* σ' ∷ k2 ⟩ → *)
(*   ⟨ Γ ⊢ γsτ : τ ~ τ' ∷ k1 ⟩ → *)
(*   ∃ ηs, ⟨ Γ ⊢ ηs : τapp (τabs k1 σ) τ ↝* σ'[beta1 τ'] ∷ k2 ⟩. *)
(* Proof.   *)
(*   unfold coredstarbeta₁; depind rσ; crush. *)
(* Qed. *)

(* Definition coredstarbeta₂ (σ: Exp) (γs: list Exp)  : list Exp := *)
(*   List.map (cobeta (redrefl σ)) γs. *)
(* Lemma RedStarBeta₂ {Γ γs τ1 τ2} (rτ: ⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ kstar ⟩) : *)
(*   ∀ {σ}, ⟨ Γ ⊢ σ ∷ kstar ⟩ → ⟨ Γ ⊢ coredstarbeta₂ σ γs: beta σ τ1 ↝* beta σ τ2 ∷ kstar ⟩. *)
(* Proof. unfold coredstarbeta₂; depind rτ; crush. Qed. *)

(* Definition coredstarbeta (σγs: list Exp) (σ1 σ2: Exp) (τγs: list Exp) (τ1 τ2 : Exp) : list Exp := *)
(*   rstrans (coredstarbeta₁ σγs τ1) (coredstarbeta₂ σ2 τγs). *)
(* Lemma RedStarBeta {Γ σγs τγs σ1 σ2 τ1 τ2} (wΓ: WfEnv Γ) *)
(*   (wσγs: ⟨ Γ ⊢ σγs : σ1 ↝* σ2 ∷ kstar ⟩) *)
(*   (wτγs: ⟨ Γ ⊢ τγs : τ1 ↝* τ2 ∷ kstar ⟩) : *)
(*   ⟨ Γ ⊢ coredstarbeta σγs σ1 σ2 τγs τ1 τ2 : beta σ1 τ1 ↝* beta σ2 τ2 ∷ kstar ⟩. *)
(* Proof. *)
(*   eapply RsTrans. *)
(*   - eapply RedStarBeta₁; crush. *)
(*   - eapply RedStarBeta₂; crush. *)
(* Qed. *)
*)


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype.
Require Import bigop ssralg matrix zmodp div.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory.
Local Open Scope nat_scope.
Local Open Scope ring_scope.

Section ExtraBigOp.

Lemma sumr_add : forall (R : ringType) m n (F : 'I_(m + n) -> R),
  \sum_(i < m + n) F i = \sum_(i < m) F (lshift _ i)
  + \sum_(i < n) F (rshift _ i).
Proof.
move=> R; elim=> [|m ihm] n F.
  rewrite !big_ord0 add0r; apply: congr_big=> // [[i hi]] _.
  by rewrite /rshift /=; congr F; apply: val_inj.
rewrite !big_ord_recl ihm -addrA.
congr (_ + _); first by congr F; apply: val_inj.
congr (_ + _); by apply: congr_big=> // i _ /=; congr F; apply: val_inj.
Qed.

Lemma mxtens_index_proof m n (ij : 'I_m * 'I_n) : ij.1 * n + ij.2 < m * n.
Proof.
case: m ij=> [[[] //]|] m ij; rewrite mulSn addnC -addSn leq_add //.
by rewrite leq_mul2r; case: n ij=> // n ij; rewrite leq_ord orbT.
Qed.

Definition mxtens_index m n ij := Ordinal (@mxtens_index_proof m n ij).

Lemma mxtens_index_proof1 m n (k : 'I_(m * n)) : k %/ n < m.
Proof. by move: m n k=> [_ [] //|m] [|n] k; rewrite ?divn0 // ltn_divLR. Qed.
Lemma mxtens_index_proof2 m n (k : 'I_(m * n)) : k %% n < n.
Proof. by rewrite ltn_mod; case: n k=> //; rewrite muln0=> [] []. Qed.

Definition mxtens_unindex m n k :=
  (Ordinal (@mxtens_index_proof1 m n k), Ordinal (@mxtens_index_proof2 m n k)).

Implicit Arguments mxtens_index [[m] [n]].
Implicit Arguments mxtens_unindex [[m] [n]].

Lemma mxtens_indexK m n : cancel (@mxtens_index m n) (@mxtens_unindex m n).
Proof.
case: m=> [[[] //]|m]; case: n=> [[_ [] //]|n].
move=> [i j]; congr (_, _); apply: val_inj=> /=.
  by rewrite divnMDl // divn_small.
by rewrite modnMDl // modn_small.
Qed.

Lemma mxtens_unindexK m n : cancel (@mxtens_unindex m n) (@mxtens_index m n).
Proof.
case: m=> [[[] //]|m]. case: n=> [|n] k.
  by suff: False by []; move: k; rewrite muln0=> [] [].
by apply: val_inj=> /=; rewrite -divn_eq.
Qed.

CoInductive is_mxtens_index (m n : nat) : 'I_(m * n) -> Type :=
    IsMxtensIndex : forall (i : 'I_m) (j : 'I_n),
                   is_mxtens_index (mxtens_index (i, j)).

Lemma mxtens_indexP (m n : nat) (k : 'I_(m * n)) : is_mxtens_index k.
Proof. by rewrite -[k]mxtens_unindexK; constructor. Qed.

Lemma mulr_sum (R : ringType) m n (Fm : 'I_m -> R) (Fn : 'I_n -> R) :
  (\sum_(i < m) Fm i) * (\sum_(i < n) Fn i)
  = \sum_(i < m * n) ((Fm (mxtens_unindex i).1) * (Fn (mxtens_unindex i).2)).
Proof.
rewrite mulr_suml; transitivity (\sum_i (\sum_(j < n) Fm i * Fn j)).
  by apply: eq_big=> //= i _; rewrite -mulr_sumr.
rewrite pair_big; apply: reindex=> //=.
by exists mxtens_index=> i; rewrite (mxtens_indexK, mxtens_unindexK).
Qed.

End ExtraBigOp.

Section ExtraMx.

Lemma castmx_mul (R : ringType)
  (m m' n p p': nat) (em : m = m') (ep : p = p')
  (M : 'M[R]_(m, n)) (N : 'M[R]_(n, p)) :
  castmx (em, ep) (M *m N) = castmx (em, erefl _) M *m castmx (erefl _, ep) N.
Proof. by case: m' / em; case: p' / ep. Qed.

Lemma mulmx_cast (R : ringType)
  (m n n' p p' : nat) (en : n' = n) (ep : p' = p)
  (M : 'M[R]_(m, n)) (N : 'M[R]_(n', p')) :
  M *m (castmx (en, ep) N) =
  (castmx (erefl _, (esym en)) M) *m (castmx (erefl _, ep) N).
Proof. by case: n / en in M *; case: p / ep in N *. Qed.

Lemma castmx_row (R : Type) (m m' n1 n2 n1' n2' : nat)
  (eq_n1 : n1 = n1') (eq_n2 : n2 = n2') (eq_n12 : (n1 + n2 = n1' + n2')%N)
  (eq_m : m = m') (A1 : 'M[R]_(m, n1)) (A2 : 'M_(m, n2)) :
  castmx (eq_m, eq_n12) (row_mx A1 A2) =
  row_mx (castmx (eq_m, eq_n1) A1) (castmx (eq_m, eq_n2) A2).
Proof.
case: _ / eq_n1 in eq_n12 *; case: _ / eq_n2 in eq_n12 *.
by case: _ / eq_m; rewrite castmx_id.
Qed.

Lemma castmx_col (R : Type) (m m' n1 n2 n1' n2' : nat)
  (eq_n1 : n1 = n1') (eq_n2 : n2 = n2') (eq_n12 : (n1 + n2 = n1' + n2')%N)
  (eq_m : m = m') (A1 : 'M[R]_(n1, m)) (A2 : 'M_(n2, m)) :
  castmx (eq_n12, eq_m) (col_mx A1 A2) =
  col_mx (castmx (eq_n1, eq_m) A1) (castmx (eq_n2, eq_m) A2).
Proof.
case: _ / eq_n1 in eq_n12 *; case: _ / eq_n2 in eq_n12 *.
by case: _ / eq_m; rewrite castmx_id.
Qed.

Lemma castmx_block (R : Type) (m1 m1' m2 m2' n1 n2 n1' n2' : nat)
  (eq_m1 : m1 = m1') (eq_n1 : n1 = n1') (eq_m2 : m2 = m2') (eq_n2 : n2 = n2')
  (eq_m12 : (m1 + m2 = m1' + m2')%N) (eq_n12 : (n1 + n2 = n1' + n2')%N)
  (ul : 'M[R]_(m1, n1)) (ur : 'M[R]_(m1, n2))
  (dl : 'M[R]_(m2, n1)) (dr : 'M[R]_(m2, n2)) :
  castmx (eq_m12, eq_n12) (block_mx ul ur dl dr) =
  block_mx (castmx (eq_m1, eq_n1) ul) (castmx (eq_m1, eq_n2) ur)
  (castmx (eq_m2, eq_n1) dl) (castmx (eq_m2, eq_n2) dr).
Proof.
case: _ / eq_m1 in eq_m12 *; case: _ / eq_m2 in eq_m12 *.
case: _ / eq_n1 in eq_n12 *; case: _ / eq_n2 in eq_n12 *.
by rewrite !castmx_id.
Qed.

End ExtraMx.

Section MxTens.

Variable R : ringType.

Definition tensmx {m n p q : nat}
  (A : 'M_(m, n)) (B : 'M_(p, q)) : 'M[R]_(_,_) := nosimpl
  (\matrix_(i, j) (A (mxtens_unindex i).1 (mxtens_unindex j).1
                 * B (mxtens_unindex i).2 (mxtens_unindex j).2)).

Notation "A *t B" := (tensmx A B)
  (at level 40, left associativity, format "A  *t  B").

Lemma tensmxE {m n p q} (A : 'M_(m, n)) (B : 'M_(p, q)) i j k l :
  (A *t B) (mxtens_index (i, j)) (mxtens_index (k, l)) = A i k * B j l.
Proof. by rewrite !mxE !mxtens_indexK. Qed.

Lemma tens0mx {m n p q} (M : 'M[R]_(p,q)) : (0 : 'M_(m,n)) *t M = 0.
Proof. by apply/matrixP=> i j; rewrite !mxE mul0r. Qed.

Lemma tensmx0 {m n p q} (M : 'M[R]_(m,n)) : M *t (0 : 'M_(p,q)) = 0.
Proof. by apply/matrixP=> i j; rewrite !mxE mulr0. Qed.

Lemma tens_scalar_mx (m n : nat) (c : R) (M : 'M_(m,n)):
  c%:M *t M = castmx (esym (mul1n _), esym (mul1n _)) (c *: M).
Proof.
apply/matrixP=> i j.
case: (mxtens_indexP i)=> i0 i1; case: (mxtens_indexP j)=> j0 j1.
rewrite tensmxE [i0]ord1 [j0]ord1 !castmxE !mxE /= mulr1n.
by congr (_ * M _ _); apply: val_inj.
Qed.

Lemma tens_scalar1mx (m n : nat) (M : 'M_(m,n)) :
  1 *t M = castmx (esym (mul1n _), esym (mul1n _)) M.
Proof. by rewrite tens_scalar_mx scale1r. Qed.

Lemma tens_scalarN1mx (m n : nat) (M : 'M_(m,n)) :
  (-1) *t M = castmx (esym (mul1n _), esym (mul1n _)) (-M).
Proof. by rewrite [-1]mx11_scalar /= tens_scalar_mx !mxE scaleNr scale1r. Qed.

Lemma trmx_tens {m n p q} (M :'M[R]_(m,n)) (N : 'M[R]_(p,q)) :
  (M *t N)^T = M^T *t N^T.
Proof. by apply/matrixP=> i j; rewrite !mxE. Qed.

Lemma tens_col_mx {m n p q} (r : 'rV[R]_n)
  (M :'M[R]_(m, n)) (N : 'M[R]_(p, q)) :
  (col_mx r M) *t N =
  castmx (esym (mulnDl _ _ _), erefl _) (col_mx (r *t N) (M *t N)).
Proof.
apply/matrixP=> i j.
case: (mxtens_indexP i)=> i0 i1; case: (mxtens_indexP j)=> j0 j1.
rewrite !tensmxE castmxE /= cast_ord_id esymK !mxE /=.
case: splitP=> i0' /= hi0'; case: splitP=> k /= hk.
+ case: (mxtens_indexP k) hk=> k0 k1 /=; rewrite tensmxE.
  move=> /(f_equal (edivn^~ p)); rewrite !edivn_eq // => [] [h0 h1].
  by congr (r _ _ * N _ _); apply:val_inj; rewrite /= -?h0 ?h1.
+ move: hk (ltn_ord i1); rewrite hi0'.
  by rewrite [i0']ord1 mul0n mul1n add0n ltnNge=> ->; rewrite leq_addr.
+ move: (ltn_ord k); rewrite -hk hi0' ltnNge {1}mul1n.
  by rewrite mulnDl {1}mul1n -addnA leq_addr.
case: (mxtens_indexP k) hk=> k0 k1 /=; rewrite tensmxE.
rewrite hi0' mulnDl -addnA=> /addnI.
 move=> /(f_equal (edivn^~ p)); rewrite !edivn_eq // => [] [h0 h1].
by congr (M _ _ * N _ _); apply:val_inj; rewrite /= -?h0 ?h1.
Qed.

Lemma tens_row_mx {m n p q} (r : 'cV[R]_m) (M :'M[R]_(m,n)) (N : 'M[R]_(p,q)) :
  (row_mx r M) *t N =
  castmx (erefl _, esym (mulnDl _ _ _)) (row_mx (r *t N) (M *t N)).
Proof.
rewrite -[_ *t _]trmxK trmx_tens tr_row_mx tens_col_mx.
apply/eqP; rewrite -(can2_eq (castmxKV _ _) (castmxK _ _)); apply/eqP.
by rewrite trmx_cast castmx_comp castmx_id tr_col_mx -!trmx_tens !trmxK.
Qed.

Lemma tens_block_mx {m n p q}
  (ul : 'M[R]_1) (ur : 'rV[R]_n) (dl : 'cV[R]_m)
  (M :'M[R]_(m,n)) (N : 'M[R]_(p,q)) :
  (block_mx ul ur dl M) *t N =
  castmx (esym (mulnDl _ _ _), esym (mulnDl _ _ _))
  (block_mx (ul *t N) (ur *t N) (dl *t N) (M *t N)).
Proof.
rewrite !block_mxEv tens_col_mx !tens_row_mx -!cast_col_mx castmx_comp.
by congr (castmx (_,_)); apply nat_irrelevance.
Qed.

Fixpoint ntensmx_rec {m n} (A : 'M_(m,n)) k : 'M_(m ^ k.+1,n ^ k.+1) :=
  if k is k'.+1 then (A *t (ntensmx_rec A k')) else A.

Definition ntensmx {m n} (A : 'M_(m, n)) k := nosimpl
  (if k is k'.+1 return 'M[R]_(m ^ k,n ^ k) then ntensmx_rec A k' else 1).

Notation "A ^t k" := (ntensmx A k)
  (at level 39, left associativity, format "A  ^t  k").

Lemma ntensmx0 : forall {m n} (A : 'M_(m,n)) , A ^t 0 = 1.
Proof. by []. Qed.

Lemma ntensmx1 : forall {m n} (A : 'M_(m,n)) , A ^t 1 = A.
Proof. by []. Qed.

Lemma ntensmx2 : forall {m n} (A : 'M_(m,n)) , A ^t 2 = A *t A.
Proof. by []. Qed.

Lemma ntensmxSS : forall {m n} (A : 'M_(m,n)) k, A ^t k.+2 = A *t A ^t k.+1.
Proof. by []. Qed.

Definition ntensmxS := (@ntensmx1, @ntensmx2, @ntensmxSS).

End MxTens.

Notation "A *t B" := (tensmx A B)
  (at level 40, left associativity, format "A  *t  B").

Notation "A ^t k" := (ntensmx A k)
  (at level 39, left associativity, format "A  ^t  k").

Section MapMx.
Variables (aR rR : ringType).
Hypothesis f : {rmorphism aR -> rR}.
Local Notation "A ^f" := (map_mx f A) : ring_scope.

Variables m n p q: nat.
Implicit Type A : 'M[aR]_(m, n).
Implicit Type B : 'M[aR]_(p, q).

Lemma map_mxT A B : (A *t B)^f = A^f *t B^f :> 'M_(m*p, n*q).
Proof. by apply/matrixP=> i j; rewrite !mxE /= rmorphM. Qed.

End MapMx.

Section Misc.

Lemma tensmx_mul (R : comRingType) m n p q r s
  (A : 'M[R]_(m,n)) (B : 'M[R]_(p,q)) (C : 'M[R]_(n, r)) (D : 'M[R]_(q, s)) :
  (A *t B) *m (C *t D) = (A *m C) *t (B *m D).
Proof.
apply/matrixP=> /= i j.
case (mxtens_indexP i)=> [im ip] {i}; case (mxtens_indexP j)=> [jr js] {j}.
rewrite !mxE !mxtens_indexK mulr_sum; apply: congr_big=> // k _.
by rewrite !mxE !mxtens_indexK mulrCA !mulrA [C _ _ * A _ _]mulrC.
Qed.

(* Todo : move to div ? *)
Lemma eq_addl_mul q q' m m' d : m < d -> m' < d ->
  (q * d + m == q' * d  + m')%N = ((q, m) == (q', m')).
Proof.
move=> lt_md lt_m'd; apply/eqP/eqP; last by move=> [-> ->].
by move=> /(f_equal (edivn^~ d)); rewrite !edivn_eq.
Qed.

Lemma tensmx_unit (R : fieldType) m n (A : 'M[R]_m%N) (B : 'M[R]_n%N) :
  m != 0%N -> n != 0%N -> A \in unitmx -> B \in unitmx -> (A *t B) \in unitmx.
Proof.
move: m n A B => [|m] [|n] // A B _ _ uA uB.
suff : (A^-1 *t B^-1) *m (A *t B) = 1 by case/mulmx1_unit.
rewrite tensmx_mul !mulVmx //; apply/matrixP=> /= i j.
rewrite !mxE /=; symmetry; rewrite -natrM -!val_eqE /=.
rewrite {1}(divn_eq i n.+1) {1}(divn_eq j n.+1).
by rewrite eq_addl_mul ?ltn_mod // xpair_eqE mulnb.
Qed.

Lemma tens_mx_scalar : forall (R : comRingType)
  (m n : nat) (c : R) (M : 'M[R]_(m,n)),
  M *t c%:M = castmx (esym (muln1 _), esym (muln1 _)) (c *: M).
Proof.
move=> R0 m n c M; apply/matrixP=> i j.
case: (mxtens_indexP i)=> i0 i1; case: (mxtens_indexP j)=> j0 j1.
rewrite tensmxE [i1]ord1 [j1]ord1 !castmxE !mxE /= mulr1n mulrC.
by congr (_ * M _ _); apply: val_inj=> /=; rewrite muln1 addn0.
Qed.

Lemma tensmx_decr : forall (R : comRingType) m n (M :'M[R]_m) (N : 'M[R]_n),
  M *t N = (M *t 1%:M) *m (1%:M *t N).
Proof. by move=> R0 m n M N; rewrite tensmx_mul mul1mx mulmx1. Qed.

Lemma tensmx_decl : forall (R : comRingType) m n (M :'M[R]_m) (N : 'M[R]_n),
  M *t N = (1%:M *t N) *m (M *t 1%:M).
Proof. by move=> R0 m n M N; rewrite tensmx_mul mul1mx mulmx1. Qed.

End Misc.


Require Import Notation.
Require Import GeneralTactics.
Require Import TacticCombinators.

Import EqNotations.

Lemma proof_irrelevance__uip_refl :
  (forall (P: Prop) (p1 p2: P), p1 = p2) ->
  forall A (x: A) (h: x = x), h = eq_refl x.
Proof using.
  intros ? *.
  assumption!.
Qed.

Module Type UipImpl.
  Axiom uip_refl : forall A (x: A) (h: x = x), h = eq_refl x.
End UipImpl.

Module UipTheory (M: UipImpl).

Lemma uip_refl : forall A (x: A) (h: x = x), h = eq_refl x.
Proof using.
  exact M.uip_refl.
Qed.

Lemma uip : forall A (x y: A) (p q: x = y),
  p = q.
Proof using.
  intros.
  destruct q.
  apply uip_refl.
Qed.

Lemma eq_K : forall A (x: A) (P: x = x -> Type),
  P (eq_refl x) ->
  forall p: x = x, P p.
Proof using.
  intros.
  now rewrite uip_refl.
Qed.

Lemma eq_rect_eq : forall A (x: A) (P: A -> Type) (y: P x) (h: x = x),
  y = eq_rect x P y x h.
Proof using.
  intros *.
  now rewrite (uip_refl _ _ h).
Qed.

Lemma inj_pair2 :
  forall A (P: A -> Type) a (x y: P a),
    ⟨a, x⟩ = ⟨a, y⟩ ->
    x = y.
Proof using.
  intros.
  inversion_sigma.
  now find rewrite <- eq_rect_eq in.
Qed.

Notation inj_pairT2 := inj_pair2.

(* Dependent inversion tactics leveraging LEM *)

Ltac destr_sigma_eq :=
  repeat match goal with
  | H: existT _ _ _ = existT _ _ _ |- _ =>
      simple apply inj_pairT2 in H
  end.

Tactic Notation "dependent" "inv" hyp(H) :=
  inv H;
  destr_sigma_eq;
  subst!.

Tactic Notation "dependent" "inv" hyp(H) "as" simple_intropattern(pat) :=
  inv H as pat;
  destr_sigma_eq;
  subst!.

Tactic Notation "dependent" "invc" hyp(H) :=
  invc H;
  destr_sigma_eq;
  subst!.

Tactic Notation "dependent" "invc" hyp(H) "as" simple_intropattern(pat) :=
  invc H as pat;
  destr_sigma_eq;
  subst!.

Tactic Notation "inv!" hyp(H) :=
  env_delta (dependent inv H) (fun ls =>
  foreach ls (fun H => hide_proof_terms in H)
  ).

Tactic Notation "inv!" hyp(H) "as" simple_intropattern(pat) :=
  env_delta (dependent inv H as pat) (fun ls =>
  foreach ls (fun H => hide_proof_terms in H)
  ).

Tactic Notation "invc!" hyp(H) :=
  env_delta (dependent invc H) (fun ls =>
  foreach ls (fun H => hide_proof_terms in H)
  ).

Tactic Notation "invc!" hyp(H) "as" simple_intropattern(pat) :=
  env_delta (dependent invc H as pat) (fun ls =>
  foreach ls (fun H => hide_proof_terms in H)
  ).

(* This is a modification of injection, which behaves like `invc` in the sense
   that it clears the original, does `subst!`, and destructs sigma equalities
   with UIP *)
Ltac inject H :=
  match goal with
  | |- ?g =>
      injection H;
      try clear H;
      repeat lazymatch goal with
      | |- g => fail
      | _ => intro
      end;
      subst!;
      destr_sigma_eq;
      subst!
  end.

(* Here we give a redefinition of the JMeq construct. Unfortunately, the
   existing JMeq definition is irrevocably tied to the JMeq_eq axiom,
   which we'd rather not accept here, since it can be derived by
   UIP (and by extesion, LEM).
 *)

Unset Elimination Schemes.
Inductive JMeq (A: Type) (x : A) : forall B : Type, B -> Prop :=
  | JMeq_refl : JMeq A x A x.
Set Elimination Schemes.
Arguments JMeq {A} x {B} y.
Arguments JMeq_refl {A} x.

Notation "x ~=~ y" := (JMeq x y) (at level 70, no associativity).
Notation "x ~<>~ y" := (~ JMeq x y) (at level 70, no associativity).

Register JMeq as core.JMeq.type.
Register JMeq_refl as core.JMeq.refl.

#[global]
Hint Resolve JMeq_refl : core.

Definition JMeq_hom {A} (x y: A) := x ~=~ y.
Register JMeq_hom as core.JMeq.hom.

(* Note: this is in fact equivalent to UIP. *)
Lemma JMeq_eq : forall A (x y: A),
  x ~=~ y ->
  x = y.
Proof using.
  intros * Heq.
  now dependent inv Heq.
Qed.

Lemma eq_JMeq : forall A (x y: A),
  x = y ->
  x ~=~ y.
Proof using.
  now intros * ->.
Qed.

Lemma JMeq_is_eq : forall A (x y: A),
  x ~=~ y <-> x = y.
Proof using.
  intros *.
  split; intros ?.
  - now apply JMeq_eq.
  - now apply eq_JMeq.
Qed.

Theorem JMeq_rect : forall (A: Type) (x: A) (P : A -> Type),
  P x ->
  forall y : A, x ~=~ y -> P y.
Proof using.
  intros * ? * Heq.
  apply JMeq_eq in Heq.
  now induction Heq.
Qed.

Lemma JMeq_rec : forall (A: Type) (x: A) (P : A -> Set),
  P x ->
  forall y : A, x ~=~ y -> P y.
Proof using.
  exact JMeq_rect.
Qed.

Lemma JMeq_ind : forall (A: Type) (x: A) (P : A -> Prop),
  P x ->
  forall y : A, x ~=~ y -> P y.
Proof using.
  exact JMeq_rect.
Qed.

Register JMeq_ind as core.JMeq.ind.

Theorem JMeq_sym : forall A B (a: A) (b: B),
  a ~=~ b ->
  b ~=~ a.
Proof using.
  intros.
  follows destruct H.
Qed.

#[global]
Hint Immediate JMeq_sym : core.
Register JMeq_sym as core.JMeq.sym.

Theorem JMeq_trans : forall A B C (a: A) (b: B) (c: C),
  a ~=~ b ->
  b ~=~ c ->
  a ~=~ c.
Proof using.
  intros * [] [].
  constructor.
Qed.

Register JMeq_trans as core.JMeq.trans.

Theorem JMeq_congr : forall A (x: A) B (f: A -> B) (y: A),
  x ~=~ y ->
  f x = f y.
Proof using.
  intros * H.
  pattern y.
  follows eapply JMeq_ind.
Qed.

Register JMeq_congr as core.JMeq.congr.

Theorem f_JMequal : forall A (B: A -> Type) (f: forall a, B a) (x y: A),
  x = y ->
  f x ~=~ f y.
Proof using.
  follows intros * <-.
Qed.

Theorem JMeq_type_eq {A B} {a: A} {b: B}:
  a ~=~ b ->
  A = B.
Proof using.
  follows intros [].
Defined.

Theorem mistyped_nJMeq {A B} {a: A} {b: B}:
  A <> B ->
  a ~<>~ b.
Proof using.
  follows do 2 intro.
Qed.

Lemma rew_JMeq {A B} : forall (H: A = B) (a: A),
  rew H in a ~=~ a.
Proof using.
  intros *.
  now destruct H.
Qed.

Corollary rew_JMeq_sym {A B} : forall (H: A = B) (a: A),
  a ~=~ rew H in a.
Proof using.
  symmetry.
  apply rew_JMeq.
Qed.

Definition JMcast {A B} (H: A = B) (a: A) : {b: B | a ~=~ b} :=
  exist _ (rew H in a) (rew_JMeq_sym H a).

Theorem JMeq_by_rew_eq {A B}: forall (H: A = B) (x: A) (y: B),
  rew H in x = y ->
  x ~=~ y.
Proof using.
  intros * Heq.
  apply JMeq_trans with (b := rew H in x).
  - apply rew_JMeq_sym.
  - follows rewrite Heq.
Qed.

Theorem rew_eq_by_JMeq {A B}: forall (x: A) (y: B),
  forall h: x ~=~ y,
  rew JMeq_type_eq h in x = y.
Proof using.
  intros *.
  follows destruct h.
Qed.

Theorem JMeq_by_rew_eqr {A B}: forall (H: B = A) (x: A) (y: B),
  x = rew H in y ->
  x ~=~ y.
Proof using.
  intros * Heq.
  apply JMeq_trans with (b := rew H in y).
  - follows rewrite Heq.
  - apply rew_JMeq.
Qed.

Theorem rew_eqr_by_JMeq {A B}: forall (x: A) (y: B),
  forall h: x ~=~ y,
  x = rew eq_sym (JMeq_type_eq h) in y.
Proof using.
  intros *.
  follows destruct h.
Qed.

Theorem rew_eq_refl_cancel : forall A (x: A),
  rew eq_refl A in x = x.
Proof using.
  tedious.
Qed.

Theorem rew_cancel: forall A (H: A = A) (x: A),
  rew H in x = x.
Proof using.
  intros.
  rewrite (uip_refl _ _ H).
  apply rew_eq_refl_cancel.
Qed.

Theorem existT_eq_intro :
  forall (A: Type) (B: A -> Type) (a a': A) (b: B a) (b': B a'),
    a = a' ->
    b ~=~ b' ->
    ⟨a, b⟩ = ⟨a', b'⟩.
Proof using.
  intros * <- Heq'.
  f_equal.
  follows apply JMeq_eq.
Qed.

Lemma pair_JMeq_intro :
  forall A B C D (a: A) (b: B) (c: C) (d: D),
    a ~=~ b ->
    c ~=~ d ->
    (a, c) ~=~ (b, d).
Proof using.
  follows intros * [] [].
Qed.

(* `crush_eqs` aggressively factors out and destruct equalities by UIP *)

Ltac _crush_eqs cleanup :=
  match goal with
  | |- context[?p] =>
      match type of p with
      | _ = _ =>
          not is_var p;
          not (unify p eq_refl);
          let Heq := fresh "Heq" in
          set (Heq := p) in *;
          clearbody Heq;
          _crush_eqs (cleanup, Heq)
      end
  | _ : context[?p] |- _ =>
      match type of p with
      | _ = _ =>
          not is_var p;
          not (unify p eq_refl);
          let Heq := fresh "Heq" in
          set (Heq := p) in *;
          clearbody Heq;
          _crush_eqs (cleanup, Heq)
      end
  | _ =>
      repeat match goal with
      | Heq : ?x = ?y |- _ =>
          (rewrite (uip_refl _ x Heq) in *; try clear Heq) +
          (* destruct Heq + *)
          (let _tmp := fresh in copy Heq _tmp; destruct _tmp) +
          rewrite Heq in *
      end;
      foreach cleanup (fun H => try clear H)
  end.

Ltac crush_eqs :=
  subst!;
  _crush_eqs hnil.

End UipTheory.


Require Import type.

Lemma t_eq_dec : forall A (eq_dec : forall (x y : A), {x = y} + {x <> y}) (x y : t A),
  {x = y} + {x <> y}.
Proof.
  intros A eq_dec.
  unshelve refine (fix aux (x : t A) :=
    let aux2 (l1 : list (t A)) : forall l2, {l1 = l2} + {l1 <> l2} := _ in
    _); [|clearbody aux2].
  - decide equality.
  - decide equality.
Defined.

Fixpoint t_eq_dec' A (eq_dec : forall (x y : A), {x = y} + {x <> y}) x : forall y : t A,
  {x = y} + {x <> y}.
Proof.
  decide equality. decide equality.
Defined.


Require Import MirrorSolve.FirstOrder.

Require Import MirrorSolve.BV.
Require Import MirrorSolve.SMT.
Require Import MirrorSolve.UF.

Require Import MirrorSolve.Reflection.Core.
Require Import MirrorSolve.Reflection.FM.
Require Import MirrorSolve.Reflection.Tactics.
From Hammer Require Import Hammer.

Require Import MirrorSolve.Crush.

Ltac hammer' := timeout 60 hammer.
Ltac crush' := timeout 60 crush.

Section Groups.

  Unset Universe Polymorphism.
  (* The set of the group. *)
  (*** MS BEGIN {"type": "definition"} *)
  Variable G : Set.
  (*** MS END {"type": "definition"} *)

  (* The binary operator. *)

  (*** MS EFFORT {"type": "definition"} *)
  (*** MS BEGIN {"type": "definition"} *)
  Variable f : G -> G -> G.
  Definition f' := f.
  (*** MS END {"type": "definition"} *)

  (* The group identity. *)
  (*** MS EFFORT {"type": "definition"} *)
  (*** MS BEGIN {"type": "definition"} *)
  Variable e : G.
  Definition e' := e.
  (*** MS END {"type": "definition"} *)

  (* The inverse operator. *)
  (*** MS EFFORT {"type": "definition"} *)
  (*** MS BEGIN {"type": "definition"} *)
  Variable i : G -> G.
  Definition i' := i.
  (*** MS END {"type": "definition"} *)

  (* For readability, we use infix <+> to stand for the binary operator. *)
  Infix "<+>" := f' (at level 50, left associativity).

  (* The operator [f] is associative. *)
  (*** MS EFFORT {"type": "edit"} *)
  (*** MS BEGIN {"type": "definition"} *)
  Axiom assoc : forall a b c, a <+> b <+> c = a <+> (b <+> c).
  (*** MS END {"type": "definition"} *)

  (* [e] is the right-identity for all elements [a] *)
  (*** MS EFFORT {"type": "edit"} *)
  (*** MS BEGIN {"type": "definition"} *)
  Axiom id_r : forall a, a <+> e' = a.
  (*** MS END {"type": "definition"} *)

  (*** MS EFFORT {"type": "edit"} *)
  (* [i a] is the right-inverse of [a]. *)
  (*** MS BEGIN {"type": "definition"} *)
  Axiom inv_r : forall a, a <+> i' a = e'.
  (*** MS END {"type": "definition"} *)

  (* encoding groups in in FOL *)

  Local Declare ML Module "mirrorsolve".

  From MetaCoq.Template Require Import All Loader.
  Import MCMonadNotation.
  Require Import MirrorSolve.Config.
  Require Import Coq.Lists.List.
  Import ListNotations.
  Open Scope bs.

  Universe foo.
  MetaCoq Quote Definition typ_term := Type@{foo}.

  Notation pack x := (existT _ _ x).

  Definition fun_syms : list Config.packed := ([
      pack f'
    ; pack e'
    ; pack i'
  ])%type.

  Definition rel_syms : list Config.packed := ([
  ])%type.

  Definition prim_syms : list (Config.packed * String.string) := [
  ].

  MetaCoq Run (
    xs <- add_funs typ_term fun_syms [] ;;
    xs' <- tmQuote xs ;;
    tmMkDefinition "trans_tbl" xs'
  ).

  MetaCoq Run (
    gen_sig typ_term sorts fol_funs fol_rels
  ).
  MetaCoq Run (
    gen_interp_funs sorts interp_sorts fol_funs trans_tbl
  ).
  MetaCoq Run (
    gen_interp_rels sorts interp_sorts fol_rels trans_tbl
  ).
  Definition fm_model := Build_model sig interp_sorts interp_funs interp_rels.
  MetaCoq Run (
    match Utils.find _ _ smt_fun_base_beq IntLit (Utils.flip trans_tbl.(mp_consts)) with
    | Some v => add_const_wf_instance sig fm_model v IntLit
    | None => tmReturn tt
    end
  ).
  MetaCoq Run (
    match Utils.find _ _ smt_fun_base_beq BoolLit (Utils.flip trans_tbl.(mp_consts)) with
    | Some v => add_const_wf_instance sig fm_model v BoolLit
    | None => tmReturn tt
    end
  ).
  MetaCoq Run (
    add_matches sig fm_model trans_tbl
  ).
  MetaCoq Run (
    ctx <- build_printing_ctx sig sort_Prop trans_tbl prim_syms;;
    ctx' <- tmEval all ctx ;;
    rhs <- tmQuote ctx' ;;
    tmMkDefinition "fol_theory" rhs
  ).

  Require Import MirrorSolve.Reflection.Tactics.

  Transparent denote_tm.
  Require Import MirrorSolve.Axioms.

  (* We make use of the verification trick of negating the goal and checking for unsat.
    The check_unsat_neg tactic behaves like idtac if the negated goal is unsat and otherwise fails.
    *)
  Ltac check_goal_unsat :=
    match goal with
    | |- ?G => check_unsat_neg_func fol_theory G; eapply UnsoundAxioms.interp_true
    end.

  Create HintDb groups_eqns.

  Ltac prep_proof :=
    hints_foreach (fun x => pose proof x) "groups_eqns";
    Utils.revert_all;
    unfold "<->" in *.

  Scheme Equality for sorts.

  Ltac quote_reflect_groups := quote_reflect sig fm_model sorts_eq_dec match_tacs match_sorts.

  Ltac mirrorsolve :=
    timeout 60 (prep_proof;
    quote_reflect_groups;
    check_goal_unsat).

  Set MirrorSolve Solver "z3".
  (*** MS END {"type": "configuration", "config_type":"tactics"} *)

  Hint Immediate assoc : groups_eqns.
  Hint Immediate inv_r : groups_eqns.
  Hint Immediate id_r : groups_eqns.

  Hint Transparent f'.
  Hint Transparent e'.
  Hint Transparent i'.

  Hint Resolve assoc.
  Hint Resolve inv_r.
  Hint Resolve id_r.

  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 1} *)
  Lemma mult_both :
    forall a b c d1 d2,
      a <+> c = d1
      -> b <+> c = d2
      -> a = b
      -> d1 = d2.
  Proof.
    crush'.
    Restart.
    hammer'.
    Restart.
    mirrorsolve.
  Qed.

  Hint Extern 100 (_ = _) =>
  match goal with
    | [ _ : True |- _ ] => fail 1
    | _ => assert True by constructor; eapply mult_both
  end.

  (*** MS LEMMA {"original": False, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  Lemma add_right :
    forall a b c,
      a <+> b = a <+> c ->
      a <+> b <+> i' b = a <+> c <+> i' c.
  Proof.
    crush'.
    Restart.
    hammer'.
    Restart.
    mirrorsolve.
  Qed.

  Hint Immediate add_right : groups_eqns.
  Hint Resolve add_right.

  (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma unique_id :
    forall a,
      a <+> a = a ->
      a = e'.
  (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    mirrorsolve.
  Qed.

  Hint Immediate unique_id : groups_eqns.
  Hint Resolve unique_id.

  (* [i a] is the left-inverse of [a]. *)
  (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma inv_l :
    forall a,
      i' a <+> a = e'.
  (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    mirrorsolve.
  Qed.

  Hint Immediate inv_l : groups_eqns.
  Hint Resolve inv_l.

  (* [e] is the left-identity. *)
  (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma id_l :
    forall a,
      e' <+> a = a.
      (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    mirrorsolve.
  Qed.

  Hint Immediate id_l : groups_eqns.
  Hint Resolve id_l.

  (*** MS LEMMA {"original": False , "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  Lemma cancel_inv_r :
    forall a b x,
      a <+> x <+> i' x = b <+> x <+> i' x
      -> a = b.
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    Set MirrorSolve Solver "z3".
    mirrorsolve.
  Qed.

  Hint Resolve cancel_inv_r.
  Hint Immediate cancel_inv_r : groups_eqns.

  (* [x] can be cancelled on the right. *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 0, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma cancel_r :
    forall a b x,
      a <+> x = b <+> x ->
      a = b.
      (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    mirrorsolve.
  Qed.

  Hint Immediate cancel_r : groups_eqns.
  Hint Resolve cancel_r.

  (*** MS LEMMA {"original": False , "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  Lemma cancel_inv_l :
    forall a b x,
      x <+> i' x <+> a = x <+> i' x <+> b ->
      a = b.
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    mirrorsolve.
  Qed.

  Hint Resolve cancel_inv_l.
  Hint Immediate cancel_inv_l : groups_eqns.

  (* [x] can be cancelled on the left. *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma cancel_l:
    forall a b x,
      x <+> a = x <+> b ->
      a = b.
    (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    try mirrorsolve.
  Qed.

  Hint Immediate cancel_l : groups_eqns.
  Hint Resolve cancel_l : groups_eqns.

  (* The left identity is unique. *)
  (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma e_uniq_l :
    forall a p,
      p <+> a = a ->
      p = e'.
    (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    try mirrorsolve.
  Qed.

  Hint Immediate e_uniq_l : groups_eqns.
  Hint Resolve e_uniq_l.

  (* The left inverse is unique. *)
  (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma inv_uniq_l :
    forall a b,
      a <+> b = e' ->
      a = i' b.
    (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    try mirrorsolve.
  Qed.

  Hint Immediate inv_uniq_l : groups_eqns.
  Hint Resolve inv_uniq_l.

  (* The right identity is unique. *)
  (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)

  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma e_uniq_r :
    forall a p,
      a <+> p = a ->
      p = e'.
    (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    try mirrorsolve.
  Qed.

  Hint Immediate e_uniq_r : groups_eqns.
  Hint Resolve e_uniq_r.

  (* The right inverse is unique. *)
  (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)

  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma inv_uniq_r :
    forall a b,
      a <+> b = e' ->
      b = i' a.
    (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    try mirrorsolve.
  Qed.

  Hint Immediate inv_uniq_r : groups_eqns.
  Hint Resolve inv_uniq_r.

  (* The right inverse is unique. *)

  (* The inverse operator distributes over the group operator. *)
   (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma inv_distr :
    forall a b,
      i' (a <+> b) = i' b <+> i' a.
      (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    try mirrorsolve.
  Qed.

  Hint Immediate inv_distr : groups_eqns.
  Hint Resolve inv_distr.

  (* The inverse of an inverse produces the original element. *)
   (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma double_inv :
    forall a,
      i' (i' a) = a.
    (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    try mirrorsolve.
  Qed.

  Hint Immediate double_inv : groups_eqns.
  Hint Resolve inv_distr.

  (* The identity is its own inverse. *)
   (*** MS EFFORT {"type": "edit"} *)
  (*** MS LEMMA {"original": True, "sfo": True, "tsfo": True, "ho": False, "goals": 1, "ms": 1, "hammer": 1, "crush": 0} *)
  (*** MS BEGIN {"type": "proof_definition"} *)
  Lemma id_inv :
    i' e' = e'.
    (*** MS END {"type": "proof_definition"} *)
  Proof.
    try hammer'.
    Restart.
    try crush'.
    Restart.
    try mirrorsolve.
  Qed.

End Groups.


From AlphaPearl Require Import Util.Seq Util.PlfTactics.
From Coq Require Import Bool List ssreflect.
Import ListNotations.
From mathcomp Require Import bigop eqtype seq ssrbool ssrnat.
From extructures Require Import fmap fset ord.

Set Asymmetric Patterns.
Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.
Unset Printing Implicit Defensive.

#[local] Open Scope fset_scope.
#[local] Open Scope list_scope.

Notation "'∅'" := fset0 : fset_scope.

Notation "x '∪' y" := (x :|: y) (at level 52) : fset_scope.

Notation "x '∩' y" := (x :&: y) (at level 48) : fset_scope.

Notation "⋃_( x ∈ s ) y" :=
  (\bigcup_(x <- s) y)
    (at level 41, x, s at level 50, y at level 200) : fset_scope.

Notation "∑_( x ∈ s ) y" :=
  (\sum_(x <- s) y)
    (at level 41, x, s at level 50, y at level 200) : fset_scope.

Infix "⊆" := fsubset (at level 40) : fset_scope.

(** Coercions can't be overridden, so we'll define a wrapper type (and some new, yet similar-looking)
    notation to convince Coq to use this coercion instead. *)
Definition fmap_of' (S : ordType) (T : Type) := @FMap.fmap_of _ _ (Phant (S -> T)).

Notation "'{' 'fmap' S '→' T '}'" := (fmap_of' S T) (at level 0) : type_scope.

Definition fmap_to_Prop (A : ordType) (B : Type) (R : {fmap A → B}) (k : A) (v : B) : Prop :=
  getm R k = Some v.

Coercion fmap_to_Prop : fmap_of' >-> Funclass.

Arguments getmP {_ _ _ _ _}.

Arguments injectivemP {_ _ _}.

Arguments pimfsetP {_ _ _ _ _}.

Lemma fset_uniq :
  forall (A : ordType) (s : {fset A}),
    uniq s.
Proof.
  intros ?.
  apply fset_ind; auto. intros.
  rewrite -[s]fsvalK -fset_cons /=.
  assert (uniq (x :: s)). { rewrite /= H H0 //. }
  rewrite -> uniq_size_fset in *.
  rewrite fsvalK //.
Qed.

Lemma size_cons :
  forall (A : ordType) (s : {fset A}) (x : A),
    x ∉ s ->
    size (x |: s) = S (size s).
Proof.
  intros.
  assert (uniq (x :: s)). { rewrite cons_uniq H fset_uniq //. }
  rewrite uniq_size_fset in H0.
  rewrite -[s]fsvalK -fset_cons.
  apply (rwP eqP) in H0.
  rewrite -H0 fsvalK //.
Qed.

Lemma In_mem :
  forall (A : ordType) (l : list A) (x : A),
    In x l <-> x ∈ l.
Proof.
  intros.
  split; intros;
  induction l; auto.
  - inverts H.
    + apply mem_head.
    + rewrite in_cons.
      apply (rwP orP).
      auto.
  - inverts H.
  - rewrite in_cons in H.
    apply (rwP orP) in H.
    inverts H.
    + left.
      apply (rwP eqP) in H0. auto.
    + right. auto.
Qed.

Lemma In_mem_fset :
  forall (A : ordType) (l : list A) (x : A),
    In x l <-> x ∈ fset l.
Proof.
  intros.
  split; intros;
  induction l; auto.
  - rewrite fset_cons in_fsetU.
    inverts H.
    + rewrite in_fset1 eq_refl //.
    + rewrite IHl // orbT //.
  - rewrite -fset0E in H.
    inverts H.
  - rewrite fset_cons in_fsetU in H.
    apply (rwP orP) in H. inverts H.
    + rewrite in_fset1 in H0.
      apply (rwP eqP) in H0. subst.
      left. auto.
    + right. auto.
Qed.

Lemma fset1_repeat :
  forall (A : ordType) (x : A),
    fset [x; x] = fset1 x.
Proof.
  intros.
  apply eq_fset. intro.
  apply Bool.eq_true_iff_eq.
  split; intros.
  - rewrite in_fset1.
    apply In_mem_fset in H.
    inverts H; auto.
    + apply eq_refl.
    + inverts H0; auto.
      apply eq_refl.
  - rewrite in_fset1 in H.
    apply In_mem_fset.
    left.
    apply (rwP eqP) in H. auto.
Qed.

Lemma size_fset2 :
  forall (A : ordType) (x y : A),
    x <> y ->
    size (fset [x; y]) = 2.
Proof.
  intros.
  replace 2 with (size [x; y]); auto.
  symmetry.
  apply (introF eqP) in H. apply Bool.negb_true_iff in H.
  apply (rwP eqP).
  rewrite -uniq_size_fset /= in_fset1 H //.
Qed.

Lemma app_as_cat :
  forall (A : Type) (l1 l2 : list A),
    app l1 l2 = seq.cat l1 l2.
Proof. induction l1; auto. Qed.

Definition any (A : Type) (P : A -> bool) (l : list A) : bool := fold_right orb false (map P l).

Lemma anyP :
  forall {A : ordType} {P : A -> bool} {l : list A},
    reflect (exists x : A, (x ∈ l) && P x) (any P l).
Proof.
  intros.
  induction l.
  - constructor.
    intros []. auto.
  - cbn. fold (any P l).
    inverts IHl.
    + rewrite orbT. constructor.
      destruct H0 as [].
      exists x. rewrite in_cons Bool.andb_orb_distrib_l H0 orbT //.
    + destruct (P a) eqn:?;
      constructor; eauto.
      * exists a. rewrite mem_head Heqb //.
      * intros [].
        apply H0. exists x.
        rewrite in_cons in H1.
        apply (rwP andP) in H1 as [].
        rewrite H2.
        apply (rwP orP) in H1 as [].
        -- apply (rwP eqP) in H1. subst.
           rewrite H2 // in Heqb.
        -- rewrite H1 //.
Qed.

Lemma fset2_eq :
  forall (A : ordType) (x y : A),
    [fset x; y] = fset [x; y].
Proof.
  intros.
  apply eq_fset.
  intro.
  rewrite in_fset2.
  apply Bool.eq_true_iff_eq.
  split; intros.
  - apply (rwP orP) in H.
    inverts H;
    apply (rwP eqP) in H0;
    subst;
    apply In_mem_fset;
    (left + (right; left)); auto; fail.
  - apply (rwP orP).
    apply In_mem_fset in H.
    inverts H; auto.
    inverts H0; auto.
Qed.

Lemma fset2_reorder :
  forall (A : ordType) (x y : A),
    x <> y ->
    fset [x; y] = fset [y; x].
Proof.
  intros.
  apply eq_fset. intro.
  rewrite -!fset2_eq !in_fset2 Bool.orb_comm //.
Qed.

Lemma fsval_fset2 :
  forall (A : ordType) (x y : A),
    x <> y ->
    FSet.fsval (fset [x; y]) = [x; y] \/ FSet.fsval (fset [x; y]) = [y; x].
Proof.
  intros.
  assert (2 = size (fset [x; y])).
  { apply (rwP eqP).
    replace 2 with (size [x; y]) by auto.
    rewrite -uniq_size_fset /= Bool.andb_true_r.
    apply Bool.eq_true_not_negb. intro. apply H.
    rewrite mem_seq1 in H0.
    rewrite (rwP eqP) //. }
  destruct (FSet.fsval (fset [x; y])) eqn:?;
  inverts H0.
  destruct l.
  - inverts H2.
  - destruct l.
    + rewrite -fset2_eq in Heql.
      assert (s ∈ FSet.fsval [fset x; y]). { rewrite Heql mem_head //. }
      assert (s0 ∈ FSet.fsval [fset x; y]). { rewrite Heql. apply mem_last. }
      assert (x ∈ FSet.fsval [fset x; y]). { apply In_mem_fset. left. auto. }
      assert (y ∈ FSet.fsval [fset x; y]).
      { apply In_mem_fset.
        right.
        apply In_mem.
        apply In_mem_fset.
        left. auto. }
      apply (rwP (fset2P _)) in H0, H1.
      inverts H0; inverts H1; auto;
      ((assert (x ∈ [y; y]) by rewrite -Heql //) ||
       (assert (y ∈ [x; x]) by rewrite -Heql //));
      apply In_mem in H0;
      inverts H0; auto;
      inverts H1; auto;
      inverts H0; auto.
    + inverts H2.
Qed.

Lemma mapm_setm :
  forall (A : ordType) (B C : Type) (f : B -> C) (m : {fmap A -> B}) (k : A) (v : B),
    mapm f (setm m k v) = setm (mapm f m) k (f v).
Proof.
  intros.
  apply eq_fmap. intro.
  rewrite !mapmE !setmE.
  destruct (x =P k); subst; auto.
  rewrite mapmE //.
Qed.

Lemma all_fset1 :
  forall (A : ordType) (P : A -> bool) (x : A),
    all P (fset1 x) = P x.
Proof.
  intros.
  rewrite /= Bool.andb_true_r //.
Qed.

Lemma all_fset2 :
  forall (A : ordType) (P : A -> bool) (x y : A),
    all P (fset [x; y]) = P x && P y.
Proof.
  intros.
  rewrite all_fset /= Bool.andb_true_r //.
Qed.

Lemma all_fsubset :
  forall (A : ordType) (P : A -> bool) (s s__sub : {fset A}),
    fsubset s__sub s ->
    all P s ->
    all P s__sub.
Proof.
  intros. generalize dependent s__sub.
  apply (fset_ind (P := fun s__sub : {fset A} => fsubset s__sub s -> all P s__sub)); auto. intros.
  rewrite all_fsetU.
  rewrite -(rwP andP).
  rewrite fsubU1set in H2.
  apply (rwP andP) in H2 as [].
  split; auto.
  rewrite all_fset1.
  apply (rwP allP) in H0.
  auto.
Qed.

Definition rem_fsetm (A : ordType) (B : Type) (m : {fmap A -> B}) (s : {fset A}) : {fmap A -> B} :=
  filterm (fun x _ => x ∉ s) m.

Infix "∖" := rem_fsetm (at level 40).

Lemma rem_fsetm_correct :
  forall (A : ordType) (B : Type) (m : {fmap A -> B}) (s : {fset A}) (x : A),
    (x ∈ s -> getm (m ∖ s) x = None) /\ (x ∉ s -> getm (m ∖ s) x = getm m x).
Proof.
  intros.
  split; intros;
  rewrite /rem_fsetm filtermE;
  destruct (getm m x) eqn:?;
  rewrite // H //.
Qed.

Lemma rem_fsetmE :
  forall (A : ordType) (B : Type) (m : {fmap A -> B}) (s : {fset A}) (k : A),
    (m ∖ s) k = if k ∈ s then None else m k.
Proof.
  intros.
  rewrite /rem_fsetm filtermE.
  destruct (m k) eqn:?.
  - apply if_neg.
  - rewrite if_same //.
Qed.

Lemma remm_disjoint_fset :
  forall (A : ordType) (B : Type) (m : {fmap A -> B}) (s : {fset A}),
    fdisjoint (domm m) s ->
    m ∖ s = m.
Proof.
  intros.
  apply eq_fmap. intro.
  rewrite /rem_fsetm filtermE.
  destruct (getm m x) eqn:?, (x ∈ s) eqn:?; rewrite /= //.
  assert (x ∉ domm m).
  { apply Bool.eq_true_not_negb. intro. subst.
    assert (x ∈ domm m ∩ s). { rewrite in_fsetI Heqb0 H0 //. }
    apply fdisjoint_fsetI0 in H.
    rewrite H in H1. inverts H1. }
  assert (exists b, m x = Some b) by eauto. apply (rwP dommP) in H1.
  rewrite H1 in H0. inverts H0.
Qed.

Lemma remm_disjoint_fset' :
  forall (A : ordType) (B : Type) (m : {fmap A -> B}) (s : {fset A}),
    m ∖ s = m ->
    fdisjoint (domm m) s.
Proof.
  intros.
  rewrite <- H.
  apply (rwP fdisjointP).
  intros.
  apply (rwP dommP) in H0 as [].
  rewrite rem_fsetmE in H0.
  apply Bool.negb_true_iff.
  destruct (x ∈ s) eqn:?; auto.
  inverts H0.
Qed.

Lemma rem_fsetm_as_fsetD :
  forall (A : ordType) (B : Type) (m : {fmap A -> B}) (s : {fset A}),
    domm (m ∖ s) = domm m :\: s.
Proof.
  intros.
  apply eq_fset. intros_all.
  rewrite /rem_fsetm in_fsetD mem_domm filtermE.
  destruct (m x) eqn:?.
  - simpl.
    destruct (x ∈ s) eqn:?; auto.
    symmetry.
    apply (rwP dommP). eauto.
  - simpl.
    apply (rwP dommPn) in Heqo. apply Bool.negb_true_iff in Heqo.
    rewrite Heqo andbF //.
Qed.

Definition fset_flat_map (A B : ordType) (f : A -> {fset B}) (s : {fset A}) : {fset B} :=
  ⋃_(x ∈ f @: s) x.

Lemma fset_flat_mapP :
  forall {A B : ordType} {f : A -> {fset B}} {s : {fset A}} {x : B},
    reflect (exists2 y, y ∈ s & x ∈ f y) (x ∈ fset_flat_map f s).
Proof.
  intros.
  apply (iffP idP); intros.
  - rewrite /fset_flat_map in_bigcup in H. apply (rwP hasP) in H as [].
    apply (rwP imfsetP) in H as []. subst. eauto.
  - rewrite /fset_flat_map in_bigcup. apply (rwP hasP).
    destruct H. exists (f x0); eauto.
    apply (rwP imfsetP). eauto.
Qed.

Definition fproduct (A B : ordType) (xs : {fset A}) (ys : {fset B}) : {fset (A * B)} :=
  fset_flat_map (fun x : A => fset_flat_map (fun y : B => fset1 (x, y)) ys) xs.

Infix "×" := fproduct (at level 40).

Lemma fproductP :
  forall (A B : ordType) (x : A) (y : B) (xs : {fset A}) (ys : {fset B}),
    reflect (x ∈ xs /\ y ∈ ys) ((x, y) ∈ xs × ys).
Proof.
  intros.
  apply (iffP idP); intros.
  - apply (rwP fset_flat_mapP) in H as []. apply (rwP fset_flat_mapP) in H0 as [].
    rewrite in_fset1 in H1. apply (rwP eqP) in H1. inversion H1. eauto.
  - destruct H.
    apply (rwP fset_flat_mapP). exists x; eauto.
    apply (rwP fset_flat_mapP). exists y; eauto.
    rewrite in_fset1 //.
Qed.

Lemma in_codomm_remm :
  forall (A B : ordType) (m : {fmap A -> B}) (k k' : A) (v : B),
    getm m k = Some v ->
    k <> k' ->
    v ∈ codomm (remm m k').
Proof.
  intros.
  apply (rwP codommP). exists k. rewrite remmE.
  replace (k == k') with false; auto.
  symmetry. apply Bool.not_true_is_false. intro. apply (rwP eqP) in H1. auto.
Qed.

Lemma codomm_setmE :
  forall (A B : ordType) (m : {fmap A -> B}) (k : A) (v : B),
    codomm (setm m k v) = v |: codomm (remm m k).
Proof.
  intros.
  apply eq_fset. intro.
  rewrite in_fsetU in_fset1.
  destruct (x ∈ codomm (setm m k v)) eqn:?.
  - apply (rwP codommP) in Heqb as []. rewrite setmE in H.
    destruct (x0 =P k); subst.
    + inverts H. rewrite eq_refl //.
    + assert (exists x0, m x0 = Some x) by eauto. apply (rwP codommP) in H0.
      erewrite in_codomm_remm; eauto. rewrite orbT //.
  - apply Bool.negb_true_iff in Heqb.
    rewrite <- (rwP (@codommPn _ _ (setm m k v) x)) in Heqb.
    assert (setm m k v k != Some x) by auto.
    replace (x == v) with false; cycle 1.
    { symmetry. apply Bool.not_true_is_false. intro. apply (rwP eqP) in H0. subst.
      rewrite setmE eq_refl in H. apply Bool.negb_true_iff in H. rewrite eq_refl // in H. }
    symmetry.
    apply Bool.negb_true_iff.
    rewrite <- (rwP (@codommPn _ _ (remm m k) x)). intros.
    rewrite remmE.
    destruct (k' =P k); subst; auto.
    assert (setm m k v k' != Some x) by auto.
    rewrite setmE in H0.
    replace (k' == k) with false in H0; auto.
    symmetry. apply Bool.not_true_is_false. intro. apply (rwP eqP) in H0. subst.
    apply n, (rwP eqP). auto.
Qed.

Lemma remm_setm_distr :
  forall (A B : ordType) (m : {fmap A -> B}) (k k' : A) (v : B),
    k <> k' ->
    remm (setm m k v) k' = setm (remm m k') k v.
Proof.
  intros.
  apply eq_fmap. intro.
  rewrite remmE !setmE remmE.
  destruct (x =P k'), (x =P k); auto.
  subst. exfalso. auto.
Qed.

Lemma remm_emptym :
  forall (A : ordType) (B : Type) (k : A),
    remm (@emptym _ B) k = emptym.
Proof.
  intros.
  apply eq_fmap. intro.
  rewrite remmE.
  destruct (x =P k); auto.
Qed.

Lemma fsetI0_fdisjoint :
  forall (T : ordType) (s1 s2 : {fset T}),
    s1 ∩ s2 = ∅ ->
    fdisjoint s1 s2.
Proof.
  intros.
  apply (rwP fdisjointP). intros.
  apply Bool.negb_true_iff, Bool.not_true_iff_false. intros_all.
  assert (x ∈ s1 ∩ s2). { rewrite -(rwP (fsetIP _ s1 s2)) //. }
  rewrite H in_fset0 // in H2.
Qed.

Lemma rem_fsetmI0 :
  forall (A : ordType) (B : Type) (m : {fmap A -> B}),
    m ∖ ∅ = m.
Proof.
  intros.
  apply eq_fmap. intros_all.
  rewrite rem_fsetmE //.
Qed.

Definition rem_valm {A B : ordType} (m : {fmap A -> B}) (v : B) : {fmap A -> B} :=
  filterm (fun _ v' => v != v') m.

Lemma rem_valmE :
  forall (A B : ordType) (m : {fmap A -> B}) (k : A) (v : B),
    getm (rem_valm m v) k =
      match m k with
      | Some v' => if v == v' then None else Some v'
      | None => None
      end.
Proof.
  intros.
  rewrite /rem_valm filtermE.
  destruct (m k) eqn:?; auto.
  simpl. destruct (v =P s); auto.
Qed.

Lemma eq_fmap' :
  forall (A B : ordType) (m1 m2 : {fmap A -> B}),
    (forall (a : A) (b : B), m1 a = Some b <-> m2 a = Some b) ->
    m1 = m2.
Proof.
  intros.
  apply eq_fmap. intros_all.
  destruct (m1 x) eqn:?.
  - apply H in Heqo. auto.
  - cut (forall y : B, m2 x <> Some y).
    { intros_all.
      destruct (m2 x) eqn:?; auto.
      exfalso. apply (H0 s). auto. }
    intros_all.
    apply H in H0. rewrite H0 // in Heqo.
Qed.

Lemma domm_codomm_invm :
  forall (A B : ordType) (m : {fmap A -> B}),
    injectivem m ->
    domm m = codomm (invm m).
Proof.
  intros.
  apply (rwP injectivemP) in H.
  apply eq_fset. intros_all.
  destruct (x ∈ domm m) eqn:?.
  - apply (rwP dommP) in Heqb as [].
    symmetry. apply (rwP codommP).
    exists x0.
    apply getm_inv.
    rewrite invmK //.
  - apply Bool.negb_true_iff, (rwP dommPn) in Heqb.
    symmetry. apply Bool.negb_true_iff, (rwP codommPn). intros_all.
    apply Bool.negb_true_iff, Bool.not_true_iff_false. intros_all.
    apply (rwP eqP), getm_inv in H0.
    rewrite Heqb // in H0.
Qed.

Lemma codomm_domm_invm :
  forall (A B : ordType) (m : {fmap A -> B}),
    injectivem m ->
    codomm m = domm (invm m).
Proof.
  intros.
  apply (rwP injectivemP) in H.
  apply eq_fset. intros_all.
  destruct (x ∈ codomm m) eqn:?.
  - apply (rwP dommP) in Heqb as [].
    symmetry. apply (rwP codommP).
    exists x0.
    apply getm_inv. auto.
  - apply Bool.negb_true_iff, (rwP dommPn) in Heqb.
    symmetry. apply Bool.negb_true_iff, (rwP dommPn). auto.
Qed.

Lemma invm_None :
  forall (A B : ordType) (m : {fmap A -> B}) (x : B),
    injectivem m ->
    invm m x = None <-> x ∉ codomm m.
Proof.
  intros.
  split; intros.
  - rewrite codomm_domm_invm; auto.
    apply (rwP dommPn). auto.
  - rewrite <- (rwP (@codommPn _ _ m x)) in H0.
    cut (forall y, invm m x <> Some y).
    { intros. destruct (invm m x) eqn:?; auto. exfalso. apply (H1 s). auto. }
    intros_all.
    pose proof H0 y. apply Bool.negb_true_iff, Bool.not_true_iff_false in H2. apply H2.
    rewrite (getm_inv (k := x)); auto. rewrite eq_refl //.
Qed.

Lemma fsetU_repeat : forall (A : ordType) (s : {fset A}), s ∪ s = s.
Proof.
  intros.
  apply eq_fset. intros_all.
  rewrite in_fsetU Bool.orb_diag //.
Qed.

Lemma fsetU_noop :
  forall (A : ordType) (s s' : {fset A}),
    s' ⊆ s ->
    s ∪ s' = s.
Proof.
  intros.
  apply eq_fset. intros_all.
  rewrite in_fsetU.
  destruct (x ∈ s) eqn:?; auto.
  apply (rwP fsubsetP) in H.
  apply Bool.not_true_iff_false. intros_all.
  apply H in H0. rewrite H0 // in Heqb.
Qed.

Lemma fsubset_fsetU :
  forall (A : ordType) (s1 s2 s3 : {fset A}),
    s1 ⊆ s2 ->
    (s1 ∪ s3) ⊆ (s2 ∪ s3).
Proof.
  intros.
  apply (rwP fsubsetP) in H.
  apply (rwP fsubsetP). intros_all.
  rewrite in_fsetU.
  rewrite in_fsetU in H0. apply (rwP orP) in H0 as [].
  - apply H in H0. rewrite H0 //.
  - rewrite H0 orbT //.
Qed.

Lemma remm_mapm :
  forall (A : ordType) (B : Type) (f : B -> B) (m : {fmap A → B}) (x : A),
    remm (mapm f m) x = mapm f (remm m x).
Proof.
  intros.
  apply eq_fmap. intros_all.
  rewrite remmE !mapmE remmE.
  destruct (x0 =P x); subst; auto.
Qed.

Lemma codomm_mapm :
  forall (A B : ordType) (f : B -> B) (m : {fmap A → B}),
    codomm (mapm f m) = f @: codomm m.
Proof.
  intros.
  apply eq_fset. intros_all.
  apply Bool.eq_iff_eq_true. split; intros.
  - apply (rwP codommP) in H as [].
    rewrite mapmE in H.
    destruct (getm m x0) eqn:?; inverts H.
    apply (rwP imfsetP). exists s; auto.
    apply (rwP codommP). eauto.
  - apply (rwP imfsetP) in H as [].
    apply (rwP codommP) in H as [].
    subst.
    apply (rwP codommP).
    exists x1. rewrite mapmE H //.
Qed.

Lemma remm_union :
  forall (A B : ordType) (m n : {fmap A → B}) (k : A),
    remm (unionm m n) k = unionm (remm m k) (remm n k).
Proof.
  introv.
  apply eq_fmap. intros x.
  rewrite remmE !unionmE !remmE.
  destruct (x =P k); subst; auto.
Qed.

Lemma injectivem_union :
  forall (A B : ordType) (m n : {fmap A → B}),
    fdisjoint (domm m) (domm n) ->
    injectivem (unionm m n) ->
    injectivem m /\ injectivem n.
Proof.
  introv Hdisj Hmn.
  rewrite fdisjointC in Hdisj. rewrite <- (rwP fdisjointP) in Hdisj.
  apply (rwP injectivemP) in Hmn.
  split; rewrite <- (rwP injectivemP); intros x Hx y Hxy.
  apply Hmn; try solve [rewrite domm_union in_fsetU Hx // orbC //];
  rewrite !unionmE -Hxy;
  apply (rwP dommP) in Hx as [v Hx]; rewrite Hx in Hxy.
  { rewrite Hx //. }
  apply Hmn.
  { rewrite domm_union in_fsetU Hx orbC //. }
  rewrite !unionmE.
  assert (y ∈ domm n) as Hy.
  { apply (rwP dommP). apply (rwP dommP) in Hx as [v Hx]. rewrite Hx in Hxy. eauto. }
  apply Hdisj, (rwP dommPn) in Hx, Hy. rewrite Hx Hy //.
Qed.

Lemma injectivem_union_disjoint_codomm :
  forall (A B : ordType) (m n : {fmap A → B}),
    fdisjoint (domm m) (domm n) ->
    injectivem (unionm m n) ->
    fdisjoint (codomm m) (codomm n).
Proof.
  introv Hdisj Hmn.
  rewrite fdisjointC in Hdisj. rewrite <- (rwP fdisjointP) in Hdisj.
  apply (rwP injectivemP) in Hmn.
  apply (rwP fdisjointP). intros x Hm'x.
  apply (rwP codommP) in Hm'x as [v Hmv].
  apply (rwP (@codommPn _ _ n _)). intros y.
  apply Bool.negb_true_iff, Bool.not_true_iff_false. intros Hny.
  apply (rwP eqP) in Hny.
  assert (v = y); subst.
  { apply Hmn.
    { rewrite domm_union in_fsetU. apply (rwP orP). left. apply (rwP dommP). eauto. }
    rewrite !unionmE Hmv /=.
    assert (y ∉ domm m) as Hmny. { apply Hdisj, (rwP dommP). eauto. }
    apply (rwP dommPn) in Hmny. rewrite Hmny //. }
  assert (y ∈ domm n) as H'ny. { apply (rwP dommP). eauto. }
  assert (y ∈ domm m) as H'my. { apply (rwP dommP). eauto. }
  apply Hdisj in H'ny. rewrite H'my // in H'ny.
Qed.

Lemma fsetU_after_fsetD :
  forall (A : ordType) (s : {fset A}) (x : A),
     (s :\ x) ∪ fset1 x = s ∪ fset1 x.
Proof.
  intros.
  apply eq_fset. intros k.
  rewrite !in_fsetU in_fsetD in_fset1.
  destruct (k =P x), (k ∈ s) eqn:Hks; subst; auto.
Qed.

Lemma fsetD_after_fsetU :
  forall (A : ordType) (s : {fset A}) (x : A),
    (s ∪ fset1 x) :\ x = s :\ x.
Proof.
  intros.
  apply eq_fset. intros k.
  rewrite !in_fsetD in_fsetU in_fset1.
  destruct (k =P x), (k ∈ s) eqn:Hks; subst; auto.
Qed.

Lemma unionm_set_switch :
  forall (A : ordType) (B : Type) (m1 m2 : {fmap A → B}) (k : A) (v : B),
    k ∉ domm m1 ->
    unionm (setm m1 k v) m2 = unionm m1 (setm m2 k v).
Proof.
  introv Hknm1.
  apply eq_fmap. intros x.
  rewrite !unionmE !setmE.
  destruct (x =P k); subst; auto.
  apply (rwP dommPn) in Hknm1.
  rewrite Hknm1 //.
Qed.


Set Universe Polymorphism.
Set Polymorphic Inductive Cumulativity.
Set Printing Universes.

Inductive List (A: Type) := nil | cons : A -> List A -> List A.

Section ListLift.
  Universe i j.

  Constraint i < j.

  Definition LiftL {A} : List@{i} A -> List@{j} A := fun x => x.

End ListLift.

Lemma LiftL_Lem A (l : List A) : l = LiftL l.
Proof. reflexivity. Qed.

Section ListLower.
  Universe i j.

  Constraint i < j.

  Definition LowerL {A : Type@{i}} : List@{j} A -> List@{i} A := fun x => x.

End ListLower.

Lemma LowerL_Lem@{i j|j<i+} (A : Type@{j}) (l : List@{i} A) : l = LowerL@{j i} l.
Proof. reflexivity. Qed.
(*
I disable these tests because cqochk can't process them when compiled with
   ocaml-4.02.3+32bit and camlp5-4.16 which is the case for Travis!

   I have added this file (including the commented parts below) in
   test-suite/success/cumulativity.v which doesn't run coqchk on them.
*)
(* Inductive Tp := tp : Type -> Tp. *)

(* Section TpLift. *)
(*   Universe i j. *)

(*   Constraint i < j. *)

(*   Definition LiftTp : Tp@{i} -> Tp@{j} := fun x => x. *)

(* End TpLift. *)

(* Lemma LiftC_Lem (t : Tp) : LiftTp t = t. *)
(* Proof. reflexivity. Qed. *)

(* Section TpLower. *)
(*   Universe i j. *)

(*   Constraint i < j. *)

(*   Fail Definition LowerTp : Tp@{j} -> Tp@{i} := fun x => x. *)

(* End TpLower. *)

(* Section subtyping_test. *)
(*   Universe i j. *)
(*   Constraint i < j. *)

(*   Inductive TP2 := tp2 : Type@{i} -> Type@{j} -> TP2. *)

(* End subtyping_test. *)


Require Import Crypto.Util.Tuple.
Require Import Crypto.Compilers.Syntax.

Local Open Scope ctype_scope.
Section language.
  Context {base_type_code : Type}.

  Local Notation flat_type := (flat_type base_type_code).

  Section interp.
    Section flat_type.
      Context {interp_base_type : base_type_code -> Type}.
      Local Notation interp_flat_type := (interp_flat_type interp_base_type).

      Fixpoint flat_interp_tuple' {T n} : interp_flat_type (tuple' T n) -> Tuple.tuple' (interp_flat_type T) n
        := match n return interp_flat_type (tuple' T n) -> Tuple.tuple' (interp_flat_type T) n with
           | O => fun x => x
           | S n' => fun '((x, y) : interp_flat_type (tuple' T n' * T))
                     => (@flat_interp_tuple' _ n' x, y)
           end.
      Definition flat_interp_tuple {T n} : interp_flat_type (tuple T n) -> Tuple.tuple (interp_flat_type T) n
        := match n return interp_flat_type (tuple T n) -> Tuple.tuple (interp_flat_type T) n with
           | O => fun x => x
           | S n' => @flat_interp_tuple' T n'
           end.
      Fixpoint flat_interp_untuple' {T n} : Tuple.tuple' (interp_flat_type T) n -> interp_flat_type (tuple' T n)
        := match n return Tuple.tuple' (interp_flat_type T) n -> interp_flat_type (tuple' T n) with
           | O => fun x => x
           | S n' => fun '((x, y) : Tuple.tuple' _ n' * _)
                     => (@flat_interp_untuple' _ n' x, y)
           end.
      Definition flat_interp_untuple {T n} : Tuple.tuple (interp_flat_type T) n -> interp_flat_type (tuple T n)
        := match n return Tuple.tuple (interp_flat_type T) n -> interp_flat_type (tuple T n) with
           | O => fun x => x
           | S n' => @flat_interp_untuple' T n'
           end.
      Lemma flat_interp_untuple'_tuple' {T n v}
        : @flat_interp_untuple' T n (flat_interp_tuple' v) = v.
      Proof using Type. induction n; [ reflexivity | simpl; destruct v; rewrite IHn; reflexivity ]. Qed.
      Lemma flat_interp_untuple_tuple {T n v}
        : flat_interp_untuple (@flat_interp_tuple T n v) = v.
      Proof using Type. destruct n; [ reflexivity | apply flat_interp_untuple'_tuple' ]. Qed.
      Lemma flat_interp_tuple'_untuple' {T n v}
        : @flat_interp_tuple' T n (flat_interp_untuple' v) = v.
      Proof using Type. induction n; [ reflexivity | simpl; destruct v; rewrite IHn; reflexivity ]. Qed.
      Lemma flat_interp_tuple_untuple {T n v}
        : @flat_interp_tuple T n (flat_interp_untuple v) = v.
      Proof using Type. destruct n; [ reflexivity | apply flat_interp_tuple'_untuple' ]. Qed.
    End flat_type.
  End interp.

  Section interp2.
    Section flat_type.
      Context {interp_base_type1 interp_base_type2 : base_type_code -> Type}.
      Local Notation interp_flat_type1 := (interp_flat_type interp_base_type1).
      Local Notation interp_flat_type2 := (interp_flat_type interp_base_type2).

      Definition tuple_map {A B n} (f : interp_flat_type1 A -> interp_flat_type2 B) (v : interp_flat_type1 (tuple A n))
        : interp_flat_type2 (tuple B n)
        := flat_interp_untuple (Tuple.map f (flat_interp_tuple v)).
    End flat_type.
  End interp2.
End language.
Global Arguments flat_interp_tuple' {_ _ _ _} _.
Global Arguments flat_interp_tuple {_ _ _ _} _.
Global Arguments flat_interp_untuple' {_ _ _ _} _.
Global Arguments flat_interp_untuple {_ _ _ _} _.
Global Arguments tuple_map {_ _ _ _ _ n} _ _.

Ltac unfold_flat_interp_tuple _ :=
  let handle n :=
      ltac:(let n' := (eval cbv in n) in
            progress change n with n') in
  repeat match goal with
         | [ |- context[@flat_interp_tuple _ _ _ ?n] ]
           => handle n
         | [ |- context[@flat_interp_tuple' _ _ _ ?n] ]
           => handle n
         | [ |- context[@flat_interp_untuple _ _ _ ?n] ]
           => handle n
         | [ |- context[@flat_interp_untuple' _ _ _ ?n] ]
           => handle n
         | [ |- context[@tuple _ _ ?n] ]
           => handle n
         | [ |- context[@tuple' _ _ ?n] ]
           => handle n
         end;
  cbv [flat_interp_tuple flat_interp_tuple' flat_interp_untuple flat_interp_untuple' tuple tuple'].


(** * 6.887 Formal Reasoning About Programs, Spring 2017 - Pset 5 *)

Require Import Frap Datatypes.
Export Datatypes.

(* Authors:
 * Joonwon Choi (joonwonc@csail.mit.edu),
 * Adam Chlipala (adamc@csail.mit.edu)
 *)

Set Implicit Arguments.

(** * Correctness of a Producer-Consumer implementation *)

(* Here we prove the correctness of a Producer-Consumer implementation.
 * For general specification, refer to this article first:
 *   https://en.wikipedia.org/wiki/Producer%E2%80%93consumer_problem
 *
 * Producer-Consumer is usually implemented using concurrency-control objects
 * like locks or semaphores, and we use the former here.
 * In addition to the concurrency control, we have to think about interleavings
 * between Producer and Consumer, since they communicate via a buffer.
 *
 * Therefore, in order to solve the problem, you should either 1) carefully
 * abstract the system enough to check with the FRAP model checker, or 2)
 * directly prove the given invariant (possibly with parameterized PRD_COUNT).
 *)

(* Here's another example of a reusable program for building multithreaded
 * systems out of systems for single threads.  We will build in general handling
 * of a standard locking protocol, in contrast to the freeform notion of shared
 * state in the [parallel] combinator we saw in class. *)

(* First, a general record type for adding a lock bit to a type of shared
 * state: *)
Record sharedWithLock shared := { Lock : bool; SharedOrig : shared }.

(* We also force single-thread systems to use instantiations of this type for
 * their private state, to signal when they want to lock or unlock. *)
Inductive stateWithLock private :=
| Aprivate : private -> stateWithLock private
(* This is a state for a thread whose next step is *not* lock-related. *)

| Alock : stateWithLock private
| Aunlock : stateWithLock private
(* These states respectively indicate that the next thing the thread wants to do
 * is claim or relinquish the lock.  For simplicity, we make the arbitrary
 * choice that threads waiting to lock or unlock store no additional local
 * state, but the approach would generalize to including that state. *).

Arguments Alock {_}.
Arguments Aunlock {_}.
(* These lines ask Coq to infer the [private] type associated with a use of one
 * of the second two constructors. *)

(* Initial states of the two-thread system combine initial states of the
 * constituent systems, with the lock initialized to [false]. *)
Inductive locking1 shared private1 private2
          (init1 : threaded_state shared (stateWithLock private1) -> Prop)
          (init2 : threaded_state shared (stateWithLock private2) -> Prop)
  : threaded_state (sharedWithLock shared)
                   (stateWithLock private1 * stateWithLock private2) -> Prop :=
| Ainit : forall sh pr1 pr2,
    init1 {| Shared := sh; Private := pr1 |} ->
    init2 {| Shared := sh; Private := pr2 |} ->
    locking1 init1 init2 {| Shared := {| Lock := false; SharedOrig := sh |};
                            Private := (pr1, pr2) |}.

(* Here's the combined transition relation.  The rules come in symmetric pairs,
 * based on which of the two threads steps. *)
Inductive locking2 shared private1 private2
          (step1 : threaded_state shared (stateWithLock private1) ->
                   threaded_state shared (stateWithLock private1) -> Prop)
          (step2 : threaded_state shared (stateWithLock private2) ->
                   threaded_state shared (stateWithLock private2) -> Prop)
  : threaded_state (sharedWithLock shared) (stateWithLock private1 * stateWithLock private2) ->
    threaded_state (sharedWithLock shared) (stateWithLock private1 * stateWithLock private2) ->
    Prop :=

(* First, a thread that is not asking to lock or unlock may simply take a step
 * as normal. *)
| AstepN1 : forall sh pr1 pr2 sh' l pr1',
    pr1 <> Alock -> pr1 <> Aunlock ->
    step1 {| Shared := sh; Private := pr1 |} {| Shared := sh'; Private := pr1' |} ->
    locking2 step1 step2
             {| Shared := {| Lock := l; SharedOrig := sh |}; Private := (pr1, pr2) |}
             {| Shared := {| Lock := l; SharedOrig := sh' |}; Private := (pr1', pr2) |}
| AstepN2 : forall sh pr1 pr2 sh' l pr2',
    pr2 <> Alock -> pr2 <> Aunlock ->
    step2 {| Shared := sh; Private := pr2 |} {| Shared := sh'; Private := pr2' |} ->
    locking2 step1 step2
             {| Shared := {| Lock := l; SharedOrig := sh |}; Private := (pr1, pr2) |}
             {| Shared := {| Lock := l; SharedOrig := sh' |}; Private := (pr1, pr2') |}

(* A thread asking to lock may only step when the lock is not held, and then the
 * step toggles the lock. *)
| AstepLock1 : forall sh pr2 pr1',
    step1 {| Shared := sh; Private := Alock |} {| Shared := sh; Private := pr1' |} ->
    locking2 step1 step2
             {| Shared := {| Lock := false; SharedOrig := sh |}; Private := (Alock, pr2) |}
             {| Shared := {| Lock := true; SharedOrig := sh |}; Private := (pr1', pr2) |}
| AstepLock2 : forall sh pr1 pr2',
    step2 {| Shared := sh; Private := Alock |} {| Shared := sh; Private := pr2' |} ->
    locking2 step1 step2
             {| Shared := {| Lock := false; SharedOrig := sh |}; Private := (pr1, Alock) |}
             {| Shared := {| Lock := true; SharedOrig := sh |}; Private := (pr1, pr2') |}

(* A thread asking to unlock may only step when the lock is held, and then the
 * step toggles the lock. *)
| AstepUnlock1 : forall sh pr2 pr1',
    step1 {| Shared := sh; Private := Aunlock |} {| Shared := sh; Private := pr1' |} ->
    locking2 step1 step2
             {| Shared := {| Lock := true; SharedOrig := sh |}; Private := (Aunlock, pr2) |}
             {| Shared := {| Lock := false; SharedOrig := sh |}; Private := (pr1', pr2) |}
| AstepUnlock2 : forall sh pr1 pr2',
    step2 {| Shared := sh; Private := Aunlock |} {| Shared := sh; Private := pr2' |} ->
    locking2 step1 step2
             {| Shared := {| Lock := true; SharedOrig := sh |}; Private := (pr1, Aunlock) |}
             {| Shared := {| Lock := false; SharedOrig := sh |}; Private := (pr1, pr2') |}.

(* Here's the final definition of a two-thread system with locking. *)
Definition locking shared private1 private2
           (sys1 : trsys (threaded_state shared (stateWithLock private1)))
           (sys2 : trsys (threaded_state shared (stateWithLock private2))) :=
  {| Initial := locking1 sys1.(Initial) sys2.(Initial);
     Step := locking2 sys1.(Step) sys2.(Step)
  |}.

(* PRD_COUNT is the number of produced items by Producer.
 * This is large enough that direct use of "model_check" for the system
 * takes really long. Thus, yes, during grading for this problem set, we will
 * just stop the checker if it takes a long time.
 *
 * Note that for PRD_COUNT = 15, we have hundreds of possible states.
 *)
Definition PRD_COUNT := 15.

(* Below is pseudocode of our Producer-Consumer implementation.  Producer always
 * produces "1" and pushes it to the buffer [buf].  Consumer pops the value from
 * the buffer and adds it to [acc].
 *)
(* <<
   queue buf = empty;
   int cnt = PRD_COUNT;
   int acc = 0;

   void produce() {
     int local;
     while (cnt > 0) {
       lock();
       cnt = cnt - 1;
       buf.push(1);
       unlock();
     }
   }

   void consume() {
     int local, val;
     while (true) {
       lock();
       val = buf.pop();
       acc = acc + val;
       unlock();
     }
   }
   >>
 *)

Inductive pdcs_thread :=
(* Both Producer and Consumer start here. *)
| Start : pdcs_thread
(* Producer commands *)
| CheckCount : pdcs_thread
| DecCount : pdcs_thread
| Push : pdcs_thread
(* Consumer commands *)
| Pop : pdcs_thread
| Acc : nat -> pdcs_thread.

Record pdcs_global_state :=
  { buf : list nat;
    cnt : nat;
    acc : nat }.

Definition pdcs_state :=
  threaded_state pdcs_global_state (stateWithLock pdcs_thread).

Inductive pdcs_init : pdcs_state -> Prop :=
| PdcsInit :
    pdcs_init {| Shared := {| buf := nil; cnt := PRD_COUNT; acc := 0 |};
                 Private := Aprivate Start |}.

Inductive pdcs_step :
  bool (* "true" for the producer *) -> pdcs_state -> pdcs_state -> Prop :=
| PdStart :
    forall sh, pdcs_step true
                         {| Shared := sh; Private := Aprivate Start |}
                         {| Shared := sh; Private := Aprivate CheckCount |}
| PdCheckCount :
    forall b c a,
      pdcs_step true
                {| Shared := {| buf := b; cnt := S c; acc := a |};
                   Private := Aprivate CheckCount |}
                {| Shared := {| buf := b; cnt := S c; acc := a |};
                   Private := Alock |}
| PdLock :
    forall sh, pdcs_step true
                         {| Shared := sh; Private := Alock |}
                         {| Shared := sh; Private := Aprivate DecCount |}
| PdDecCount :
    forall b c a,
      pdcs_step true
                {| Shared := {| buf := b; cnt := S c; acc := a |};
                   Private := Aprivate DecCount |}
                {| Shared := {| buf := b; cnt := c; acc := a |};
                   Private := Aprivate Push |}
| PdPush :
    forall b c a,
      pdcs_step true
                {| Shared := {| buf := b; cnt := c; acc := a |};
                   Private := Aprivate Push |}
                {| Shared := {| buf := 1 :: b; cnt := c; acc := a |};
                   Private := Aunlock |}
| PdUnlock :
    forall sh, pdcs_step true
                         {| Shared := sh; Private := Aunlock |}
                         {| Shared := sh; Private := Aprivate CheckCount |}

| CsStart :
    forall sh, pdcs_step false
                         {| Shared := sh; Private := Aprivate Start |}
                         {| Shared := sh; Private := Alock |}
| CsLock :
    forall sh, pdcs_step false
                         {| Shared := sh; Private := Alock |}
                         {| Shared := sh; Private := Aprivate Pop |}
| CsPop :
    forall bh bt c a,
      pdcs_step false
                {| Shared := {| buf := bh :: bt; cnt := c; acc := a |};
                   Private := Aprivate Pop |}
                {| Shared := {| buf := bt; cnt := c; acc := a |};
                   Private := Aprivate (Acc bh) |}
| CsAcc :
    forall b c a v,
      pdcs_step false
                {| Shared := {| buf := b; cnt := c; acc := a |};
                   Private := Aprivate (Acc v) |}
                {| Shared := {| buf := b; cnt := c; acc := a + v |};
                   Private := Aunlock |}
| CsUnlock :
    forall sh, pdcs_step false
                         {| Shared := sh; Private := Aunlock |}
                         {| Shared := sh; Private := Alock |}.

Definition pdcs_sys is_producer :=
  {| Initial := pdcs_init;
     Step := pdcs_step is_producer |}.

Definition pdcs2_sys := locking (pdcs_sys true) (pdcs_sys false).

(* The correctness of the system is given as below: when Producer completely
 * produces all values and Consumer consumes all of them, then the accumulated
 * value equals PRD_COUNT.
 *)
Definition pdcs2_correct
           (s : threaded_state (sharedWithLock pdcs_global_state)
                               (stateWithLock pdcs_thread * stateWithLock pdcs_thread)) :=
  s.(Shared).(SharedOrig).(cnt) = 0 ->
  s.(Shared).(SharedOrig).(buf) = nil ->
  s.(Shared).(Lock) = false ->
  s.(Shared).(SharedOrig).(acc) = PRD_COUNT.

Module Type S.
  Axiom pdcs2_ok : invariantFor pdcs2_sys pdcs2_correct.
End S.