Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e256m2e32m977_13limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


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 D O Oprime M C1 D1 : Universe, ((wd_ C1 D1 /\ (wd_ C1 M /\ (wd_ D1 M /\ (wd_ A B /\ (wd_ B D1 /\ (wd_ A D1 /\ (wd_ B C1 /\ (wd_ A C1 /\ (wd_ B Oprime /\ (wd_ A Oprime /\ (wd_ B D /\ (wd_ A D /\ (wd_ B O /\ (wd_ A O /\ (wd_ B C /\ (wd_ A C /\ (wd_ M A /\ (wd_ M B /\ (wd_ Oprime D1 /\ (wd_ O C1 /\ (col_ D1 A M /\ (col_ M C1 D1 /\ (col_ M A B /\ (col_ D1 Oprime M /\ col_ C1 O M)))))))))))))))))))))))) -> col_ A B D1)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** the coinductive analogue of [MultiSortedMonadConstruction_actegorical]

author: Ralph Matthes 2023
 *)

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.Core.Univalence.
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.exponentials.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
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.HSET.Univalence.
Require Import UniMath.CategoryTheory.categories.StandardCategories.
Require Import UniMath.CategoryTheory.Groupoids.

(** for the additions in 2023 *)
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.FunctorCoalgebras.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.Chains.Cochains.
Require Import UniMath.CategoryTheory.Chains.CoAdamek.
Require Import UniMath.CategoryTheory.Chains.OmegaContFunctors.
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.
Require Import UniMath.SubstitutionSystems.ContinuitySignature.MultiSortedSignatureFunctorEquivalence.
Require Import UniMath.SubstitutionSystems.ContinuitySignature.CommutingOfOmegaLimitsAndCoproducts.
Require Import UniMath.SubstitutionSystems.ContinuitySignature.InstantiateHSET.

Local Open Scope cat.

Import BifunctorNotations.
Import MonoidalNotations.

Section ToBeMoved.

  (* Definition limArrowOfInverses
             {C : category} {g : graph} {d : diagram g C}
             (CC : LimCone d)
             (c : C) (cc : cone d c)
    : (∏  v : vertex g, is_z_isomorphism (pr1 cc v)) -> is_z_isomorphism (limArrow CC c cc).
  Proof.
    intro iv.
    apply isLim_is_z_iso.
    intros x x_con.
    use tpair.
    - unfold LimCone in CC.
      use tpair.
      + refine (pr11 (pr2 CC x x_con) · _).
        Search lim.
        Search lim.

    use make_is_z_isomorphism.
    - unfold cone in cc.

      Check pr1 cc.
      Search lim. *)

  Lemma isaprop_isCoproduct
        {C : category} {I : UU}
        {i : I -> C} {x : C}
        (j : ∏ i0 : I, C ⟦ i i0, x ⟧)
    : isaprop (isCoproduct I C i x j).
  Proof.
    repeat (apply impred; intro).
    apply isapropiscontr.
  Qed.

  Definition z_iso_from_coproduct_to_coproduct
             {C : category} {I : UU}
             {ind : I -> C}
             (CC CC' : Coproduct I C ind) : z_iso (pr11 CC) (pr11 CC').
  Proof.
    use make_z_iso.
    - apply CoproductArrow, CoproductIn.
    - apply CoproductArrow, CoproductIn.
    - split.
      + etrans. 1: apply postcompWithCoproductArrow.
        apply pathsinv0, Coproduct_endo_is_identity.
        intro.
        etrans.
        1: apply CoproductInCommutes.
        apply CoproductInCommutes.
      + etrans. 1: apply postcompWithCoproductArrow.
        apply pathsinv0, Coproduct_endo_is_identity.
        intro.
        etrans.
        1: apply CoproductInCommutes.
        apply CoproductInCommutes.
  Defined.

  Definition eq_Coproduct
             {C : category}
             {I : UU}
             {ind : I -> C}
             (C1 C2 : Coproduct I C ind)
             (q : pr11 C1  = pr11 C2)
             (e : ∏ i : I, CoproductIn I C C2 i = CoproductIn I C C1 i · pr1 (Univalence.idtoiso q))
  : C1 = C2.
  Proof.
    use subtypePath.
    { intro ; apply isaprop_isCoproduct. }
    use total2_paths_f.
    - exact q.
    - rewrite transportf_sec_constant.
      apply funextsec ; intro i.
      rewrite <- Univalence.idtoiso_postcompose.
      exact (! e i).
  Defined.

  Lemma isaprop_Coproducts
        {C : category} (Cuniv : Univalence.is_univalent C) (I : UU)
    : isaprop (Coproducts I C).
  Proof.

    use invproofirrelevance.
    intros C1 C2.
    apply funextsec ; intro ind.
    use eq_Coproduct.
    - refine (Univalence.isotoid _ Cuniv _).
      apply z_iso_from_coproduct_to_coproduct.
    - intro.
      rewrite Univalence.idtoiso_isotoid ; cbn.
      apply pathsinv0, CoproductInCommutes.
  Qed.

  Lemma ω_limits_distribute_over_I_coproducts_independent_of_product
        {C : category} {I : SET}
        (Cuniv : Univalence.is_univalent C)
        {l : Lims_of_shape conat_graph C}
        (p q : Coproducts (pr1 I) C)
    : ω_limits_distribute_over_I_coproducts C I l p
      -> ω_limits_distribute_over_I_coproducts C I l q.
  Proof.
    intro distr.

    transparent assert (pq : (p = q)).
    {
      apply isaprop_Coproducts.
      exact Cuniv.
    }
    induction pq.
    exact distr.
  Qed.

  Definition BinProduct_of_functors_BinProducts_of_shape
             {C D : category}
             (BC :  Colims_of_shape two_graph D)
             (F G : functor C D)
    : nat_z_iso (BinCoproduct_of_functors C D (BinCoproducts_from_Colims _ BC) F G)
                (coproduct_of_functors bool C D (Coproducts_from_Colims _ _ BC) (λ x : bool, if x then F else G)).
  Proof.
    use make_nat_z_iso.
    - use make_nat_trans.
      + intro c.
        use colimOfArrows.
        * intro b.
          induction b ; apply identity.
        * intros b1 b2 e.
          apply fromempty.
          exact e.
      + intros c1 c2 f.
        cbn.
        etrans.
        2: apply pathsinv0, precompWithColimOfArrows.
        etrans.
        1: apply postcompWithColimArrow.
        apply colimArrowUnique.
        intro b.
        cbn.
        etrans.
        1: apply (colimArrowCommutes (BC (bincoproduct_diagram D (F c1) (G c1)))).
        cbn.
        induction b.
        * cbn.
          etrans.
          1: apply assoc'.
          etrans.
          1: { apply maponpaths.
               apply (colimArrowCommutes  (BC (bincoproduct_diagram D (F c2) (G c2))) _ _ true).
          }
          cbn.
          etrans.
          1: apply maponpaths, id_left.
          apply pathsinv0, id_left.
        * cbn.
          etrans.
          1: apply assoc'.
          etrans.
          1: { apply maponpaths.
               apply (colimArrowCommutes  (BC (bincoproduct_diagram D (F c2) (G c2))) _ _ false).
          }
          cbn.
          etrans.
          1: apply maponpaths, id_left.
          apply pathsinv0, id_left.
    - intro c.
      use tpair.
      + use colimOfArrows.
        * intro b.
          induction b ; apply identity.
        * intros b1 b2 e.
          apply fromempty.
          exact e.
      + split ; cbn.
        * etrans.
          1: apply postcompWithColimArrow.
          apply pathsinv0.
          use colimArrowUnique.
          intro b.
          etrans.
          1: apply id_right.
          cbn.
          etrans.
          2: apply assoc.
          etrans.
          2: { apply maponpaths, pathsinv0.
               apply (colimArrowCommutes (BC (coproducts_diagram bool D (λ i : bool, (if i then F else G) c))) ).
          }
          induction b ; refine (_ @ ! id_left _) ; apply pathsinv0, id_left.
        * etrans.
          1: apply postcompWithColimArrow.
          apply pathsinv0.
          use colimArrowUnique.
          intro b.
          etrans.
          1: apply id_right.
          cbn.
          etrans.
          2: apply assoc.
          etrans.
          2: { apply maponpaths, pathsinv0.
               apply (colimArrowCommutes (BC (bincoproduct_diagram D (F c) (G c))) ).
          }
          induction b ; refine (_ @ ! id_left _) ; apply pathsinv0, id_left.
  Defined.

  Definition Colims_from_BinCoproducts
             {C : category} (CC : BinCoproducts C)
    : Colims_of_shape two_graph C.
  Proof.
    unfold Colims_of_shape.
    intro d.
    unfold diagram in d.
    cbn in d.

    set (c := CC (pr1 d true) (pr1 d false)).
    unfold BinCoproduct in c.
    use make_ColimCocone.
    - exact (pr11 c).
    - use tpair.
      + intro b.
        induction b.
        * exact (pr121 c).
        * exact (pr221 c).
      + intros b1 b2 e.
        apply fromempty.
        exact e.
    - intros co cc.
      unfold cocone in cc.

      use tpair.
      + exists (pr11 (pr2 c co (pr1 cc true) (pr1 cc false))).
        intro b.
        induction b.
        * exact (pr121 (pr2 c co (pr1 cc true) (pr1 cc false))).
        * exact (pr221 (pr2 c co (pr1 cc true) (pr1 cc false))).
      + intro t.
        transparent assert (ϕ : (∑ fg : C ⟦ pr11 c, co ⟧, pr121 c · fg = pr1 cc true × pr221 c · fg = pr1 cc false)).
        {
          use tpair.
          - exact (pr1 t).
          - split ; apply (pr2 t).
        }

        set (p := pr2 (pr2 c co (pr1 cc true) (pr1 cc false)) ϕ).
        use total2_paths_f.
        * apply (base_paths _ _ p).
        * apply isaprop_is_cocone_mor.
  Defined.

End ToBeMoved.

Section Upstream.

  Context (C : category) (BC : BinCoproducts C).
  Local Definition Id_H := LiftingInitial_alt.Id_H C BC.

  Context (L : ∏ coch : cochain [C, C], LimCone coch).
  Context (distr :  ω_limits_distribute_over_I_coproducts [C, C] (bool,, isasetbool) L
    (Coproducts_from_Colims bool [C, C]
       (Colims_from_BinCoproducts (BinCoproducts_functor_precat C C BC)))).

  Definition is_omega_cont_Id_H (H: [C, C] ⟶ [C, C]) :
    is_omega_cont H -> is_omega_cont (Id_H H).
  Proof.
    intro Hc.
    use is_omega_cont_z_iso.
    2: {
      use z_iso_from_nat_z_iso.
      use nat_z_iso_inv.

      transparent assert (BC0 : (Colims_of_shape two_graph [C,C])).
      {
        use Colims_from_BinCoproducts.
        apply BinCoproducts_functor_precat.
        exact BC.
      }

      exact (BinProduct_of_functors_BinProducts_of_shape BC0 (constant_functor [C, C] [C, C] (functor_identity C)) H).
    }

    use (coproduct_of_functors_omega_cont [C,C] (bool,,isasetbool)).
    - exact L.
    - exact distr.
    - intro b.
      induction b.
      + apply is_omega_cont_constant_functor.
      + exact Hc.
  Defined.

End Upstream.

Section MBindingSig.

Context (sort : UU) (* (Hsort_set : isaset sort) *) (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)).

(* Let Hsort := hlevelntosn 2 _ Hsort_set. *)

(** 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.

(* Assumptions needed to prove ω-continuity of the functor *)
Context (HcoC : Lims_of_shape conat_graph C)
 (* (HCcommuteBP : propcoproducts_commute_binproducts C BP (λ p : hProp, CC p (isasetaprop (pr2 p)))) *)
 (HCcommuteCC : ∏ I : SET, ω_limits_distribute_over_I_coproducts C I HcoC (CC (pr1 I) (pr2 I))).

(** * 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).*)
  Let TCsortToC1 : Terminal sortToC1 := Terminal_functor_precat _ _ (Terminal_functor_precat _ _ TC).

  Local Definition HcoCsortToC : Lims_of_shape conat_graph sortToC.
  Proof.
    apply LimsFunctorCategory_of_shape, HcoC.
  Defined.
  Local Definition HcoCsortToC1 : Lims_of_shape conat_graph sortToC1.
  Proof.
    apply LimsFunctorCategory_of_shape, HcoCsortToC.
  Defined.

  Local Definition MultiSortedSigToFunctor' : MultiSortedSig sort -> sortToC2 := MultiSortedSigToFunctor' sort Hsort C TC BP BC CC.

  Local Definition is_omega_cont_MultiSortedSigToFunctor' (M : MultiSortedSig sort) :
    is_omega_cont (MultiSortedSigToFunctor' M) :=
    is_omega_cont_MultiSortedSigToFunctor' sort Hsort C TC
                                          BP BC CC HcoC HCcommuteCC M.

  Context (sortToC_exp : Exponentials (BinProducts_functor_precat [path_pregroupoid sort Hsort, C] C BP)).

  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 := Id_H sortToC BCsortToC.

  (** Construction of terminal coalgebra for the omega-continuous signature functor with lax lineator *)
  Definition coindCodatatypeOfMultisortedBindingSig_CAT (sig : MultiSortedSig sort) (Cuniv : is_univalent C) :
    Terminal (CoAlg_category (Id_H (MultiSortedSigToFunctor' sig))).
  Proof.
    use limCoAlgTerminal.
    - exact TCsortToC1.
    - use is_omega_cont_Id_H.
      + apply HcoCsortToC1.
      + set (CP' := CoproductsBool BCsortToC).

        transparent assert (CP'' : (Coproducts bool sortToC)).
        {
          use Coproducts_functor_precat.
          apply CC.
          apply isasetbool.
        }

        transparent assert (CP'_distr : (ω_limits_distribute_over_I_coproducts sortToC (bool,, isasetbool) HcoCsortToC CP'')).
        {
          use functor_category_ω_limits_distribute_over_I_coproducts.
          apply HCcommuteCC.
        }

        set (q := functor_category_ω_limits_distribute_over_I_coproducts sortToC  (bool,, isasetbool) HcoCsortToC CP'' CP'_distr sortToC).
        use (ω_limits_distribute_over_I_coproducts_independent_of_product _ _ _ q).
        do 2 apply is_univalent_functor_category.
        apply Cuniv.
      + exact (is_omega_cont_MultiSortedSigToFunctor' sig).
    - apply HcoCsortToC1.
  Defined.

  Definition coindGHSSOfMultiSortedSig_CAT (sig : MultiSortedSig sort) (Cuniv : is_univalent C) :
    ghss (monendocat_monoidal sortToC) (MultiSortedSigToFunctor' sig) (MultiSortedSigToStrength' sig).
  Proof.
    use (terminal_coalg_to_ghss (MultiSortedSigToStrength' sig) BCsortToC1).
    - apply BindingSigToMonad_actegorical.bincoprod_distributor_pointed_CAT.
    - exact (pr1 (coindCodatatypeOfMultisortedBindingSig_CAT sig Cuniv)).
    - exact (pr2 (coindCodatatypeOfMultisortedBindingSig_CAT sig Cuniv)).
  Defined.

  (** the associated Sigma-monoid *)
  Definition coindSigmaMonoidOfMultiSortedSig_CAT (sig : MultiSortedSig sort) (Cuniv : is_univalent C) : SigmaMonoid (MultiSortedSigToStrength' sig).
  Proof.
    apply ghhs_to_sigma_monoid.
    exact (coindGHSSOfMultiSortedSig_CAT sig Cuniv).
  Defined.

  (** the associated monad *)
  Definition coindMonadOfMultiSortedSig_CAT (sig : MultiSortedSig sort) (Cuniv : is_univalent C) : Monad sortToC.
  Proof.
    use monoid_to_monad_CAT.
    use SigmaMonoid_to_monoid.
    - exact (MultiSortedSigToFunctor' sig).
    - exact (MultiSortedSigToStrength' sig).
    - exact (coindSigmaMonoidOfMultiSortedSig_CAT sig Cuniv).
  Defined.

End monad.

End MBindingSig.

Section InstanceHSET.

  Context (sort : UU)  (Hsort : isofhlevel 3 sort) (*(Hsort_set : isaset sort)*).

  (* Let Hsort := hlevelntosn 2 _ Hsort_set.*)

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

  Definition coindMultiSortedSigToMonadHSET_viaCAT : MultiSortedSig sort → Monad (sortToHSET).
  Proof.
    intros sig; simple refine (coindMonadOfMultiSortedSig_CAT sort Hsort HSET _ _ _ _ _ _ sig _).
    - apply TerminalHSET.
    - apply BinProductsHSET.
    - apply BinCoproductsHSET.
    - apply CoproductsHSET.
    - apply LimsHSET_of_shape.
    - apply I_coproduct_distribute_over_omega_limits_HSET.
    - apply is_univalent_HSET.
  Defined.

End InstanceHSET.


Require Export ch2o.abstract_c.architectures.
Require Export bigstep.
Require Export stack_assertions.
Require Export ch2o.axiomatic.axiomatic_expressions.
Require Export ch2o.axiomatic.axiomatic_statements.
Require Export ch2o.axiomatic.axiomatic_adequate.

Section Soundness.

Context {K} {HK: Env K} {HK': EnvSpec K} (Γ: env K) (δ: funenv K).

Lemma eval_sound st e z:
  eval st e z →
  (assert_stack st ⊆{Γ,δ} e ⇓ inr (intV{sintT} z))%A.
Proof.
induction 1.
- apply assert_int_typed_eval; assumption.
- apply assert_stack_load with (1:=H).
Qed.

Definition R (st: store) (O: outcome): val K -> assert K :=
  λ v,
  (∃st',
   assert_stack st' ★
   ⌜length st' = length st /\
    ∃z, O = oreturn z /\ v = intV{sintT} z⌝)%A.

Definition J: labelname -> assert K := (λ _, False%A).
Definition T: nat -> assert K := (λ _, False%A).
Definition C: option Z -> assert K := (λ _, False%A).

Lemma exec_sound_lemma st s O:
  exec st s O →
  Γ\ δ\ R st O\ J\ T\ C ⊨ₛ
  {{ assert_stack st }} s {{ ∃st', assert_stack st' ★ ⌜O = onormal st'⌝ }}.
Proof.
induction 1.
- (* exec_local_normal *)
  apply ax_local.
  apply ax_stmt_weaken with (8:=IHexec); intros.
  + unfold R.
    apply assert_exist_elim; intro st'0.
    apply assert_Prop_intro_r.
    intros.
    destruct H0.
    destruct H1.
    destruct H1.
    discriminate.
  + unfold J.
    apply assert_False_elim.
  + unfold J.
    rewrite stack_indep.
    apply @RightAbsorb_instance_2.
  + unfold T.
    apply assert_False_elim.
  + unfold C.
    rewrite stack_indep.
    apply @RightAbsorb_instance_2.
  + simpl.
    reflexivity.
  + apply assert_exist_elim. intro st'0.
    apply assert_Prop_intro_r. intro HO.
    injection HO; clear HO; intros; subst.
    simpl.
    apply assert_sep_preserving.
    * destruct mv.
      -- eapply assert_exist_intro.
         unfold var_points_to.
         reflexivity.
      -- reflexivity.
    * rewrite assert_lift_exists.
      eapply assert_exist_intro.
      rewrite assert_lift_sep.
      rewrite stack_indep.
      rewrite assert_Prop_r. 2:reflexivity.
      reflexivity.
- apply ax_local.
  apply ax_stmt_weaken with (8:=IHexec); intros.
  + unfold R.
    apply assert_exist_elim; intro st'.
    apply assert_Prop_intro_r.
    intros.
    destruct H0.
    destruct H1.
    destruct H1.
    injection H1; clear H1; intros; subst.
    destruct st' as [|mv st']; [discriminate|].
    simpl.
    apply assert_sep_preserving.
    * destruct mv.
      -- eapply assert_exist_intro.
         unfold var_points_to.
         reflexivity.
      -- reflexivity.
    * rewrite assert_lift_exists.
      apply assert_exist_intro with (x0:=st').
      rewrite assert_lift_sep.
      rewrite stack_indep.
      rewrite assert_Prop_r.
      -- reflexivity.
      -- split.
         ++ simpl in H0; congruence.
         ++ eexists; tauto.
  + unfold J.
    apply assert_False_elim.
  + unfold J.
    rewrite stack_indep.
    apply @RightAbsorb_instance_2.
  + unfold T.
    apply assert_False_elim.
  + unfold C.
    rewrite stack_indep.
    apply @RightAbsorb_instance_2.
  + simpl.
    reflexivity.
  + apply assert_exist_elim. intro st'0.
    apply assert_Prop_intro_r. intro HO.
    discriminate.
- eapply ax_stmt_weaken_post with (Q:=(assert_stack (<[i:=Some z]>st))%A). {
    apply assert_exist_intro with (x:=(<[i:=Some z]> st)).
    rewrite assert_Prop_r; reflexivity.
  }
  eapply ax_stmt_weaken_pre with (P:=((∃p, var i ⇓ inl p ∧ emp) ★ assert_stack st)%A). {
    apply assert_stack_var.
    assumption.
  }
  apply ax_do.
  apply ax_assign with
    (Q1:=λ ν, (var i ⇓ ν ∧ emp)%A)
    (Q2:=λ ν, (⌜ν = inr (intV{sintT} z)⌝ ★ assert_stack st)%A)
    (μ:=false)
    (γ:=perm_full)
    (τ:=sintT%T).
  + reflexivity.
  + intros.
    rewrite (commutative (★)%A).
    rewrite <- (associative (★)%A).
    apply assert_Prop_intro_l. intros.
    injection H1; clear H1; intros; subst.
    rewrite (commutative (★)%A).
    apply assert_exist_intro with (x:=intV{sintT} z).
    apply assert_exist_intro with (x:=intV{sintT} z).
    apply assert_and_intro.
    * clear H0.
      revert st i H.
      induction st.
      -- simpl; intros; lia.
      -- Opaque perm_full.
         rename a into mv.
         simpl; intros.
         destruct i.
         ++ clear IHst H.
            simpl.
            assert (var_points_to 0 mv ⊆{Γ,δ} var 0 ↦{false,perm_full} - : sintT%BT)%A. {
              destruct mv.
              - eapply assert_exist_intro.
                simpl. reflexivity.
              - reflexivity.
            }
            rewrite H.
            rewrite assert_singleton_l_.
            rewrite (commutative (★)%A).
            rewrite <- (associative (★)%A).
            rewrite assert_exist_sep.
            apply assert_exist_elim; intro p'.
            rewrite (associative (★)%A).
            rewrite (commutative (★)%A).
            rewrite <- (associative (★)%A).
            rewrite (associative (★)%A).
            rewrite assert_eval_functional'.
            rewrite <- (associative (★)%A).
            apply assert_Prop_intro_l. intro Hp'. injection Hp'; clear Hp'; intros; subst p'.
            rewrite (associative (★)%A).
            rewrite (commutative (★)%A).
            rewrite (associative (★)%A).
            rewrite (commutative (★)%A).
            apply assert_sep_preserving; [reflexivity|].
            rewrite (commutative (★)%A).
            apply assert_wand_intro.
            rewrite (commutative (★)%A).
            rewrite (associative (★)%A).
            rewrite <- assert_unlock_sep.
            apply assert_sep_preserving.
            ** rewrite (commutative (★)%A).
               rewrite assert_singleton_l_2.
               apply assert_unlock_singleton.
               reflexivity.
            ** apply assert_stack_unlock_indep.
         ++ simpl.
            rewrite <- assert_unlock_sep.
            rewrite <- assert_wand_sep.
            rewrite (commutative (★)%A).
            rewrite <- (associative (★)%A).
            rewrite (commutative (★)%A) with (x:=(% p ↦{false,perm_full} - : sintT%BT)%A).
            rewrite <- (associative (★)%A).
            apply assert_sep_preserving; [apply var_points_to_unlock_indep|].
            rewrite (commutative (★)%A).
            rewrite (commutative (★)%A) with (y:=(% p ↦{false,perm_full} - : sintT%BT)%A).
            assert (
              ((var (S i) ⇓ inl p ∧ emp) ★ assert_stack st↑)%A ⊆{Γ,δ}
              (((var i ⇓ inl p ∧ emp) ★ assert_stack st)↑)%A). {
              rewrite assert_lift_sep.
              rewrite assert_lift_and.
              rewrite stack_indep.
              apply assert_sep_preserving; [|reflexivity].
              apply assert_and_intro.
              - apply assert_and_elim_l.
                rewrite <- assert_lift_eval.
                reflexivity.
              - apply assert_and_elim_r; reflexivity.
            }
            rewrite H0.
            rewrite IHst.
            ** rewrite assert_lift_sep.
               rewrite assert_lift_wand.
               rewrite assert_lift_unlock.
               rewrite assert_lift_singleton.
               rewrite assert_lift_singleton_.
               reflexivity.
            ** lia.
    * apply assert_wand_intro.
      simpl.
      rewrite eval_sound with (1:=H0).
      assert (forall P Q, P ⊆{Γ,δ} Q -> P ⊆{Γ,δ} (Q ∧ Q)%A). {
        intros.
        apply assert_and_intro; assumption.
      }
      apply H1; clear H1.
      rewrite (right_id _ (★)%A).
      rewrite <- (left_id _ (★)%A) with (x:=(cast{sintT%BT} (# intV{sintT} z) ⇓ inr (intV{sintT} z))%A).
      apply assert_sep_preserving.
      -- apply assert_and_elim_r; reflexivity.
      -- rewrite assert_eval_int_typed.
         apply assert_Prop_intro_l. intro Hz.
         eapply assert_eval_int_cast'.
         ++ rewrite <- assert_int_typed_eval; trivial.
         ++ apply int_cast_ok_self; apply Hz.
         ++ apply int_cast_self; assumption.
  + apply ax_expr_exist_pre. intro p.
    apply ax_expr_base with (ν:=inl p).
    apply assert_and_intro; [reflexivity|].
    apply assert_and_elim_l; reflexivity.
  + apply ax_expr_base with (ν:=inr (intV{sintT} z)).
    rewrite assert_Prop_l; [|reflexivity].
    apply assert_and_intro; [reflexivity|].
    rewrite eval_sound with (1:=H0) at 1.
    rewrite assert_eval_int_typed'.
    rewrite assert_Prop_intro_l; [reflexivity|]. intros.
    rewrite assert_eval_int_cast with (τi:=sintT%IT) (σi:=sintT%IT).
    * rewrite int_cast_self; [|assumption]. reflexivity.
    * apply int_cast_ok_self; assumption.
- eapply ax_comp with (P':=assert_stack st').
  + eapply ax_stmt_weaken.
    Focus 8. {
      apply IHexec1.
    } Unfocus.
    * intros; unfold R.
      apply assert_exist_elim; intro st'0.
      apply assert_Prop_intro_r.
      intros.
      destruct H1 as [? [? [? ?]]].
      discriminate.
    * trivial.
    * trivial.
    * trivial.
    * trivial.
    * trivial.
    * apply assert_exist_elim; intro st'0.
      apply assert_Prop_intro_r.
      intros.
      injection H1; clear H1; intros; subst.
      reflexivity.
  + eapply ax_stmt_weaken.
    Focus 8. {
      apply IHexec2.
    } Unfocus.
    * intros.
      unfold R.
      rewrite exec_onormal_length_st with (1:=H); reflexivity.
    * trivial.
    * trivial.
    * trivial.
    * trivial.
    * trivial.
    * trivial.
- eapply ax_ret with (Q1:=fun ν =>
    (∃ st', assert_stack st' ★ ⌜ ν = inr (intV{sintT} z) ∧ length st' = length st ⌝)%A).
  + intros.
    apply assert_exist_elim; intro st'.
    unfold R.
    rewrite assert_unlock_exists.
    apply assert_exist_intro with (x:=st').
    apply assert_Prop_intro_r. intros [? ?].
    injection H0; clear H0; intros; subst.
    rewrite assert_Prop_r.
    * apply assert_stack_unlock_indep'.
    * intuition.
      eexists; tauto.
  + apply ax_expr_base with (ν:=inr (intV{sintT} z)).
    apply assert_and_intro.
    * apply assert_exist_intro with (x:=st).
      rewrite assert_Prop_r; [reflexivity|].
      tauto.
    * rewrite eval_sound with (1:=H).
      rewrite assert_eval_int_typed'.
      apply assert_Prop_intro_l. intros.
      rewrite <- assert_eval_int_cast' with (τi:=sintT%IT) (σi:=sintT%IT) at 1.
      -- reflexivity.
      -- reflexivity.
      -- apply int_cast_ok_self; assumption.
      -- apply int_cast_self; assumption.
Qed.

Require Export ch2o.core_c.restricted_smallstep.

Lemma body_returns_call_returns v s f S0 S:
  Γ\ δ\ [] ⊢ₛ S0 ⇒* S →
  ∀ k ϕ m,
  S0 = State (k ++ [CParams f []]) ϕ m →
  (∀ S,
   Γ\ δ\ [] ⊢ₛ State k ϕ m ⇒* S →
   red (rcstep Γ δ []) S ∨
   ∃ m',
   S = State [] (Stmt (⇈ v) s) m') →
  red (rcstep Γ δ []) S ∨
  ∃ m',
  S = State [] (Return f v) m'.
Proof.
induction 1.
- intros; subst.
  destruct (H0 (State k ϕ m)) as [Hred|[m' Hm']].
  + constructor.
  + left.
    apply rcred_app.
    assumption.
  + injection Hm'; clear Hm'; intros; subst.
    left.
    econstructor.
    econstructor.
- intros; subst.
  destruct (H2 (State k ϕ m)) as [Hred|[m' Hm']].
  + constructor.
  + destruct y as [k'long ϕ' m'].
    assert (suffix_of [CParams f []] k'long). {
      apply cstep_app_suffix_of with (1:=Hred) (2:=H).
    }
    destruct H1 as [k' Hk']; subst.
    eapply IHrtc. reflexivity.
    intros.
    apply H2.
    apply rtc_l with (2:=H1).
    apply rcstep_app_inv with (1:=H).
  + injection Hm'; clear Hm'; intros; subst.
    simpl in H.
    inversion H; subst.
    * simpl in H0.
      inversion H0; subst.
      -- right. eexists; reflexivity.
      -- inversion H1.
    * inversion H7.
Qed.

Lemma rcsteps_csteps S0 S:
  Γ\ δ\ [] ⊢ₛ S0 ⇒* S →
  Γ\ δ ⊢ₛ S0 ⇒* S.
Proof.
induction 1.
- constructor.
- apply rtc_l with (2:=IHrtc).
  apply rcstep_cstep with (1:=H).
Qed.

Lemma cmap_empty_valid: ✓{Γ} (∅: mem K).
Proof.
split. {
  apply memenv_empty_valid.
}
split. {
  intros.
  simpl in H.
  rewrite lookup_empty in H; discriminate.
}
intros.
simpl in H.
rewrite lookup_empty in H; discriminate.
Qed.

Theorem exec_sound (s: stmt K) z S f:
  ✓ Γ →
  ✓{Γ,'{∅}} δ →
  (Γ, '{∅}, []) ⊢ s : (true, Some sintT%T) →
  exec [] s (oreturn z) →
  Γ\ δ\ [] ⊢ₛ State [CParams f []] (Stmt ↘ s) ∅ ⇒* S →
  red (rcstep Γ δ []) S ∨
  ∃ m,
  S = State [] (Return f (intV{sintT} z)) m.
Proof.
intros.
eapply body_returns_call_returns with (1:=H3) (k:=[]). reflexivity.
clear S H3.
intros.
apply rcsteps_csteps in H3.
destruct ax_stmt_adequate with (cmτ:=(true, Some sintT%T): rettype K) (Q:=λ v, (⌜ v = intV{sintT} z ⌝ ★ True)%A) (7:=H3) as [[n' [m' [? ?]]] | [[n' [m' [v [? ?]]]] | ?]]; try assumption.
- apply cmap_empty_valid.
- apply mem_locks_empty.
- eapply ax_stmt_weaken.
  8: apply exec_sound_lemma with (1:=H2).
  + intros. unfold R.
    apply assert_exist_elim; intro st'.
    apply assert_Prop_intro_r; intros.
    destruct H4 as [? [? [? ?]]].
    rewrite assert_Prop_l.
    * apply assert_True_intro.
    * congruence.
  + intros.
    reflexivity.
  + intros; reflexivity.
  + intros; reflexivity.
  + intros; reflexivity.
  + rewrite cmap_erase_empty.
    simpl.
    intro; intros.
    unfold assert_eq_mem in H10; simpl in H10.
    subst.
    unfold assert_Prop; simpl.
    tauto.
  + apply assert_exist_elim; intro st'.
    apply assert_Prop_intro_r; intros.
    discriminate.
- simpl in H5.
  destruct H5 as [? [? [? [? [[? ?] ?]]]]].
  discriminate.
- subst.
  right.
  eexists m'.
  destruct H5 as [? [? [? [? [[? ?] ?]]]]].
  subst.
  reflexivity.
- left.
  inversion H4.
  econstructor.
  apply cstep_rcstep with (1:=H5).
Qed.

End Soundness.


(** * The Category of Functions *)

(** Definitions to work with Coq functions [A -> B] categorically.
 *)

(* begin hide *)
From ITree Require Import
     Basics.Basics
     Basics.CategoryOps.

Import CatNotations.
#[local] Open Scope cat_scope.
(* end hide *)

(** The name of the category. *)
Definition Fun (A B : Type) : Type := A -> B.

(** The identity function, but can sometimes help type inference. *)
Definition apply_Fun {A B : Type} (f : Fun A B) : A -> B := f.

(** Extensional function equality *)
#[global] Instance eeq : Eq2 Fun :=
  fun A B f g => forall a : A, f a = g a.

(** Identity function *)
#[global] Instance Id_Fun : Id_ Fun :=
  fun A => fun a => a.

(** Function composition *)
#[global] Instance Cat_Fun : Cat Fun :=
  fun A B C f g => fun a => g (f a).

(** [void] as an initial object. *)
#[global] Instance Initial_void : Initial Fun void :=
  fun _ v => match v : void with end.

(** [unit] as a final object. *)
#[global] Instance Terminal_unit : Terminal Fun unit :=
  fun _ x => tt.

(** ** The [sum] coproduct. *)

(** Coproduct elimination *)
#[global] Instance case_sum : Case Fun sum :=
  fun {A B C} (f : A -> C) (g : B -> C) (x : A + B) =>
    match x with
    | inl a => f a
    | inr b => g b
    end.

(** Injections *)
#[global] Instance sum_inl : Inl Fun sum := @inl.
#[global] Instance sum_inr : Inr Fun sum := @inr.

(** ** The [pair] product. *)
#[global] Instance Pair_Fun : Pair Fun prod :=
  fun {A B C} l r c => (l c, r c).

#[global] Instance Fst_Fun : Fst Fun prod := @fst.
#[global] Instance Snd_Fun : Snd Fun prod := @snd.

(** ** Cartesian closure. *)
(** The [exponential] is just [_ -> _], which is a just another name for [Fun] *)
#[global] Instance Apply_Fun : Apply Fun prod Fun :=
    fun {A B} '(f, b) => f b.

#[global] Instance Curry_Fun : Curry Fun prod Fun :=
  fun {A B C} f => fun c a => f (c, a).


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Structure.Limit.
Require Export Category.Structure.Span.
Require Export Category.Structure.Pullback.

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

Definition Pullback_Limit {C : Category} (F : Cospan C) := Limit F.
Arguments Pullback_Limit {_%category} F%functor /.

Definition Pushout_Limit {C : Category} (F : Span C) := Colimit F.
Arguments Pushout_Limit {_%category} F%functor /.

Program Definition Pullback_to_Universal {C : Category}
        (F : Cospan C) (P : Pullback_Limit F) :
  Pullback (unop (fmap[F] ZeroNeg)) (unop (fmap[F] ZeroPos)) := {|
  Pull := P;
  pullback_fst := vertex_map;
  pullback_snd := vertex_map
|}.
Next Obligation.
  pose proof (@ump_cones _ _ _ P).
  unfold unop.
  rewrite !X.
  reflexivity.
Qed.
Next Obligation.
  given (cone : Cone F). {
    unshelve (refine {| vertex_obj := Q |}); intros.
      destruct x; auto.
      exact (unop (fmap[F] ZeroPos) ∘ q2).
    simpl;
    destruct x, y; auto with roof_laws; simpl in f;
    rewrite (RoofHom_inv _ _ f); cat.
  }
  destruct P, limit_cone; simpl in *.
  exists (unique_morphism (ump_limits cone)). {
    split;
    [ pose proof (unique_property (ump_limits cone) RNeg)
    | pose proof (unique_property (ump_limits cone) RPos) ];
    unfold cone in *; simpl in *; clear cone;
    rewrites; reflexivity.
  }
  intros.
  apply (uniqueness (ump_limits cone)); intros.
  simpl in *.
  destruct x, X0; simpl; auto.
  rewrites.
  rewrite comp_assoc.
  unfold unop.
  rewrite ump_cones.
  reflexivity.
Qed.

Program Definition Pullback_from_Universal {C : Category}
        {x y z : C} (f : x ~> z) (g : y ~> z) (P : Pullback f g) :
  Pullback_Limit (@ASpan (C^op) _ _ _ f g)^op := {|
  limit_cone := {| vertex_obj := P |}
|}.
Next Obligation.
  destruct x0;
  destruct P; simpl in *; auto.
  exact (f ∘ pullback_fst).
Defined.
Next Obligation.
  destruct x0, y0;
  destruct P; simpl in *; auto with roof_laws; cat.
Qed.
Next Obligation.
  destruct P, N; simpl in *.
  assert (eqv : f ∘ vertex_map RNeg ≈ g ∘ vertex_map RPos).
    rewrite (ump_cones RNeg RZero ZeroNeg).
    rewrite (ump_cones RPos RZero ZeroPos).
    reflexivity.
  unfold Pullback_from_Universal_obligation_1; simpl.
  destruct (ump_pullbacks vertex_obj (vertex_map RNeg) (vertex_map RPos) eqv).
  construct; simplify; auto.
    destruct x0; auto.
    rewrite <- comp_assoc.
    rewrite unique_property.
    apply (ump_cones RNeg RZero ZeroNeg).
  apply uniqueness.
  split.
    apply (X RNeg).
  apply (X RPos).
Defined.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Import Lia.
Require Export CoRN.algebra.CMonoids.
Require Export CoRN.model.monoids.Nmonoid.
Require Export CoRN.model.setoids.Nfinsetoid.

Section p70text.

(**
** A morphism from the natural numbers to the free setoid with one element
*)

Let A:= (CSetoid_of_less 1).

(* begin hide *)
Let ZerolessOne: 0<1.
Proof.
 intuition.
Qed.

(* end hide *)

Fixpoint to_word (n:nat):(list (F 1)):=
match n with
|0 => (@nil (F 1))
|(S m)=> (cons (Build_F 1 0 ZerolessOne)(to_word m))
end.

Definition to_word_: nat_as_CMonoid -> (free_monoid_as_CMonoid A).
Proof.
 simpl.
 unfold Astar.
 unfold A.
 intro n.
 unfold CSetoid_of_less.
 simpl.
 apply to_word.
 exact n.
Defined.

Hint Extern 10 => lia : core.

Lemma  to_word_strext: (fun_strext to_word_).
Proof.
 unfold fun_strext; simpl.
 induction x; destruct y; firstorder with bool.
Qed.

Definition to_word_as_CSetoid_fun:=
(Build_CSetoid_fun nat_as_CSetoid (free_csetoid_as_csetoid  A) to_word_ to_word_strext).

Lemma to_word_bijective: (bijective to_word_as_CSetoid_fun).
Proof.
 unfold bijective.
 split.
  unfold injective.
  simpl.
  intros a0.
  induction a0.
   intro a1.
   case a1.
    unfold ap_nat.
    intuition.
   simpl.
   intuition.
  intro a1.
  case a1.
   simpl.
   intuition.
  intros n H.
  unfold ap_nat in H.
  simpl.
  right.
  apply IHa0.
  unfold ap_nat.
  intro H1.
  rewrite H1 in H.
  apply H.
  reflexivity.
 unfold surjective.
 simpl.
 unfold Astar.
 unfold A.
 intro b.
 induction b.
  exists 0.
  simpl.
  exact I.
 elim IHb.
 intros c H.
 exists (S c).
 split.
  simpl in a.
  elim a.
  simpl.
  intuition.
 exact H.
Qed.

Lemma pres_plus_to_word:
forall (n m: nat_as_CMonoid),(to_word_ n)[+](to_word_ m)[=](to_word_ (n[+]m)).
Proof.
 simpl.
 intros n m.
 induction n.
  simpl.
  apply eq_fm_reflexive.
 simpl.
 intuition.
Qed.

End p70text.