(** this file is a follow-up of [MultisortedMonadConstruction_alt], where the semantic signatures [Signature] are replaced by functors with tensorial strength and HSS by GHSS

based on the lax lineator constructed in [Multisorted_actegories] and transferred (through weak equivalence) to the strength notion of
generalized heterogeneous substitution systems (GHSS), a GHSS is constructed and a monad obtained through it

author: Ralph Matthes, 2023

notice: this file does not correspond to [MultisortedMonadConstruction] but to [MultisortedMonadConstruction_alt], even though this is not indicated in the name
 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.All.

Require Import UniMath.Combinatorics.Lists.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.products.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.exponentials.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Chains.All.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Colimits.
Require Import UniMath.CategoryTheory.categories.HSET.Limits.
Require Import UniMath.CategoryTheory.categories.HSET.Structures.
Require Import UniMath.CategoryTheory.categories.StandardCategories.
Require Import UniMath.CategoryTheory.Groupoids.

Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.SubstitutionSystems.SumOfSignatures.
Require Import UniMath.SubstitutionSystems.BinProductOfSignatures.
Require Import UniMath.SubstitutionSystems.SignatureExamples.

(** for the additions in 2023 *)
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Actegories.Actegories.
Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories.
Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories.
Require Import UniMath.CategoryTheory.Actegories.CoproductsInActegories.
Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegoryMorphisms.
Require Import UniMath.CategoryTheory.Monoidal.CategoriesOfMonoids.
Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects.
Require Import UniMath.CategoryTheory.Monoidal.Examples.EndofunctorsMonoidalElementary.
Require Import UniMath.CategoryTheory.Monoidal.Examples.MonadsAsMonoidsElementary.
Require Import UniMath.SubstitutionSystems.EquivalenceLaxLineatorsHomogeneousCase.
Require UniMath.SubstitutionSystems.LiftingInitial_alt.
Require Import UniMath.SubstitutionSystems.MultiSorted_alt.
Require Import UniMath.SubstitutionSystems.MultiSorted_actegorical.
Require Import UniMath.SubstitutionSystems.MultiSortedMonadConstruction_alt.
Require Import UniMath.SubstitutionSystems.GeneralizedSubstitutionSystems.
Require Import UniMath.SubstitutionSystems.ConstructionOfGHSS.
Require UniMath.SubstitutionSystems.BindingSigToMonad_actegorical.
Require Import UniMath.SubstitutionSystems.SigmaMonoids.
Require Import UniMath.SubstitutionSystems.ContinuitySignature.ContinuityOfMultiSortedSigToFunctor.

(** for the instantiation to [HSET] *)
Require Import UniMath.Bicategories.PseudoFunctors.Examples.CurryingInBicatOfCats.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses.
Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction.
Require Import UniMath.CategoryTheory.categories.HSET.Univalence.

Local Open Scope cat.

Import BifunctorNotations.
Import MonoidalNotations.

Section MBindingSig.

(* Interestingly we only need that [sort] is a 1-type *)
Context (sort : UU) (Hsort : isofhlevel 3 sort) (C : category).

(* Assumptions on [C] used to construct the functor *)
(* Note that there is some redundancy in the assumptions *)
Context (TC : Terminal C) (IC : Initial C)
          (BP : BinProducts C) (BC : BinCoproducts C)
          (PC : forall (I : UU), Products I C) (CC : forall (I : UU), isaset I → Coproducts I C).

Local Notation "'1'" := (TerminalObject TC).
Local Notation "a ⊕ b" := (BinCoproductObject (BC a b)).

(** Define the category of sorts *)
Let sort_cat : category := path_pregroupoid sort Hsort.

(** This represents "sort → C" *)
Let sortToC : category := [sort_cat,C].
Let make_sortToC (f : sort → C) : sortToC := functor_path_pregroupoid Hsort f.

Let BCsortToC : BinCoproducts sortToC := BinCoproducts_functor_precat _ _ BC.

Let BPC : BinProducts [sortToC,C] := BinProducts_functor_precat sortToC C BP.

Let BPCsortToC : BinProducts sortToC := BinProducts_functor_precat _ C BP.
Let BPC1 : BinProducts [sortToC,sortToC] := BinProducts_functor_precat sortToC sortToC BPCsortToC.

(* Assumptions needed to prove ω-cocontinuity of the functor *)
Context (expSortToC1 : Exponentials BPC1) (** this requires exponentials in a higher space than before for [MultiSortedSigToFunctor] *)
  (HC : Colims_of_shape nat_graph C).

(* The [expSortToC1] assumption is fulfilled for C = Set, to be seen in the instantiation. *)

(** * Construction of a monad from a multisorted signature *)
Section monad.

  Local Definition sortToC1 := [sortToC, sortToC].
  Local Definition sortToC2 := [sortToC1, sortToC1].

  Let BCsortToC1 : BinCoproducts sortToC1 := BinCoproducts_functor_precat _ _ BCsortToC.
  Let ICsortToC1 : Initial sortToC1 := Initial_functor_precat _ _ (Initial_functor_precat _ _ IC).
  Local Definition HCsortToC : Colims_of_shape nat_graph sortToC.
  Proof.
    apply ColimsFunctorCategory_of_shape, HC.
  Defined.
  Local Definition HCsortToC1 : Colims_of_shape nat_graph sortToC1.
  Proof.
    apply ColimsFunctorCategory_of_shape, HCsortToC.
  Defined.

  Local Definition MultiSortedSigToFunctor' : MultiSortedSig sort -> sortToC2 := MultiSortedSigToFunctor' sort Hsort C TC BP BC CC.
  Local Definition is_omega_cocont_MultiSortedSigToFunctor' : ∏ M : MultiSortedSig sort, is_omega_cocont (MultiSortedSigToFunctor' M)
    := is_omega_cocont_MultiSortedSigToFunctor' sort Hsort C TC BP BC PC CC expSortToC1 HC.
  Local Definition MultiSortedSigToStrength' : ∏ M : MultiSortedSig sort,
        MultiSorted_actegorical.pointedstrengthfromselfaction_CAT sort Hsort C (MultiSortedSigToFunctor' M)
    := MultiSortedSigToStrength' sort Hsort C TC BP BC CC.

  Let Id_H : sortToC2 → sortToC2 := LiftingInitial_alt.Id_H sortToC BCsortToC.

 (** Construction of initial algebra for the omega-cocontinuous signature functor with lax lineator *)
  Definition DatatypeOfMultisortedBindingSig_CAT (sig : MultiSortedSig sort) :
    Initial (FunctorAlg (Id_H (MultiSortedSigToFunctor' sig))).
  Proof.
    use colimAlgInitial.
    - exact ICsortToC1.
    - apply (LiftingInitial_alt.is_omega_cocont_Id_H _ _ _ (is_omega_cocont_MultiSortedSigToFunctor' sig)).
    - apply HCsortToC1.
  Defined.

  (** the associated GHSS *)
  Definition GHSSOfMultiSortedSig_CAT (sig : MultiSortedSig sort) :
    ghss (monendocat_monoidal sortToC) (MultiSortedSigToFunctor' sig) (MultiSortedSigToStrength' sig).
  Proof.
    use (initial_alg_to_ghss (MultiSortedSigToStrength' sig) BCsortToC1).
    - apply BindingSigToMonad_actegorical.bincoprod_distributor_pointed_CAT.
    - exact ICsortToC1.
    - apply HCsortToC1.
    - apply (is_omega_cocont_MultiSortedSigToFunctor' sig).
    - intro F. apply Initial_functor_precat.
    - intro F. apply (is_omega_cocont_pre_composition_functor F HCsortToC).
  Defined.

  (** the associated initial Sigma-monoid *)
  Definition InitialSigmaMonoidOfMultiSortedSig_CAT (sig : MultiSortedSig sort) : Initial (SigmaMonoid (MultiSortedSigToStrength' sig)).
  Proof.
    use (SigmaMonoidFromInitialAlgebraInitial (MultiSortedSigToStrength' sig) BCsortToC1).
    - apply BindingSigToMonad_actegorical.bincoprod_distributor_pointed_CAT.
    - exact ICsortToC1.
    - apply HCsortToC1.
    - apply (is_omega_cocont_MultiSortedSigToFunctor' sig).
    - intro F. apply Initial_functor_precat.
    - intro F. apply (is_omega_cocont_pre_composition_functor F HCsortToC).
  Defined.

  (** the associated Sigma-monoid - defined separately *)
  Definition SigmaMonoidOfMultiSortedSig_CAT (sig : MultiSortedSig sort) : SigmaMonoid (MultiSortedSigToStrength' sig).
  Proof.
    apply ghhs_to_sigma_monoid.
    exact (GHSSOfMultiSortedSig_CAT sig).
  Defined.

(* currently obsolete because this was only for the original definition with [MultiSortedSigToFunctor]

  (** the characteristic equation of the Sigma monoid is even fulfilled w.r.t. to the original lax lineator, not only
      the one obtained through weak equivalence *)
Section CharEq.

  Context (sig : MultiSortedSig sort).
  Let σ := SigmaMonoidOfMultiSortedSig_CAT sig.
  Let st' : sortToC1 ⟦ (SigmaMonoid_carrier _ σ) ⊗_{monendocat_monoidal sortToC : bifunctor _ _ _}
                         (pr1 (MultiSortedSigToFunctor sig) (SigmaMonoid_carrier _ σ)),
                pr1 (MultiSortedSigToFunctor sig) ((SigmaMonoid_carrier _ σ) ⊗_{monendocat_monoidal sortToC}
                                                     (SigmaMonoid_carrier _ σ)) ⟧
      := pr1 (MultiSortedSigToStrengthCAT sort Hsort C TC BP BC CC sig)
           (SigmaMonoid_carrier _ σ ,, SigmaMonoid_η _ σ) (SigmaMonoid_carrier _ σ).

  Lemma SigmaMonoidOfMultiSortedSig_CAT_char_eq_ok :
    SigmaMonoid_characteristic_equation (SigmaMonoid_carrier _ σ) (SigmaMonoid_η _ σ) (SigmaMonoid_μ _ σ) (SigmaMonoid_τ _ σ) st'.
  Proof.
   Admitted. (* the proof depends on [lax_lineators_from_lifted_precomp_CAT_and_lifted_self_action_agree] to be defined! *)
 (*
    (** beginning of proof that depends on that currently deactivated definition *)
    assert (Hyp := SigmaMonoid_is_compatible (MultiSortedSigToStrengthFromSelfCAT sig) σ).
    hnf.
    hnf in Hyp.
    etrans.
    2: { exact Hyp. }
    clear Hyp.
    do 2 apply cancel_postcomposition.
    apply idpath.
    (* no need for extensional reasoning:
    apply (nat_trans_eq sortToC).
    intro F.
    apply (nat_trans_eq C).
    intro s.
    simpl.
    apply idpath.
     *)
  Qed.
  (** end of proof that depends on that currently deactivated definition *)
*)
End CharEq.
*)

  (** the associated monad *)
  Definition MonadOfMultiSortedSig_CAT (sig : MultiSortedSig sort) : Monad sortToC.
  Proof.
    use monoid_to_monad_CAT.
    use SigmaMonoid_to_monoid.
    - exact (MultiSortedSigToFunctor' sig).
    - exact (MultiSortedSigToStrength' sig).
    - exact (SigmaMonoidOfMultiSortedSig_CAT sig).
  Defined.

End monad.

End MBindingSig.

Section InstanceHSET.

  Context (sort : UU) (Hsort : isofhlevel 3 sort).

  Let sortToHSET : category := [path_pregroupoid sort Hsort, HSET].

  Let BPCsortToHSET : BinProducts sortToHSET := BinProducts_functor_precat _ HSET BinProductsHSET.
  Let BPC1 : BinProducts [sortToHSET,sortToHSET] := BinProducts_functor_precat sortToHSET sortToHSET BPCsortToHSET.

  Definition expSortToHSET1 : Exponentials BPC1.
  Proof.
    set (aux := category_binproduct sortToHSET (path_pregroupoid sort Hsort)).
    set (BPaux' := BinProducts_functor_precat aux _ BinProductsHSET).
    assert (Hyp : Exponentials BPaux').
    { apply Exponentials_functor_HSET. }
    transparent assert (HypAdj : (equivalence_of_cats [sortToHSET, sortToHSET] [aux, SET])).
    { apply currying_hom_equivalence. }
    use (exponentials_through_adj_equivalence_univalent_cats _ _ Hyp).
    2: { apply is_univalent_functor_category.
         apply is_univalent_HSET. }
    2: { do 2 apply is_univalent_functor_category.
         apply is_univalent_HSET. }
    transparent assert (HypAdj' : (adj_equivalence_of_cats (left_functor HypAdj))).
    { apply adjointificiation. }
    use tpair.
    2: { apply (adj_equivalence_of_cats_inv HypAdj'). }
  Defined.

  Definition MultiSortedSigToMonadHSET_viaCAT : MultiSortedSig sort → Monad (sortToHSET).
  Proof.
    intros sig; simple refine (MonadOfMultiSortedSig_CAT sort Hsort HSET _ _ _ _ _ _ _ _ sig).
    - apply TerminalHSET.
    - apply InitialHSET.
    - apply BinProductsHSET.
    - apply BinCoproductsHSET.
    - apply ProductsHSET.
    - apply CoproductsHSET.
    - change (Exponentials BPC1). apply expSortToHSET1.
    - apply ColimsHSET_of_shape.
  Defined.

End InstanceHSET.


Require Import TacNewHyps.
Require Import LibHypsNaming.
Require Import LibDecomp.
(* Some tactics used in sparkCompcert. Mostly about autorenaming. *)

(* Same tactic as LibDecomp.decomp_logical but make sure the name of
   the hypothesis decomposed is not recycled during the process, so
   that all generated hypothesis are detected as such. *)
Ltac decompose_clear c :=
  let h := fresh "h_decomp" in
  pose proof c as h;
  decomp_logicals c; try clear h.

(* decompose + rename new hyps. *)
Tactic Notation "decomp" constr(c) := (!!decompose_clear c).

(* Iterating the tactic on all hypothesis. Moves up all Set/Type
   variables to the top. Really useful with [Set Compact Context]
   which is no yet commited in coq-trunk. *)
Ltac up_type := map_all_hyps_rev move_up_types.

(* rew foo with tac first rewrite everywhere with t' (right to left),
then applies tac and then rewrite eveywhere in the other direction.
this is useful when some tactic needs the goal (or a hypothesis to be
in a certain form but you don't want to keep this form in your goal. *)
Tactic Notation "rew" constr(t') "with"  tactic(tac) :=
  try (rewrite <- t' in * ); tac; (try rewrite t' in * ).

(* subst with all new hyps if ossible after applying tactic tac *)
(* Ltac subst_new_hyps tac := onNewHypsOf ltac:tac do substHyp. *)

(* !!! tac performs tac, then subst with new hypothesis when possible,
   then rename remaining new hyps. *)
Tactic Notation "!!!" tactic3(Tac) := !!(tac_new_hyps Tac substHyp).

(* Same + move hyp to the top of the goal if it is Type-sorted *)
Tactic Notation (at level 4) "!!!!" tactic4(tac1) :=
  (tac1 ;; (fun h => substHyp h||(move_up_types h;autorename h))).

(* subst or revert, revert is done from older to newer *)
Tactic Notation (at level 4) "??" tactic4(tac1) :=
  (tac1 ;; substHyp ;!; revertHyp).

(* in sparkCompcert !inversion always tries to subst. *)
Tactic Notation "!inversion" hyp(h) := !!! (inversion h).
Tactic Notation "!invclear" hyp(h) := !!! (inversion h;clear h).

(* Example of !!! and ?? *)
(*
Ltac rename_hyp_2 h th :=
  match th with
  | true = false => fresh "trueEQfalse"
  end.

Ltac rename_hyp ::= rename_hyp_2.

Lemma foo: forall x y,
    x <= y ->
    x = y ->
    ~x = y ->
    ~1 < 0 ->
    forall z t:nat,
    (0 < 1 -> ~(true=false)) ->
    (forall w w',w < w' -> ~(true=false)) ->
    (0 < 1 -> ~(1<0)) ->
    (0 < 1 -> 1<0) -> 0 < z.
  (* auto naming + subst when possible at intro: *)
  ??intros.
  Undo.
  !!!intros.
  Undo.
  !!!!intros.
Admitted.
*)
(* Examples of decomp *)
(*
Lemma foo : forall x, { aa:nat | (aa = x /\ x=aa) & (aa = aa /\ aa= x) } -> False.
Proof.
  intros x H.
  decomp H.
Abort.

Lemma foo : { aa:False & True  } -> False.
Proof.
  intros H.
  decomp H.
Abort.

Lemma foo : { aa:False & True & False  } -> False.
Proof.
  intros H.
  decomp H.
Abort.
*)


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(** * Proofs about standard combinators, exports functional extensionality.

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

Require Import Coq.Program.Basics.
Require Export FunctionalExtensionality.

Open Scope program_scope.

(** Composition has [id] for neutral element and is associative. *)

Lemma compose_id_left : forall A B (f : A -> B), id ∘ f = f.
Proof.
  intros.
  reflexivity.
Qed.

Lemma compose_id_right : forall A B (f : A -> B), f ∘ id = f.
Proof.
  intros.
  reflexivity.
Qed.

Lemma compose_assoc : forall A B C D (f : A -> B) (g : B -> C) (h : C -> D),
  h ∘ g ∘ f = h ∘ (g ∘ f).
Proof.
  intros.
  reflexivity.
Qed.

Hint Rewrite @compose_id_left @compose_id_right : core.
Hint Rewrite <- @compose_assoc : core.

(** [flip] is involutive. *)

Lemma flip_flip : forall A B C, @flip A B C ∘ flip = id.
Proof.
  intros.
  reflexivity.
Qed.

(** [prod_curry] and [prod_uncurry] are each others inverses. *)

Lemma prod_uncurry_curry : forall A B C, @prod_uncurry A B C ∘ prod_curry = id.
Proof.
  intros.
  reflexivity.
Qed.

Lemma prod_curry_uncurry : forall A B C, @prod_curry A B C ∘ prod_uncurry = id.
Proof.
  simpl ; intros.
  unfold prod_uncurry, prod_curry, compose.
  extensionality x ; extensionality p.
  destruct p ; simpl ; reflexivity.
Qed.


Require Export Coq.Program.Utils Coq.Program.Basics.

Section Maybe.
  Context {A B : Type}.

  Definition obind (f : A -> option B) (o : option A) : option B :=
    match o with
    | Some a => f a
    | None => None
    end.

  Definition omap (f : A -> B) : option A -> option B :=
    obind (Some ∘ f)%prg.
End Maybe.

Declare Scope maybe_scope.
Delimit Scope maybe_scope with maybe.

Notation "o '>>=' f"
  := (obind f o)
       (at level 50, left associativity) : maybe_scope.
Notation "o '>>|' f"
  := (omap f o)
       (at level 50, left associativity) : maybe_scope.
Notation "'let*' a ':=' o 'in' b"
  := (obind (fun a => b) o)
       (at level 60, a pattern,
        right associativity) : maybe_scope.
Notation "'let!' a ':=' o 'in' b"
  := (omap (fun a => b) o)
       (at level 60, a pattern,
        right associativity) : maybe_scope.

Ltac maybe_simpl :=
  unfold ">>|","∘",">>=",omap,obind; simpl.

Ltac maybe_simpl_hyp H :=
  unfold ">>|","∘",">>=",omap,obind in H; simpl H.


(** Real polynomials on multiple variables *)

Require Import riesz_logic_List_more.

Require Export Reals.
Require Import Rpos.
Require Import Bool.
Require Import Lra.
Require Import FunctionalExtensionality.
Require Import Lia.

Require Import RL.OLlibs.Permutation_Type.
Require Import RL.OLlibs.List_Type.
Require Import RL.OLlibs.List_more.

Local Open Scope R_scope.

(* begin hide *)
(** * Operations on valuations *)
Definition upd_val (v : nat -> R) n r :=
  fun n' => if beq_nat n n' then r else v n'.

Fixpoint upd_val_vec (val : nat -> R) (vx : list nat) (vr : list R) :=
  match vx, vr with
  | nil , _ => val
  | _ , nil => val
  | x :: vx, r :: vr => upd_val_vec (upd_val val x r) vx vr
  end.

Lemma upd_val_vec_not_in : forall val L v x,
    (In_inf x v -> False) ->
    upd_val_vec val v L x = val x.
Proof.
  intros val L v; revert val L; induction v; intros val L x Hin.
  - reflexivity.
  - destruct L; [reflexivity | ].
    simpl.
    rewrite IHv.
    2:{ intros H; apply Hin; right; apply H. }
    case_eq (a =? x); intros H; unfold upd_val; rewrite H; [ apply Nat.eqb_eq in H | apply Nat.eqb_neq in H].
    + exfalso.
      apply Hin; left; lia.
    + reflexivity.
Qed.

Lemma upd_val_vec_seq_add : forall L v n k1 k2 i,
    upd_val_vec v (seq (k1 + k2) n) L (k1 + k2 + i) = upd_val_vec (fun x => v (k1 + x)%nat) (seq k2 n) L (k2 + i).
Proof.
  intros L v n.
  revert L v; induction n; intros L v k1 k2 i.
  - simpl.
    replace (k1 + k2 + i)%nat with (k1 + (k2 + i))%nat by lia.
    reflexivity.
  - destruct L; simpl; [ replace (k1 + k2 + i)%nat with (k1 + (k2 + i))%nat by lia; reflexivity| ].
    destruct i.
    + rewrite ? upd_val_vec_not_in.
      * unfold upd_val.
        replace (k1 + k2 =? k1 + k2 + 0) with true by (symmetry; apply Nat.eqb_eq; lia).
        replace (k2 =? k2 + 0) with true by (symmetry; apply Nat.eqb_eq; lia).
        reflexivity.
      * apply not_In_inf_seq.
        lia.
      * apply not_In_inf_seq.
        lia.
    + replace (S (k1 + k2)) with (k1 + S k2)%nat by lia.
      replace (k1 + k2 + S i)%nat with (k1 + (S k2) + i)%nat by lia.
      rewrite IHn.
      replace (k2 + S i)%nat with (S k2 + i)%nat by lia.
      replace (fun x : nat => upd_val v (k1 + k2) r (k1 + x)) with (upd_val (fun x : nat => v (k1 + x)%nat) k2 r) ; [ reflexivity | ].
      apply functional_extensionality.
      intros x.
      unfold upd_val.
      case_eq (k2 =? x) ; intros H.
      * replace (k1 + k2 =? k1 + x) with true; [ reflexivity | ].
        symmetry; apply Nat.eqb_eq; apply Nat.eqb_eq in H.
        lia.
      * replace (k1 + k2 =? k1 + x) with false; [ reflexivity | ].
        symmetry; apply Nat.eqb_neq; apply Nat.eqb_neq in H; lia.
Qed.

Lemma upd_val_vec_eq : forall L v n i,
    upd_val_vec v (seq i (length L)) L (i + n) = nth n L (v (i + n))%nat.
Proof.
  intros L v n i; revert L v n; induction i.
  - induction L; intros v n.
    + destruct n; simpl; try reflexivity.
    + destruct n.
      * simpl.
        rewrite upd_val_vec_not_in; try reflexivity.
        apply not_In_inf_seq; lia.
      * simpl.
        change (v (S n)) with ((fun x => v (S x)) n).
        rewrite <- IHL.
        replace (1%nat) with (1 + 0)%nat by lia.
        replace (S n) with (1 + 0 + n)%nat by lia.
        rewrite upd_val_vec_seq_add.
        simpl.
        replace (fun x : nat => upd_val v 0 a (S x)) with (fun x : nat => v (S x)) ; [reflexivity | ].
        apply functional_extensionality.
        intros x.
        unfold upd_val.
        replace (0 =? S x) with false by (symmetry; apply Nat.eqb_neq; lia).
        reflexivity.
  - intros L v n.
    replace (S i) with (1 + 0 + i)%nat by lia.
    rewrite upd_val_vec_seq_add.
    rewrite IHi.
    replace (1 + 0 + (i + n))%nat with (1 + 0 + i + n)%nat by lia.
    reflexivity.
Qed.

Lemma upd_val_eq : forall val i a,
             upd_val val i a i = a.
Proof.
  intros val i a; unfold upd_val.
  rewrite Nat.eqb_refl.
  reflexivity.
Qed.

Lemma map_upd_val_vec_eq : forall v L i,
    map (upd_val_vec v (seq i (length L)) L) (seq i (length L)) = L.
Proof.
  intros v L i.
  apply nth_ext with 0 0.
  { rewrite map_length; rewrite seq_length.
    reflexivity. }
  intros n.
  intros Hlt.
  rewrite map_length in Hlt; rewrite seq_length in Hlt.
  rewrite nth_indep with _ _ _ _ (upd_val_vec v (seq i (length L)) L 0).
  2:{ rewrite map_length; rewrite seq_length.
      lia. }
  rewrite map_nth.
  rewrite seq_nth; [ | assumption].
  rewrite upd_val_vec_eq.
  rewrite nth_indep with _ _ _ _ 0 ; auto.
Qed.

(* end hide *)

Inductive Poly : Type :=
| Poly_var : nat -> Poly
| Poly_cst : R -> Poly
| Poly_mul : Poly -> Poly -> Poly
| Poly_add : Poly -> Poly -> Poly.

Notation "f1 *R f2" := (Poly_mul f1 f2) (at level 20, left associativity).
Notation "f1 +R f2" := (Poly_add f1 f2) (at level 15).

Fixpoint max_var_Poly t :=
  match t with
  | Poly_var n => n
  | Poly_cst r => 0%nat
  | Poly_mul t1 t2 => Nat.max (max_var_Poly t1) (max_var_Poly t2)
  | Poly_add t1 t2 => Nat.max (max_var_Poly t1) (max_var_Poly t2)
  end.

Fixpoint eval_Poly (v : nat -> R) t :=
  match t with
  | Poly_var n => v n
  | Poly_cst r => r
  | Poly_mul t1 t2 => (eval_Poly v t1) * (eval_Poly v t2)
  | Poly_add t1 t2 => (eval_Poly v t1) + (eval_Poly v t2)
  end.

(* begin hide *)
Lemma eval_Poly_upd_val_vec_not_in : forall val vx vr i,
    (In_inf i vx -> False) ->
    eval_Poly (upd_val_vec val vx vr) (Poly_var i) = val i.
Proof.
  intros val vx; revert val; induction vx; intros val vr i Hin; auto.
  destruct vr; auto.
  simpl in *.
  rewrite IHvx.
  2:{ intros H; apply Hin; now right. }
  unfold upd_val.
  case_eq (a =? i); intros; auto.
  exfalso; apply Hin.
  left.
  apply Nat.eqb_eq; apply H.
Qed.

Lemma map_val_seq_var : forall val L i,
    map (eval_Poly (upd_val_vec val (seq i (length L)) L)) (map Poly_var (seq i (length L))) = L.
Proof.
  intros val L i.
  apply nth_ext with 0 0 ; [ rewrite 2 map_length; now rewrite seq_length | ].
  intros n.
  intros H.
  rewrite ? map_length in H; rewrite seq_length in H.
  rewrite nth_indep with _ _ _ _ (eval_Poly (upd_val_vec val (seq i (length L)) L) (Poly_var 0%nat)).
  2:{ rewrite 2 map_length; rewrite seq_length; apply H. }
  rewrite map_nth.
  rewrite map_nth.
  rewrite seq_nth; auto.
  simpl.
  rewrite upd_val_vec_eq.
  apply nth_indep; assumption.
Qed.

Lemma upd_val_term_lt :
  forall val a x r,
    (max_var_Poly a < x)%nat ->
    eval_Poly (upd_val val x r) a = eval_Poly val a.
Proof.
  intros val; induction a; intros x r' Hlt; simpl in *; try rewrite IHa1; try rewrite IHa2; try reflexivity; try lia.
  unfold upd_val.
  replace (x =? n) with false by (symmetry; apply Nat.eqb_neq; lia).
  reflexivity.
Qed.

(* end hide *)

Definition Permutation_Type_Poly val l1 l2 := Permutation_Type (map (eval_Poly val) l1) (map (eval_Poly val) l2).


Require Import IntegersC.
Require Import CoqlibC.
Require Import Zwf.
Require Coq.Program.Wf.
Require Import Recdef.
Require Import Intv.
Require Import AxiomsC.

Definition main_id := (77%positive).
Definition f_id := (154%positive).
Definition g_id := (176%positive).
Definition MAX: Z := 1000%Z.

Definition sum (i: int): int :=
  let sumz: Z := fold_rec Z Z.add 0%Z 0%Z (i.(Int.intval) + 1)%Z in
  Int.repr sumz
.

Lemma eta
      i iproof j jproof
      (EQ: i = j)
  :
    Int.mkint i iproof = Int.mkint j jproof
.
Proof.
  clarify.
  assert(iproof = jproof).
  { eapply proof_irr. }
  clarify.
Qed.

Lemma sum_recurse
      i
  :
    (sum i) = if Z.eqb i.(Int.intval) 0%Z then Int.zero else Int.add (sum (Int.sub i Int.one)) i
.
Proof.
  des_ifs.
  - apply Z.eqb_eq in Heq. destruct i; ss. clarify. unfold sum. ss.
    rewrite fold_rec_equation. des_ifs. zsimpl. rewrite fold_rec_equation. des_ifs.
  - destruct i; ss. apply Z.eqb_neq in Heq.
    assert(intval >= 1) by xomega.
    unfold Int.sub. ss.
    unfold sum at 1.
    rewrite fold_rec_equation. ss. des_ifs; try xomega.
    assert(exists j, j.(Int.intval) = intval - 1).
    { unshelve eexists (Int.mkint _ _); simpl; try reflexivity.
      xomega.
    }
    des.
    rewrite Int.unsigned_one.
    unfold sum.
    assert(MOD0: Int.Z_mod_modulus intval = intval).
    { rewrite Int.Z_mod_modulus_eq.
      symmetry. eapply Z.mod_unique_pos with (q := 0%Z); try xomega.
    }
    assert(MOD1: Int.Z_mod_modulus (intval - 1) = intval - 1).
    { rewrite Int.Z_mod_modulus_eq.
      symmetry. eapply Z.mod_unique_pos with (q := 0%Z); try xomega.
    }
    replace {| Int.intval := intval; Int.intrange := conj intrange intrange0 |} with
        (Int.repr intval); cycle 1.
    { Local Transparent Int.repr.
      eapply eta.
      Local Opaque Int.repr.
      ss.
    }
    rewrite Int.Ptrofs_add_repr.
    f_equal.
    zsimpl.
    rewrite Z.add_comm. f_equal. f_equal.
    Local Transparent Int.repr.
    ss.
    Local Opaque Int.repr.
    rewrite MOD1. lia.
Qed.

Require AST.

Definition fg_sig: AST.signature := (AST.mksignature [AST.Tint] (Some AST.Tint) AST.cc_default true).


From iris.algebra Require Import excl auth cmra gmap agree gset numbers.
From iris.algebra.lib Require Import frac_agree.
From iris.heap_lang Require Export notation locations lang.
From iris.base_logic.lib Require Export invariants.
From iris.program_logic Require Export atomic.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode par.
From iris.bi.lib Require Import fractional.
Set Default Proof Using "All".
Require Export lock multicopy multicopy_util.

Parameter inContents : val.
Parameter findNext : val.
Parameter addContents: val.
Parameter atCapacity: val.
Parameter chooseNext: val.
Parameter mergeContents: val.
Parameter allocNode: val.
Parameter insertNode: val.

(** Template algorithms *)

Definition traverse : val :=
  rec: "t_rec" "n" "k" :=
    lockNode "n" ;;
    match: (inContents "n" "k") with
      SOME "v" => unlockNode "n";; "v"
    | NONE => match: (findNext "n" "k") with
                SOME "n'" => unlockNode "n" ;; "t_rec" "n'" "k"
              | NONE => unlockNode "n" ;; #bot end end.

Definition search (r: Node) : val :=
  λ: "k", traverse #r "k".

Definition upsert (r: Node) : val :=
  rec: "upsert_rec" "k" "v" :=
    lockNode #r ;;
    let: "res" := addContents #r "k" "v" in
    if: "res" then
      unlockNode #r
    else
      unlockNode #r;;
      "upsert_rec" "k" "v".

Definition compact (r: Node) : val :=
  rec: "compact_rec" "n" :=
    lockNode "n" ;;
    if: atCapacity "n" then
      match: (chooseNext "n") with
        SOME "m" =>
          lockNode "m" ;;
          mergeContents "n" "m" ;;
          unlockNode "n" ;;
          unlockNode "m" ;;
          "compact_rec" "m"
      | NONE =>
          let: "m" := allocNode #() in
          insertNode #r "n" "m";;
          mergeContents "n" "m" ;;
          unlockNode "n" ;;
          unlockNode "m";;
          "compact_rec" "m" end
    else
      unlockNode "n".

(** Proof setup **)

Definition esT : Type := gmap Node (gset K).
Canonical Structure esRAC := leibnizO esT.

(* RAs used in proof *)

Definition prod4O A B C D :=
  prodO (prodO (prodO A B) C) D.

Definition per_node_gl :=
    agreeR
      (prod4O gnameO gnameO gnameO (gmapO K gnameO)).

Definition ghost_heapUR := gmapUR Node $ per_node_gl.

Definition KT: Type := K*T.

Definition flow_KTR := authR (multiset_flowint_ur KT).
Definition flow_KR := authR (multiset_flowint_ur K).
Definition set_nodeR := authR (gsetUR Node).
Definition frac_contR := frac_agreeR (gmapUR K natUR).
Definition frac_esR := frac_agreeR (esRAC).
Definition timeR := authR (max_natUR).
Definition ghR := authR $ ghost_heapUR.

Class multicopy_lsmG Σ := MULTICOPY_LSM {
                            multicopy_lsm_flow_KTG :> inG Σ flow_KTR;
                            multicopy_lsm_flow_KG :> inG Σ flow_KR;
                            multicopy_lsm_set_nodeG :> inG Σ set_nodeR;
                            multicopy_lsm_frac_contG :> inG Σ frac_contR;
                            multicopy_lsm_frac_esG :> inG Σ frac_esR;
                            multicopy_lsm_timeG :> inG Σ timeR;
                            multicopy_lsm_ghG :> inG Σ ghR;
                      }.

Definition multicopy_lsmΣ : gFunctors :=
  #[GFunctor flow_KTR; GFunctor flow_KR; GFunctor set_nodeR;
    GFunctor frac_contR; GFunctor frac_esR;
    GFunctor timeR; GFunctor ghR ].

Instance subG_multicopy_lsmΣ {Σ} : subG multicopy_lsmΣ Σ → multicopy_lsmG Σ.
Proof. solve_inG. Qed.

Section multicopy_lsm.
  Context {Σ} `{!heapG Σ, !multicopyG Σ, !multicopy_lsmG Σ}.
  Notation iProp := (iProp Σ).
  Local Notation "m !1 i" := (nzmap_total_lookup i m) (at level 20).

  (** Assumptions on the implementation made by the template algorithms. *)

  (* The node predicate is specific to each template implementation. See GRASShopper files
     multicopy-lsm.spl for the concrete definition. *)
  Parameter node : Node → Node → esT → (gmap K V) → iProp.

  Parameter nodeSpatial : Node → iProp.

  Parameter needsNewNode : Node → Node → esT → (gmap K V) → iProp.

  (* The following assumption is justified by the fact that GRASShopper uses a
   * first-order separation logic. *)
  Parameter node_timeless_proof : ∀ r n es V, Timeless (node r n es V).
  Global Instance node_timeless r n es V: Timeless (node r n es V).
  Proof. apply node_timeless_proof. Qed.

  (* The following hypothesis are proved as a GRASShopper lemma in
   * multicopy-lsm.spl *)
  Parameter node_sep_star: ∀ r n es V es' V',
    node r n es V ∗ node r n es' V' -∗ False.

  Parameter node_es_disjoint: ∀ r n es V,
    node r n es V -∗ ⌜∀ n1 n2, n1 ≠ n2 → es !!! n1 ∩ es !!! n2 = ∅⌝.

  Parameter node_es_empty: ∀ r n es V,
    node r n es V -∗ ⌜es !!! r = ∅ ∧ es !!! n = ∅⌝.

  (** The LSM multicopy structure invariant *)

  Definition inFP γ_f (n: Node) : iProp := own γ_f (◯ {[n]}).

  Definition closed γ_f (es: esT) : iProp := ∀ n, ⌜es !!! n  ≠ ∅⌝ → inFP γ_f n.

  Definition inflow_zero (I: multiset_flowint_ur KT) := ∀ n, inset KT I n = ∅.

  Definition outflow_zero (I: multiset_flowint_ur KT) := out_map I = ∅.

  Definition outflow_zero_J (I: multiset_flowint_ur K) := out_map I = ∅.

  Definition inflow_J (J: multiset_flowint_ur K) r :=
    ∀ n k, k ∈ KS → if decide (n = r) then in_inset K k J n else ¬ in_inset K k J n.

  Definition outflow_le_1 (I: multiset_flowint_ur KT) :=
    ∀ n kt, out I n !1 kt ≤ 1.

  Definition outflow_constraint_I (In: multiset_flowint_ur KT) (es: esT)
                          (Qn: gmap K T) :=
    ∀ n' k t, k ∈ KS → ((k,t) ∈ outset KT In n' ↔
                          k ∈ es !!! n' ∧ (Qn !! k = Some t)).

  Definition outflow_constraint_J (Jn: multiset_flowint_ur K) (es: esT) n :=
    ∀ n' k, k ∈ KS → (k ∈ outset K Jn n' ↔ k ∈ es !!! n' ∧ k ∈ inset K Jn n).

  (* This constraint is implicit in the paper. We track B_n
     explicitly as ghost state here. That is the following
     captures the definition of B_n in terms of C_n/Q_n given
     in the paper. *)
  Definition contents_in_reach (Bn Tn Qn: gmap K T) :=
              ∀ k t, k ∈ KS → ((Tn !! k = Some t → Bn !! k = Some t)
                 ∧ (Tn !! k = None → Bn !! k = Qn !! k)).

  (** ϕ_1 in the paper *)
  Definition φ1 (es: esT) (Qn: gmap K T) :=
              ∀ k, k ∈ KS → ((∀ n', k ∉ es !!! n') → Qn !! k = None).

  (** ϕ_2 in the paper *)
  Definition φ2 n (Bn: gmap K T) In :=
              ∀ k t, k ∈ KS → ((k,t) ∈ inset KT In n → Bn !!! k = t).

  (** ϕ_3 in the paper *)
  Definition φ3 (Bn Qn: gmap K T) :=
              ∀ k, k ∈ KS → (Qn !!! k ≤ Bn !!! k).

  (** ϕ_4 in the paper *)
  Definition φ4 n (Bn: gmap K T) Jn :=
              ∀ k, k ∈ KS → (Bn !! k = None ∨ k ∈ inset K Jn n).

  (** ϕ_5 in the paper *)
  Definition φ5 n (Jn: multiset_flowint_ur K) :=
              ∀ k, inf Jn n !1 k ≤ 1.

  (** The following two constraints are inductive consequences of ϕ1..ϕ5.
  We track them explicitly in the invariant for convenience. *)
  Definition φ6 n (es: esT) (Jn: multiset_flowint_ur K) (Qn: gmap K T) :=
              ∀ k, k ∈ KS → ((∃ n', k ∈ es !!! n') ∧ k ∈ inset K Jn n
                          → k ∈ dom (gset K) Qn).

  Definition φ7 (n: Node) (In: multiset_flowint_ur KT) :=
              ∀ kt, inf In n !1 kt ≤ 1.

  Definition f_mergeLeft {A} (K1: gset K) (Vn: gmap K A) (Es: gset K)
                        (Vm: gmap K A) :=
                    λ k (o1: option A) (o2: option A),
                      if (decide (k ∈ (KS ∩ K1 ∩ dom (gset K) Vn ∩ Es)))
                      then (None: option A)
                      else o1.

  Global Instance f_mergeLeft_diag_none {A} (K1: gset K) (Vn: gmap K A) (Es: gset K)
                        (Vm: gmap K A) k:
                      DiagNone (f_mergeLeft K1 Vn Es Vm k).
  Proof.
    unfold DiagNone. unfold f_mergeLeft.
    destruct (decide (k ∈ ((KS ∩ K1) ∩ dom (gset K) Vn) ∩ Es));
        try by simpl.
  Qed.

  Definition mergeLeft {A} (K1: gset K) (Vn: gmap K A) (Es: gset K)
                        (Vm: gmap K A) : gmap K A :=
              gmap_imerge (f_mergeLeft K1 Vn Es Vm) Vn Vm.

  Definition f_mergeRight {A} (K1: gset K) (Vn: gmap K A) (Es: gset K)
                        (Vm: gmap K A) :=
                    λ k (o1: option A) (o2: option A),
                      if (decide (k ∈ (KS ∩ K1 ∩ dom (gset K) Vn ∩ Es)))
                      then o1
                      else o2.

  Global Instance f_mergeRight_diag_none {A} (K1: gset K) (Vn: gmap K A) (Es: gset K)
                        (Vm: gmap K A) k:
                      DiagNone (f_mergeRight K1 Vn Es Vm k).
  Proof.
    unfold DiagNone. unfold f_mergeRight.
    destruct (decide (k ∈ ((KS ∩ K1) ∩ dom (gset K) Vn) ∩ Es));
        try by simpl.
  Qed.

  Definition mergeRight {A} (K1: gset K) (Vn: gmap K A) (Es: gset K)
                        (Vm: gmap K A) : gmap K A :=
              gmap_imerge (f_mergeRight K1 Vn Es Vm) Vn Vm.

  Definition frac_ghost_state γ_en γ_cn γ_qn (es: esT)
                                  (Tn Qn: gmap K T): iProp :=
      own (γ_en) (to_frac_agree (1/2) (es))
    ∗ own (γ_cn) (to_frac_agree (1/2) (Tn))
    ∗ own (γ_qn) (to_frac_agree (1/2) (Qn)).

  Definition singleton_interfaces_ghost_state (γ_I γ_J: gname) (n: Node)
                  (In: multiset_flowint_ur KT) (Jn: multiset_flowint_ur K) : iProp :=
      own γ_I (◯ In)
    ∗ own γ_J (◯ Jn)
    ∗ ⌜domm In = {[n]}⌝
    ∗ ⌜domm Jn = {[n]}⌝.

  Definition outflow_constraints n In Jn es Qn : iProp :=
      ⌜outflow_constraint_I In es Qn⌝
    ∗ ⌜outflow_constraint_J Jn es n⌝
    ∗ ⌜outflow_le_1 In⌝.

  Definition ghost_loc γ_en γ_cn γ_qn (γ_cirn: gmap K gnameO) : per_node_gl :=
        to_agree (γ_en, γ_cn, γ_qn, γ_cirn).

  Definition contents_proj (Cn: gmap K (V*T)) (Vn: gmap K V) (Tn: gmap K T) : iProp :=
      ⌜dom (gset K) Cn = dom (gset K) Vn⌝
    ∗ ⌜dom (gset K) Cn = dom (gset K) Tn⌝
    ∗ ⌜∀ k v t, Cn !! k = Some (v, t) ↔ Vn !! k = Some v ∧ Tn !! k = Some t⌝.

  Definition nodePred' γ_gh γ_s r n (Cn: gmap K (V*T)) (Vn: gmap K V)
                      (Tn Qn: gmap K T) γ_en γ_cn γ_qn γ_cirn es: iProp :=
      node r n es Vn
    ∗ own γ_gh (◯ {[n := ghost_loc γ_en γ_cn γ_qn γ_cirn]})
    ∗ frac_ghost_state γ_en γ_cn γ_qn es Tn Qn
    ∗ own γ_s (◯ set_of_map Cn)
    ∗ contents_proj Cn Vn Tn.

  (** Predicate N_L in the paper *)
  Definition nodePred γ_gh γ_s r n (Cn: gmap K (V*T)) (Qn: gmap K T) : iProp :=
    ∃ γ_en γ_cn γ_qn γ_cirn es Vn Tn, nodePred' γ_gh γ_s r n Cn Vn Tn Qn
                                             γ_en γ_cn γ_qn γ_cirn es.

  Definition nodeShared' (γ_I γ_J γ_f: gname) γ_gh r n
          (Tn Qn Bn: gmap K T) H γ_en γ_cn γ_qn γ_cirn es In Jn: iProp :=
      own γ_gh (◯ {[n := ghost_loc γ_en γ_cn γ_qn γ_cirn]})
    ∗ frac_ghost_state γ_en γ_cn γ_qn es Tn Qn
    ∗ singleton_interfaces_ghost_state γ_I γ_J n In Jn
    ∗ inFP γ_f n
    ∗ closed γ_f es
    ∗ outflow_constraints n In Jn es Qn
    ∗ ⌜contents_in_reach Bn Tn Qn⌝
    ∗ (if decide (n = r)
       then ⌜∀ k, Bn !!! k = ((map_of_set H) !!! k).2⌝
            ∗ ⌜inflow_zero In⌝
       else True)%I
    ∗ ([∗ set] k ∈ KS, own (γ_cirn !!! (k)) (● (MaxNat (Bn !!! k))))
    ∗ ⌜φ1 es Qn⌝ ∗ ⌜φ2 n Bn In⌝ ∗ ⌜φ3 Bn Qn⌝ ∗ ⌜φ4 n Bn Jn⌝
    ∗ ⌜φ5 n Jn⌝ ∗ ⌜φ6 n es Jn Qn⌝ ∗ ⌜φ7 n In⌝.

  (** Predicate N_S in the paper *)
  Definition nodeShared (γ_I γ_J γ_f: gname) γ_gh r n
          (Qn : gmap K T) H: iProp :=
    ∃ γ_en γ_cn γ_qn γ_cirn es Tn Bn In Jn,
        nodeShared' γ_I γ_J γ_f γ_gh r n Tn Qn Bn H
                    γ_en γ_cn γ_qn γ_cirn es In Jn.

  (** Predicate G in the paper *)
  Definition global_state (γ_I γ_J γ_f γ_gh: gname) (r: Node)
          (hγ: gmap Node per_node_gl) (I: multiset_flowint_ur KT)
          (J: multiset_flowint_ur K) : iProp :=
      own γ_I (● I) ∗ ⌜outflow_zero I⌝
    ∗ own γ_J (● J) ∗ ⌜outflow_zero_J J⌝ ∗ ⌜inflow_J J r⌝
    ∗ own γ_f (● domm I)
    ∗ own γ_gh (● hγ)
    ∗ inFP γ_f r
    ∗ ⌜domm I = domm J⌝
    ∗ ⌜domm I = dom (gset Node) hγ⌝.

  Definition Inv_LSM γ_s γ_I γ_J γ_f γ_gh r H : iProp :=
    ∃ hγ
      (I: multiset_flowint_ur KT) (J: multiset_flowint_ur K),
      global_state γ_I γ_J γ_f γ_gh r hγ I J
    ∗ ([∗ set] n ∈ (domm I), ∃ (bn: bool) Cn Qn,
        (lockR bn n (nodePred γ_gh γ_s r n Cn Qn))
        ∗ (nodeShared γ_I γ_J γ_f γ_gh r n Qn H))%I.

  Global Instance Inv_LSM_timeless γ_s γ_I γ_J γ_f γ_gh r H:
    Timeless (Inv_LSM γ_s γ_I γ_J γ_f γ_gh r H).
  Proof.
    rewrite /Inv_LSM.
    repeat (apply bi.exist_timeless; intros).
    repeat apply bi.sep_timeless; try apply _.
    apply big_sepS_timeless.
    repeat (intros; apply bi.exist_timeless; intros).
    apply bi.sep_timeless; try apply _.
    destruct x3; try apply _.
    repeat apply bi.sep_timeless; try apply _.
    repeat (apply bi.exist_timeless; intros).
    repeat apply bi.sep_timeless; try apply _.
    destruct (decide (x2 = r)); try apply _.
  Qed.

  (** Helper functions specs *)

  (* The following specs are proved for each implementation in GRASShopper
   * (see multicopy-lsm.spl *)

  Parameter inContents_spec : ∀ r n esn (Vn: gmap K V) (k: K),
     ⊢ ({{{ node r n esn Vn }}}
           inContents #n #k
       {{{ (v: option V),
              RET (match v with Some v => SOMEV #v | None => NONEV end);
                  node r n esn Vn ∗ ⌜Vn !! k = v⌝ }}})%I.

  Parameter findNext_spec : ∀ r n esn (Vn: gmap K V) (k: K),
     ⊢ ({{{ node r n esn Vn }}}
           findNext #n #k
       {{{ (n': option Node),
              RET (match n' with Some n' => SOMEV #n' | None => NONEV end);
                  node r n esn Vn
                  ∗ (match n' with Some n' => ⌜k ∈ esn !!! n'⌝
                                 | None => ⌜∀ n'', k ∉ esn !!! n''⌝ end) }}})%I.

  Parameter addContents_spec : ∀ r n esn (Vn: gmap K V) (k: K) (v: V),
     ⊢ ({{{ node r n esn Vn ∗ ⌜n = r⌝ }}}
           addContents #r #k #v
       {{{ (succ: bool) (Vn': gmap K V),
              RET #succ;
                  node r n esn Vn' ∗ if succ then ⌜Vn' = <[k := v]> Vn⌝
                                else ⌜Vn' = Vn⌝ }}})%I.

  Parameter atCapacity_spec : ∀ r n esn (Vn: gmap K V),
     ⊢ ({{{ node r n esn Vn }}}
           atCapacity #n
       {{{ (b: bool), RET #b;
           node r n esn Vn }}})%I.

  Parameter chooseNext_spec : ∀ r n esn (Vn: gmap K V),
     ⊢ ({{{ node r n esn Vn }}}
           chooseNext #n
       {{{ (n1: option Node),
              RET (match n1 with Some n1 => SOMEV #n1 | None => NONEV end);
           node r n esn Vn
           ∗ (match n1 with Some n1 => ⌜esn !!! n1 ≠ ∅⌝
                          | None => needsNewNode r n esn Vn end) }}})%I.

  Parameter allocNode_spec :
     ⊢ ({{{ True }}}
           allocNode #()
       {{{ (m: Node) (l:loc), RET #m;
            nodeSpatial m
            ∗ ⌜lockLoc m = l⌝
            ∗ l ↦ #true }}})%I.

  Parameter insertNode_spec : ∀ r n m esn Vn,
    ⊢ {{{ node r n esn Vn ∗ needsNewNode r n esn Vn
          ∗ nodeSpatial m ∗ ⌜m ≠ r⌝ }}}
          insertNode #r #n #m
      {{{ esn' esm Vm, RET #();
          node r n esn' Vn ∗ node r m esm Vm
          ∗ ⌜esn' = <[m:=esn' !!! m]> esn⌝
          ∗ ⌜esn' !!! m ≠ ∅⌝
          ∗ ⌜Vm = ∅⌝ ∗ ⌜esm = ∅⌝ }}}.

  Parameter mergeContents_spec : ∀ r n m esn esm (Vn Vm: gmap K V),
     ⊢ ({{{ node r n esn Vn ∗ node r m esm Vm ∗ ⌜esn !!! m ≠ ∅⌝ }}}
           mergeContents #n #m
       {{{ (K1: gset K) Vn' Vm', RET #();
           node r n esn Vn' ∗ node r m esm Vm'
           ∗ ⌜Vn' = mergeLeft K1 Vn (esn !!! m) Vm⌝
           ∗ ⌜Vm' = mergeRight K1 Vn (esn !!! m) Vm⌝ }}})%I.

End multicopy_lsm.


Require Import SystemFR.Trees.
Require Import SystemFR.Syntax.
Require Import SystemFR.RewriteTactics.
Require Import SystemFR.PrimitiveRecognizers.
Require Import SystemFR.FVLemmas.
Require Import SystemFR.FVLemmasEval.
Require Import SystemFR.WFLemmasEval.
Require Import SystemFR.WFLemmas.
Require Import SystemFR.Evaluator.
Require Import SystemFR.StarLemmas.

Require Import String.

Reserved Notation "t '~~>*' v" (at level 20).

Inductive bcbv_step: tree -> tree -> Prop :=
  (* unit *)
  | BSuu : uu ~~>* uu
  (* nat *)
  | BSzero : zero ~~>* zero
  | BSsucc : forall t v,
      t ~~>* v ->
        succ t ~~>* succ v
  | BSmatch0 : forall t t0 ts v,
      t ~~>* zero ->
      t0 ~~>* v ->
        tmatch t t0 ts ~~>* v
  | BSmatchS : forall t v t0 ts v',
      t ~~>* succ v ->
      open 0 ts v ~~>* v' ->
        tmatch t t0 ts ~~>* v'
  | BSplus : forall t1 t2 n1 n2,
      t1 ~~>* build_nat n1 ->
      t2 ~~>* build_nat n2 ->
        binary_primitive Plus t1 t2 ~~>* build_nat (n1 + n2)
  | BSminus : forall t1 t2 n1 n2,
      t1 ~~>* build_nat n1 ->
      t2 ~~>* build_nat n2 ->
      n1 >= n2 ->
        binary_primitive Minus t1 t2 ~~>* build_nat (n1 - n2)
  | BSmul : forall t1 t2 n1 n2,
      t1 ~~>* build_nat n1 ->
      t2 ~~>* build_nat n2 ->
        binary_primitive Mul t1 t2 ~~>* build_nat (n1 * n2)
  | BSdiv : forall t1 t2 n1 n2,
      t1 ~~>* build_nat n1 ->
      t2 ~~>* build_nat n2 ->
      n2 > 0 ->
        binary_primitive Div t1 t2 ~~>* build_nat (PeanoNat.Nat.div n1 n2)
  | BSeq : forall t1 t2 n1 n2,
      t1 ~~>* build_nat n1 ->
      t2 ~~>* build_nat n2 ->
        binary_primitive Eq t1 t2 ~~>* (if PeanoNat.Nat.eqb n1 n2 then ttrue else tfalse)
  | BSneq : forall t1 t2 n1 n2,
      t1 ~~>* build_nat n1 ->
      t2 ~~>* build_nat n2 ->
        binary_primitive Neq t1 t2 ~~>* (if PeanoNat.Nat.eq_dec n1 n2 then tfalse else ttrue)
  | BSlt : forall t1 t2 n1 n2,
      t1 ~~>* build_nat n1 ->
      t2 ~~>* build_nat n2 ->
        binary_primitive Lt t1 t2 ~~>* (if PeanoNat.Nat.ltb n1 n2 then ttrue else tfalse)
  | BSleq : forall t1 t2 n1 n2,
      t1 ~~>* build_nat n1 ->
      t2 ~~>* build_nat n2 ->
        binary_primitive Leq t1 t2 ~~>* (if PeanoNat.Nat.leb n1 n2 then ttrue else tfalse)
  | BSgt : forall t1 t2 n1 n2,
      t1 ~~>* build_nat n1 ->
      t2 ~~>* build_nat n2 ->
        binary_primitive Gt t1 t2 ~~>* (if PeanoNat.Nat.leb n1 n2 then tfalse else ttrue)
  | BSget : forall t1 t2 n1 n2,
      t1 ~~>* build_nat n1 ->
      t2 ~~>* build_nat n2 ->
        binary_primitive Geq t1 t2 ~~>* (if PeanoNat.Nat.ltb n1 n2 then tfalse else ttrue)
  (* function *)
  | BSlambda : forall t,
      notype_lambda t ~~>* notype_lambda t
  | BSapp : forall t1 b1 t2 v2 v,
      t1 ~~>* notype_lambda b1 ->
      t2 ~~>* v2 ->
      open 0 b1 v2 ~~>* v ->
        app t1 t2 ~~>* v
  | BSfix : forall t v,
      open 0 (open 1 t zero) (notype_tfix t) ~~>* v ->
        notype_tfix t ~~>* v
  (* pair *)
  | BSpair : forall t1 t2 v1 v2,
      t1 ~~>* v1 ->
      t2 ~~>* v2 ->
        pp t1 t2 ~~>* pp v1 v2
  | BSproj1 : forall t v1 v2,
      t ~~>* pp v1 v2 ->
        pi1 t ~~>* v1
  | BSproj2 : forall t v1 v2,
      t ~~>* pp v1 v2 ->
        pi2 t ~~>* v2
  (* boolean *)
  | BStrue : ttrue ~~>* ttrue
  | BSfalse : tfalse ~~>* tfalse
  | BSitetrue : forall c t1 v1 t2,
      c ~~>* ttrue ->
      t1 ~~>* v1 ->
        ite c t1 t2 ~~>* v1
  | BSitefalse : forall c t1 t2 v2,
      c ~~>* tfalse ->
      t2 ~~>* v2 ->
        ite c t1 t2 ~~>* v2
  | BSisPair : forall t v,
      t ~~>* v ->
        boolean_recognizer 0 t ~~>* is_pair v
  | BSisSucc : forall t v,
      t ~~>* v ->
        boolean_recognizer 1 t ~~>* is_succ v
  | BSisLambda : forall t v,
      t ~~>* v ->
        boolean_recognizer 2 t ~~>* is_lambda v
  | BSnot1 : forall t,
      t ~~>* ttrue ->
        unary_primitive Not t ~~>* tfalse
  | BSnot2 : forall t,
      t ~~>* tfalse ->
        unary_primitive Not t ~~>* ttrue
  | BSand1 : forall t1 t2,
      t1 ~~>* ttrue ->
      t2 ~~>* ttrue ->
        binary_primitive And t1 t2 ~~>* ttrue
  | BSand2 : forall t1 t2,
      t1 ~~>* ttrue ->
      t2 ~~>* tfalse ->
        binary_primitive And t1 t2 ~~>* tfalse
  | BSand3 : forall t1 t2,
      t1 ~~>* tfalse ->
      t2 ~~>* ttrue ->
        binary_primitive And t1 t2 ~~>* tfalse
  | BSand4 : forall t1 t2,
      t1 ~~>* tfalse ->
      t2 ~~>* tfalse ->
        binary_primitive And t1 t2 ~~>* tfalse
  | BSor1 : forall t1 t2,
      t1 ~~>* ttrue ->
      t2 ~~>* ttrue ->
        binary_primitive Or t1 t2 ~~>* ttrue
  | BSor2 : forall t1 t2,
      t1 ~~>* ttrue ->
      t2 ~~>* tfalse ->
        binary_primitive Or t1 t2 ~~>* ttrue
  | BSor3 : forall t1 t2,
      t1 ~~>* tfalse ->
      t2 ~~>* ttrue ->
        binary_primitive Or t1 t2 ~~>* ttrue
  | BSor4 : forall t1 t2,
      t1 ~~>* tfalse ->
      t2 ~~>* tfalse ->
        binary_primitive Or t1 t2 ~~>* tfalse
  (* either *)
  | BSleft : forall t v,
      t ~~>* v ->
        tleft t ~~>* tleft v
  | BSright : forall t v,
      t ~~>* v ->
        tright t ~~>* tright v
  | BSmatchLeft : forall t v tr tl v',
      t ~~>* tleft v ->
      open 0 tl v ~~>* v' ->
        sum_match t tl tr ~~>* v'
  | BSmatchRight : forall t v tr tl v',
      t ~~>* tright v ->
      open 0 tr v ~~>* v' ->
        sum_match t tl tr ~~>* v'
  (* size *)
  | BSsize : forall t v,
      t ~~>* v ->
        tsize t ~~>* build_nat (tsize_semantics v)
where "t '~~>*' v" := (bcbv_step t v).

#[export]
Hint Constructors bcbv_step : bcbv_step.

Lemma bs_closed_term: forall t1 t2, t1 ~~>* t2 -> closed_term t1 -> closed_value t2.
Proof.
  induction 1; repeat light || apply_any; t_closing;
  eauto with fv erased wf; try solve [inversion H4; eauto].
  repeat light || eapply wf_open; eauto with wf.
  repeat light || eapply is_erased_open; eauto with erased.
Qed.

#[export] Hint Resolve bs_closed_term : values.

Lemma bs_value: forall t v, t ~~>* v -> cbv_value v.
Proof.
  induction 1; repeat light || destruct_match; auto with values;
  inversion IHbcbv_step; light.
Qed.

Lemma value_bs: forall v, cbv_value v -> v ~~>* v .
Proof.
  induction 1; eauto with bcbv_step.
Qed.

#[export]
Hint Immediate bs_value value_bs : values.

Lemma bs_unique: forall t v1 v2,
  t ~~>* v1 ->
  t ~~>* v2 ->
    v1 = v2.
Proof.
  intros; generalize dependent v2;
  induction H; inversion 1;
  repeat light || t_equality
  || invert_constructor_equalities || build_nat_inj
  || instantiate_any || destruct_match.
Qed.

Ltac instantiate_bs_unique :=
  match goal with
  | H : ?v ~~>* _,
    H': ?v ~~>* _ |- _ =>
      poseNew (Mark v "bs_unique");
      pose proof bs_unique _ _ _ H H'
  end.

(* Equivalance small step*)

Ltac big_step_value :=
  match goal with
  | H: ?v ~~>* ?v' |- _ =>
    unshelve epose proof value_bs v _;
    try solve [
      repeat light || destruct_match;
      eauto with values
    ];
    instantiate_bs_unique;
    repeat light
  | |- ?v ~~>* ?v =>
    apply value_bs;
    eauto with values;
    fail
  end.

Lemma ss_bs: forall t1 t2, t1 ~> t2 ->
  forall v, t2 ~~>* v -> t1 ~~>* v.
Proof.
  induction 1;
  try solve [
    inversion 1;
    repeat light;
    try instantiate_any;
    eauto with bcbv_step values;
    constructor; auto
  ]; try solve [
    repeat light || big_step_value
    || constructor || destruct_match;
    eauto with bcbv_step values
  ].
Qed.

Lemma tcss_bs: forall t v,
  cbv_value v -> t ~>* v ->
    t ~~>* v.
Proof.
  induction 2.
  eauto using value_bs.
  eauto using ss_bs.
Qed.

Ltac bs_tccs :=
  match goal with
  | H1 : ?t1 ~>* ?v1,
    H2 : ?t2 ~>* ?v2
    |- binary_primitive ?op ?t1 ?t2 ~>* _ =>
      eapply star_trans with (binary_primitive op v1 t2);
      eauto with cbvlemmas smallstep star values;
      eapply star_trans with (binary_primitive op v1 v2);
      eauto with cbvlemmas smallstep star values
  | H : ?t ~>* ?v
    |- unary_primitive ?op ?t ~>* _ =>
      eapply star_trans with (unary_primitive op v);
      eauto with cbvlemmas smallstep star values
  | H : ?t ~>* ?v
    |- boolean_recognizer ?id ?t ~>* _ =>
      eapply star_trans with (boolean_recognizer id v);
      eauto with cbvlemmas smallstep star values
  | H1 : ?t1 ~>* ?v1,
    H2 :   _ ~>* ?v2
    |- tmatch ?t _ _ ~>* ?v2 =>
      eapply star_trans with (tmatch v1 _ _);
      eauto with cbvlemmas smallstep star values
  | H1 : ?c ~>* ?b,
    H2 :  _ ~>* ?v
    |- ite ?c _ _ ~>* ?v =>
      eapply star_trans with (ite b _ _);
      eauto with cbvlemmas smallstep star values
  | H1 : ?t ~>* ?v,
    H2 : open 0 _ _ ~>* ?v'
    |- sum_match ?t _ _ ~>* ?v' =>
      eapply star_trans with (sum_match v _ _);
      eauto with cbvlemmas smallstep star values
  | H : ?t ~>* pp ?v1 ?v2
    |- ?C ?t ~>* _ =>
      is_constructor C;
      eapply star_trans with (C (pp v1 v2));
      eauto with cbvlemmas smallstep star values
  end.

Ltac invert_cbv_value :=
  match goal with
  | H : cbv_value (?C _) |- _ =>
    is_constructor C; inversion H
  | H : cbv_value (?C _ _) |- _ =>
    is_constructor C; inversion H
  end.

Lemma bs_tccs: forall t v,
  t ~~>* v -> t ~>* v.
Proof.
  induction 1;
  try solve [constructor];
  eauto with cbvlemmas;
  try solve [
    eapply star_trans;
    eauto with cbvlemmas smallstep star values
  ]; repeat apply_anywhere bs_value;
  try invert_cbv_value;
  try bs_tccs.
  (* 4 *)
  - (* app *)
    eapply star_trans with (app (notype_lambda b1) t2);
    eauto with cbvlemmas smallstep star values.
    eapply star_trans with (app (notype_lambda b1) v2);
    eauto with cbvlemmas smallstep star values.
  - (* tsize *)
    eapply star_trans with (tsize v);
    eauto with cbvlemmas smallstep star values.
Qed.