Require Import UniMath.Foundations.Generalities.uu0.
Require Import UniMath.Foundations.hlevel1.hProp.
Require Import UniMath.Foundations.hlevel2.hSet.

Require Import UniMath.RezkCompletion.precategories.
Require Import UniMath.RezkCompletion.functor_categories.
Require Import SubstSystems.UnicodeNotations.
Require Import UniMath.RezkCompletion.whiskering.
Require Import UniMath.RezkCompletion.Monads.
Require Import UniMath.RezkCompletion.FunctorAlgebras.
Require Import UniMath.RezkCompletion.limits.coproducts.
Require Import SubstSystems.Auxiliary.
Require Import SubstSystems.PointedFunctors.
Require Import SubstSystems.ProductPrecategory.
Require Import SubstSystems.HorizontalComposition.
Require Import SubstSystems.PointedFunctorsComposition.
Require Import SubstSystems.EndofunctorsMonoidal.
Require Import SubstSystems.Signatures.
(* Require Import SubstSystems.FunctorAlgebraViews. *)
Require Import SubstSystems.FunctorsPointwiseCoproduct.

Local Notation "# F" := (functor_on_morphisms F)(at level 3).
Local Notation "F ⟶ G" := (nat_trans F G) (at level 39).
Arguments functor_composite {_ _ _} _ _ .
Arguments nat_trans_comp {_ _ _ _ _} _ _ .
Local Notation "G ∙ F" := (functor_composite F G : [ _ , _ , _ ]) (at level 35).
Local Notation "α ∙∙ β" := (hor_comp β α) (at level 20).
Ltac pathvia b := (apply (@pathscomp0 _ _ b _ )).

Local Notation "α 'ø' Z" := (pre_whisker Z α)  (at level 25).
Local Notation "Z ∘ α" := (post_whisker _ _ _ _ α Z) (at level 35).

Local Notation "C ⟦ a , b ⟧" := (precategory_morphisms (C:=C) a b) (at level 50).

Section def_hss.

(** ** Some variables and assumptions *)

(** Assume having a precategory [C] whose hom-types are sets *)
Variable C : precategory.
Variable hs : has_homsets C.

Variable CP : Coproducts C.

Local Notation "'EndC'":= ([C, C, hs]) .
Let hsEndC : has_homsets EndC := functor_category_has_homsets C C hs.
Let CPEndC : Coproducts EndC := Coproducts_functor_precat _ _ CP hs.

Variable H : Signature C hs.

Let θ := theta H.

Let θ_strength1_int := Sig_strength_law1 _ _ H.
Let θ_strength2_int := Sig_strength_law2 _ _ H.

Let Id_H
: functor EndC EndC
  := coproduct_functor _ _ CPEndC
                       (constant_functor _ _ (functor_identity _ : EndC))
                       H.

(*
(** [H] is a rank-2 endofunctor on endofunctors *)
Variable H : functor [C, C, hs] [C, C, hs].
*)
(** The forgetful functor from pointed endofunctors to endofunctors *)
Local Notation "'U'" := (functor_ptd_forget C hs).
(** The precategory of pointed endofunctors on [C] *)
Local Notation "'Ptd'" := (precategory_Ptd C hs).
(** The category of endofunctors on [C] *)
Local Notation "'EndC'":= ([C, C, hs]) .
(** The product of two precategories *)
Local Notation "A 'XX' B" := (product_precategory A B) (at level 2).
(** Pre-whiskering defined as morphism part of the functor given by precomposition
    with a fixed functor *)
Local Notation "α 'øø' Z" :=  (# (pre_composition_functor_data _ _ _ hs _  Z) α) (at level 25).

Local Notation "A ⊗ B" := (prodcatpair _ _ A B) (at level 10).

Local Coercion alg_carrier : algebra_ob >-> ob.

(* Local Notation "'τ'" := (tau). *)

(** ** Definition of algebra structure [τ] of a pointed functor *)
(*
Definition AlgStruct (T : Ptd) : UU := pr1 (H(U T)) ⟶ pr1 (U T).

Definition Alg : UU := Σ T : Ptd, AlgStruct T.

Coercion PtdFromAlg (T : Alg) : Ptd := pr1 T.

Definition τ (T : Alg) : pr1 (H (U T)) ⟶ pr1 (U T) := pr2 T.
*)

(* An Id_H algebra is a pointed functor *)

Definition eta_from_alg (T : algebra_ob _ Id_H) : EndC ⟦ functor_identity _,  T ⟧.
Proof.
  exact (CoproductIn1 _ _ ;; alg_map _ _ T).
Defined.

Definition ptd_from_alg (T : algebra_ob _ Id_H) : Ptd.
Proof.
  exists (pr1 T).
  exact (eta_from_alg T).
Defined.

Definition tau_from_alg (T : algebra_ob _ Id_H) : EndC ⟦H T, T⟧.
Proof.
  exact (CoproductIn2 _ _ ;; alg_map _ _ T).
Defined.

Local Notation "'p' T" := (ptd_from_alg T) (at level 3).

(*
Coercion functor_from_algebra_ob (X : algebra_ob _ Id_H) : functor C C  := pr1 X.
*)
Local Notation "` T" := (alg_carrier _ _ T : functor C C) (at level 3).

Local Notation "f ⊕ g" := (CoproductOfArrows _ (CPEndC _ _ ) (CPEndC _ _ ) f g) (at level 40).

(*
Definition bracket (T : algebra_ob _ Id_H) : UU :=
  ∀ (Z : Ptd) (f : Z ⇒ ptd_from_alg T), iscontr
   (Σ h : `T ∙ (U Z)  ⇒ T,
          alg_map _ _ T øø (U Z) ;; h =
          CoproductOfArrows _ (CPEndC _ _ ) (CPEndC _ _ ) (identity (U Z)) (θ (`T ⊗ Z)) ;;
          CoproductOfArrows _ (CPEndC _ _ ) (CPEndC _ _ ) (identity (U Z)) (#H h) ;;
          CoproductArrow _ (CPEndC _ _ ) (#U f) (tau_from_alg T )).
*)

Definition bracket_property (T : algebra_ob _ Id_H) {Z : Ptd} (f : Z ⇒ ptd_from_alg T)
           (h : `T ∙ (U Z)  ⇒ T) : UU
  :=
    alg_map _ _ T øø (U Z) ;; h =
          identity (U Z) ⊕ θ (`T ⊗ Z) ;;
          identity (U Z) ⊕ #H h ;;
          CoproductArrow _ (CPEndC _ _ ) (#U f) (tau_from_alg T).

Definition bracket_at (T : algebra_ob _ Id_H) {Z : Ptd} (f : Z ⇒ ptd_from_alg T): UU :=
  iscontr
   (Σ h : `T ∙ (U Z)  ⇒ T, bracket_property T f h).

Definition bracket (T : algebra_ob _ Id_H) : UU
  := ∀ (Z : Ptd) (f : Z ⇒ ptd_from_alg T), bracket_at T f.

Definition bracket_property_parts (T : algebra_ob _ Id_H) {Z : Ptd} (f : Z ⇒ ptd_from_alg T)
           (h : `T ∙ (U Z)  ⇒ T) : UU
  :=
    (#U f = eta_from_alg T øø (U Z) ;; h) ×
     (θ (`T ⊗ Z) ;; #H h ;; tau_from_alg T  = tau_from_alg T øø (U Z) ;;  h).

Definition bracket_parts_at (T : algebra_ob _ Id_H) {Z : Ptd} (f : Z ⇒ ptd_from_alg T) : UU :=
   iscontr
   (Σ h : `T ∙ (U Z)  ⇒ T, bracket_property_parts T f h).

Definition bracket_parts (T : algebra_ob _ Id_H) : UU
  := ∀ (Z : Ptd) (f : Z ⇒ ptd_from_alg T), bracket_parts_at T f.

(* show that for any h of suitable type, the following are equivalent *)

Lemma parts_from_whole (T : algebra_ob _ Id_H) (Z : Ptd) (f : Z ⇒ ptd_from_alg T)
      (h :  `T ∙ (U Z)  ⇒ T) :
  bracket_property T f h → bracket_property_parts T f h.
  (*
    alg_map _ _ T øø (U Z) ;; h =
          identity (U Z) ⊕ θ (`T ⊗ Z) ;;
          identity (U Z) ⊕ #H h ;;
          CoproductArrow _ (CPEndC _ _ ) (#U f) (tau_from_alg T ) →
   (#U f = eta_from_alg T øø (U Z) ;; h) ×
     (θ (`T ⊗ Z) ;; #H h ;; tau_from_alg T  = tau_from_alg T øø (U Z) ;;  h ).
*)
Proof.
  intro Hyp.
(*  assert (Hyp_inst :=  maponpaths (fun m:EndC⟦_,_⟧ => CoproductIn1 ([C, C] hs)
      (CPEndC
         ((constant_functor ([C, C] hs) ([C, C] hs) (functor_identity C)) T)
         (H T));;m) Hyp). *)
  split.
  + unfold eta_from_alg.
    apply nat_trans_eq; try (exact hs).
    intro c.
    simpl.
    unfold coproduct_nat_trans_in1_data.
    assert (Hyp_inst := nat_trans_eq_pointwise _ _ _ _ _ _ Hyp c); clear Hyp.
    apply (maponpaths (fun m =>  CoproductIn1 C (CP _ _);; m)) in Hyp_inst.
    match goal with |[ H1 : _  = ?f |- _ = _   ] =>
         pathvia (f) end.

    * clear Hyp_inst.
      rewrite <- assoc.
      apply CoproductIn1Commutes_right_in_ctx_dir.
      rewrite id_left.
      apply CoproductIn1Commutes_right_in_ctx_dir.
      rewrite id_left.
      apply CoproductIn1Commutes_right_dir.
      apply idpath.
    * rewrite <- Hyp_inst; clear Hyp_inst.
      rewrite <- assoc.
      apply idpath.
  + unfold tau_from_alg.
    apply nat_trans_eq; try (exact hs).
    intro c.
    simpl.
    unfold coproduct_nat_trans_in2_data.
    assert (Hyp_inst := nat_trans_eq_pointwise _ _ _ _ _ _ Hyp c); clear Hyp.
    apply (maponpaths (fun m =>  CoproductIn2 C (CP _ _);; m)) in Hyp_inst.
    match goal with |[ H1 : _  = ?f |- _ = _   ] =>
         pathvia (f) end.

    * clear Hyp_inst.
      do 2 rewrite <- assoc.
      apply CoproductIn2Commutes_right_in_ctx_dir.
      simpl.
      rewrite <- assoc.
      apply maponpaths.
      apply CoproductIn2Commutes_right_in_ctx_dir.
      simpl.
      rewrite <- assoc.
      apply maponpaths.
      unfold tau_from_alg.
      apply CoproductIn2Commutes_right_dir.
      apply idpath.
    * rewrite <- Hyp_inst; clear Hyp_inst.
      rewrite <- assoc.
      apply idpath.
Qed.

Lemma whole_from_parts (T : algebra_ob _ Id_H) (Z : Ptd) (f : Z ⇒ ptd_from_alg T)
      (h :  `T ∙ (U Z)  ⇒ T) :
  bracket_property_parts T f h → bracket_property T f h.
(*
  (#U f = eta_from_alg T øø (U Z) ;; h) ×
  (θ (`T ⊗ Z) ;; #H h ;; tau_from_alg T  = tau_from_alg T øø (U Z) ;;  h )
   →
    alg_map _ _ T øø (U Z) ;; h =
          identity (U Z) ⊕ θ (`T ⊗ Z) ;;
          identity (U Z) ⊕ #H h ;;
          CoproductArrow _ (CPEndC _ _ ) (#U f) (tau_from_alg T ).
*)
Proof.
  intros [Hyp1 Hyp2].
  apply nat_trans_eq; try (exact hs).
  intro c.
  apply CoproductArrow_eq_cor.
  + clear Hyp2.
    assert (Hyp1_inst := nat_trans_eq_pointwise _ _ _ _ _ _ Hyp1 c); clear Hyp1.
    rewrite <- assoc.
    apply CoproductIn1Commutes_right_in_ctx_dir.
    rewrite id_left.
    apply CoproductIn1Commutes_right_in_ctx_dir.
    rewrite id_left.
    apply CoproductIn1Commutes_right_dir.
    rewrite Hyp1_inst.
    simpl.
    apply assoc.
  + clear Hyp1.
    assert (Hyp2_inst := nat_trans_eq_pointwise _ _ _ _ _ _ Hyp2 c); clear Hyp2.
    rewrite <- assoc.
    apply CoproductIn2Commutes_right_in_ctx_dir.
    simpl.
    rewrite assoc.
    eapply pathscomp0.
    * eapply pathsinv0.
      exact Hyp2_inst.
    * clear Hyp2_inst.
      simpl.
      do 2 rewrite <- assoc.
      apply maponpaths.
      apply CoproductIn2Commutes_right_in_ctx_dir.
      simpl.
      rewrite <- assoc.
      apply maponpaths.
      apply CoproductIn2Commutes_right_dir.
      apply idpath.
Qed.

(* show bracket_parts_point is logically equivalent to bracket_point, then
   use it to show that bracket_parts is equivalent to bracket using [weqonsecfibers:
  ∀ (X : UU) (P Q : X → UU),
  (∀ x : X, P x ≃ Q x) → (∀ x : X, P x) ≃ (∀ x : X, Q x)] *)

Definition hss : UU := Σ T, bracket T.

Coercion alg_from_hss (T : hss) : algebra_ob _ Id_H := pr1 T.

Definition fbracket (T : hss) {Z : Ptd} (f : Z ⇒ ptd_from_alg T)
  : `T ∙ (U Z) ⇒ T
  := pr1 (pr1 (pr2 T Z f)).

(** The bracket operation [fbracket] is unique *)

Definition fbracket_unique_pointwise (T : hss) {Z : Ptd} (f : Z ⇒ ptd_from_alg T)
  : ∀ (α : functor_composite (U Z) `T ⟶ `T),
     (∀ c : C, pr1 (#U f) c = pr1 (eta_from_alg T) (pr1 (U Z) c) ;; α c) →
     (∀ c : C, pr1 (θ (`T ⊗ Z))  c ;; pr1 (#H α) c ;; pr1 (tau_from_alg T) c =
        pr1 (tau_from_alg T) (pr1 (U Z) c) ;; α c) → α = fbracket T f.
Proof.
  intros α H1 H2.
  apply path_to_ctr.
  apply whole_from_parts.
  split.
  - apply nat_trans_eq; try assumption.
  - apply nat_trans_eq; assumption.
Qed.

Definition fbracket_unique (T : hss) {Z : Ptd} (f : Z ⇒ ptd_from_alg T)
: ∀ α : functor_composite (U Z)(`T) ⟶ `T,
    bracket_property_parts T f α
(*
     (#U f = eta_from_alg T øø ((U Z)) ;; α) →
     (θ (`T ⊗ Z) ;; #H α ;; tau_from_alg T = tau_from_alg T øø (U Z) ;; α)
*)
   → α = fbracket T f.
Proof.
  intros α [H1 H2].
  apply path_to_ctr.
  apply whole_from_parts.
  split;  assumption.
Qed.

Definition fbracket_unique_target_pointwise (T : hss) {Z : Ptd} (f : Z ⇒ ptd_from_alg T)
: ∀ α : functor_composite (U Z)(`T) ⟶ `T,
        bracket_property_parts T f α
(*
     (#U f =  eta_from_alg T øø U Z ;; α) →
     (θ (`T ⊗ Z) ;; #H α ;; tau_from_alg T = tau_from_alg T øø U Z ;; α)
*)
   → ∀ c, α c = pr1 (fbracket T f) c.
Proof.
  intros α H12.
  set (t:= fbracket_unique _ _ α H12).
  apply (nat_trans_eq_weq _ _ hs _ _ _ _ t).
Qed.

(** Properties of [fbracket] by definition: commutative diagrams *)

Lemma fbracket_η (T : hss) : ∀ {Z : Ptd} (f : Z ⇒ ptd_from_alg T),
   #U f = eta_from_alg T øø U Z ;; fbracket T f.
Proof.
  intros Z f.
  (* assert (H' := parts_from_whole T Z f (fbracket _ f)) . *)
  exact (pr1 (parts_from_whole _ _ _ _  (pr2 (pr1 (pr2 T Z f))))).
Qed.

Lemma fbracket_τ (T : hss) : ∀ {Z : Ptd} (f : Z ⇒ ptd_from_alg T),
    θ (`T ⊗ Z) ;; #H (fbracket T f) ;; tau_from_alg T
    =
    tau_from_alg T øø U Z ;; (fbracket T f).
Proof.
  intros Z f.
  exact (pr2 (parts_from_whole _ _ _ _ (pr2 (pr1 (pr2 T Z f))))).
Qed.

(** [fbracket] is also natural *)

Lemma fbracket_natural (T : hss) {Z Z' : Ptd} (f : Z ⇒ Z') (g : Z' ⇒ ptd_from_alg T)
  : post_whisker _ _ _ _ (#U f)(`T) ;; fbracket T g = fbracket T (f ;; g).
Proof.
  apply fbracket_unique_pointwise.
  - simpl. intro c.
    rewrite assoc.
    set (H':=nat_trans_ax (eta_from_alg T)).
    simpl in H'.
    rewrite <- H'; clear H'.
    rewrite <- assoc.
    apply maponpaths.
    set (X:= nat_trans_eq_weq _ _ hs _ _ _ _  (fbracket_η T g)).
    simpl in X. exact (X _ ).
  - intro c; simpl.
    assert (H':=nat_trans_ax (tau_from_alg T)).
    simpl in H'.
    eapply pathscomp0. Focus 2. apply (!assoc _ _ _ _ _ _ _ _ ).
    eapply pathscomp0. Focus 2.  apply  cancel_postcomposition. apply H'.
    clear H'.
    set (H':=fbracket_τ T g).
    simpl in H'.
    assert (X:= nat_trans_eq_pointwise _ _  _ _ _ _ H' c).
    simpl in X.
    rewrite  <- assoc.
    rewrite  <- assoc.
    transitivity (  # (pr1 (H ((`T)))) (pr1 (pr1 f) c) ;;
                     (pr1 (θ ((`T) ⊗ Z')) c);; pr1 (# H (fbracket T g)) c;; pr1 (tau_from_alg T) c).
    Focus 2.
      rewrite <- assoc.
      rewrite <- assoc.
      apply maponpaths.
      repeat rewrite assoc.
      apply X.
    clear X.
    set (A:=θ_nat_2_pointwise).
    simpl in *.
    set (A':= A _ hs H θ (`T) Z Z').
    simpl in A'.
    set (A2:= A' f).
    clearbody A2; clear A'; clear A.
    rewrite A2; clear A2.
    repeat rewrite <- assoc.
    apply maponpaths.
    simpl.
    repeat rewrite assoc.
    apply cancel_postcomposition.
    set (A := functor_comp H).
    simpl in A.
    rewrite A.
    apply cancel_postcomposition.
    clear A. clear H'.
    set (A:=horcomp_id_postwhisker C _ _ hs hs).
    rewrite A.
    apply idpath.
Qed.

(** As a consequence of naturality, we can compute [fbracket f] from [fbracket identity] *)

Lemma compute_fbracket (T : hss) : ∀ {Z : Ptd} (f : Z ⇒ ptd_from_alg T),
  fbracket T f = post_whisker _ _ _ _ (#U f)(`T) ;; fbracket T (identity _ ).
Proof.
  intros Z f.
  assert (A : f = f ;; identity _ ).
  { rewrite id_right; apply idpath. }
  rewrite A.
  rewrite <- fbracket_natural.
  rewrite id_right.
  apply idpath.
Qed.

(** ** Morphisms of heterogeneous substitution systems *)

(** A morphism [f] of pointed functors is an algebra morphism when... *)
(*
Definition isAlgMor {T T' : Alg} (f : T ⇒ T') : UU :=
  #H (# U f) ;; τ T' = compose (C:=EndC) (τ T) (#U f).

Lemma isaprop_isAlgMor (T T' : Alg) (f : T ⇒ T') : isaprop (isAlgMor f).
Proof.
  apply isaset_nat_trans.
  apply hs.
Qed.
*)

(** a little preparation for much later *)
Lemma τ_part_of_alg_mor  (T T' : algebra_ob ([C, C] hs) Id_H)
  (β : algebra_mor ([C, C] hs) Id_H T T'): #H β ;; tau_from_alg T' = compose (C:=EndC) (tau_from_alg T) β.
Proof.
  assert (β_is_alg_mor := pr2 β).
  simpl in β_is_alg_mor.
  assert (β_is_alg_mor_inst := maponpaths (fun m:EndC⟦_,_⟧ => (CoproductIn2 EndC (CPEndC _ _));; m) β_is_alg_mor); clear β_is_alg_mor.
  simpl in β_is_alg_mor_inst.
  apply nat_trans_eq; try (exact hs).
  intro c.
  assert (β_is_alg_mor_inst':= nat_trans_eq_pointwise _ _ _ _ _ _ β_is_alg_mor_inst c); clear β_is_alg_mor_inst.
  simpl in β_is_alg_mor_inst'.
  rewrite assoc in β_is_alg_mor_inst'.
  eapply pathscomp0.
Focus 2.
  eapply pathsinv0.
  exact β_is_alg_mor_inst'.
  clear β_is_alg_mor_inst'.
  apply CoproductIn2Commutes_right_in_ctx_dir.
  simpl.
  rewrite <- assoc.
  apply idpath.
Qed.

(** A morphism [β] of pointed functors is a bracket morphism when... *)

Lemma is_ptd_mor_alg_mor (T T' : algebra_ob ([C, C] hs) Id_H)
  (β : algebra_mor ([C, C] hs) Id_H T T') :
  @is_ptd_mor C (ptd_from_alg T) (ptd_from_alg T') (pr1 β).
Proof.
  simpl.
  unfold is_ptd_mor. simpl.
  intro c.
  rewrite <- assoc.
  assert (X:=pr2 β).
  assert (X':= nat_trans_eq_pointwise _ _ _ _ _ _ X c).
  simpl in *.
  eapply pathscomp0. apply maponpaths. apply X'.
  unfold coproduct_nat_trans_in1_data.
  repeat rewrite assoc.
  unfold coproduct_nat_trans_data.
  eapply pathscomp0.
  apply cancel_postcomposition.
  apply CoproductIn1Commutes.
  simpl.
  repeat rewrite <- assoc.
  apply id_left.
Qed.

Definition ptd_from_alg_mor {T T' : algebra_ob _ Id_H} (β : algebra_mor _ _ T T')
: ptd_from_alg T ⇒ ptd_from_alg T'.
Proof.
  exists (pr1 β).
  apply is_ptd_mor_alg_mor.
Defined.

(* show functor laws for [ptd_from_alg] and [ptd_from_alg_mor] *)

Definition ptd_from_alg_functor_data : functor_data (precategory_FunctorAlg _ Id_H hsEndC) Ptd.
Proof.
  exists ptd_from_alg.
  intros T T' β.
  apply ptd_from_alg_mor.
  exact β.
Defined.

Lemma is_functor_ptd_from_alg_functor_data : is_functor ptd_from_alg_functor_data.
Proof.
  split; simpl; intros.
  + unfold functor_idax.
    intro T.
    (* match goal with | [ |- ?l = _ ] => let ty:= (type of l) in idtac ty end. *)
    apply (invmap (eq_ptd_mor_precat _ hs _ _)).
    apply (invmap (eq_ptd_mor _ hs _ _)).
    (* match goal with | [ |- ?l = _ ] => let ty:= (type of l) in idtac ty end. *)
    apply idpath.
  + unfold functor_compax.
    intros T T' T'' β β'.
    apply (invmap (eq_ptd_mor_precat _ hs _ _)).
    apply (invmap (eq_ptd_mor _ hs _ _)).
    apply idpath.
Qed.

Definition ptd_from_alg_functor: functor (precategory_FunctorAlg _ Id_H hsEndC) Ptd :=
  tpair _ _ is_functor_ptd_from_alg_functor_data.

Definition isbracketMor {T T' : hss} (β : algebra_mor _ _ T T') : UU :=
    ∀ (Z : Ptd) (f : Z ⇒ ptd_from_alg T),
       fbracket _ f ;;  β
       =
       (β)øø (U Z) ;; fbracket _ (f ;; # ptd_from_alg_functor β ).

Lemma isaprop_isbracketMor (T T':hss) (β : algebra_mor _ _ T T') : isaprop (isbracketMor β).
Proof.
  do 2 (apply impred; intro).
  apply isaset_nat_trans.
  apply hs.
Qed.

(** A morphism of hss is a pointed morphism that is compatible with both
    [τ] and [fbracket] *)

Definition ishssMor {T T' : hss} (β : algebra_mor _ _ T T') : UU
  :=   isbracketMor β.

Definition hssMor (T T' : hss) : UU
  := Σ β : algebra_mor _ _ T T', ishssMor β.

Coercion ptd_mor_from_hssMor (T T' : hss) (β : hssMor T T') : algebra_mor _ _ T T' := pr1 β.

(*
Definition isAlgMor_hssMor {T T' : hss} (β : hssMor T T')
  : isAlgMor β := pr1 (pr2 β).
*)
Definition isbracketMor_hssMor {T T' : hss} (β : hssMor T T')
  : isbracketMor β := pr2 β.

(** **** Equality of morphisms of hss *)

Section hssMor_equality.

(** Show that equality of hssMor is equality of underlying nat. transformations *)

Variables T T' : hss.
Variables β β' : hssMor T T'.
Definition hssMor_eq1 : β = β' ≃ (pr1 β = pr1 β').
Proof.
  apply total2_paths_isaprop_equiv.
  intro γ.
  apply isaprop_isbracketMor.
Defined.

Definition hssMor_eq : β = β' ≃ (β : EndC ⟦ _ , _ ⟧) = β'.
Proof.
  eapply weqcomp.
  - apply hssMor_eq1.
  - apply total2_paths_isaprop_equiv.
    intro.
    apply isaset_nat_trans.
    apply hs.
Defined.

End hssMor_equality.

Lemma isaset_hssMor (T T' : hss) : isaset (hssMor T T').
Proof.
  intros β β'.
  apply (isofhlevelweqb _ (hssMor_eq _ _ β β')).
  apply isaset_nat_trans.
  apply hs.
Qed.

(** ** The precategory of hss *)

(** *** Identity morphism of hss *)

Lemma ishssMor_id (T : hss) : ishssMor (identity (C:=precategory_FunctorAlg _ _ hsEndC ) (pr1 T)).
Proof.
  unfold ishssMor.
  unfold isbracketMor.
  intros Z f.
  rewrite id_right.
  rewrite functor_id.
  rewrite id_right.
  apply pathsinv0.
  set (H2:=pre_composition_functor _ _ C _ hs (U Z)).
  set (H2' := functor_id H2). simpl in H2'.
  simpl.
  rewrite H2'.
  rewrite (id_left EndC).
  apply idpath.
Qed.

Definition hssMor_id (T : hss) : hssMor _ _ := tpair _ _ (ishssMor_id T).

(** *** Composition of morphisms of hss *)

Lemma ishssMor_comp {T T' T'' : hss} (β : hssMor T T') (γ : hssMor T' T'')
  : ishssMor (compose (C:=precategory_FunctorAlg _ _ hsEndC) (pr1 β)  (pr1 γ)).
Proof.
  unfold ishssMor.
  unfold isbracketMor.
  intros Z f.
  eapply pathscomp0.
    apply assoc.
  (* match goal with | [|- ?l = _ ] => assert (Hyp : l = fbracket T f;; pr1 β;; pr1 γ) end. *)
  eapply pathscomp0.
    apply cancel_postcomposition.
    apply isbracketMor_hssMor.
  rewrite <- assoc.
  eapply pathscomp0.
    apply maponpaths.
    apply isbracketMor_hssMor.
  rewrite assoc.
  rewrite functor_comp.
  rewrite assoc.
  apply cancel_postcomposition.
  set (H2:=functor_comp (pre_composition_functor _ _ C _ hs (U Z)) ).
  apply pathsinv0.
  apply H2.
Qed.

Definition hssMor_comp {T T' T'' : hss} (β : hssMor T T') (γ : hssMor T' T'')
  : hssMor T T'' := tpair _ _ (ishssMor_comp β γ).

Definition hss_obmor : precategory_ob_mor.
Proof.
  exists hss.
  exact hssMor.
Defined.

Definition hss_precategory_data : precategory_data.
Proof.
  exists hss_obmor.
  split.
  - exact hssMor_id.
  - exact @hssMor_comp.
Defined.

Lemma is_precategory_hss : is_precategory hss_precategory_data.
Proof.
  repeat split; intros.
  - apply (invmap (hssMor_eq _ _ _ _ )).
    apply (id_left EndC).
  - apply (invmap (hssMor_eq _ _ _ _ )).
    apply (id_right EndC).
  - apply (invmap (hssMor_eq _ _ _ _ )).
    apply (assoc EndC).
Qed.

Definition hss_precategory : precategory := tpair _ _ is_precategory_hss.

End def_hss.

Arguments hss {_ _} _  _ .
Arguments hssMor {_ _ _ _ } _ _ .
Arguments fbracket {_ _ _ _ } _ {_} _ .
Arguments fbracket_η {_ _ _ _ } _ {_} _ .
Arguments fbracket_τ {_ _ _ _} _ {_} _ .
Arguments fbracket_unique_target_pointwise {_ _ _ _ } _ {_ _ _} _ _  .
Arguments fbracket_unique {_ _ _ _ } _ {_} _ _ _  .
(* Arguments Alg {_ _} _. *)
Arguments hss_precategory {_ _} _ _ .


Require Import base.
Require Import z_theory_base.
Require Import z_theory_bool.
Require Import z_theory_N.
Require Import Classical.
Require Import Ltac.
Require Import Logic.
Require Import Specif.
Require Import Coq.Init.Tactics.

Section ZNums.
Definition Zset :=
	E{ p in cartesian Nnat Nnat | exists a b : _, (E(a, b) =E p) /\ ((a =E N O) \/ (b =E N O)) }.
Lemma Zminimize (v : Ensemble) (vin : v inE cartesian Nnat Nnat) :
	let (tmpm, tmp) := cartesian_is_product _ _ _ vin in
	let (tmpn, tmp2) := tmp in
	let (tmp3, veq) := tmp2 in
	let (minN, ninN) := tmp3 in
	let (m, _) := minN in
	let (n, _) := ninN in
	Eexists z in Zset, exists a b : _, (E(N a, N b) =E z) /\ (addN m b = addN n a).
	specialize (cartesian_is_product _ _ _ vin) as [m [n [[minN ninN] veq]]].
	unfold In, cartesian, separation_cons, Nnat, power_set_cons, pair_union_cons, pairing_cons, ens_union_cons in vin.
	Unset Printing Notations.
	destruct vin as [l r].
Definition Zadd l r :=

End ZNums.


Require Import Stlc.SpecTyping.
Require Import Stlc.SpecEquivalent.
Require Import Stlc.LemmasEvaluation.
Require Import Utlc.SpecEquivalent.
Require Import Utlc.LemmasEvaluation.

Require Import Compiler.Erase.
Require Import Compiler.ProtectConfine.

Require Import LogRel.PseudoType.
Require Import LogRel.LemmasPseudoType.
Require Import LogRel.LR.
Require Import LogRel.LemmasLR.

Require Import Omega.

Definition compile (τ : S.Ty) (t : S.Tm) : U.UTm :=
  U.app (protect τ) (erase t).

Definition compile_pctx (τ : S.Ty) (C : S.PCtx) : U.PCtx :=
  U.pctx_cat (U.papp₂ (confine τ) U.phole) (erase_pctx C).

Lemma equivalenceReflection {t₁ t₂ τ} :
  ⟪ S.empty ⊢ t₁ : τ ⟫ →
  ⟪ S.empty ⊢ t₂ : τ ⟫ →
  ⟨ 0 ⊢ compile τ t₁ ≃ compile τ t₂ ⟩ →
  ⟪ S.empty ⊢ t₁ ≃ t₂ : τ ⟫.
Proof.
  revert t₁ t₂ τ.
  enough (∀ {t₁ t₂} τ,
            ⟪ S.empty ⊢ t₁ : τ ⟫ →
            ⟪ S.empty ⊢ t₂ : τ ⟫ →
            ⟨ 0 ⊢ compile τ t₁ ≃ compile τ t₂ ⟩ →
            ∀ C τ', ⟪ ⊢ C : S.empty , τ → S.empty, τ' ⟫ →
                    S.Terminating (S.pctx_app t₁ C) → S.Terminating (S.pctx_app t₂ C)) as Hltor
      by (intros t₁ t₂ τ ty1 ty2 eq C τ';
          assert (⟨ 0 ⊢ compile τ t₂ ≃ compile τ t₁ ⟩)
            by (apply U.pctx_equiv_symm; assumption);
          split;
          refine (Hltor _ _ τ _ _ _ C τ' _); assumption).

  intros t₁ t₂ τ ty1 ty2 eq C τ' tyC term.

  destruct (S.Terminating_TerminatingN term) as [n termN]; clear term.

  assert (⟪ pempty ⊩ t₁ ⟦ dir_lt , S n ⟧ compile τ t₁ : embed τ ⟫) as lrt₁ by
      (unfold compile;
       apply protect_transp_open;
       exact (erase_correct ty1)).
  assert (⟪ ⊩ C ⟦ dir_lt , S n ⟧ erase_pctx C : pempty , embed τ → pempty , embed τ' ⟫) as lrC_lt
    by (apply (erase_ctx_correct tyC)).
  apply lrC_lt in lrt₁.

  assert (U.Terminating (U.pctx_app (compile τ t₁) (erase_pctx C)))
    as termu₁ by (apply (adequacy_lt lrt₁ termN); omega).

  assert (U.Terminating (U.pctx_app (compile τ t₂) (erase_pctx C)))
    by (apply eq; try assumption;
        apply (erase_pctx_scope C _ _ _ _ tyC)).

  destruct (U.Terminating_TerminatingN H) as [n' termN']; clear H.

  assert (⟪ ⊩ C ⟦ dir_gt , S n' ⟧ erase_pctx C : pempty , embed τ → pempty , embed τ' ⟫) as lrC_gt
    by (apply (erase_ctx_correct tyC)).
  assert (⟪ pempty ⊩ t₂ ⟦ dir_gt , S n' ⟧ compile τ t₂ : embed τ ⟫) as lrt₂ by
      (unfold compile;
       apply protect_transp_open;
       exact (erase_correct ty2)).
  apply lrC_gt in lrt₂.

  apply (adequacy_gt lrt₂ termN'); omega.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B D T Bprimeprime : Universe, ((wd_ A B /\ (wd_ A D /\ (wd_ A T /\ (wd_ B D /\ (wd_ B T /\ (wd_ D T /\ (wd_ Bprimeprime T /\ (wd_ D Bprimeprime /\ (wd_ B Bprimeprime /\ (col_ Bprimeprime B D /\ (col_ B Bprimeprime T /\ col_ T D A))))))))))) -> col_ A B T)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


Require Import String.
Require Import Names.
Require Import PNames.
Require Import Bool.
Require Import Lambda.
Require Import Bool_Lambda.
Require Import Functors.
(* Require Import MonadLib. *)

Open Scope string_scope.

Section Type_Test_Section.
  (* Type Testing, of course. *)
  Definition D := BType :+: LType.

End Type_Test_Section.

Section Test_Section.

  Definition E (A : Set) := Bool :+: (Lambda D A).

  Global Instance Fun_E : forall (A : Set),
    Functor (E A).
  Proof.
    eauto with typeclass_instances.
  Defined.

  Instance D_typeof T : FAlgebra TypeofName T (typeofR D) (E (typeofR D)).
    eauto 150 with typeclass_instances.
  Defined.

  Definition V := StuckValue :+: BotValue :+: (ClosValue E) :+: BoolValue.

  Instance V_eval : FAlgebra EvalName (Exp E nat) (evalR V) (E nat).
    eauto 150 with typeclass_instances.
  Defined.

  Definition SV := (SubValue_refl V) ::+:: (SubValue_Bot V) ::+:: (SubValue_Clos E V).

   Definition EV_Alg : PAlgebra EC_ExpName (sig (UP'_P (eval_continuous_Exp_P V (E _) SV))) (E nat).
    eauto 150 with typeclass_instances.
   Defined.

  Definition eval_continuous : forall m,
    forall (e : Exp E nat) (gamma gamma' : Env _),
      forall n (Sub_G_G' : Sub_Environment V SV gamma gamma'),
        m <= n ->
        SubValueC _ SV (beval _ _ m e gamma) (beval _ _ n e gamma').
    eapply beval_continuous with (eval_continuous_Exp_E := EV_Alg);
      eauto 150 with typeclass_instances.
  Qed.

  Eval compute in ("Continuity of Evaluation Proven!").

  Definition Eqv (A B : Set) := (NP_Functor_eqv E Bool A B) ::+:: (Lambda_eqv D E A B).
  Definition WFV := (WFValue_Clos D E V Eqv ((fun e => typeof _ _ (proj1_sig e)))) ::+::
    (WFValue_Bot D V) ::+:: (WFValue_VB D V).

  Instance eq_DType_eq_alg : (PAlgebra eq_DType_eqName (sig (UP'_P (eq_DType_eq_P D))) D).
    eauto 250 with typeclass_instances.
  Defined.

  Global Instance Bool_Soundness_alg P_bind P pb typeof_rec eval_rec :
    PAlgebra eval_Soundness_alg_Name
    (sig (UP'_P2 (eval_alg_Soundness_P D V (E nat) WFV P_bind P
      (E (typeofR D)) (Functor_Plus Bool (Lambda D (typeofR D))) pb typeof_rec eval_rec
      f_algebra f_algebra))) Bool.
  Proof.
    eauto 100 with typeclass_instances.
  Defined.

  Theorem soundness : forall n gamma gamma' gamma'' e' e'',
    E_eqvC _ Eqv gamma gamma' e' e'' ->
    forall (WF_gamma : forall n b, lookup gamma' n = Some b ->
      exists T, lookup gamma b = Some T)
    (WF_gamma2 : List.length gamma = List.length gamma')
    (WF_gamma' : forall n b, lookup gamma' n = Some b -> b = n)
    (WF_gamma'' : WF_Environment _ _ WFV gamma'' gamma) T,
    typeof D (E _) (proj1_sig e') = Some T -> WFValueC _ _ WFV (beval _ _ n e'' gamma'') T.
  Proof.
    apply soundness_X with (eval_continuous_Exp_E := EV_Alg);
      eauto 350 with typeclass_instances.
  Qed.

  Eval compute in ("Type Soundness for Lambda :+: Boolean Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import list_examples.

Require Import ZArith.
Require Import List.

Definition head_code :=
  SReturn (ELoad (EVar "x")).

Lemma head_spec : forall c, kcell c = kra (KStmt head_code) kdot ->
    forall xv,
      store c ~= ("x" s|-> KInt xv) ->
    forall hd tl m,
      heap c |= rep_list (hd :: tl) xv :* litP m
     -> sound kstep (returns c hd).
Proof.
list_solver.
Qed.


Require Export himp_cfg_and_prims.
Require Import equate_map_reflection.
Require Import patterns.

Require Import himp_claims.

Require Import Setoid.
Require Import ZArith.

Fixpoint stk_equiv (s1 s2 : list Frame) : Prop :=
  match s1, s2 with
    | nil, nil => True
    | frame k1 e1::s1', frame k2 e2::s2' =>
      k1 = k2 /\ e1 ~= e2 /\ stk_equiv s1' s2'
    | _, _ => False
  end.

Definition kequiv (k1 k2 : kcfg) : Prop :=
  match k1, k2 with
    | KCfg k1 store1 stk1 heap1 funs1 mark1,
      KCfg k2 store2 stk2 heap2 funs2 mark2 =>
      k1 = k2 /\ store1 ~= store2 /\ stk_equiv stk1 stk2
      /\ heap1 ~= heap2 /\ funs1 ~= funs2 /\ mark1 = mark2
  end.

Add Morphism KCfg with signature
  @eq k ==> MapEquiv ==> stk_equiv ==> MapEquiv ==> MapEquiv ==> @eq Z ==> kequiv as KCfg_mor.
Proof. firstorder. Qed.

(** A predicate saying two stacks are equivalent,
    requires exact equality of the code but compares
    environments up to map equality *)

Definition returning' c e c' : Prop :=
     match c' with
       | KCfg (kra (KStmt (SReturn e')) _) _ stack' heap' functions' _ =>
         match c with
           | KCfg kcell _ stack heap functions alloc_mark =>
               e = e'
               /\ stk_equiv stack stack'
               /\ heap ~= heap'
               /\ functions ~= functions'
         end
       | _ => False
     end.

Lemma returning_returns : forall c e c', returning' c e c' ->
  exists krest,
  kcell c' = kra (KStmt (SReturn e)) krest.
Proof.
destruct c'.
simpl;intro H.
repeat match type of H with
| (match ?x with _ => _ end) => destruct x;try solve[destruct H];[idtac]
end.
intuition.
exists kcell.
congruence.
Qed.

Definition returning c v := returning' c (ECon v).
Inductive returns (c : kcfg) (v : Z) : kcfg -> (kcfg -> Prop) -> Prop :=
  returns_claim : returns c v c (returning c v).

Definition returning_bool c b := returning' c (BCon b).
Inductive returns_bool (c : kcfg) (v : bool) : kcfg -> (kcfg -> Prop) -> Prop :=
  returns_bool_claim : returns_bool c v c (returning_bool c v).

Definition get_returning (c : kcfg) : option Z :=
  match kcell c with
    | kra (KStmt (SReturn (ECon v'))) _ => Some v'
    | _ => None
  end.
Lemma get_returning_returns : forall c,
  match get_returning c with
    | Some v => exists krest, kcell c = kra (KStmt (SReturn (ECon v))) krest
    | None => True
  end.
Proof.
destruct c.
unfold get_returning. simpl.
repeat match goal with
| [|- match (match ?x with _ => _ end) with _ => _ end]
   => destruct x;try (exact I)
end.
eexists.
reflexivity.
Qed.

Lemma use_returning : forall ckcell cstore cstk cheap cfunctions cmark
     e (Q : kcfg -> (kcfg -> Prop) -> Prop) (P : kcfg -> Prop),
  (forall kstore kheap kfunctions kmark,
    cheap ~= kheap ->
    cfunctions ~= kfunctions ->
   forall kstk,
    stk_equiv cstk kstk ->
   forall krest,
    Q (KCfg (kra (KStmt (SReturn e)) krest)
            kstore kstk kheap kfunctions kmark) P
   ) ->
  (forall k', returning'
     (KCfg ckcell cstore cstk cheap cfunctions cmark)
    e k' -> Q k' P).
intros.
pose proof (returning_returns _ _ _ H0).
destruct H1.
destruct k';simpl in * |- *;subst.
intuition.
Qed.

Lemma expose_frame : forall p m stk (Q : list Frame -> Prop),
  (forall m' stk',
     m' ~= m -> stk_equiv stk stk' -> Q (frame p m'::stk')) ->
  (forall stk',
     stk_equiv (frame p m::stk) stk' -> Q stk').
intros.
destruct stk';[solve[destruct H0]|].
destruct f.
simpl in H0.
intuition. subst.
symmetry in H0.
auto.
Qed.

(* Somehow simple "apply" doesn't unify well enough *)
Ltac use_expose_frame := refine (expose_frame _ _ _ _ _).


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Functor.
Require Import Blech.Category.Over.
Require Import Blech.Category.Bsh.

Require Blech.Reflect.

Import CategoryNotations.
Import FunctorNotations.
Import BishopNotations.
Import OverNotations.

Open Scope category_scope.
Open Scope object_scope.
Open Scope bishop_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

#[local]
Definition pullback {A B C: Bsh} (f: Bsh A C) (g: Bsh B C) :=
  { '(x, y) | proj1_sig f x == proj1_sig g y }.

#[program]
Instance pullback_Setoid {A B C: Bsh} (f: Bsh A C) (g: Bsh B C): Setoid (pullback f g) := {
  equiv x y := fst (proj1_sig x) == fst (proj1_sig y) ∧ snd (proj1_sig x) == snd (proj1_sig y) ;
}.

Next Obligation.
Proof.
  exists.
  - intros [[? ?] p].
    cbn in *.
    split.
    all: reflexivity.
  - intros [[? ?] p] [[? ?] q] [r l].
    cbn in *.
    rewrite r, l.
    split.
    all: reflexivity.
  - intros [[? ?] ?] [[? ?] ?] [[? ?] ?] [p q] [r s].
    cbn in *.
    rewrite p, q, r, s.
    split.
    all: reflexivity.
Qed.

#[program]
Definition Basechange {A B: Bsh} (f: Bsh A B): Functor (Bsh/B) (Bsh/A) := {|
  op (u: Bsh/B) := lub (pullback f (π u) /~ pullback_Setoid f (π u)), λ x, fst (proj1_sig x) ;
  map '(lub _, _) '(lub _, _) f '(x, y) := (x, f y) ;
|}.

Next Obligation.
Proof.
  intros ? ? [p q].
  auto.
Qed.

Next Obligation.
Proof.
  rewrite (H _).
  cbn in *.
  destruct pat.
  cbn in *.
  destruct x0.
  cbn in *.
  inversion Heq_anonymous.
  subst.
  apply e.
Qed.

Next Obligation.
Proof.
  intros ? ? [p q].
  cbn.
  rewrite p, q.
  split.
  all: reflexivity.
Qed.

Next Obligation.
Proof.
  exists.
  all: cbn.
  - intros.
    split.
    all: reflexivity.
  - intros.
    split.
    all: reflexivity.
  - intros ? ? [? ?] [? ?] r [[? ?] ?].
    cbn in *.
    split.
    1: reflexivity.
    apply r.
Qed.


Set Implicit Arguments.
Unset Strict Implicit.

Module Type SIG.
  Parameter id : forall A : Set, A -> A.
End SIG.

Module M (X: SIG).
  Definition idid := X.id X.id.
  Definition id := idid X.id.
End M.

Module N := M.

Module Nat.
  Definition T := nat.
  Definition x := 0.
  Definition id (A : Set) (x : A) := x.
End Nat.

Module Z := N Nat.

Check (Z.idid 0).

Module P (Y: SIG) := N.

Module Y := P Nat Z.

Check (Y.id 0).


Require Import Coq.Logic.Classical.
Require Import Coq.Lists.List.
Require Import Coq.Sets.Ensembles.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import VST.floyd.sublist.
Require Import compcert.lib.Integers.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.Ensembles_ext.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.Relation_ext.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.weak_mark_lemmas.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.graph_gen.
Require Import CertiGraph.graph.graph_relation.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.reachable_computable.
Require Export CertiGraph.graph.FiniteGraph.
Require Export CertiGraph.graph.MathGraph.
Require Export CertiGraph.graph.LstGraph.
Require Export CertiGraph.msl_application.UnionFindGraph.

Local Open Scope logic.
Local Open Scope Z_scope.

Instance Z_EqDec : EqDec Z eq. Proof. hnf. intros. apply Z.eq_dec. Defined.

Definition is_null_Z: DecidablePred Z := existT (fun P : Z -> Prop => forall a : Z, {P a} + {~ P a}) (fun x : Z => x < 0) (fun a : Z => Z_lt_dec a 0).

Definition UFGraph := (@UFGraph Z Z _ _ is_null_Z id nat unit unit).
Definition LGraph := (@LGraph Z Z _ _ nat unit unit).
Definition UFGraph_LGraph (G: UFGraph): LGraph := lg_gg G.

Local Coercion UFGraph_LGraph: UFGraph >-> LGraph.
Local Identity Coercion ULGraph_LGraph: LGraph >-> UnionFindGraph.LGraph.
Local Identity Coercion LGraph_LabeledGraph: UnionFindGraph.LGraph >-> LabeledGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Instance maGraph(G: UFGraph): MathGraph G is_null_Z := maGraph G.
Instance finGraph (G: UFGraph): FiniteGraph G := finGraph G.
Instance liGraph (G: UFGraph):  LstGraph G id := liGraph G.

Definition vgamma := (@vgamma Z Z _ _ is_null_Z id nat unit unit).
Definition Graph_gen_redirect_parent (g: UFGraph) (x: Z) (pa: Z) (H: weak_valid g pa) (Hv: vvalid g x) (Hn: ~ reachable g pa x): UFGraph :=
    Graph_gen_redirect_parent g x pa H Hv Hn.

Class SpatialArrayGraphAssum (Pred : Type):=
  {
    SGP_ND: NatDed Pred;
    SGP_SL : SepLog Pred;
    SGP_ClSL: ClassicalSep Pred;
    SGP_CoSL: CorableSepLog Pred
  }.

Fixpoint makeSet_discrete_PreGraph (size: nat) : PreGraph Z Z :=
  match size with
  | O => Build_PreGraph Z_EqDec Z_EqDec (fun _ => False) (fun _ => False) (fun _ => -1) (fun _ => -1)
  | S n => pregraph_add_edge (pregraph_add_vertex (makeSet_discrete_PreGraph n) (Z.of_nat n)) (Z.of_nat n) (Z.of_nat n) (-1)
  end.

Lemma makeSet_vvalid: forall size x, vvalid (makeSet_discrete_PreGraph size) x <-> 0 <= x < Z.of_nat size.
Proof.
  induction size; simpl; intros; split; intros.
  - exfalso; auto.
  - destruct H. intuition.
  - unfold addValidFunc in H. rewrite Zpos_P_of_succ_nat, <- Z.add_1_r. destruct H; [rewrite IHsize in H|]; intuition.
  - unfold addValidFunc. rewrite Zpos_P_of_succ_nat, <- Z.add_1_r in H. rewrite IHsize. lia.
Qed.

Lemma makeSet_evalid: forall size e, evalid (makeSet_discrete_PreGraph size) e <-> 0 <= e < Z.of_nat size.
Proof.
  induction size; simpl; intros; split; intros.
  - exfalso. auto.
  - destruct H; intuition.
  - unfold addValidFunc in H. rewrite Zpos_P_of_succ_nat, <- Z.add_1_r. destruct H; [apply IHsize in H | subst e]; intuition.
  - unfold addValidFunc. rewrite Zpos_P_of_succ_nat, <- Z.add_1_r in H. rewrite IHsize. lia.
Qed.

Lemma makeSet_evalid_src: forall size e, evalid (makeSet_discrete_PreGraph size) e -> src (makeSet_discrete_PreGraph size) e = e.
Proof.
  induction size; simpl; intros.
  - exfalso; auto.
  - unfold addValidFunc in H. unfold updateEdgeFunc. destruct (equiv_dec (Z.of_nat size) e).
    + unfold Equivalence.equiv in e0. auto.
    + unfold Equivalence.equiv in c. unfold complement in c. destruct H. 1: apply IHsize; auto. exfalso; intuition.
Qed.

Lemma makeSet_dst: forall size e, dst (makeSet_discrete_PreGraph size) e = -1.
Proof. induction size; simpl; intros; auto. unfold updateEdgeFunc. destruct (equiv_dec (Z.of_nat size) e); auto. Qed.

Definition makeSet_discrete_MathGraph (size: nat) : MathGraph (makeSet_discrete_PreGraph size) is_null_Z.
Proof.
  constructor; intros; [split|].
  - rewrite (makeSet_evalid_src _ _ H). rewrite makeSet_evalid in H. rewrite makeSet_vvalid. auto.
  - left. rewrite makeSet_dst. hnf. rewrite Z.compare_lt_iff. intuition.
  - rewrite makeSet_vvalid in H. hnf in H0. rewrite Z.compare_lt_iff in H0. intuition.
Qed.

Definition makeSet_discrete_LstGraph (size: nat) : LstGraph (makeSet_discrete_PreGraph size) id.
Proof.
  constructor; intros.
  - unfold id. split; intros.
    + destruct H0. apply makeSet_evalid_src in H1. intuition.
    + subst e. split.
      * rewrite makeSet_vvalid, <- makeSet_evalid in H. apply makeSet_evalid_src; auto.
      * rewrite makeSet_vvalid in H. rewrite makeSet_evalid. auto.
  - destruct p as [v p]. destruct H as [[? ?] [? ?]]. simpl in H. subst v. clear H2. destruct p; auto. simpl in H1. destruct H1.
    assert (strong_evalid (makeSet_discrete_PreGraph size) z) by (destruct p; [|destruct H1]; auto). clear H1. destruct H2 as [_ [_ ?]].
    rewrite makeSet_dst in H1. rewrite makeSet_vvalid in H1. exfalso; intuition.
Qed.

Fixpoint makeSet_discrete_list (size: nat) :=
  match size with
  | O => nil
  | S n => Z.of_nat n :: makeSet_discrete_list n
  end.

Lemma makeSet_discrete_list_iff: forall size x, List.In x (makeSet_discrete_list size) <-> 0 <= x < Z.of_nat size.
Proof.
  induction size; intros; simpl; split; intros.
  - exfalso; auto.
  - destruct H; intuition.
  - rewrite Zpos_P_of_succ_nat, <- Z.add_1_r. rewrite IHsize in H. intuition.
  - rewrite Zpos_P_of_succ_nat, <- Z.add_1_r in H. rewrite IHsize. lia.
Qed.

Lemma makeSet_discrete_list_NoDup: forall size, NoDup (makeSet_discrete_list size).
Proof. induction size; simpl; constructor; auto; intro. rewrite makeSet_discrete_list_iff in H. intuition. Qed.

Definition makeSet_discrete_FiniteGraph (size: nat) : FiniteGraph (makeSet_discrete_PreGraph size).
Proof.
  constructor; unfold EnumEnsembles.Enumerable, In; exists (makeSet_discrete_list size); split; intros.
  - apply makeSet_discrete_list_NoDup.
  - rewrite makeSet_discrete_list_iff, makeSet_vvalid. intuition.
  - apply makeSet_discrete_list_NoDup.
  - rewrite makeSet_discrete_list_iff, makeSet_evalid. intuition.
Qed.

Definition makeSet_discrete_sound (size: nat) : @LiMaFin _ _ _ _ is_null_Z id (makeSet_discrete_PreGraph size).
Proof. constructor. exact (makeSet_discrete_LstGraph size). exact (makeSet_discrete_MathGraph size). exact (makeSet_discrete_FiniteGraph size). Qed.

Definition makeSet_discrete_LabeledGraph (size: nat) : LGraph := Build_LabeledGraph _ _ _ (makeSet_discrete_PreGraph size) (fun _ => O) (fun _ => tt) tt.

Definition makeSet_discrete_Graph (size: nat) : UFGraph := Build_GeneralGraph _ _ _ _ (makeSet_discrete_LabeledGraph size) (makeSet_discrete_sound size).

Corollary makeSet_discrete_Graph_dst:
  forall size e, dst (makeSet_discrete_Graph size) e = -1.
Proof.
apply makeSet_dst.
Qed.

Class SpatialArrayGraph (Addr: Type) (Pred: Type) := vcell_array_at: Addr -> list (nat * Z) -> Pred.

Existing Instances SGP_ND SGP_SL SGP_ClSL SGP_CoSL.

Section SpaceArrayGraph.

  Context {Pred: Type}.

  Context {SAGP: SpatialArrayGraphAssum Pred}.

  Context {Addr: Type}.

  Context {SAG: SpatialArrayGraph Addr Pred}.

  Definition graph_vcell_at (g: UFGraph) (P: Z -> Prop) (x: Addr) :=
    EX l: list Z, !!(forall v, List.In v l <-> P v) && !! NoDup l && vcell_array_at x (map (fun x => vgamma (lg_gg g) x) l).

  Definition full_graph_at (g: UFGraph) (x: Addr) :=
    EX n: nat, !!(forall v, 0 <= v < Z.of_nat n <-> vvalid (pg_lg (lg_gg g)) v) && !!(Z.of_nat n <= Int.max_signed / 8) && vcell_array_at x (map (fun x => vgamma (lg_gg g) x) (nat_inc_list n)).

End SpaceArrayGraph.