(** Studies the actegory stemming from the self action of the endofunctors on [C] by precomposition

author: Ralph Matthes, 2023
 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.BicatOfCatsElementary.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Examples.EndofunctorsMonoidalElementary.
Require Import UniMath.CategoryTheory.Actegories.Examples.ActionOfEndomorphismsInCATElementary.
Require Import UniMath.CategoryTheory.Actegories.Actegories.
Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories.
Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories.

Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.Actegories.CoproductsInActegories.

Local Open Scope cat.

Section FixACategory.

Context (C : category).

Local Definition Mon_endo : monoidal [C, C] := monendocat_monoidal C.

Definition SelfActCAT : actegory Mon_endo [C, C] := actegory_with_canonical_self_action Mon_endo.

End FixACategory.

Section LineatorForPostcomposition.

  Context (C : category) (G : functor C C).

  Definition lax_lineator_postcomp_SelfActCAT_data :
    lineator_data (Mon_endo C) (SelfActCAT C) (SelfActCAT C) (post_comp_functor G).
  Proof.
    intros F K. cbn.
    apply rassociator_CAT.
  Defined.

  Lemma lax_lineator_postcomp_SelfActCAT_laws :
    lineator_laxlaws (Mon_endo C) (SelfActCAT C) (SelfActCAT C) (post_comp_functor G)
      lax_lineator_postcomp_SelfActCAT_data.
  Proof.
    split4.
    - intro; intros.
      apply (nat_trans_eq C).
      intro c.
      cbn.
      rewrite id_left; apply id_right.
    - intro; intros.
      apply (nat_trans_eq C).
      intro c.
      cbn.
      rewrite id_left; apply id_right.
    - intro; intros.
      apply (nat_trans_eq C).
      intro c.
      cbn.
      do 3 rewrite id_left.
      apply functor_id.
    - intro; intros.
      apply (nat_trans_eq C).
      intro c.
      cbn.
      rewrite id_left.
      apply functor_id.
  Qed.

  (** the following definition may not be usable because of its tight typing *)
  Definition lax_lineator_postcomp_SelfActCAT :
    lineator_lax (Mon_endo C) (SelfActCAT C) (SelfActCAT C) (post_comp_functor G) :=
    _,,lax_lineator_postcomp_SelfActCAT_laws.

End LineatorForPostcomposition.

Section LineatorForPostcomposition_alt.

  Context (C D : category) (G : functor D C).

  Definition lax_lineator_postcomp_SelfActCAT_alt_data :
    lineator_data (Mon_endo C) (actegory_from_precomp_CAT C D) (SelfActCAT C) (post_comp_functor G).
  Proof.
    intros F K. cbn.
    apply rassociator_CAT.
  Defined.

  Lemma lax_lineator_postcomp_SelfActCAT_alt_laws :
    lineator_laxlaws (Mon_endo C) (actegory_from_precomp_CAT C D) (SelfActCAT C) (post_comp_functor G)
      lax_lineator_postcomp_SelfActCAT_alt_data.
  Proof.
    split4.
    - intro; intros.
      apply (nat_trans_eq C).
      intro c.
      cbn.
      rewrite id_left; apply id_right.
    - intro; intros.
      apply (nat_trans_eq C).
      intro c.
      cbn.
      rewrite id_left; apply id_right.
    - intro; intros.
      apply (nat_trans_eq C).
      intro c.
      cbn.
      do 3 rewrite id_left.
      apply functor_id.
    - intro; intros.
      apply (nat_trans_eq C).
      intro c.
      cbn.
      rewrite id_left.
      apply functor_id.
  Qed.

  (** the following definition is peculiar since it relates different constructions of actegories *)
  Definition lax_lineator_postcomp_SelfActCAT_alt :
    lineator_lax (Mon_endo C) (actegory_from_precomp_CAT C D) (SelfActCAT C) (post_comp_functor G) :=
    _,,lax_lineator_postcomp_SelfActCAT_alt_laws.

End LineatorForPostcomposition_alt.

Section DistributionOfCoproducts.

  Context (C : category).

Section BinaryCoproduct.

  Context (BCP : BinCoproducts C).

  Let BCPCD : BinCoproducts [C, C] := BinCoproducts_functor_precat C C BCP.

  Definition SelfActCAT_bincoprod_distributor_data :
    actegory_bincoprod_distributor_data (Mon_endo C) BCPCD (SelfActCAT C).
  Proof.
    intro F.
    apply precomp_bincoprod_distributor_data.
  Defined.

  Goal ∏ F G1 G2 c, pr1 (SelfActCAT_bincoprod_distributor_data F G1 G2) c = identity _.
  Proof.
    intros.
    apply idpath.
  Qed.

  Lemma SelfActCAT_bincoprod_distributor_law :
    actegory_bincoprod_distributor_iso_law _ _ _ SelfActCAT_bincoprod_distributor_data.
  Proof.
    intro F.
    apply precomp_bincoprod_distributor_law.
  Qed.

  Definition SelfActCAT_bincoprod_distributor :
    actegory_bincoprod_distributor (Mon_endo C) BCPCD (SelfActCAT C) :=
    _,,SelfActCAT_bincoprod_distributor_law.

End BinaryCoproduct.

Section Coproduct.

  Context {I : UU} (CP : Coproducts I C).

  Let CPCD : Coproducts I [C, C] := Coproducts_functor_precat I C C CP.

  Definition SelfActCAT_coprod_distributor_data :
    actegory_coprod_distributor_data (Mon_endo C) CPCD (SelfActCAT C).
  Proof.
    intros F Gs.
    apply precomp_coprod_distributor_data.
  Defined.

  Lemma SelfActCAT_coprod_distributor_law :
    actegory_coprod_distributor_iso_law _ _ _ SelfActCAT_coprod_distributor_data.
  Proof.
    intros F Gs.
    apply precomp_coprod_distributor_law.
  Qed.

  Definition SelfActCAT_CAT_coprod_distributor :
    actegory_coprod_distributor (Mon_endo C) CPCD (SelfActCAT C) :=
    _,,SelfActCAT_coprod_distributor_law.

End Coproduct.

End DistributionOfCoproducts.


Require Import Blech.Defaults.

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

Require Import Blech.Bishop.
Require Import Blech.Bishop.Prod.
Require Import Blech.Functor.
Require Import Blech.Category.
Require Import Blech.Category.Funct.
Require Import Blech.Groupoid.
Require Import Blech.Category.Op.
Import GroupoidNotations.

Import BishopNotations.
Import CategoryNotations.
Import OpNotations.
Import ProdNotations.
Import FunctorNotations.

Open Scope category_scope.
Open Scope bishop_scope.

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

Reserved Notation "∅".
Reserved Notation "X ⊕ Y" (at level 30, right associativity).
Reserved Notation "X †" (at level 1).

#[universes(cumulative)]
Class Category := {
  C: Category.Category ;

  (* Enriched over a group structure *)
  zero {A B}: C A B ;
  plus {A B}: C A B → C A B → C A B ;
  neg {A B}: C A B → C A B ;

  compose_zero_left {X Y Z} (y: C X Y): @zero Y Z ∘ y == zero ;
  compose_zero_right {X Y Z} (x: C Y Z): x ∘ @zero X Y == zero ;

  neg_compose {X Y Z} (x: C Y Z) (y: C X Y):
  neg (x ∘ y) == neg x ∘ neg y ;
  neg_zero {A B} : neg (@zero A B) == zero ;
  plus_neg_right {A B} (x: C A B): plus x (neg x) == zero ;
  plus_zero_right {A B} (x: C A B): plus x zero == x ;
  plus_zero_left {A B} (x: C A B): plus zero x == x ;

  plus_compat {A B}: Proper (equiv ==> equiv ==> equiv) (@plus A B) ;
  neg_compat {A B}: Proper (equiv ==> equiv) (@neg A B) ;

  (* FIXME add laws such as commutativity *)
}.

Existing Instance C.
Coercion C: Category >-> Category.Category.

Existing Instance plus_compat.
Existing Instance neg_compat.

Module Import RingoidNotations.
  Notation "∅" := zero.
  Notation "x ⊕ y" := (plus x y).
  Notation "- x" := (neg x).
End RingoidNotations.

(* Doesn't seem quite right maybe I need an Ab enriched dagger category?

   Should also almost be a ringoid.
 *)
#[program]
Definition Complex (C: Category): Category.Category := {|
  Obj := C ;
  Mor A B := (C A B) * (C A B) ;

  id _ := (id _, ∅) ;
  compose X Y Z '(a, b) '(c, d) :=
    ((a ∘ c) ⊕ (- (b ∘ d)),
     (a ∘ d) ⊕ (b ∘ c)) ;
|}.

Next Obligation.
Proof.
  admit.
Admitted.

Next Obligation.
Proof.
  split.
  - rewrite compose_id_left.
    rewrite neg_compose.
    rewrite neg_zero.
    rewrite compose_zero_left.
    rewrite plus_zero_right.
    reflexivity.
  - rewrite compose_zero_left.
    rewrite plus_zero_right.
    rewrite compose_id_left.
    reflexivity.
Qed.

Next Obligation.
Proof.
  split.
  - rewrite compose_id_right.
    rewrite compose_zero_right.
    rewrite neg_zero.
    rewrite plus_zero_right.
    reflexivity.
  - rewrite compose_zero_right.
    rewrite compose_id_right.
    rewrite plus_zero_left.
    reflexivity.
Qed.

Next Obligation.
Proof.
  admit.
Admitted.

Definition neg' {C: Category} {A B: C} (f: (Complex C) A B) :=
  let '(a, b) := f in
  (- a, - b).

Definition j {C: Category} (A: C): (Complex C) A A := (∅, id _).

(* I think an appropriate generalization should probably obey j ∘ (j †) == -id *)
Definition j_squared {C: Category} (A: C): j A ∘ j A == neg' (@id (Complex C) A).
Proof.
  cbn.
  split.
  - rewrite compose_zero_left.
    rewrite plus_zero_left.
    rewrite compose_id_right.
    reflexivity.
  - rewrite neg_zero.
    rewrite compose_zero_left.
    rewrite compose_zero_right.
    rewrite plus_zero_left.
    reflexivity.
Qed.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Unique.
Require Export Category.Structure.Wedge.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Class End `(F : C^op ∏ C ⟶ D) := {
  end_wedge : Wedge F;

  ump_ends : ∀ W : Wedge F, ∃! u : W ~> end_wedge, ∀ x : C,
    wedge_map[end_wedge] ∘ u ≈ @wedge_map _ _ _ W x
}.

Arguments End {_%category _%category} F%functor.
Arguments end_wedge {_%category _%category} F%functor {_}.

Coercion wedge_obj `(F : C^op ∏ C ⟶ D) (E : End F) := @end_wedge _ _ _ E.

Require Import Category.Functor.Opposite.

Definition Coend `(F : C^op ∏ C ⟶ D) := @End (C^op) (D^op) (F^op).


From CHKC Require Import CheckedC.

Definition list : struct := 0.
Definition val  : field := 0.
Definition next : field := 1.
Definition list_fields :=
  Fields.add val TNat (Fields.add next (TPtr Checked (TStruct list)) (@Fields.empty type)).

Definition D : structdef :=
  StructDef.add list list_fields (StructDef.empty fields).

Definition p : var := 0.
Definition x : var := 1.
Definition node :=
   ELet p (EMalloc (TStruct list))
          (EAssign (EFieldAddr (EVar p) next) (EVar p)).

Definition heap_empty := Heap.empty (nat * type).
Definition heap_final := Heap.add 1 (0, TNat) (Heap.add 2 (1, TPtr Checked (TStruct list)) heap_empty).

Require Import Omega.
Definition list_ptr := TPtr Checked (TStruct list).
Example well_typed_cyclic :
  @well_typed D heap_final (Env.empty type) Checked
              (ELit 1 list_ptr) list_ptr.
Proof.
  constructor.
  eapply TyLitC; simpl in *; eauto; simpl in *.
  intros k Hk.
  assert (k = 0 \/ k = 1) by omega.
  inv H.
  - (* val *)
    exists 0. exists TNat.
    repeat (split; eauto).
    unfold heap_final.
    apply Heap.add_1; auto.
  - (* next *)
    exists 1. exists list_ptr.
    repeat (split; eauto).
    + unfold heap_final, list_ptr.
      apply Heap.add_2; auto.
      apply Heap.add_1; auto.
    + unfold list_ptr.
      constructor.
      left; auto.
Qed.

Example well_typed_node :
  @well_typed D (Heap.empty (nat * type)) (Env.empty type) Checked
              node (TPtr Checked (TStruct list)).
Proof.
  unfold node.
  eapply TyLet with (t1 := TPtr Checked (TStruct list)); eauto.
  - eapply TyMalloc.
    intros; congruence.
  - eapply TyAssign; eauto.
    + eapply TyFieldAddr with (i := next); eauto.
      * apply TyVar.
        apply Env.add_1; auto.
      * unfold D.
          apply StructDef.add_1; auto.
      * unfold list_fields.
        apply Fields.add_2; auto.
        apply Fields.add_1; auto.
      * auto.
    + apply TyVar.
      apply Env.add_1; auto.
Unshelve. exact 0.
Qed.

Example reduce_node :
  reduce D heap_empty node Checked heap_final (RExpr (ELit 1 list_ptr)).
Proof.
  ctx (in_hole (EMalloc (TStruct list))
               (CLet p CHole (EAssign (EFieldAddr (EVar p) next) (EVar p))))
      (node).
  unfold node in *.
  rewrite <- HCtx.
  eapply RSExp.
  ctx (subst p (ELit 1 list_ptr) (EVar p)) (ELit 1 list_ptr).
  rewrite <- HCtx.
  apply SLet.


(** The definition of computations, used to represent interactive programs. *)
Require Import Coq.NArith.NArith.
Require Import ListString.All.

Local Open Scope type.

(** System calls. *)
Module Command.
  Inductive t :=
  | AskCard
  | AskPIN
  | CheckPIN (pin : N)
  | AskAmount
  | CheckAmount (amount : N)
  | GiveCard
  | GiveAmount (amount : N)
  | ShowError (message : LString.t).

  (** The type of an answer for a command depends on the value of the command. *)
  Definition answer (command : t) : Type :=
    match command with
    | AskCard => bool (* If the given card seems valid. *)
    | AskPIN => option N (* A number or cancellation. *)
    | CheckPIN _ => bool (* If the PIN number is valid. *)
    | AskAmount => option N (* A number or cancellation. *)
    | CheckAmount _ => bool (* If the amount can be withdrawn. *)
    | GiveCard => bool (* If the card was given. *)
    | GiveAmount _ => bool (* If the money was given. *)
    | ShowError _ => unit (* Show an error message. *)
    end.
End Command.

(** Computations with I/Os. *)
Module C.
  (** A computation can either does nothing, or do a system call and wait
      for the answer to run another computation. *)
  Inductive t : Type :=
  | Ret : t
  | Call : forall (command : Command.t), (Command.answer command -> t) -> t.
  Arguments Ret.
  Arguments Call _ _.

  (** Some optional notations. *)
  Module Notations.
    (** A nicer notation for `Ret`. *)
    Definition ret : t :=
      Ret.

    (** We define an explicit apply function so that Coq does not try to expand
        the notations everywhere. *)
    Definition apply {A B} (f : A -> B) (x : A) := f x.

    (** System call. *)
    Notation "'call!' answer ':=' command 'in' X" :=
      (Call command (fun answer => X))
      (at level 200, answer ident, command at level 100, X at level 200).

    (** System call with typed answer. *)
    Notation "'call!' answer : A ':=' command 'in' X" :=
      (Call command (fun (answer : A) => X))
      (at level 200, answer ident, command at level 100, A at level 200, X at level 200).

    (** System call ignoring the answer. *)
    Notation "'do_call!' command 'in' X" :=
      (Call command (fun _ => X))
      (at level 200, command at level 100, X at level 200).

    (** This notation is useful to compose computations which wait for a
        continuation. We do not have an explicit bind operator to simplify the
        language and the proofs. *)
    Notation "'let!' x ':=' X 'in' Y" :=
      (apply X (fun x => Y))
      (at level 200, x ident, X at level 100, Y at level 200).

    (** Let with a typed answer. *)
    Notation "'let!' x : A ':=' X 'in' Y" :=
      (apply X (fun (x : A) => Y))
      (at level 200, x ident, X at level 100, A at level 200, Y at level 200).

    (** Let ignoring the answer. *)
    Notation "'do!' X 'in' Y" :=
      (apply X (fun _ => Y))
      (at level 200, X at level 100, Y at level 200).
  End Notations.
End C.


(** * Definition of Context Free Grammars *)
Require Import Coq.Strings.String Coq.Lists.List.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.Reachable.MaybeEmpty.Core.
Require Import Fiat.Common.

Set Implicit Arguments.

Local Open Scope string_like_scope.
Local Open Scope type_scope.

Section cfg.
  Context {Char} {HSLM : StringLikeMin Char} {predata : @parser_computational_predataT Char} (G : grammar Char).

  Context (ch : Char) (valid : nonterminals_listT).

  (** Relation defining if a character is reachable *)
  Inductive reachable_from_productions : productions Char -> Type :=
  | ReachableHead : forall pat pats, reachable_from_production pat
                                     -> reachable_from_productions (pat::pats)
  | ReachableTail : forall pat pats, reachable_from_productions pats
                                     -> reachable_from_productions (pat::pats)
  with reachable_from_production : production Char -> Type :=
  | ReachableProductionHead : forall it its, maybe_empty_production G valid its
                                             -> reachable_from_item it
                                             -> reachable_from_production (it::its)
  | ReachableProductionTail : forall it its, reachable_from_production its
                                             -> reachable_from_production (it::its)
  with reachable_from_item : item Char -> Type :=
  | ReachableTerminal : forall P, is_true (P ch) -> reachable_from_item (Terminal P)
  | ReachableNonTerminal : forall nt, is_valid_nonterminal valid (of_nonterminal nt)
                                      -> reachable_from_productions (Lookup G nt)
                                      -> reachable_from_item (NonTerminal nt).
End cfg.


From isla Require Import opsem.

Definition a10 : isla_trace :=
  AssumeReg "PSTATE" [Field "EL"] (RegVal_Base (Val_Bits (BV 2%N 0x2%Z))) Mk_annot :t:
  AssumeReg "PSTATE" [Field "SP"] (RegVal_Base (Val_Bits (BV 1%N 0x1%Z))) Mk_annot :t:
  Smt (DeclareConst 38%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "SP_EL2" [] (RegVal_Base (Val_Symbolic 38%Z)) Mk_annot :t:
  Smt (DefineConst 59%Z (Unop (Extract 63%N 0%N) (Unop (ZeroExtend 64%N) (Val (Val_Symbolic 38%Z) Mk_annot) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "R29" [] (RegVal_Base (Val_Symbolic 59%Z)) Mk_annot :t:
  Smt (DeclareConst 60%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 60%Z)) Mk_annot :t:
  Smt (DefineConst 61%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 60%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 61%Z)) Mk_annot :t:
  tnil
.


Require compcert.backend.Linear.
Require EventsX.

Import Coqlib.
Import Integers.
Import AST.
Import Values.
Import Memory.
Import Globalenvs.
Import EventsX.
Import Smallstep.
Import Locations.
Import Conventions.
Export Linear.

Section WITHCONFIG.
Context `{compiler_config: CompilerConfiguration}.

(** Execution of Linear functions with Asm-style arguments (long long 64-bit integers NOT allowed) *)

Inductive initial_state (lm: locset) (p: Linear.program) (i: ident) (sg: signature) (args: list val) (m: mem): state -> Prop :=
| initial_state_intro
    b
    (Hb: Genv.find_symbol (Genv.globalenv p) i = Some b)
    f
    (Hf: Genv.find_funct_ptr (Genv.globalenv p) b = Some f)
    (Hsig: sg = funsig f)
    (Hargs: args = map lm (loc_arguments sg))
  :
      initial_state lm p i sg args m (Callstate nil f lm m)
.

Inductive final_state (lm: locset) (sg: signature): state -> (list val * mem) -> Prop :=
| final_state_intro
    rs
    v
    (Hv: v = List.map rs (map R (loc_result sg)))
    (** Callee-save registers *)
    (CALLEE_SAVE: forall r,
       ~ In r destroyed_at_call ->
       rs (R r) = lm (R r))
    m :
    final_state lm sg (Returnstate nil rs m) (v, m)
.

Definition semantics
           (lm: locset)
           (p: Linear.program) (i: ident) (sg: signature) (args: list val) (m: mem) :=
  Semantics (
      let _ := writable_block_with_init_mem_writable_block_ops m in
      Linear.step lm
    ) (initial_state lm p i sg args m) (final_state lm sg) (Genv.globalenv p).

End WITHCONFIG.