(** * (co)limits assemble into functors *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import KanExtensions.Core KanExtensions.Functors.
Require Import Limits.Core.
Require Import Adjoint.UniversalMorphisms.Core.
Require Import FunctorCategory.Core.
Require Import Adjoint.Core.
Require Import InitialTerminalCategory.Core NatCategory.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

(** (co)limits assemble into functors *)

Local Open Scope category_scope.

Section functors.
  Context `{Funext}.
  Variables C D : PreCategory.

  (** ** Colimit functor, which is left adjoint to Δ *)
  Section colimit.
    Context `(has_colimits
              : forall F : Functor D C,
                  @IsColimit _ C D F (colimits F)).

    (** TODO(jgross): We'll probably want to compose this with the
        functor from [1 → C] to [C], and then compose the adjunctions
        similarly.  This will require turning the equality in the
        exponential laws into an adjunction. Probably not very
        hard. *)

    Definition colimit_functor : Functor (D -> C) (1 -> C)
      := left_kan_extension_functor has_colimits.

    Definition colimit_adjunction
    : colimit_functor -| diagonal_functor _ _
      := left_kan_extension_adjunction has_colimits.
  End colimit.

  Section limit.
    Context `(has_limits
              : forall F : Functor D C,
                  @IsLimit _ C D F (limits F)).

    (** TODO(jgross): We'll probably want to compose this with the
        functor from [1 -> C] to [C], and then compose the adjunctions
        similarly.  This will require turning the equality in the
        exponential laws into an adjunction. Probably not very
        hard. *)

    (** ** Limit functor, which is right adjoint to Δ *)
    Definition limit_functor : Functor (D -> C) (1 -> C)
      := right_kan_extension_functor has_limits.

    Definition limit_adjunction
    : diagonal_functor _ _ -| limit_functor
      := right_kan_extension_adjunction has_limits.
  End limit.
End functors.


Require Import propInv4.
Require Import verif_cond_3.
Require Import extra3.
Local Open Scope Z.

Theorem proof4_3: (startnewloop hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1) /\ cond3 ->
 (inv hands1 dryer2 ctrlState1 ctrlTimer1 timer1).

Proof.
intros.
split.
unfold propInv4.
inversion_clear H.
inversion_clear H1.
inversion_clear H2.
intros.
(*analysis of cases i<timer1 and i=timer1*)
elim Zle_lt_or_eq with i timer1.
intros.
(*prove that dryer1 and dryer2 are equal in all indexes j<timer1*)
assert (Hdryer1_dryer2_same : (forall j, j<timer1 -> dryer1.[of_Z j]=dryer2.[of_Z j])).
intros.
apply arr_same_before_upd with OFF timer1.
split; assumption.
rewrite <- Hdryer1_dryer2_same.
rewrite <- Hdryer1_dryer2_same in H4.
apply startnewloop_to_propInv.
assumption.
split.
apply H2.
inversion_clear H0.
auto with zarith.
assumption.
auto with zarith.
assumption.
(*analysis of case i=timer1*)
intros.
rewrite H5 in H4.
inversion_clear H4.
elimtype False.
auto.
inversion_clear H2.
assumption.
apply extra3.
split.
inversion_clear H.
inversion_clear H0.
split.
apply H.
assumption.
apply H.
Qed.


Require Import Coq.ZArith.ZArith Coq.micromega.Psatz.
Require Import Crypto.LegacyArithmetic.Interface.
Require Import Crypto.LegacyArithmetic.InterfaceProofs.
Require Import Crypto.LegacyArithmetic.Double.Core.
Require Import Crypto.LegacyArithmetic.Double.Proofs.Decode.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Notations.
Require Import Crypto.Util.LetIn.
Import Bug5107WorkAround.
Import BoundedRewriteNotations.

Local Open Scope Z_scope.

Lemma decode_is_spread_left_immediate_iff
      {n W}
      {decode : decoder n W}
      {sprl : spread_left_immediate W}
      {isdecode : is_decode decode}
  : is_spread_left_immediate sprl
    <-> (forall r count,
            0 <= count < n
            -> tuple_decoder (sprl r count) = decode r << count).
Proof.
  rewrite is_spread_left_immediate_alt by assumption.
  split; intros H r count Hc; specialize (H r count Hc); revert H;
    pose proof (decode_range r);
    assert (0 < 2^count < 2^n) by auto with zarith;
    autorewrite with simpl_tuple_decoder;
    simpl; intro H'; rewrite H';
      autorewrite with Zshift_to_pow;
      Z.rewrite_mod_small; reflexivity.
Qed.

Global Instance decode_is_spread_left_immediate
       {n W}
       {decode : decoder n W}
       {sprl : spread_left_immediate W}
       {isdecode : is_decode decode}
       {issprl : is_spread_left_immediate sprl}
  : forall r count,
    (0 <= count < n)%bounded_rewrite
    -> tuple_decoder (sprl r count) <~=~> decode r << count
  := proj1 decode_is_spread_left_immediate_iff _.

Section tuple2.
  Section spread_left.
    Context (n : Z) {W}
            {ldi : load_immediate W}
            {shl : shift_left_immediate W}
            {shr : shift_right_immediate W}
            {decode : decoder n W}
            {isdecode : is_decode decode}
            {isldi : is_load_immediate ldi}
            {isshl : is_shift_left_immediate shl}
            {isshr : is_shift_right_immediate shr}.

    Lemma spread_left_from_shift_correct
          r count
          (H : 0 < count < n)
      : (decode (shl r count) + decode (shr r (n - count)) << n = decode r << count mod (2^n*2^n))%Z.
    Proof using isdecode isshl isshr.
      assert (0 <= count < n) by lia.
      assert (0 <= n - count < n) by lia.
      assert (0 < 2^(n-count)) by auto with zarith.
      assert (2^count < 2^n) by auto with zarith.
      pose proof (decode_range r).
      assert (0 <= decode r * 2 ^ count < 2 ^ n * 2^n) by auto with zarith.
      push_decode; autorewrite with Zshift_to_pow zsimplify.
      replace (decode r / 2^(n-count) * 2^n)%Z with ((decode r / 2^(n-count) * 2^(n-count)) * 2^count)%Z
        by (rewrite <- Z.mul_assoc; autorewrite with pull_Zpow zsimplify; reflexivity).
      rewrite Z.mul_div_eq' by lia.
      autorewrite with push_Zmul zsimplify.
      rewrite <- Z.mul_mod_distr_r_full, Z.add_sub_assoc.
      repeat autorewrite with pull_Zpow zsimplify in *.
      reflexivity.
    Qed.

    Global Instance is_spread_left_from_shift
      : is_spread_left_immediate (sprl_from_shift n).
    Proof using Type*.
      apply is_spread_left_immediate_alt.
      intros r count; intros.
      pose proof (decode_range r).
      assert (0 < 2^n) by auto with zarith.
      assert (decode r < 2^n * 2^n) by (generalize dependent (decode r); intros; nia).
      autorewrite with simpl_tuple_decoder.
      destruct (Z_zerop count).
      { subst; autorewrite with Zshift_to_pow zsimplify.
        simpl; push_decode.
        autorewrite with push_Zpow zsimplify.
        reflexivity. }
      simpl.
      rewrite <- spread_left_from_shift_correct by lia.
      autorewrite with zsimplify Zpow_to_shift.
      reflexivity.
    Qed.
  End spread_left.

  Section full_from_half.
    Context {W}
            {mulhwll : multiply_low_low W}
            {mulhwhl : multiply_high_low W}
            {mulhwhh : multiply_high_high W}
            {adc : add_with_carry W}
            {shl : shift_left_immediate W}
            {shr : shift_right_immediate W}
            {half_n : Z}
            {ldi : load_immediate W}
            {decode : decoder (2 * half_n) W}
            {ismulhwll : is_mul_low_low half_n mulhwll}
            {ismulhwhl : is_mul_high_low half_n mulhwhl}
            {ismulhwhh : is_mul_high_high half_n mulhwhh}
            {isadc : is_add_with_carry adc}
            {isshl : is_shift_left_immediate shl}
            {isshr : is_shift_right_immediate shr}
            {isldi : is_load_immediate ldi}
            {isdecode : is_decode decode}.

    Local Arguments Z.mul !_ !_.
    Lemma spread_left_from_shift_half_correct
          r
      : (decode (shl r half_n) + decode (shr r half_n) * (2^half_n * 2^half_n)
         = (decode r * 2^half_n) mod (2^half_n*2^half_n*2^half_n*2^half_n))%Z.
    Proof using Type*.
      destruct (0 <? half_n) eqn:Hn; Z.ltb_to_lt.
      { pose proof (spread_left_from_shift_correct (2*half_n) r half_n) as H.
        specialize_by lia.
        autorewrite with Zshift_to_pow push_Zpow zsimplify in *.
        rewrite !Z.mul_assoc in *.
        simpl in *; rewrite <- H; reflexivity. }
      { pose proof (decode_range r).
        pose proof (decode_range (shr r half_n)).
        pose proof (decode_range (shl r half_n)).
        simpl in *.
        autorewrite with push_Zpow in *.
        destruct (Z_zerop half_n).
        { subst; simpl in *.
          autorewrite with zsimplify.
          nia. }
        assert (half_n < 0) by lia.
        assert (2^half_n = 0) by auto with zarith.
        assert (0 < 0) by nia; omega. }
    Qed.
  End full_from_half.
End tuple2.


Require Import A1_Plan A2_Orientation A3_Metrique A4_Droite A5_Cercle A6_Intersection A7_Tactics.
Require Import B7_Tactics.

Section DISTANCE.

(* L'ensemble des distances est isomorphe a la demi-droite [OU). *)

Definition Distance (A B : Point) : Point.
Proof.
	setCircle0 Oo A B ipattern:(c).
	setInterDiameter1 lineOoUu c ipattern:(M).
	 immediate1.
	 exact M.
Defined.

Definition IsDistance (d : Point) := ClosedRay Oo Uu d.

Lemma DiameterlineOoUuuCircle :  Diameter lineOoUu uCircle.
Proof.
	simpl in |- *; immediate1.
Qed.

Ltac destructDistance A B AB := unfold Distance;
let H1 := fresh in (
	let H2 := fresh in (
		let H3 := fresh in (
			destruct (PointDef (fun M : Point =>
     				OnCircle1 (Compass Oo A B) M /\
     				EquiOriented (Center (Compass Oo A B)) M (LineA lineOoUu) (LineB lineOoUu)))
  			as (AB, ((H1, H2), H3))))).

Lemma EquiDistantSym : forall A B C D : Point,
	EquiDistant A B C D -> EquiDistant C D A B.
Proof.
	intros.
	apply (EquiDistantRec A B).
	 trivial.
	 apply EquiDistantRefl.
Qed.

Lemma IsDistanceDistance : forall A B : Point, IsDistance (Distance A B).
Proof.
	intros; destructDistance ipattern:(A) ipattern:(B) ipattern:(AB); simpl in *.
	unfold IsDistance in |- *; immediate1.
Qed.

Lemma EquiDistantDistance : forall A B : Point, EquiDistant Oo (Distance A B) A B.
Proof.
	intros; destructDistance ipattern:(A) ipattern:(B) ipattern:(AB); simpl in *.
	trivial.
Qed.

Lemma DistanceEq : forall A B C D : Point,
	EquiDistant A B C D -> Distance A B = Distance C D.
Proof.
	intros; destructDistance ipattern:(A) ipattern:(B) ipattern:(AB); destructDistance ipattern:(C) ipattern:(D) ipattern:(CD); simpl in *.
	apply H2; split.
	 apply (EquiDistantRec C D).
	  apply EquiDistantSym; trivial.
	  apply EquiDistantSym; trivial.
	 trivial.
Qed.

Lemma EqDistance : forall A B C D : Point,
	Distance A B = Distance C D -> EquiDistant A B C D.
Proof.
	intros; apply (EquiDistantRec Oo (Distance A B)).
	 apply EquiDistantDistance.
	 rewrite H; apply EquiDistantDistance.
Qed.

Lemma EqDistanceDistance : forall A B : Point, Distance Oo (Distance A B) = Distance A B.
Proof.
	intros; apply DistanceEq; apply EquiDistantDistance.
Qed.

Lemma NullDistance : forall A : Point, Distance A A = Oo.
Proof.
	intros; destructDistance ipattern:(A) ipattern:(A) ipattern:(AA); simpl in *.
	apply H1; split.
	 apply EquiDistantAABB.
	 immediate1.
Qed.

Lemma EqNullDistance : forall A B : Point, A = B -> Distance A B = Oo.
Proof.
	intros.
	rewrite H; apply NullDistance.
Qed.

Lemma DistinctEqDistanceDistinct : forall A B C D : Point,
	A <> B -> Distance A B = Distance C D -> C <> D.
Proof.
	intros.
	setLine0 A B ipattern:(ab).
	setCircle0 A C D ipattern:(g).
	setInterDiameter1 ab g ipattern:(E).
	 immediate1.
	 intro; elim H.
	   rewrite <- (Hun A).
	  apply Hun; split.
	   apply EqDistance; trivial.
	   immediate1.
	  split.
	   rewrite H1; apply EquiDistantAABB.
	   immediate1.
Qed.

Lemma DistanceEqDistanceDistinct : forall A B d : Point,
	d <> Oo -> Distance A B = d -> A <> B.
Proof.
	red in |- *; intros.
	subst; elim H.
	apply NullDistance.
Qed.

Lemma IsDistanceEqDistance : forall d : Point,
	IsDistance d ->
	Distance Oo d = d.
Proof.
	intros; destructDistance Oo ipattern:(d) ipattern:(dd).
	apply H2; split.
	 simpl in |- *; apply EquiDistantRefl.
	 unfold IsDistance in H; immediate1.
Qed.

Lemma DistanceNotNull : forall A B : Point,
	A <> B -> Distance A B <> Oo.
Proof.
	intros; apply sym_not_eq.
	apply (DistinctEqDistanceDistinct A B).
	trivial.
	rewrite EqDistanceDistance; trivial.
Qed.

Lemma NotNullDistance : forall A B : Point,
	Distance A B <> Oo -> A <> B.
Proof.
	red in |- *; intros; subst.
	elim H; apply NullDistance.
Qed.

Lemma DistanceSym : forall A B : Point,
	Distance A B = Distance B A.
Proof.
	intros; apply DistanceEq.
	apply EquiDistantABBA.
Qed.

Lemma EqDistanceTriangleSpec : forall A B C D E F A' B' C' D' E' F' : Point,
	TriangleSpec1 A B C D E F ->
	Distance A B = Distance A' B' ->
	Distance C D = Distance C' D' ->
	Distance E F = Distance E' F' ->
	TriangleSpec1 A' B' C' D' E' F'.
Proof.
	unfold TriangleSpec1 in |- *; intuition.
 	destruct H3 as (I, (J, (K, (L, (H6, (H7, (H8, (H9, H10)))))))).
 	  exists I; exists J; exists K; exists L; intuition.
 	 apply EqDistance; rewrite <- H0; apply DistanceEq; trivial.
 	 apply EqDistance; rewrite <- H1; apply DistanceEq; trivial.
 	 apply EqDistance; rewrite <- H2; apply DistanceEq; trivial.
 	destruct H as (I, (J, (K, (L, (H6, (H7, (H8, (H9, H10)))))))).
 	  exists I; exists J; exists K; exists L; intuition.
 	 apply EqDistance; rewrite <- H1; apply DistanceEq; trivial.
 	 apply EqDistance; rewrite <- H2; apply DistanceEq; trivial.
 	 apply EqDistance; rewrite <- H0; apply DistanceEq; trivial.
 	destruct H5 as (I, (J, (K, (L, (H6, (H7, (H8, (H9, H10)))))))).
 	  exists I; exists J; exists K; exists L; intuition.
 	 apply EqDistance; rewrite <- H2; apply DistanceEq; trivial.
 	 apply EqDistance; rewrite <- H0; apply DistanceEq; trivial.
 	 apply EqDistance; rewrite <- H1; apply DistanceEq; trivial.
Qed.

Lemma UnitDistance : Distance Oo Uu = Uu.
Proof.
	apply IsDistanceEqDistance.
	unfold IsDistance in |- *; immediate1.
Qed.

End DISTANCE.


(*****************************************************************

 Change of base for enriched categories

 In this file, we define the change of base for enriched
 categories. In textbooks, this construction works as follows: if
 we have two monoidal categories `V₁` and `V₂` and a lax monoidal
 functor `F : V₁ ⟶ V₂`, then every category enriched over `V₁`
 gives rise to a category enriched over `V₂`. The objects stay the
 same and for the enriched morphisms, we use the functor `F`.

 However, in a univalent setting, we would like to restrict this
 construction. Let `V₁` be any monoidal category (for example,
 `Set`) and let `V₂` be the terminal monoidal category (only one
 object and only one morphism). Then we have a functor `V₁ ⟶ V₂`
 and as such, every category enriched over `V₁` is also enriched
 over the terminal monoidal category. However, between any two
 objects in a category enriched over the terminal monoidal
 category, there is at most one isomorphism. As such, if we leave
 the objects the same in this construction, this does not in
 general give rise to a univalent category.

 To guarantee that the change of base actually gives rise to a
 univalent category, we make two assumptions:
 - The functor `F` is fully faithful
 - The functor `F` is a strong monoidal functor
 Using these assumptions, the underlying category of the change
 of base remains the same: the only thing that changes, is the
 enrichment. As such, univalence of the change of base follows
 directly from the univalence of the original category.

 We also discuss the action of the change of base on functors
 and natural transformations.

 Contents
 1. Change of base: enrichment for categories
 2. Change of base: enrichment for functors
 3. Change of base: enrichment for natural transformations
 4. Change of base on the identity
 5. Change of base on composition

 *****************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Functors.

Local Open Scope cat.
Local Open Scope moncat.

Opaque fully_faithful_inv_hom.

Section ChangeOfBase.
  Context {V₁ V₂ : monoidal_cat}
          (F : strong_monoidal_functor V₁ V₂)
          (HF : fully_faithful F).

  (**
   1. Change of base: enrichment for categories
   *)
  Section Enrichment.
    Context {C : category}
            (E : enrichment C V₁).

    Definition change_of_base_enrichment_data
      : enrichment_data C V₂.
    Proof.
      simple refine (_ ,, _ ,, _ ,, _ ,, _).
      - exact (λ x y, F (E ⦃ x , y ⦄)).
      - exact (λ x, mon_functor_unit F · #F (enriched_id E x)).
      - exact (λ x y z, mon_functor_tensor F _ _ · #F (enriched_comp E x y z)).
      - exact (λ x y f, mon_functor_unit F · #F (enriched_from_arr E f)).
      - exact (λ x y f,
               enriched_to_arr
                 E
                 (fully_faithful_inv_hom
                    HF
                    _ _
                    (strong_functor_unit_inv F · f))).
    Defined.

    Definition change_of_base_enrichment_laws
      : enrichment_laws change_of_base_enrichment_data.
    Proof.
      repeat split.
      - intros x y ; cbn.
        refine (mon_functor_lunitor F (E ⦃ x, y ⦄) @ _).
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          apply tensor_comp_id_r.
        }
        rewrite !assoc'.
        apply maponpaths.
        refine (!_).
        etrans.
        {
          do 2 apply maponpaths.
          exact (enrichment_id_left E x y).
        }
        rewrite functor_comp.
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          refine (!_).
          apply tensor_mon_functor_tensor.
        }
        apply maponpaths_2.
        apply maponpaths.
        apply functor_id.
      - intros x y ; cbn.
        refine (mon_functor_runitor F (E ⦃ x, y ⦄) @ _).
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          apply tensor_comp_id_l.
        }
        rewrite !assoc'.
        apply maponpaths.
        refine (!_).
        etrans.
        {
          do 2 apply maponpaths.
          exact (enrichment_id_right E x y).
        }
        rewrite functor_comp.
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          refine (!_).
          apply tensor_mon_functor_tensor.
        }
        do 2 apply maponpaths_2.
        apply functor_id.
      - intros w x y z ; cbn.
        refine (!_).
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths_2.
            apply tensor_comp_id_l.
          }
          rewrite !assoc'.
          apply maponpaths.
          rewrite !assoc.
          apply maponpaths_2.
          etrans.
          {
            do 2 apply maponpaths_2.
            refine (!_).
            apply functor_id.
          }
          apply (tensor_mon_functor_tensor F).
        }
        etrans.
        {
          rewrite !assoc.
          do 2 apply maponpaths_2.
          refine (!_).
          apply (mon_functor_lassociator F).
        }
        etrans.
        {
          rewrite !assoc'.
          do 2 apply maponpaths.
          rewrite <- !functor_comp.
          apply maponpaths.
          rewrite !assoc.
          refine (!_).
          apply enrichment_assoc.
        }
        refine (!_).
        etrans.
        {
          etrans.
          {
            apply maponpaths_2.
            apply tensor_comp_id_r.
          }
          rewrite !assoc'.
          apply maponpaths.
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            etrans.
            {
              apply maponpaths_2.
              apply maponpaths.
              refine (!_).
              apply functor_id.
            }
            apply (tensor_mon_functor_tensor F).
          }
          rewrite !assoc'.
          rewrite <- functor_comp.
          apply idpath.
        }
        apply idpath.
      - intros x y f ; cbn.
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths.
          etrans.
          {
            apply maponpaths_2.
            exact (strong_functor_unit_inv_unit F).
          }
          apply id_left.
        }
        rewrite fully_faithful_inv_hom_is_inv.
        apply enriched_to_from_arr.
      - intros x y f ; cbn.
        rewrite enriched_from_to_arr.
        rewrite functor_on_fully_faithful_inv_hom.
        rewrite assoc.
        refine (_ @ id_left _).
        apply maponpaths_2.
        exact (strong_functor_unit_unit_inv F).
      - intros x ; cbn.
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths.
          etrans.
          {
            apply maponpaths_2.
            exact (strong_functor_unit_inv_unit F).
          }
          apply id_left.
        }
        rewrite fully_faithful_inv_hom_is_inv.
        apply enriched_to_arr_id.
      - intros x y z f g ; cbn.
        refine (enriched_to_arr_comp E f g @ _).
        apply maponpaths.
        refine (!_).
        etrans.
        {
          apply maponpaths.
          rewrite !assoc'.
          etrans.
          {
            do 2 apply maponpaths.
            apply maponpaths_2.
            apply tensor_comp_mor.
          }
          rewrite !assoc'.
          etrans.
          {
            do 3 apply maponpaths.
            rewrite !assoc.
            apply maponpaths_2.
            apply (tensor_mon_functor_tensor F).
          }
          rewrite !assoc'.
          rewrite <- functor_comp.
          rewrite !assoc.
          etrans.
          {
            do 3 apply maponpaths_2.
            apply tensor_linvunitor.
          }
          rewrite !assoc'.
          etrans.
          {
            apply maponpaths.
            rewrite !assoc.
            do 2 apply maponpaths_2.
            refine (!(tensor_comp_l_id_l _ _ _) @ _).
            apply maponpaths.
            apply strong_functor_unit_inv_unit.
          }
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            refine (!_).
            apply (mon_functor_linvunitor F).
          }
          rewrite <- functor_comp.
          rewrite !assoc.
          apply idpath.
        }
        apply fully_faithful_inv_hom_is_inv.
    Qed.

    Definition change_of_base_enrichment
      : enrichment C V₂.
    Proof.
      simple refine (_ ,, _).
      - exact change_of_base_enrichment_data.
      - exact change_of_base_enrichment_laws.
    Defined.
  End Enrichment.

  (**
   2. Change of base: enrichment for functors
   *)
  Section EnrichmentFunctor.
    Context {C₁ C₂ : category}
            {H : C₁ ⟶ C₂}
            {E₁ : enrichment C₁ V₁}
            {E₂ : enrichment C₂ V₁}
            (HE : functor_enrichment H E₁ E₂).

    Definition change_of_base_functor_enrichment_laws
      : @is_functor_enrichment
          _ _ _
          H
          (change_of_base_enrichment E₁)
          (change_of_base_enrichment E₂)
          (λ x y : C₁, # F (HE x y)).
    Proof.
      repeat split.
      - intros x ; cbn.
        rewrite !assoc'.
        rewrite <- functor_comp.
        do 2 apply maponpaths.
        apply functor_enrichment_id.
      - intros x y z ; cbn.
        rewrite !assoc.
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          apply (tensor_mon_functor_tensor F).
        }
        rewrite !assoc'.
        rewrite <- !functor_comp.
        do 2 apply maponpaths.
        refine (!_).
        apply functor_enrichment_comp.
      - intros x y f ; cbn.
        rewrite !assoc'.
        rewrite <- (functor_comp F).
        do 2 apply maponpaths.
        apply functor_enrichment_from_arr.
    Qed.

    Definition change_of_base_functor_enrichment
      : functor_enrichment
          H
          (change_of_base_enrichment E₁)
          (change_of_base_enrichment E₂).
    Proof.
      simple refine (_ ,, _).
      - exact (λ x y, #F (HE x y)).
      - exact change_of_base_functor_enrichment_laws.
    Defined.
  End EnrichmentFunctor.

  (**
   3. Change of base: enrichment for natural transformations
   *)
  Definition change_of_base_nat_trans_enrichment
             {C₁ C₂ : category}
             {H₁ H₂ : C₁ ⟶ C₂}
             {τ : H₁ ⟹ H₂}
             {E₁ : enrichment C₁ V₁}
             {E₂ : enrichment C₂ V₁}
             {HE₁ : functor_enrichment H₁ E₁ E₂}
             {HE₂ : functor_enrichment H₂ E₁ E₂}
             (Hτ : nat_trans_enrichment τ HE₁ HE₂)
    : nat_trans_enrichment
        τ
        (change_of_base_functor_enrichment HE₁)
        (change_of_base_functor_enrichment HE₂).
  Proof.
    intros x y ; cbn.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths_2.
        apply tensor_comp_l_id_l.
      }
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      etrans.
      {
        apply maponpaths_2.
        apply (tensor_mon_functor_tensor F).
      }
      rewrite !assoc'.
      rewrite <- functor_comp.
      apply idpath.
    }
    etrans.
    {
      rewrite !assoc.
      apply maponpaths_2.
      refine (!_).
      apply (mon_functor_rinvunitor F).
    }
    refine (!_).
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths_2.
        apply tensor_comp_r_id_l.
      }
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      etrans.
      {
        apply maponpaths_2.
        apply (tensor_mon_functor_tensor F).
      }
      rewrite !assoc'.
      rewrite <- functor_comp.
      apply idpath.
    }
    etrans.
    {
      rewrite !assoc.
      apply maponpaths_2.
      refine (!_).
      apply (mon_functor_linvunitor F).
    }
    rewrite <- !functor_comp.
    apply maponpaths.
    rewrite !assoc.
    refine (!_).
    apply Hτ.
  Qed.

  (**
   4. Change of base on the identity
   *)
  Definition change_of_base_enrichment_identity
             {C : univalent_category}
             (E : enrichment C V₁)
    : nat_trans_enrichment
        (λ _, identity _)
        (functor_id_enrichment (change_of_base_enrichment E))
        (change_of_base_functor_enrichment (functor_id_enrichment E)).
  Proof.
    intros x y ; cbn.
    rewrite !enriched_from_arr_id.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      rewrite tensor_comp_l_id_l.
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      rewrite (tensor_mon_functor_tensor F).
      rewrite !assoc'.
      rewrite <- functor_comp.
      rewrite <- enrichment_id_right.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      refine (!_).
      apply (mon_functor_runitor F).
    }
    rewrite mon_rinvunitor_runitor.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      rewrite tensor_comp_r_id_l.
      rewrite !assoc'.
      apply maponpaths.
      rewrite <- !functor_id.
      rewrite !assoc.
      rewrite (tensor_mon_functor_tensor F).
      rewrite !assoc'.
      rewrite <- functor_comp.
      rewrite <- enrichment_id_left.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      refine (!_).
      apply (mon_functor_lunitor F).
    }
    rewrite mon_linvunitor_lunitor.
    apply idpath.
  Qed.

  Definition change_of_base_enrichment_identity_inv
             {C : univalent_category}
             (E : enrichment C V₁)
    : nat_trans_enrichment
        (λ _, identity _)
        (change_of_base_functor_enrichment (functor_id_enrichment E))
        (functor_id_enrichment (change_of_base_enrichment E)).
  Proof.
    intros x y ; cbn.
    rewrite !enriched_from_arr_id.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      rewrite tensor_comp_l_id_l.
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      rewrite <- functor_id.
      rewrite (tensor_mon_functor_tensor F).
      rewrite !assoc'.
      rewrite <- functor_comp.
      rewrite <- enrichment_id_right.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      refine (!_).
      apply (mon_functor_runitor F).
    }
    rewrite mon_rinvunitor_runitor.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      rewrite tensor_comp_r_id_l.
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      rewrite (tensor_mon_functor_tensor F).
      rewrite !assoc'.
      rewrite <- functor_comp.
      rewrite <- enrichment_id_left.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      refine (!_).
      apply (mon_functor_lunitor F).
    }
    rewrite mon_linvunitor_lunitor.
    apply idpath.
  Qed.

  (**
   5. Change of base on composition
   *)
  Definition change_of_base_enrichment_comp
             {C₁ C₂ C₃ : univalent_category}
             {G₁ : C₁ ⟶ C₂}
             {G₂ : C₂ ⟶ C₃}
             {E₁ : enrichment C₁ V₁}
             {E₂ : enrichment C₂ V₁}
             {E₃ : enrichment C₃ V₁}
             (EG₁ : functor_enrichment G₁ E₁ E₂)
             (EG₂ : functor_enrichment G₂ E₂ E₃)
    : nat_trans_enrichment
        (λ c, identity _)
        (functor_comp_enrichment
           (change_of_base_functor_enrichment EG₁)
           (change_of_base_functor_enrichment EG₂))
        (change_of_base_functor_enrichment (functor_comp_enrichment EG₁ EG₂)).
  Proof.
    intros x y ; cbn.
    rewrite !enriched_from_arr_id.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      rewrite tensor_comp_l_id_l.
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      rewrite (tensor_mon_functor_tensor F).
      rewrite !assoc'.
      rewrite <- functor_comp.
      do 2 apply maponpaths.
      rewrite tensor_split'.
      rewrite !assoc'.
      rewrite <- enrichment_id_right.
      rewrite tensor_runitor.
      apply idpath.
    }
    rewrite functor_comp.
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      rewrite <- (mon_functor_runitor F).
      apply idpath.
    }
    rewrite !assoc.
    rewrite mon_rinvunitor_runitor.
    rewrite id_left.
    refine (!_).
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      rewrite <- functor_comp.
      rewrite tensor_comp_r_id_l.
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      rewrite (tensor_mon_functor_tensor F).
      rewrite !assoc'.
      rewrite <- functor_comp.
      do 2 apply maponpaths.
      rewrite tensor_split.
      rewrite !assoc'.
      rewrite <- enrichment_id_left.
      rewrite tensor_lunitor.
      apply idpath.
    }
    rewrite functor_comp.
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      rewrite <- (mon_functor_lunitor F).
      apply idpath.
    }
    rewrite !assoc.
    rewrite mon_linvunitor_lunitor.
    rewrite id_left.
    apply idpath.
  Qed.

  Definition change_of_base_enrichment_comp_inv
             {C₁ C₂ C₃ : univalent_category}
             {G₁ : C₁ ⟶ C₂}
             {G₂ : C₂ ⟶ C₃}
             {E₁ : enrichment C₁ V₁}
             {E₂ : enrichment C₂ V₁}
             {E₃ : enrichment C₃ V₁}
             (EG₁ : functor_enrichment G₁ E₁ E₂)
             (EG₂ : functor_enrichment G₂ E₂ E₃)
    : nat_trans_enrichment
        (λ c, identity _)
        (change_of_base_functor_enrichment (functor_comp_enrichment EG₁ EG₂))
        (functor_comp_enrichment
           (change_of_base_functor_enrichment EG₁)
           (change_of_base_functor_enrichment EG₂)).
  Proof.
    intros x y ; cbn.
    rewrite !enriched_from_arr_id.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      rewrite <- functor_comp.
      rewrite tensor_comp_l_id_l.
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      rewrite (tensor_mon_functor_tensor F).
      rewrite !assoc'.
      rewrite <- functor_comp.
      do 2 apply maponpaths.
      rewrite tensor_split'.
      rewrite !assoc'.
      rewrite <- enrichment_id_right.
      rewrite tensor_runitor.
      apply idpath.
    }
    rewrite functor_comp.
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      rewrite <- (mon_functor_runitor F).
      apply idpath.
    }
    rewrite !assoc.
    rewrite mon_rinvunitor_runitor.
    rewrite id_left.
    refine (!_).
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      rewrite tensor_comp_r_id_l.
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      rewrite (tensor_mon_functor_tensor F).
      rewrite !assoc'.
      rewrite <- functor_comp.
      do 2 apply maponpaths.
      rewrite tensor_split.
      rewrite !assoc'.
      rewrite <- enrichment_id_left.
      rewrite tensor_lunitor.
      apply idpath.
    }
    rewrite functor_comp.
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      rewrite <- (mon_functor_lunitor F).
      apply idpath.
    }
    rewrite !assoc.
    rewrite mon_linvunitor_lunitor.
    rewrite id_left.
    apply idpath.
  Qed.
End ChangeOfBase.


Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import language.
Require Import state.
Require Import util.
Require Import semantic.
Require Import Unicode.Utf8.

Definition assertion := state -> Prop.

Definition emp : assertion :=
  fun st: state => snd st = emp_heap.

Definition point_to (e1 e2: aexp): assertion :=
  fun st: state =>
  match st with
  | (s,h) => h = h_update emp_heap (aeval s e1) (aeval s e2)
  end.
Notation "e1 '|->' e2" := (point_to e1 e2) (at level 60).

Definition sep_conj (p q : assertion) : assertion :=
    fun st: state =>
      match st with
      | (s, h) =>
        ∃ h1, ∃ h2,
          disjoint h1 h2 /\ h_union h1 h2 = h /\ p (s, h1) /\ q (s, h2)
      end.
Notation "p '**' q" := (sep_conj p q) (at level 70).

Definition sep_disj (p q: assertion) : assertion :=
  fun (st : state) =>
    match st with
    | (s, h) =>
      ∀ h', disjoint h' h -> p (s, h') -> q (s, h_union h h')
    end.
Notation "p '--*' q" := (sep_disj p q) (at level 80).

Definition s_conj (p q: assertion) : assertion :=
  fun (s: state) => p s /\ q s.
Notation "p '//\\' q" := (s_conj p q) (at level 75).

Definition s_disj (p q: assertion) : assertion :=
  fun (s: state) => p s \/ q s.
Notation "p '\\//' q" := (s_disj p q) (at level 78).

Definition s_imp (p q: assertion) : assertion :=
  fun (s: state) => p s -> q s.
Notation "p '-->' q" := (s_imp p q) (at level 85).

Definition strongerThan (p q: assertion) : Prop :=
  ∀ s: state, s_imp p q s.
Notation "p '==>' q" := (strongerThan p q) (at level 90).

Definition spEquiv (p q: assertion) : Prop :=
  (p ==> q) /\ (q ==> p).
Notation "p '<==>' q" := (spEquiv p q) (at level 90).

(* theorems of assertion *)
Lemma disj_star_distr: ∀ (p q r: assertion),
  (p \\// q) ** r <==> (p ** r) \\// (q ** r).
Proof.
  intros.
  unfold spEquiv. split.
  -unfold strongerThan, s_imp. intros.
   destruct s. destruct H. destruct H. destruct H. destruct H0.
   destruct H1. unfold s_disj in *. destruct H1.
   +left. unfold sep_conj. ∃ x. ∃ x0. auto.
   +right. unfold sep_conj. ∃ x. ∃ x0. auto.
  -unfold strongerThan, s_imp. intros.
   destruct s. unfold s_disj in *. destruct H.
   +simpl. repeat destruct H. destruct H0. destruct H1.
    ∃ x. ∃ x0. auto.
   +simpl. repeat destruct H. destruct H0. destruct H1.
    ∃ x. ∃ x0. auto.
Qed.

Lemma conj2disj : ∀ p1 p2 p3,
  p1 ** p2 ==> p3 ->
  p1 ==> p2 --* p3.
Proof.
  unfold strongerThan, s_imp. intros. destruct s.
  unfold sep_disj. intros. unfold sep_conj in *.
  apply H. ∃ h. ∃ h'. split.
  -apply disjoint_comm. assumption.
  -split. +reflexivity. +split; assumption.
Qed.


(**********************************************************************************

 The fiberwise product of two-sided displayed categories

 If we have two two-sided displayed categories over the same `C₁` and `C₂`, then
 we can form their product to obtain a new two-sided displayed category over `C₁`
 and `C₂`.

 Contents
 1. The definition
 2. Isomorphisms
 3. Univalence and discreteness

 **********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete.

Local Open Scope cat.

Definition transportf_dirprod_fam
           {X : UU}
           {Y₁ Y₂ : X → UU}
           {x₁ x₂ : X}
           (p : x₁ = x₂)
           (y : Y₁ x₁ × Y₂ x₁)
  : transportf
      (λ x, Y₁ x × Y₂ x)
      p
      y
    =
    transportf Y₁ p (pr1 y) ,, transportf Y₂ p (pr2 y).
Proof.
  induction p.
  apply idpath.
Defined.

Section FiberwiseProduct.
  Context {C₁ C₂ : category}
          (D₁ D₂ : twosided_disp_cat C₁ C₂).

  (**
   1. The definition
   *)
  Definition prod_of_twosided_disp_cat_ob_mor
    : twosided_disp_cat_ob_mor C₁ C₂.
  Proof.
    simple refine (_ ,, _).
    - exact (λ x y, D₁ x y × D₂ x y).
    - exact (λ x₁ x₂ y₁ y₂ xy₁ xy₂ f g,
             pr1 xy₁ -->[ f ][ g ] pr1 xy₂
             ×
             pr2 xy₁ -->[ f ][ g ] pr2 xy₂).
  Defined.

  Definition prod_of_twosided_disp_cat_id_comp
    : twosided_disp_cat_id_comp prod_of_twosided_disp_cat_ob_mor.
  Proof.
    simple refine (_ ,, _).
    - exact (λ x y xy, id_two_disp (pr1 xy) ,, id_two_disp (pr2 xy)).
    - exact (λ x₁ x₂ x₃ y₁ y₂ y₃ xy₁ xy₂ xy₃ f₁ f₂ g₁ g₂ fg₁ fg₂,
             (pr1 fg₁ ;;2 pr1 fg₂) ,, (pr2 fg₁ ;;2 pr2 fg₂)).
  Defined.

  Definition prod_of_twosided_disp_cat_data
    : twosided_disp_cat_data C₁ C₂.
  Proof.
    simple refine (_ ,, _).
    - exact prod_of_twosided_disp_cat_ob_mor.
    - exact prod_of_twosided_disp_cat_id_comp.
  Defined.

  Definition prod_of_twosided_disp_cat_axioms
    : twosided_disp_cat_axioms prod_of_twosided_disp_cat_data.
  Proof.
    repeat split.
    - intro ; intros ; cbn.
      unfold transportb.
      rewrite transportf_dirprod_fam.
      rewrite transportf_dirprod_fam.
      use dirprod_paths ; apply id_two_disp_left.
    - intro ; intros ; cbn.
      unfold transportb.
      rewrite transportf_dirprod_fam.
      rewrite transportf_dirprod_fam.
      use dirprod_paths ; apply id_two_disp_right.
    - intro ; intros ; cbn.
      unfold transportb.
      rewrite transportf_dirprod_fam.
      rewrite transportf_dirprod_fam.
      use dirprod_paths ; apply assoc_two_disp.
    - intro ; intros.
      apply isasetdirprod ; apply isaset_disp_mor.
  Qed.

  Definition prod_of_twosided_disp_cat
    : twosided_disp_cat C₁ C₂.
  Proof.
    simple refine (_ ,, _).
    - exact prod_of_twosided_disp_cat_data.
    - exact prod_of_twosided_disp_cat_axioms.
  Defined.

  (**
   2. Isomorphisms
   *)
  Definition make_is_iso_prod_of_twosided_disp_cat
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {f : x₁ --> x₂}
             (Hf : is_z_isomorphism f)
             {g : y₁ --> y₂}
             (Hg : is_z_isomorphism g)
             {xy₁₁ : D₁ x₁ y₁}
             {xy₁₂ : D₂ x₁ y₁}
             {xy₂₁ : D₁ x₂ y₂}
             {xy₂₂ : D₂ x₂ y₂}
             (fg₁ : xy₁₁ -->[ f ][ g ] xy₂₁)
             (Hfg₁ : is_iso_twosided_disp Hf Hg fg₁)
             (fg₂ : xy₁₂ -->[ f ][ g ] xy₂₂)
             (Hfg₂ : is_iso_twosided_disp Hf Hg fg₂)
    : @is_iso_twosided_disp
        _ _
        prod_of_twosided_disp_cat
        _ _ _ _
        (xy₁₁ ,, xy₁₂)
        (xy₂₁ ,, xy₂₂)
        f g
        Hf Hg
        (fg₁ ,, fg₂).
  Proof.
    simple refine ((_ ,, _) ,, _ ,, _).
    - exact (pr1 Hfg₁).
    - exact (pr1 Hfg₂).
    - abstract
        (cbn ;
         unfold transportb ;
         rewrite !transportf_dirprod_fam ;
         use pathsdirprod ;
         [ apply Hfg₁
         | apply Hfg₂ ]).
    - abstract
        (cbn ;
         unfold transportb ;
         rewrite !transportf_dirprod_fam ;
         use pathsdirprod ;
         [ apply Hfg₁
         | apply Hfg₂ ]).
  Defined.

  Definition isaprop_disp_twosided_mor_prod_of_twosided_disp_cat
             (HD₁ : isaprop_disp_twosided_mor D₁)
             (HD₂ : isaprop_disp_twosided_mor D₂)
    : isaprop_disp_twosided_mor prod_of_twosided_disp_cat.
  Proof.
    intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g fg fg'.
    apply pathsdirprod.
    - apply HD₁.
    - apply HD₂.
  Qed.

  Definition make_iso_prod_of_twosided_disp_cat
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {f : z_iso x₁ x₂}
             {g : z_iso y₁ y₂}
             {xy₁₁ : D₁ x₁ y₁}
             {xy₁₂ : D₂ x₁ y₁}
             {xy₂₁ : D₁ x₂ y₂}
             {xy₂₂ : D₂ x₂ y₂}
             (fg : iso_twosided_disp f g xy₁₁ xy₂₁
                   ×
                   iso_twosided_disp f g xy₁₂ xy₂₂)
    : @iso_twosided_disp
        _ _
        prod_of_twosided_disp_cat
        _ _ _ _
        f g
        (xy₁₁ ,, xy₁₂)
        (xy₂₁ ,, xy₂₂).
  Proof.
    simple refine ((_ ,, _) ,, _).
    - exact (pr11 fg).
    - exact (pr12 fg).
    - use make_is_iso_prod_of_twosided_disp_cat.
      + exact (pr21 fg).
      + exact (pr22 fg).
  Defined.

  Definition iso_prod_of_twosided_disp_cat_pr1
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {f : z_iso x₁ x₂}
             {g : z_iso y₁ y₂}
             {xy₁₁ : D₁ x₁ y₁}
             {xy₁₂ : D₂ x₁ y₁}
             {xy₂₁ : D₁ x₂ y₂}
             {xy₂₂ : D₂ x₂ y₂}
             (fg : @iso_twosided_disp
                     _ _
                     prod_of_twosided_disp_cat
                     _ _ _ _
                     f g
                     (xy₁₁ ,, xy₁₂)
                     (xy₂₁ ,, xy₂₂))
    : iso_twosided_disp f g xy₁₁ xy₂₁.
  Proof.
    simple refine (_ ,, _ ,, _ ,, _).
    - exact (pr11 fg).
    - exact (pr112 fg).
    - abstract
        (refine (maponpaths dirprod_pr1 (pr122 fg) @ _) ; cbn ;
         unfold transportb ;
         rewrite !transportf_dirprod_fam ;
         apply idpath).
    - abstract
        (refine (maponpaths dirprod_pr1 (pr222 fg) @ _) ; cbn ;
         unfold transportb ;
         rewrite !transportf_dirprod_fam ;
         apply idpath).
  Defined.

  Definition iso_prod_of_twosided_disp_cat_pr2
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {f : z_iso x₁ x₂}
             {g : z_iso y₁ y₂}
             {xy₁₁ : D₁ x₁ y₁}
             {xy₁₂ : D₂ x₁ y₁}
             {xy₂₁ : D₁ x₂ y₂}
             {xy₂₂ : D₂ x₂ y₂}
             (fg : @iso_twosided_disp
                     _ _
                     prod_of_twosided_disp_cat
                     _ _ _ _
                     f g
                     (xy₁₁ ,, xy₁₂)
                     (xy₂₁ ,, xy₂₂))
    : iso_twosided_disp f g xy₁₂ xy₂₂.
  Proof.
    simple refine (_ ,, _ ,, _ ,, _).
    - exact (pr21 fg).
    - exact (pr212 fg).
    - abstract
        (refine (maponpaths dirprod_pr2 (pr122 fg) @ _) ; cbn ;
         unfold transportb ;
         rewrite !transportf_dirprod_fam ;
         apply idpath).
    - abstract
        (refine (maponpaths dirprod_pr2 (pr222 fg) @ _) ; cbn ;
         unfold transportb ;
         rewrite !transportf_dirprod_fam ;
         apply idpath).
  Defined.

  Definition from_iso_prod_of_twosided_disp_cat
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {f : z_iso x₁ x₂}
             {g : z_iso y₁ y₂}
             {xy₁₁ : D₁ x₁ y₁}
             {xy₁₂ : D₂ x₁ y₁}
             {xy₂₁ : D₁ x₂ y₂}
             {xy₂₂ : D₂ x₂ y₂}
             (fg : @iso_twosided_disp
                     _ _
                     prod_of_twosided_disp_cat
                     _ _ _ _
                     f g
                     (xy₁₁ ,, xy₁₂)
                     (xy₂₁ ,, xy₂₂))
    : iso_twosided_disp f g xy₁₁ xy₂₁
      ×
      iso_twosided_disp f g xy₁₂ xy₂₂
    := iso_prod_of_twosided_disp_cat_pr1 fg
       ,,
       iso_prod_of_twosided_disp_cat_pr2 fg.

  Definition weq_iso_prod_of_twosided_disp_cat
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {f : z_iso x₁ x₂}
             {g : z_iso y₁ y₂}
             (xy₁₁ : D₁ x₁ y₁)
             (xy₁₂ : D₂ x₁ y₁)
             (xy₂₁ : D₁ x₂ y₂)
             (xy₂₂ : D₂ x₂ y₂)
    :(iso_twosided_disp f g xy₁₁ xy₂₁
      ×
      iso_twosided_disp f g xy₁₂ xy₂₂)
     ≃
     @iso_twosided_disp
        _ _
        prod_of_twosided_disp_cat
        _ _ _ _
        f g
        (xy₁₁ ,, xy₁₂)
        (xy₂₁ ,, xy₂₂).
  Proof.
    use weq_iso.
    - exact make_iso_prod_of_twosided_disp_cat.
    - exact from_iso_prod_of_twosided_disp_cat.
    - abstract
        (intro fg ;
         use pathsdirprod ;
         (use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ;
         apply idpath)).
    - abstract
        (intro fg ;
         use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ;
         apply idpath).
  Defined.

  (**
   3. Univalence and discreteness
   *)
  Definition prod_twosided_disp_cat_all_disp_mor_iso
             (HD₁ : all_disp_mor_iso D₁)
             (HD₂ : all_disp_mor_iso D₂)
    : all_disp_mor_iso prod_of_twosided_disp_cat.
  Proof.
    intro ; intros.
    use make_is_iso_prod_of_twosided_disp_cat.
    - apply HD₁.
    - apply HD₂.
  Defined.

  Definition is_univalent_prod_of_twosided_disp_cat
             (HD₁ : is_univalent_twosided_disp_cat D₁)
             (HD₂ : is_univalent_twosided_disp_cat D₂)
    : is_univalent_twosided_disp_cat prod_of_twosided_disp_cat.
  Proof.
    intros x₁ x₂ y₁ y₂ p₁ p₂ xy₁ xy₂.
    induction p₁, p₂ ; cbn.
    use weqhomot.
    - exact (weq_iso_prod_of_twosided_disp_cat _ _ _ _
             ∘ weqdirprodf
                 (_ ,, HD₁ x₁ x₁ y₁ y₁ (idpath _) (idpath _) _ _)
                 (_ ,, HD₂ x₁ x₁ y₁ y₁ (idpath _) (idpath _) _ _)
             ∘ pathsdirprodweq)%weq.
    - abstract
        (intro p ;
         induction p ; cbn ;
         use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ;
         apply idpath).
  Defined.

  Definition discrete_prod_twosided_disp_cat
             (HD₁ : discrete_twosided_disp_cat D₁)
             (HD₂ : discrete_twosided_disp_cat D₂)
    : discrete_twosided_disp_cat prod_of_twosided_disp_cat.
  Proof.
    repeat split.
    - use isaprop_disp_twosided_mor_prod_of_twosided_disp_cat.
      + apply HD₁.
      + apply HD₂.
    - use prod_twosided_disp_cat_all_disp_mor_iso.
      + apply HD₁.
      + apply HD₂.
    - use is_univalent_prod_of_twosided_disp_cat.
      + apply HD₁.
      + apply HD₂.
  Qed.
End FiberwiseProduct.


(** **********************************************************

Benedikt Ahrens, Ralph Matthes

SubstitutionSystems

2015

************************************************************)

(** **********************************************************

Contents :

- Derivation of Generalized Iteration in Mendler-style
- Instantiation to a special case, Specialized Mendler Iteration
- Proof of a fusion law à la Bird-Paterson (Generalised folds
  for nested datatypes) for Generalized Iteration in Mendler-style

************************************************************)

Require Export UniMath.Tactics.EnsureStructuredProofs.
Require Import UniMath.Foundations.PartD.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.yoneda.
Require Import UniMath.CategoryTheory.Adjunctions.Core.

Arguments functor_composite {_ _ _} _ _ .
Arguments nat_trans_comp {_ _ _ _ _} _ _ .
Local Notation "G ∙ F" := (functor_composite F G : [ _ , _ , _ ]) (at level 35).
Local Notation "C '^op'" := (opp_precat C) (at level 3, format "C ^op").
Local Notation "↓ f" := (mor_from_algebra_mor _ f) (at level 3, format "↓ f").
(* in Agda mode \downarrow *)

(** Goal: derive Generalized Iteration in Mendler-style and a fusion law *)

(** * Generalized Iteration in Mendler-style *)

Section GenMenIt.

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

Let AF := FunctorAlg F.

Definition AlgConstr (A : C) (α : F A --> A) : AF.
Proof.
  exists A.
  exact α.
Defined.

Notation "⟨ A , α ⟩" := (AlgConstr A α).
(* \<  , \> *)

Variable μF_Initial : Initial AF.

Let μF : C := alg_carrier _ (InitialObject μF_Initial).
Let inF : F μF --> μF := alg_map _ (InitialObject μF_Initial).

Let iter {A : C} (α : F A --> A) : μF --> A :=
  ↓(InitialArrow μF_Initial ⟨A,α⟩).

Context (C' : category).

Section the_iteration_principle.

Variable X : C'.

Let Yon : functor C'^op HSET := yoneda_objects C' X.

Variable L : functor C C'.

Variable is_left_adj_L : is_left_adjoint L.

Let φ := @φ_adj _ _ _ _ (pr2 is_left_adj_L).
Let φ_inv := @φ_adj_inv _ _ _ _ (pr2 is_left_adj_L).
Let R : functor _ _ := right_adjoint is_left_adj_L.
Let η : nat_trans _ _ := unit_from_left_adjoint is_left_adj_L.
Let ε : nat_trans _ _ := counit_from_left_adjoint is_left_adj_L.
(* Let φ_natural_precomp := @φ_adj_natural_precomp _ _ _ is_left_adj_L.
Let φ_inv_natural_precomp := @φ_adj_inv_natural_precomp _ _ _ is_left_adj_L.
Let φ_after_φ_inv := @φ_adj_after_φ_adj_inv _ _ _ is_left_adj_L.
Let φ_inv_after_φ := @φ_adj_inv_after_φ_adj _ _ _ is_left_adj_L.*)

Arguments φ {_ _} _ .
Arguments φ_inv {_ _} _ .

Definition ψ_source : functor C^op HSET := functor_composite (functor_opp L) Yon.
Definition ψ_target : functor C^op HSET := functor_composite (functor_opp F) ψ_source.

Section general_case.

Variable ψ : ψ_source ⟹ ψ_target.

Definition preIt : L μF --> X := φ_inv (iter (φ (ψ (R X) (ε X)))).

Lemma ψ_naturality (A B: C)(h: B --> A)(f: L A --> X): ψ B (#L h· f) = #L (#F h)· ψ A f.
Proof.
  assert (ψ_is_nat := nat_trans_ax ψ);
  assert (ψ_is_nat_inst1 := ψ_is_nat _ _ h).
  (* assert (ψ_is_nat_inst2 := aux0 _ _ _ _ f ψ_is_nat_inst1). *)
  assert (ψ_is_nat_inst2 := eqtohomot ψ_is_nat_inst1 f).
  apply ψ_is_nat_inst2.
Qed.

Lemma truth_about_ε (A: C'): ε A = φ_inv (identity (R A)).
Proof.
  unfold φ_inv, φ_adj_inv.
  rewrite functor_id.
  apply pathsinv0.
  apply id_left.
Qed.

Lemma φ_ψ_μF_eq (h: L μF --> X): φ (ψ μF h) = #F (φ h) · φ(ψ (R X) (ε X)).
Proof.
  rewrite <- (φ_adj_natural_precomp (pr2 is_left_adj_L)).
  apply maponpaths.
  eapply pathscomp0.
  2: apply ψ_naturality.
  apply maponpaths.
  rewrite truth_about_ε.
  rewrite <- (φ_adj_inv_natural_precomp (pr2 is_left_adj_L)).
  rewrite id_right.
  apply pathsinv0.
  change (φ_inv(φ h) = h).
  apply φ_adj_inv_after_φ_adj.
Qed.

Lemma cancel_φ {A: C}{B: C'} (f g : L A --> B): φ f = φ g -> f = g.
Proof.
  intro Hyp.
(* pedestrian way:
  rewrite <- (φ_adj_inv_after_φ_adj _ _ _ is_left_adj_L f).
  rewrite <- (φ_adj_inv_after_φ_adj _ _ _ is_left_adj_L g).
  apply maponpaths.
  exact Hyp.
*)
  apply (invmaponpathsweq (adjunction_hom_weq (pr2 is_left_adj_L) _ _)).
  exact Hyp.
Qed.

Lemma preIt_ok : # L inF· preIt = ψ μF preIt.
Proof.
    apply cancel_φ.
    rewrite φ_ψ_μF_eq.
    rewrite (φ_adj_natural_precomp (pr2 is_left_adj_L)).
    unfold preIt.
    rewrite (φ_adj_after_φ_adj_inv (pr2 is_left_adj_L)).
    rewrite (φ_adj_after_φ_adj_inv (pr2 is_left_adj_L)).
    assert (iter_eq := algebra_mor_commutes _ _ _ (InitialArrow μF_Initial ⟨_,φ (ψ (R X) (ε X))⟩)).
    exact iter_eq.
Qed.

Lemma preIt_uniq (t : ∑ h : L μF --> X, # L inF· h = ψ μF h):
    t = tpair (λ h : L μF --> X, # L inF· h = ψ μF h) preIt preIt_ok.
Proof.
    destruct t as [h h_rec_eq]; simpl.
    assert (same: h = preIt).
    2: {
      apply subtypePath.
      + intro. apply homset_property.
      + simpl.
        exact same.
    }
    apply cancel_φ.
    unfold preIt.
    rewrite (φ_adj_after_φ_adj_inv (pr2 is_left_adj_L)).
    (* assert (iter_uniq := algebra_mor_commutes _ _ _ *)
    (*                        (InitialArrow μF_Initial ⟨_,φ (ψ (R X) (ε X))⟩)). *)
    (* simpl in iter_uniq. *)
    assert(φh_is_alg_mor: inF · φ h = #F(φ h) · φ (ψ (R X) (ε X))).
      (* remark: I am missing a definition of the algebra morphism property in UniMath.CategoryTheory.FunctorAlgebras *)
    + rewrite <- φ_ψ_μF_eq.
      rewrite <- (φ_adj_natural_precomp (pr2 is_left_adj_L)).
      apply maponpaths.
      exact h_rec_eq.
    + (* set(φh_alg_mor := tpair _ _ φh_is_alg_mor : pr1 μF_Initial --> ⟨ R X, φ (ψ (R X) (ε X)) ⟩). *)
       use (let X : AF ⟦ InitialObject μF_Initial, ⟨ R X, φ (ψ (R X) (ε X)) ⟩ ⟧ := _ in _).
       * apply (tpair _ (φ h)); assumption.
       * apply (maponpaths pr1 (InitialArrowUnique _ _ X0)).
Qed.

Theorem GenMendlerIteration : iscontr (∑ h : L μF --> X, #L inF · h = ψ μF h).
Proof.
  use tpair.
  - exists preIt.
    exact preIt_ok.
  - exact preIt_uniq.
Defined.

Definition It : L μF --> X := pr1 (pr1 GenMendlerIteration).
Lemma It_is_preIt : It = preIt.
Proof.
  apply idpath.
Qed.

End general_case.

(** * Specialized Mendler Iteration *)

Section special_case.

  Variable G : functor C' C'.
  Variable ρ : G X --> X.
  Variable θ : functor_composite F L ⟹ functor_composite L G.

  Lemma is_nat_trans_ψ_from_comps
        :  is_nat_trans ψ_source ψ_target
                        (λ (A : C^op) (f : yoneda_objects_ob C' X (L A)), θ A· # G f· ρ).
  Proof.
    intros A B h.
      apply funextfun.
      intro f.
      simpl.
      unfold compose at 1 5; simpl.
      rewrite functor_comp.
      repeat rewrite assoc.
      assert (θ_nat_trans_ax := nat_trans_ax θ).
      unfold functor_composite in θ_nat_trans_ax.
      simpl in θ_nat_trans_ax.
      rewrite <- θ_nat_trans_ax.
      apply idpath.
   Qed.

  Definition ψ_from_comps : ψ_source ⟹ ψ_target.
  Proof.
    use tpair.
    - intro A. simpl. intro f.
      unfold yoneda_objects_ob in *.
      exact (θ A · #G f · ρ).
    - apply is_nat_trans_ψ_from_comps.
  Defined.

  Definition SpecialGenMendlerIteration :
    iscontr
      (∑ h : L μF --> X, # L inF · h = θ μF · #G h · ρ)
    := GenMendlerIteration ψ_from_comps.

End special_case.

End the_iteration_principle.

(** * Fusion law for Generalized Iteration in Mendler-style *)

Variable X X': C'.
Let Yon : functor C'^op HSET := yoneda_objects C' X.
Let Yon' : functor C'^op HSET := yoneda_objects C' X'.
Variable L : functor C C'.
Variable is_left_adj_L : is_left_adjoint L.
Variable ψ : ψ_source X L ⟹ ψ_target X L.
Variable L' : functor C C'.
Variable is_left_adj_L' : is_left_adjoint L'.
Variable ψ' : ψ_source X' L' ⟹ ψ_target X' L'.

Variable Φ : functor_composite (functor_opp L) Yon ⟹ functor_composite (functor_opp L') Yon'.

Section fusion_law.

  Variable H : ψ μF · Φ (F μF) = Φ μF · ψ' μF.

  Theorem fusion_law : Φ μF (It X L is_left_adj_L ψ) = It X' L' is_left_adj_L' ψ'.
  Proof.
    apply pathsinv0.
    apply pathsinv0.
    apply path_to_ctr.
    assert (Φ_is_nat := nat_trans_ax Φ).
    assert (Φ_is_nat_inst1 := Φ_is_nat _ _ inF).
    assert (Φ_is_nat_inst2 := eqtohomot Φ_is_nat_inst1 (It X L is_left_adj_L ψ)).
    unfold compose in Φ_is_nat_inst2; simpl in Φ_is_nat_inst2.
    simpl.
    rewrite <- Φ_is_nat_inst2.
    assert (H_inst :=  eqtohomot H (It X L is_left_adj_L ψ)).
    unfold compose in H_inst; simpl in H_inst.
    rewrite <- H_inst.
    apply maponpaths.
    rewrite It_is_preIt.
    apply preIt_ok.
  Qed.

End fusion_law.

End GenMenIt.


Require Import Coq.Lists.List. Import ListNotations.

Inductive stmt{varname funcname: Type}: Type :=
| SAdd(res arg1 arg2: varname)
| SSet(x: varname)(v: nat)
| SCall(f: funcname)(res: varname)(args: list varname).

Definition collect_varnames{V F}(s: stmt (varname:=V) (funcname:=F)): list V :=
  match s with
  | SAdd res arg1 arg2 => [res; arg1; arg2]
  | SSet x v => [x]
  | SCall f res args => res :: args
  end.

Inductive empty_funcname: Type := .

Definition simple_stmt := stmt (varname:=nat) (funcname:=empty_funcname).

Lemma number_of_vars_bound: forall (s: simple_stmt),
    length (collect_varnames s) <= 2.
Proof.
  (* call counterexample generator here *)

(* for <= 3: *)
  intros.
  destruct s; simpl; repeat constructor. destruct f.
Qed.


Require Export Coq.Unicode.Utf8.
Require Export StlcProd.

(******************************************************************************)
(* Typing relation.                                                           *)
(******************************************************************************)

Inductive PTyping (Γ: Env) : Pat → Ty → Env → Prop :=
  | P_Var {T} :
      PTyping Γ (pvar T) T (evar empty T)
  | P_Prod {p1 T1 Δ1 p2 T2 Δ2} :
      PTyping Γ p1 T1 Δ1 →
      PTyping (appendEnv Γ Δ1) p2 T2 Δ2 →
      PTyping Γ (pprod p1 p2) (tprod T1 T2) (appendEnv Δ1 Δ2).

Inductive Typing (Γ: Env) : Tm → Ty → Prop :=
  | T_Var {y T} :
      lookup_evar Γ y T → Typing Γ (var y) T
  | T_Unit :
      Typing Γ tt tunit
  | T_Abs {t T1 T2} :
      Typing (evar Γ T1) t T2 →
      Typing Γ (abs T1 t) (tarr T1 T2)
  | T_App {t1 t2 T11 T12} :
      Typing Γ t1 (tarr T11 T12) → Typing Γ t2 T11 →
      Typing Γ (app t1 t2) T12
  | T_Prod {t1 T1 t2 T2} :
      Typing Γ t1 T1 → Typing Γ t2 T2 →
      Typing Γ (prod t1 t2) (tprod T1 T2)
  | T_Let {p t1 t2 T1 T2 Δ} :
      Typing Γ t1 T1 → PTyping Γ p T1 Δ →
      Typing (appendEnv Γ Δ) t2 T2 →
      Typing Γ (lett p t1 t2) T2.
Arguments T_Unit {Γ}.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e254m127x2e240m1_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


(** **********************************************************

Benedikt Ahrens, Chris Kapulkin, Mike Shulman

january 2013

************************************************************)

(** **********************************************************

Contents :

                Subcategories, Full subcats

                  Image of a functor, full subcat specified
                                       by a functor

                  Subcategories, back to
                    Inclusion functor
                    Full image of a functor
                    Factorization of a functor via its
                       full image
                    This factorization is fully faithful
                       if the functor is
                       [functor_full_img_fully_faithful_if_fun_is]

                    Isos in full subcategory are equiv
                      to isos in the precategory

                    Full subcategory of a category is
                      a category
                      [is_category_full_subcat]

************************************************************)

Require Import Foundations.hlevel2.hSet.

Require Import RezkCompletion.pathnotations.
Import RezkCompletion.pathnotations.PathNotations.

Require Import RezkCompletion.auxiliary_lemmas_HoTT.

Require Import RezkCompletion.precategories.
Require Import RezkCompletion.functors_transformations.

Local Notation "a --> b" := (precategory_morphisms a b)(at level 50).
Local Notation "f ;; g" := (compose f g)(at level 50).
Local Notation "# F" := (functor_on_morphisms F)(at level 3).

(** * Sub-precategories *)

(** A sub-precategory is specified through a predicate on objects
    and a dependent predicate on morphisms
    which is compatible with identity and composition
*)

Definition is_sub_precategory {C : precategory}
    (C' : hsubtypes C)
    (Cmor' : forall a b : C, hsubtypes (a --> b)) :=
 dirprod (forall a : C, C' a ->  Cmor' _ _ (identity a ))
         (forall (a b c : C) (f: a --> b) (g : b --> c),
                   Cmor' _ _ f -> Cmor' _ _  g -> Cmor' _ _  (f ;; g)).

Definition sub_precategories (C : precategory) := total2 (
   fun C' : dirprod (hsubtypes (ob C))
                    (forall a b:ob C, hsubtypes (a --> b)) =>
        is_sub_precategory (pr1 C') (pr2 C')).

(** A full subcategory has the true predicate on morphisms *)

Lemma is_sub_precategory_full (C : precategory)
         (C':hsubtypes (ob C)) :
        is_sub_precategory C' (fun a b => fun f => htrue).
Proof.
  split;
  intros; exact tt.
Defined.

Definition full_sub_precategory {C : precategory}
         (C': hsubtypes (ob C)) :
   sub_precategories C :=
  tpair _  (dirprodpair C' (fun a b f => htrue)) (is_sub_precategory_full C C').

(** We have a coercion [carrier] turning every predicate [P] on a type [A] into the
     total space [ { a : A & P a} ].

   For later, we define some projections with the appropriate type, also to
   avoid confusion with the aforementioned coercion.
*)

Definition sub_precategory_predicate_objects {C : precategory}
     (C': sub_precategories C):
       hsubtypes (ob C) := pr1 (pr1 C').

Definition sub_ob {C : precategory}(C': sub_precategories C): UU :=
     (*carrier*) (sub_precategory_predicate_objects C').

Definition sub_precategory_predicate_morphisms {C : precategory}
        (C':sub_precategories C) (a b : C) : hsubtypes (a --> b) := pr2 (pr1 C') a b.

Definition sub_precategory_morphisms {C : precategory}(C':sub_precategories C)
      (a b : C) : UU :=  sub_precategory_predicate_morphisms C' a b.

(** Projections for compatibility of the predicate with identity and
    composition.
*)

Definition sub_precategory_id (C : precategory)(C':sub_precategories C) :
   forall a : ob C,
       sub_precategory_predicate_objects C' a ->
       sub_precategory_predicate_morphisms  C' _ _ (identity a) :=
         pr1 (pr2 C').

Definition sub_precategory_comp (C : precategory)(C':sub_precategories C) :
   forall (a b c: ob C) (f: a --> b) (g : b --> c),
          sub_precategory_predicate_morphisms C' _ _ f ->
          sub_precategory_predicate_morphisms C' _ _ g ->
          sub_precategory_predicate_morphisms C' _ _  (f ;; g) :=
        pr2 (pr2 C').

(** the following lemma should be an instance of a general theorem saying that
     subtypes of a type of hlevel n are of hlevel n, but
     i haven't found that theorem
*)

Lemma is_set_sub_precategory_morphisms {C : precategory}(C':sub_precategories C)
      (a b : ob C) : isaset (sub_precategory_morphisms C' a b).
Proof.
  change (isaset) with (isofhlevel 2).
  apply isofhleveltotal2.
  apply setproperty.
  intro f.
  apply isasetaprop.
  apply propproperty.
Qed.

Definition sub_precategory_morphisms_set {C : precategory}(C':sub_precategories C)
      (a b : ob C) : hSet :=
    tpair _ (sub_precategory_morphisms C' a b)
        (is_set_sub_precategory_morphisms C' a b).

(** An object of a subcategory is an object of the original precategory. *)

Definition precategory_object_from_sub_precategory_object (C:precategory)
         (C':sub_precategories C) (a : sub_ob C') :
    ob C := pr1 a.
Coercion precategory_object_from_sub_precategory_object :
     sub_ob >-> ob.

(** A morphism of a subcategory is also a morphism of the original precategory. *)

Definition precategory_morphism_from_sub_precategory_morphism (C:precategory)
          (C':sub_precategories C) (a b : ob C)
           (f : sub_precategory_morphisms C' a b) : a --> b := pr1 f .
Coercion precategory_morphism_from_sub_precategory_morphism :
         sub_precategory_morphisms >-> pr1hSet.

(** ** A sub-precategory forms a precategory. *)

Definition sub_precategory_ob_mor (C : precategory)(C':sub_precategories C) :
     precategory_ob_mor.
Proof.
  exists (sub_ob C').
  exact (fun a b => @sub_precategory_morphisms_set _ C' a b).
Defined.

(*
Coercion sub_precategory_ob_mor : sub_precategories >-> precategory_ob_mor.
*)

Definition sub_precategory_data (C : precategory)(C':sub_precategories C) :
      precategory_data.
Proof.
  exists (sub_precategory_ob_mor C C').
  split.
    intro c.
    exists (identity (C:=C) (pr1 c)).
    apply sub_precategory_id.
    apply (pr2 c).
  intros a b c f g.
  exists (compose (pr1 f) (pr1 g)).
  apply sub_precategory_comp.
  apply (pr2 f). apply (pr2 g).
Defined.

(** A useful lemma for equality in the sub-precategory. *)

Lemma eq_in_sub_precategory (C : precategory)(C':sub_precategories C)
      (a b : sub_ob C') (f g : sub_precategory_morphisms C' a b) :
          pr1 f == pr1 g -> f == g.
Proof.
  intro H.
  destruct f as [f p].
  destruct g as [g p'].
  apply (total2_paths H).
  apply proofirrelevance.
  apply pr2.
Qed.

(*
Lemma eq_in_sub_precategory2 (C : precategory)(C':sub_precategories C)
     (a b : sub_ob C') (f g : a --> b)
 (pf : sub_precategory_predicate_morphisms C' _ _ f)
 (pg : sub_precategory_predicate_morphisms C' _ _ g):
  f == g -> (tpair (fun f => sub_precategory_predicate_morphisms _ _ _ f) f pf) ==
      (tpair (fun f => sub_precategory_predicate_morphisms _ _ _ f) g pg).
Proof.
  intro H.
  apply (total2_paths2 H).
  destruct H.
  apply (total2_paths2 (idpath _ )).
*)

Definition is_precategory_sub_category (C : precategory)(C':sub_precategories C) :
    is_precategory (sub_precategory_data C C').
Proof.
  repeat split;
  simpl; intros.
  unfold sub_precategory_comp;
  apply eq_in_sub_precategory; simpl;
  apply id_left.
  apply eq_in_sub_precategory. simpl.
  apply id_right.
  apply eq_in_sub_precategory.
  simpl.
  apply assoc.
Qed.

Definition carrier_of_sub_precategory (C : precategory)(C':sub_precategories C) :
   precategory := tpair _ _ (is_precategory_sub_category C C').

Coercion carrier_of_sub_precategory : sub_precategories >-> precategory.

(** An object satisfying the predicate is an object of the subcategory *)
Definition precategory_object_in_subcat {C : precategory} {C':sub_precategories C}
   (a : ob C)(p : sub_precategory_predicate_objects C' a) :
       ob C' := tpair _ a p.

(** A morphism satisfying the predicate is a morphism of the subcategory *)
Definition precategory_morphisms_in_subcat {C : precategory} {C':sub_precategories C}
   {a b : ob C'}(f : pr1 a --> pr1 b)
   (p : sub_precategory_predicate_morphisms C' (pr1 a) (pr1 b) (f)) :
       precategory_morphisms (C:=C') a b := tpair _ f p.

(** ** Functor from a sub-precategory to the ambient precategory *)

Definition sub_precategory_inclusion_data (C : precategory) (C':sub_precategories C):
  functor_data C' C.
Proof.
  exists (@pr1 _ _ ).
  intros a b.
  exact (@pr1 _ _ ).
Defined.

Definition is_functor_sub_precategory_inclusion (C : precategory)
         (C':sub_precategories C) :
    is_functor  (sub_precategory_inclusion_data C C').
Proof.
  split; simpl; intros;
  apply (idpath _ ).
Qed.

Definition sub_precategory_inclusion (C : precategory)(C': sub_precategories C) :
    functor C' C := tpair _ _ (is_functor_sub_precategory_inclusion C C').

(** ** The (full) image of a functor *)

Definition full_img_sub_precategory {C D : precategory}(F : functor C D) :
    sub_precategories D :=
       full_sub_precategory (sub_img_functor F).

(** ** Given a functor F : C -> D, we obtain a functor F : C -> Img(F) *)

Definition full_img_functor_obj {C D : precategory}(F : functor C D) :
   ob C -> ob (full_img_sub_precategory F).
Proof.
  intro c.
  exists (F c).
  intros a b.
  apply b.
  exists c.
  apply identity_iso.
Defined.

Definition full_img_functor_data {C D : precategory}(F : functor C D) :
  functor_data C (full_img_sub_precategory F).
Proof.
  exists (full_img_functor_obj F).
  intros a b f.
  exists (#F f).
  exact tt.
Defined.

Lemma is_functor_full_img (C D: precategory) (F : functor C D) :
  is_functor (full_img_functor_data F).
Proof.
  split.
  intro a; simpl.
  apply total2_paths_hProp.
    intro; apply propproperty.
  apply functor_id.
  intros a b c f g.
  set ( H := eq_in_sub_precategory D (full_img_sub_precategory F)).
  apply (H (full_img_functor_obj F a)(full_img_functor_obj F c)).
  simpl; apply functor_comp.
Qed.

Definition functor_full_img {C D: precategory}
       (F : functor C D) :
   functor C (full_img_sub_precategory F) :=
   tpair _ _ (is_functor_full_img C D F).

(** *** Morphisms in the full subprecat are equiv to morphisms in the precategory *)
(** does of course not need the category hypothesis *)

Definition hom_in_subcat_from_hom_in_precat (C : precategory)
 (C' : hsubtypes (ob C))
  (a b : ob (full_sub_precategory C'))
      (f : pr1 a --> pr1 b) : a --> b :=
       tpair _ f tt.

Definition hom_in_precat_from_hom_in_full_subcat (C : precategory)
 (C' : hsubtypes (ob C))
  (a b : ob (full_sub_precategory C')) :
     a --> b -> pr1 a --> pr1 b := @pr1 _ _ .

Lemma isweq_hom_in_precat_from_hom_in_full_subcat (C : precategory)
 (C' : hsubtypes (ob C))
    (a b : ob (full_sub_precategory C')):
 isweq (hom_in_precat_from_hom_in_full_subcat _ _ a b).
Proof.
  apply (gradth _
         (hom_in_subcat_from_hom_in_precat _ _ a b)).
  intro f.
  destruct f. simpl.
  apply eq_in_sub_precategory.
  apply idpath.
  intros. apply idpath.
Defined.

Lemma isweq_hom_in_subcat_from_hom_in_precat (C : precategory)
 (C' : hsubtypes (ob C))
    (a b : ob (full_sub_precategory C')):
 isweq (hom_in_subcat_from_hom_in_precat  _ _ a b).
Proof.
  apply (gradth _
         (hom_in_precat_from_hom_in_full_subcat _ _ a b)).
  intro f.
  intros. apply idpath.
  intro f.
  destruct f. simpl.
  apply eq_in_sub_precategory.
  apply idpath.
Defined.

Definition weq_hom_in_subcat_from_hom_in_precat (C : precategory)
     (C' : hsubtypes (ob C))
    (a b : ob (full_sub_precategory C')): weq (pr1 a --> pr1 b) (a-->b) :=
  tpair _ _ (isweq_hom_in_subcat_from_hom_in_precat C C' a b).

Lemma image_is_in_image (C D : precategory) (F : functor C D)
     (a : ob C): is_in_img_functor F (F a).
Proof.
  apply hinhpr.
  exists a.
  apply identity_iso.
Defined.

Lemma functor_full_img_fully_faithful_if_fun_is (C D : precategory)
   (F : functor C D) (H : fully_faithful F) :
   fully_faithful (functor_full_img F).
Proof.
  unfold fully_faithful in *.
  intros a b.
  set (H' := weq_hom_in_subcat_from_hom_in_precat).
  set (H'' := H' D (is_in_img_functor F)).
  set (Fa := tpair (fun a : ob D => is_in_img_functor F a)
        (F a) (image_is_in_image _ _ F a)).
  set (Fb := tpair (fun a : ob D => is_in_img_functor F a)
        (F b) (image_is_in_image _ _ F b)).
  set (H3 := (H'' Fa Fb)).
  assert (H2 : functor_on_morphisms (functor_full_img F) (a:=a) (b:=b) ==
                  funcomp (functor_on_morphisms F (a:=a) (b:=b))
                          ((H3))).
  apply funextsec. intro f.
  apply idpath.
  rewrite H2.
  apply (twooutof3c #F H3).
  apply H.
  apply pr2.
Qed.

(** *** Image factorization C -> Img(F) -> D *)

Lemma functor_full_img_factorization_ob (C D: precategory)
   (F : functor C D):
  functor_on_objects F ==
  functor_on_objects (functor_composite _ _ _
       (functor_full_img F)
            (sub_precategory_inclusion D _)).
Proof.
  simpl.
  apply etacorrection.
Defined.

(**  works up to eta conversion *)

(*
Lemma functor_full_img_factorization (C D: precategory)
                (F : functor C D) :
    F == functor_composite _ _ _ (functor_full_img F)
            (sub_precategory_inclusion D _).
Proof.
  apply functor_eq. About functor_full_img_factorization_ob.
  set (H := functor_full_img_factorization_ob C D F).
  simpl in *.
  destruct F as [F Fax].
  simpl.
  destruct F as [Fob Fmor]; simpl in *.
  apply (total2_paths2 (H)).
  unfold functor_full_img_factorization_ob in H.
  simpl in *.
  apply dep_funextfunax.
  intro a.
  apply dep_funextfunax.
  intro b.
  apply funextfunax.
  intro f.

  generalize Fmor.
  clear Fax.
  assert (H' : Fob == (fun a : ob C => Fob a)).
   apply H.

  generalize dependent a .
  generalize dependent b.
  clear Fmor.
    generalize H.
  clear H.
  intro H.
  clear H'.
  destruct H.
  tion H.
  induction  H'.
  induction H'.
  clear H.

*)

(** ** Any full subprecategory of a category is a category. *)

Section full_sub_cat.

Variable C : precategory.
Hypothesis H : is_category C.

Variable C' : hsubtypes (ob C).

(** *** Isos in the full subcategory are equivalent to isos in the precategory *)

Lemma iso_in_subcat_is_iso_in_precat (a b : ob (full_sub_precategory C'))
       (f : iso a b): is_isomorphism (C:=C) (a:=pr1 a) (b:=pr1 b)
     (pr1 (pr1 f)).
Proof.
  destruct f as [f fp].
  destruct fp as [g gx]. simpl in *.
  exists g.
  destruct gx as [t tp]; simpl in *.
  split; simpl.
  apply (base_paths _ _ t).
  apply (base_paths _ _ tp).
Qed.

Lemma iso_in_precat_is_iso_in_subcat (a b : ob (full_sub_precategory C'))
     (f : iso (pr1 a) (pr1 b)) :
   is_isomorphism (C:=full_sub_precategory C')
     (precategory_morphisms_in_subcat f tt).
Proof.
  destruct f as [f fp].
  destruct fp as [g gax].
  destruct gax as [g1 g2].
  exists (precategory_morphisms_in_subcat g tt).
  split; simpl in *.
  apply eq_in_sub_precategory. simpl.
  assumption.
  apply eq_in_sub_precategory. simpl.
  assumption.
Qed.

Definition iso_from_iso_in_sub (a b : ob (full_sub_precategory C'))
       (f : iso a b) : iso (pr1 a) (pr1 b) :=
   tpair _ _ (iso_in_subcat_is_iso_in_precat a b f).

Definition iso_in_sub_from_iso (a b : ob (full_sub_precategory C'))
   (f : iso (pr1 a) (pr1 b)) : iso a b :=
    tpair _ _ (iso_in_precat_is_iso_in_subcat a b f).

Lemma isweq_iso_from_iso_in_sub (a b : ob (full_sub_precategory C')):
     isweq (iso_from_iso_in_sub a b).
Proof.
  apply (gradth _ (iso_in_sub_from_iso a b)).
  intro f.
  apply eq_iso; simpl.
  apply eq_in_sub_precategory, idpath.
  intro f; apply eq_iso, idpath.
Defined.

Lemma isweq_iso_in_sub_from_iso (a b : ob (full_sub_precategory C')):
     isweq (iso_in_sub_from_iso a b).
Proof.
  apply (gradth _ (iso_from_iso_in_sub a b)).
  intro f; apply eq_iso, idpath.
  intro f; apply eq_iso; simpl;
  apply eq_in_sub_precategory, idpath.
Defined.

(** *** From Identity in the subcategory to isos in the category  *)
(** This gives a weak equivalence *)

Definition Id_in_sub_to_iso (a b : ob (full_sub_precategory C')):
     a == b -> iso (pr1 a) (pr1 b) :=
       funcomp (@idtoiso _ a b) (iso_from_iso_in_sub a b).

Lemma Id_in_sub_to_iso_equal_iso
  (a b : ob (full_sub_precategory C')) :
    Id_in_sub_to_iso a b == funcomp (total_paths2_hProp_equiv C' a b)
                                    (@idtoiso _ (pr1 a) (pr1 b)).
Proof.
  apply funextfunax.
  intro p.
  destruct p.
  apply eq_iso;
  simpl; apply idpath.
Qed.

Lemma isweq_Id_in_sub_to_iso (a b : ob (full_sub_precategory C')):
    isweq (Id_in_sub_to_iso a b).
Proof.
  rewrite Id_in_sub_to_iso_equal_iso.
  apply (twooutof3c _ idtoiso).
  apply pr2.
  apply H.
Defined.

(** *** Decomp of map from id in the subcat to isos in the subcat via isos in ambient precat  *)

Lemma precat_paths_in_sub_as_3_maps
   (a b : ob (full_sub_precategory C')):
     @idtoiso _ a b == funcomp (Id_in_sub_to_iso a b)
                                        (iso_in_sub_from_iso a b).
Proof.
  apply funextfunax.
  intro p; destruct p.
  apply eq_iso; simpl.
  unfold precategory_morphisms_in_subcat.
  apply eq_in_sub_precategory, idpath.
Qed.

(** *** The aforementioned decomposed map is a weak equivalence  *)

Lemma isweq_sub_precat_paths_to_iso
  (a b : ob (full_sub_precategory C')) :
 isweq (@idtoiso _ a b).
Proof.
  rewrite precat_paths_in_sub_as_3_maps.
  match goal with | [ _ : _ |- isweq (funcomp ?f ?g)]
      => apply (twooutof3c f g) end.
  apply isweq_Id_in_sub_to_iso.
  apply isweq_iso_in_sub_from_iso.
Defined.

(** ** Proof of the targeted theorem: full subcats of cats are cats *)

Lemma is_category_full_subcat: is_category (full_sub_precategory C').
Proof.
  unfold is_category.
  apply isweq_sub_precat_paths_to_iso.
Defined.

End full_sub_cat.

Lemma functor_full_img_essentially_surjective (A B : precategory)
     (F : functor A B) :
  essentially_surjective (functor_full_img F).
Proof.
  intro b.
  apply (pr2 b).
  intros [c h] q Hq.
  apply Hq.
  exists c.
  apply iso_in_sub_from_iso.
  apply h.
Qed.


(* ***********************************************************************)
(*                                                                       *)
(*   Synchronously executed Interpreted Time Petri Nets (SITPNs)         *)
(*                                                                       *)
(*                                                                       *)
(*   Copyright Université de Montpellier, contributor(s): Vincent        *)
(*   Iampietro, David Andreu, David Delahaye (May 2020)                  *)
(*                                                                       *)
(*   This software is governed by the CeCILL-C license under French law  *)
(*   and abiding by the rules of distribution of free software.  You can *)
(*   use, modify and/ or redistribute the software under the terms of    *)
(*   the CeCILL-C license as circulated by CEA, CNRS and INRIA at the    *)
(*   following URL "http://www.cecill.info".  The fact that you are      *)
(*   presently reading this means that you have had knowledge of the     *)
(*   CeCILL-C license and that you accept its terms.                     *)
(*                                                                       *)
(* ***********************************************************************)

(*! =============================== !*)
(*! ======= SITPN SEMANTICS ======= !*)
(*! =============================== !*)

Require Export ListsPlus.
Require Import simpl.Sitpn.

(** * General preliminary definitions.  *)

(** Defines a priority relation between a transition t and t', where t
    has a higher priority than t', i.e: ∀ t ∈ T, t' ∈ T/{t}, t ≻ t' *)

Definition HasHigherPriority
           (t t' : Trans)
           (pgroup : list Trans) :=
  In t pgroup /\
  In t' pgroup /\
  IsPredInNoDupList t t' pgroup.

(** Defines [pr] as the set (therefore, with no duplicates) of
    transitions that are in the [fired] list and have a higher
    priority than transition [t] in [pgroup]. *)

Definition IsPrioritySet
           (fired pgroup : list Trans)
           (t : Trans)
           (pr : list Trans) :=
  NoDup pr /\
  (forall t' : Trans,
      HasHigherPriority t' t pgroup /\ In t' fired <-> In t' pr).

(** * Functions for marking update and facts. *)

(** Sums edge weight from place p to transitions of the l list. *)

Fixpoint pre_sum (sitpn : Sitpn) (p : Place) (l : list Trans) {struct l} : nat :=
  match l with
  | t :: tail => (pre sitpn t p) + pre_sum sitpn p tail
  | [] => 0
  end.

Functional Scheme pre_sum_ind := Induction for pre_sum Sort Prop.

(** pre_sum sitpn p l + pre_sum sitpn p [t] = pres_um sitpn p (l ++ [t]) *)

Lemma pre_sum_app_add :
  forall (sitpn : Sitpn) (p : Place) (l : list Trans) (t : Trans),
    pre_sum sitpn p l + pre_sum sitpn p [t] = pre_sum sitpn p (l ++ [t]).
Proof.
  intros sitpn p l; functional induction (pre_sum sitpn p l) using pre_sum_ind; intro t'.
  - simpl; reflexivity.
  - simpl; rewrite <- (IHn t'); simpl; rewrite plus_assoc_reverse; reflexivity.
Qed.

(** Sums edge weight from transitions of the l list to place p. *)

Fixpoint post_sum (sitpn : Sitpn) (p : Place) (l : list Trans) {struct l} : nat :=
  match l with
  | t :: tail => (post sitpn t p) + post_sum sitpn p tail
  | [] => 0
  end.

Functional Scheme post_sum_ind := Induction for post_sum Sort Prop.

(** Marking m and m' apply to the same set of places. *)

Definition MarkingHaveSameStruct (m m' : list (Place * nat)) :=
  fst (split m) = fst (split m').

(** * Sensitization definition. *)

(** ∀ t ∈ T, marking m, t ∈ sens(m) if
    ∀ p ∈ P, m(p) ≥ Pre(p, t) ∧
             m(p) ≥ Pre_t(p, t) ∧
             (m(p) < Pre_i(p, t) ∨ Pre_i(p, t) = 0) *)

Definition IsSensitized
           (sitpn : Sitpn)
           (marking : list (Place * nat))
           (t : Trans) : Prop :=
  forall (p : Place)
         (n : nat),
    In (p, n) marking ->
    (pre sitpn t p) <= n  /\
    (test sitpn t p) <= n  /\
    (n < (inhib sitpn t p) \/ (inhib sitpn t p) = 0).

(** * Predicates for Time Petri nets semantics. *)

(** Tests if [t] is associated in [d_intervals] with is an active time
    interval with [min_t] = 0 (≡ 0 ∈ I) or if t has no static time
    interval in sitpn. *)

Definition HasEnteredTimeWindow
           (sitpn : Sitpn)
           (d_intervals : list (Trans * DynamicTimeInterval))
           (t : Trans) :=
  s_intervals sitpn t = None \/
  exists (upper_bound : PositiveIntervalBound),
    In (t, active {| min_t := 0; max_t := upper_bound |}) d_intervals.

(** Tests if the upper bound of a time interval equals 0.
    Useful when determining if a dynamic time interval
    should be blocked. *)

Definition HasReachedUpperBound (dyn_itval : DynamicTimeInterval) :=
  dyn_itval = active {| min_t := 0; max_t := pos_val 0 |} \/ dyn_itval = blocked.

(** Decrements the bounds of a time interval. *)

Definition dec_itval (itval : TimeInterval) :=
  match itval with
  | {| min_t := n; max_t := pos_val m |} =>
    {| min_t := n - 1; max_t := pos_val (m - 1) |}
  | {| min_t := n; max_t := pos_inf |} =>
    {| min_t := n - 1; max_t := pos_inf |}
  end.

(** * Predicates for Interpreted Petri nets semantics. *)

(** Tests if transition [t] is only associated with conditions
    evaluated to true in [cond_values]. *)

Definition HasReachedAllConditions
           (sitpn : Sitpn)
           (cond_values : list (Condition * bool))
           (t : Trans) :=
  forall (c : Condition),
    In c sitpn.(conditions) ->
    (has_condition sitpn t c) = true ->
    In (c, true) cond_values.

(** * Firability definition. *)

(** Expresses the firability of transition t at state s of SITPN
    sitpn.

    [t] is firable at state [s] of SITPN [sitpn] if m sensitizes [t], [t]
    has entered a specific time window, and all conditions associated to
    [t] are true, i.e:

    ∀ t ∈ T, s = (Fired, M, cond, ex, I, reset), t ∈ firable(s) if
    t ∈ sens(M) ∧ 0 ∈ I(t) ∧ (∀ c ∈ conditions, C(t, c) = 1 ⇒ cond(c) = 1). *)

Definition SitpnIsFirable
           (sitpn : Sitpn)
           (s : SitpnState)
           (t : Trans) :=
  IsSensitized sitpn s.(marking) t /\
  HasEnteredTimeWindow sitpn s.(d_intervals) t /\
  HasReachedAllConditions sitpn s.(cond_values) t.

(** * Sitpn Semantics definition.

      Inductive structure describing the rules regulating the
      evolution of a SITPN.

      Here, a given SITPN [sitpn] is moving from state [s] to state
      [s'] at a certain [time_value] (discrete time value
      corresponding to the count of clock cycles since the beginning).

      The [env] function gives the boolean value of conditions through
      time. It simulates the information coming from the environment
      of the SITPN.

      An instance of [Clock] parameterized the inductive structure,
      telling if the state changing is due to the occurence of a
      rising or a falling edge of a clock signal.  *)

(** Represents the two clock events regulating the Sitpn evolution. *)

Inductive Clock : Set :=
| falling_edge : Clock
| rising_edge : Clock.

(** Represents the Sitpn semantics. *)

Inductive SitpnSemantics
          (sitpn : Sitpn)
          (s s' : SitpnState)
          (time_value : nat)
          (env : Condition -> nat -> bool) : Clock -> Prop :=

(* ↓clock : s = (Fired, m, cond, ex, I, reset) ⇝ s' = (Fired', m, cond', ex', I', reset) *)

| SitpnSemantics_falling_edge :

    IsWellDefinedSitpn sitpn ->
    IsWellDefinedSitpnState sitpn s ->
    IsWellDefinedSitpnState sitpn s' ->

    (* Marking stays the same between state s and s'. *)
    s.(marking) = s'.(marking) ->

    (* Function execution orders stay the same between s and s'. *)
    s.(exec_f) = s'.(exec_f) ->

    (* Conditions values in s' receive new values from the
       environment, i.e:

       ∀ c ∈ conditions, cond'(c) = env(c). *)

    (forall (c : Condition),
        In c sitpn.(conditions) ->
        In (c, (env c time_value)) s'.(cond_values)) ->

    (* Actions associated to places with a non-zero marking are
       activated, i.e:

       ∀ a ∈ actions, ∃ p ∈ P, m(p) > 0 ∧ A(p, a) = 1 ⇒ ex'(a) = 1. *)

    (forall (a : Action),
        In a sitpn.(actions) ->
        (exists (p : Place) (n : nat),
            In (p, n) s.(marking) /\ n > 0 /\ (has_action sitpn p a) = true) ->
        In (a, true) s'.(exec_a)) ->

    (* Actions only associated with unmarked places (no tokens)
       are deactivated, i.e:

       ∀ a ∈ actions, ∀ p ∈ P, m(p) = 0 ∨ A(p, a) = 0 ⇒ ex'(a) = 0. *)

    (forall (a : Action),
        In a sitpn.(actions) ->
        (forall (p : Place) (n : nat),
            In (p, n) s.(marking) -> n = 0 \/ (has_action sitpn p a) = false) ->
        In (a, false) s'.(exec_a)) ->

    (* Time intervals are reset for all transitions sensitized by m
       and that received a reset order or were previously fired, i.e:

       ∀ t ∈ Ti, t ∉ sens(m) ∨ (t ∈ sens(m) ∧ (reset(t) = 1 ∨ t ∈ Fired)) ⇒
       I'(t) = Is(t) - 1
       where Ti = { ti | I(ti) ≠ ∅ } *)

    (forall (t : Trans)
            (itval : TimeInterval),
        In t (fst (split s.(d_intervals))) ->
        (~IsSensitized sitpn s.(marking) t \/
         (IsSensitized sitpn s.(marking) t /\ (In (t, true) s.(reset) \/ In t s.(fired)))) ->
        Some itval = (s_intervals sitpn t) ->
        In (t, active (dec_itval itval)) s'.(d_intervals)) ->

    (* Time intervals evolve normally for all transitions sensitized
       by m, having an active time interval, that didn't receive a reset
       order and were not fired at the last clock cycle, i.e:

       ∀ t ∈ Ti, t ∈ sens(m) ∧ reset(t) = 0 ∧ t ∉ Fired ∧ I(t) ≠ ψ ⇒
       I'(t) = I(t) - 1 *)

    (forall (t : Trans)
            (itval : TimeInterval),
        In (t, active itval) s.(d_intervals) ->
        IsSensitized sitpn s.(marking) t ->
        In (t, false) s.(reset) ->
        ~In t s.(fired) ->
        In (t, active (dec_itval itval)) s'.(d_intervals)) ->

    (* Time intervals stay the same for all transitions with a blocked
       time interval that are sensitized by m, didn't receive a reset
       order and were not fired at the last clock cycle, i.e:

       ∀ t ∈ Ti, t ∈ sens(m) ∧ reset(t) = 0 ∧ t ∉ Fired ∧ I(t) = ψ ⇒
       I'(t) = I(t) *)

    (forall (t : Trans),
        In (t, blocked) s.(d_intervals) ->
        IsSensitized sitpn s.(marking) t ->
        In (t, false) s.(reset) ->
        ~In t s.(fired) ->
        In (t, blocked) s'.(d_intervals)) ->

    (* Reset orders stay the same. *)

    s.(reset) = s'.(reset) ->

    (* All transitions that are not firable are not fired, i.e:

       ∀ t ∉ firable(s') ⇒ t ∉ Fired' *)

    (forall (pgroup : list Trans)
            (t : Trans),
        In pgroup sitpn.(priority_groups) ->
        In t pgroup ->
        ~SitpnIsFirable sitpn s' t ->
        ~In t s'.(fired)) ->

    (* If t is firable and sensitized by the residual marking, result
       of the firing of all higher priority transitions, then t is
       fired, i.e:

       ∀ t ∈ firable(s'), t ∈ sens(M - ∑ pre(t'), ∀ t'∈ Pr(t)) ⇒ t ∈ Fired'
       where Pr(t) = {ti | ti ≻ t /\ ti ∈ Fired'} *)

    (forall (pgroup : list Trans)
            (t : Trans)
            (residual_marking : list (Place * nat)),
        In pgroup sitpn.(priority_groups) ->
        In t pgroup ->
        SitpnIsFirable sitpn s' t ->
        (places sitpn) = (fst (split residual_marking)) ->
        (forall (pr : list Trans),
            IsPrioritySet s'.(fired) pgroup t pr ->
            (forall (p : Place)
                    (n : nat),
                In (p, n) s.(marking) ->
                In (p, n - pre_sum sitpn p pr) residual_marking)) ->
        IsSensitized sitpn residual_marking t ->
        In t s'.(fired)) ->

    (* If t is firable and not sensitized by the residual marking then
       t is not fired, i.e:

       ∀ t ∈ firable(s'), t ∉ sens(M - ∑ pre(t'), ∀ t' ∈ Pr(t)) ⇒ t ∉
       Fired' *)

    (forall (pgroup : list Trans)
            (t : Trans)
            (residual_marking : list (Place * nat)),
        In pgroup sitpn.(priority_groups) ->
        In t pgroup ->
        SitpnIsFirable sitpn s' t ->
        (places sitpn) = (fst (split residual_marking)) ->
        (forall (pr : list Trans),
            IsPrioritySet s'.(fired) pgroup t pr ->
            (forall (p : Place)
                    (n : nat),
                In (p, n) s.(marking) ->
                In (p, n - pre_sum sitpn p pr) residual_marking)) ->
        ~IsSensitized sitpn residual_marking t ->
        ~In t s'.(fired)) ->

    SitpnSemantics sitpn s s' time_value env falling_edge

(* ↑clock : s = (Fired, m, cond, ex, I, reset) ⇝ s' = (Fired, m', cond, ex', I', reset') *)

| SitpnSemantics_rising_edge :

    IsWellDefinedSitpn sitpn ->
    IsWellDefinedSitpnState sitpn s ->
    IsWellDefinedSitpnState sitpn s' ->

    (* Fired stays the same between state s and s'. *)
    s.(fired) = s'.(fired) ->

    (* M' = M - ∑ (pre(t_i) - post(t_i)), ∀ t_i ∈ Fired *)
    (forall (p : Place)
            (n : nat),
        In (p, n) s.(marking) ->
        In (p, n - (pre_sum sitpn p s.(fired)) + (post_sum sitpn p s.(fired)))
           s'.(marking)) ->

    (* All transitions disabled by the transient marking, result of
       the withdrawal of tokens in the input places of the fired
       transitions, receive a reset order, i.e:

       ∀ t ∈ Ti, t ∉ sens(m - ∑ pre(ti), ∀ ti ∈ Fired) ⇒ reset'(t) = 1 *)

    (forall (t : Trans)
            (transient_marking : list (Place * nat)),
        Permutation (places sitpn) (fs transient_marking) ->
        (forall (p : Place) (n : nat),
            In (p, n) s.(marking) ->
            In (p, n - pre_sum sitpn p s.(fired)) transient_marking) ->
        In t sitpn.(transs) ->
        s_intervals sitpn t <> None ->
        ~IsSensitized sitpn transient_marking t ->
        In (t, true) s'.(reset)) ->

    (* All transitions enabled by the transient marking receive no
       reset order, i.e:

       ∀ t ∈ Ti, t ∈ sens(m - ∑ pre(ti), ∀ ti ∈ Fired) ⇒ reset'(t) = 0 *)

    (forall (t : Trans)
            (transient_marking : list (Place * nat)),
        Permutation (places sitpn) (fs transient_marking) ->
        (forall (p : Place) (n : nat),
            In (p, n) s.(marking) ->
            In (p, n - pre_sum sitpn p s.(fired)) transient_marking) ->
        In t sitpn.(transs) ->
        s_intervals sitpn t <> None ->
        IsSensitized sitpn transient_marking t ->
        In (t, false) s'.(reset)) ->

    (* Time intervals are blocked for all transitions that have
       reached the upper bound of their time intervals and were not
       fired at this clock cycle, i.e:

       ∀ t ∈ Ti, ↑I(t) = 0 ∧ t ∉ Fired ⇒ I'(t) = ψ *)

    (forall (t : Trans)
            (dyn_itval : DynamicTimeInterval),
        In (t, dyn_itval) s.(d_intervals) ->
        HasReachedUpperBound dyn_itval ->
        ~In t s.(fired) ->
        In (t, blocked) s'.(d_intervals)) ->

    (* Time intervals stay the same for all transitions that haven't
       reached the upper bound of their time intervals or were
       fired at this clock cycle, i.e:

       ∀ t ∈ Ti, ↑I(t) ≠ 0 ∨ t ∈ Fired ⇒ I'(t) = I(t) *)

    (forall (t : Trans)
            (dyn_itval : DynamicTimeInterval),
        In (t, dyn_itval) s.(d_intervals) ->
        (~HasReachedUpperBound dyn_itval \/ In t s.(fired)) ->
        In (t, dyn_itval) s'.(d_intervals)) ->

    (* Condition values stay the same. *)

    s.(cond_values) = s'.(cond_values) ->

    (* Action activation states stay the same. *)

    s.(exec_a) = s'.(exec_a) ->

    (* All functions associated with fired transitions are executed, i.e:

       ∀ f ∈ functions, ∃ t ∈ Fired | F(t, f) = 1 ⇒ ex'(f) = 1. *)

    (forall (f : IFunction),
        In f sitpn.(functions) ->
        (exists (t : Trans),
            In t s.(fired) /\ (has_function sitpn t f) = true) ->
        In (f, true) s'.(exec_f)) ->

    (* All functions not associated with fired transitions are not
       executed, i.e:

       ∀ f ∈ functions, ∀ t ∈ Fired | F(t, f) = 0 ⇒ ex'(f) = 0. *)

    (forall (f : IFunction),
        In f sitpn.(functions) ->
        (forall t : Trans, ~In t s.(fired) \/ (has_function sitpn t f) = false) ->
        In (f, false) s'.(exec_f)) ->

    SitpnSemantics sitpn s s' time_value env rising_edge.