Require Import Coq.Arith.PeanoNat.
Require Import Coq.Bool.Bool.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Lists.List.
Require Import Coq.Program.Basics.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Setoids.Setoid.
Require Import DschingisKhan.Prelude.PreludeInit.

Module MathProps.

  Class preserves_eqProp1 {dom : Hask.t} {cod : Hask.t} {dom_isSetoid : isSetoid dom} {cod_isSetoid : isSetoid cod} (unary_op : dom -> cod) : Prop :=
    eqProp_lifted1 (lhs1 : dom) (rhs1 : dom)
      (H_EQ1 : lhs1 == rhs1)
      : unary_op lhs1 == unary_op rhs1
  .

  Global Add Parametric Morphism {dom : Hask.t} {cod : Hask.t} {dom_isSetoid : isSetoid dom} {cod_isSetoid : isSetoid cod} (unary_op : dom -> cod) {preserves_eqProp : preserves_eqProp1 unary_op} :
    unary_op with signature (eqProp ==> eqProp)
    as congruence_guarantees_eqProp_lifted1.
  Proof. intros x1 x2 H_x_eq; exact (eqProp_lifted1 x1 x2 H_x_eq). Defined.

  Class preserves_eqProp2 {dom1 : Hask.t} {dom2 : Hask.t} {cod : Hask.t} {dom1_isSetoid : isSetoid dom1} {dom2_isSetoid : isSetoid dom2} {cod_isSetoid : isSetoid cod} (binary_op : dom1 -> dom2 -> cod) : Prop :=
    eqProp_lifted2 (lhs1 : dom1) (rhs1 : dom1) (lhs2 : dom2) (rhs2 : dom2)
      (H_EQ1 : lhs1 == rhs1)
      (H_EQ2 : lhs2 == rhs2)
      : binary_op lhs1 lhs2 == binary_op rhs1 rhs2
  .

  Global Add Parametric Morphism {dom1 : Hask.t} {dom2 : Hask.t} {cod : Hask.t} {dom1_isSetoid : isSetoid dom1} {dom2_isSetoid : isSetoid dom2} {cod_isSetoid : isSetoid cod} (binary_op : dom1 -> dom2 -> cod) {preserves_eqProp : preserves_eqProp2 binary_op} :
    binary_op with signature (eqProp ==> eqProp ==> eqProp)
    as congruence_guaranteeseqProp_lifted2.
  Proof. intros x1 x2 H_x_eq y1 y2 H_y_eq; exact (eqProp_lifted2 x1 x2 y1 y2 H_x_eq H_y_eq). Defined.

  Class preserves_leProp1 {dom : Hask.t} {cod : Hask.t} {dom_isPoset : isPoset dom} {cod_isPoset : isPoset cod} (unary_op : dom -> cod) : Prop :=
    leProp_lifted1 (lhs1 : dom) (rhs1 : dom)
      (H_LE1 : lhs1 =< rhs1)
      : unary_op lhs1 =< unary_op rhs1
  .

  Global Add Parametric Morphism {dom : Hask.t} {cod : Hask.t} {dom_isPoset : isPoset dom} {cod_isPoset : isPoset cod} (unary_op : dom -> cod) {preserves_leProp : preserves_leProp1 unary_op} :
    unary_op with signature (leProp ==> leProp)
    as monotonic_guarantees_leProp_lifted1.
  Proof. intros x1 x2 H_x_le; exact (leProp_lifted1 x1 x2 H_x_le). Defined.

  Global Add Parametric Morphism {dom : Hask.t} {cod : Hask.t} {dom_isPoset : isPoset dom} {cod_isPoset : isPoset cod} (unary_op : dom -> cod) {preserves_leProp : preserves_leProp1 unary_op} :
    unary_op with signature (eqProp ==> eqProp)
    as monotonic_guarantees_eqProp_lifted1.
  Proof. ii. eapply leProp_Antisymmetric; eapply preserves_leProp; now eapply eqProp_implies_leProp. Qed.

  Class preserves_leProp2 {dom1 : Hask.t} {dom2 : Hask.t} {cod : Hask.t} {dom1_isPoset : isPoset dom1} {dom2_isPoset : isPoset dom2} {cod_isPoset : isPoset cod} (binary_op : dom1 -> dom2 -> cod) : Prop :=
    leProp_lifted2 (lhs1 : dom1) (rhs1 : dom1) (lhs2 : dom2) (rhs2 : dom2)
      (H_LE1 : lhs1 =< rhs1)
      (H_LE2 : lhs2 =< rhs2)
      : binary_op lhs1 lhs2 =< binary_op rhs1 rhs2
  .

  Global Add Parametric Morphism {dom1 : Hask.t} {dom2 : Hask.t} {cod : Hask.t} {dom1_isPoset : isPoset dom1} {dom2_isPoset : isPoset dom2} {cod_isPoset : isPoset cod} (binary_op : dom1 -> dom2 -> cod) {preserves_leProp : preserves_leProp2 binary_op} :
    binary_op with signature (leProp ==> leProp ==> leProp)
    as monotonic_guarantees_leProp_lifted2.
  Proof. intros x1 x2 H_x_le y1 y2 H_y_le; exact (leProp_lifted2 x1 x2 y1 y2 H_x_le H_y_le). Defined.

  Global Add Parametric Morphism {dom1 : Hask.t} {dom2 : Hask.t} {cod : Hask.t} {dom1_isPoset : isPoset dom1} {dom2_isPoset : isPoset dom2} {cod_isSetoid : isPoset cod} (binary_op : dom1 -> dom2 -> cod) {preserves_leProp : preserves_leProp2 binary_op} :
    binary_op with signature (eqProp ==> eqProp ==> eqProp)
    as monotonic_guarantees_eqProp_lifted2.
  Proof. ii. eapply leProp_Antisymmetric; eapply preserves_leProp; now eapply eqProp_implies_leProp. Qed.

  Section STATEMENTS_FOR_OPERATION_PROPERTIES.

  Context {A : Hask.t} {requiresSetoid : isSetoid A}.

  Class Assoc (bin_op : A -> A -> A) : Prop :=
    associativity (x : A) (y : A) (z : A)
      : bin_op x (bin_op y z) == bin_op (bin_op x y) z
  .

  Class Comm (bin_op : A -> A -> A) : Prop :=
    commutativity (x : A) (y : A)
      : bin_op x y == bin_op y x
  .

  Class Idem (bin_op : A -> A -> A) : Prop :=
    idemponence (x : A)
      : bin_op x x == x
  .

  Class Distr (bin_op1 : A -> A -> A) (bin_op2 : A -> A -> A) : Prop :=
    { left_distr (x : A) (y : A) (z : A)
      : bin_op1 x (bin_op2 y z) == bin_op2 (bin_op1 x y) (bin_op1 x z)
    ; right_distr (x : A) (y : A) (z : A)
      : bin_op1 (bin_op2 y z) x == bin_op2 (bin_op1 y x) (bin_op1 z x)
    }
  .

  Class IdElemOf (e : A) (bin_op : A -> A -> A) : Prop :=
    { left_id (x : A)
      : bin_op e x == x
    ; right_id (x : A)
      : bin_op x e == x
    }
  .

  Class InvOpOf (inv : A -> A) (bin_op : A -> A -> A) {e : A} {e_id_bin_op : IdElemOf e bin_op} : Prop :=
    { left_inv (x : A)
      : bin_op (inv x) x == e
    ; right_inv (x : A)
      : bin_op x (inv x) == e
    }
  .

  Class Absorption (bin_op1 : A -> A -> A) (bin_op2 : A -> A -> A) : Prop :=
    { abosortion_left (x : A) (y : A)
      : bin_op1 x (bin_op2 x y) == x
    ; abosortion_right (x : A) (y : A)
      : bin_op2 x (bin_op1 x y) == x
    }
  .

  Class Annihilator (a : A) (bin_op : A -> A -> A) : Prop :=
    { leftAnnihilator : forall x : A, bin_op a x == a
    ; rightAnnihilator : forall x : A, bin_op x a == a
    }
  .

  End STATEMENTS_FOR_OPERATION_PROPERTIES.

  Global Infix " `distributesOver` " := Distr (at level 70, no associativity) : type_scope.
  Global Infix " `isIdentityOf` " := IdElemOf (at level 70, no associativity) : type_scope.
  Global Infix " `isInverseOpFor` " := InvOpOf (at level 70, no associativity) : type_scope.
  Global Infix " `isAnnihilatorFor` " := Annihilator (at level 70, no associativity) : type_scope.

  Definition isInjective {dom : Hask.t} {cod : Hask.t} (f : Hask.arrow dom cod) : Prop :=
    forall x1 : dom, forall x2 : dom, << f_x1_eq_f_x2 : f x1 = f x2 >> -> << x1_eq_x2 : x1 = x2 >>
  .

  Definition isSurjection {dom : Hask.t} {cod : Hask.t} (f : Hask.arrow dom cod) : Type :=
    forall y : cod, {x : dom | << y_is_f_x : y = f x >>}
  .

  Definition isSurjective {dom : Hask.t} {cod : Hask.t} (f : Hask.arrow dom cod) : Prop :=
    forall y : cod, exists x : dom, << y_is_f_x : y = f x >>
  .

  Class Equipotent (dom : Hask.t) (cod : Hask.t) : Type :=
    { bijection : dom -> cod
    ; bijectionInjective : isInjective bijection
    ; bijectionSurjective : isSurjection bijection
    }
  .

  Section CARDINALITY_EQUIVALENCE.

  Definition haveSameCard (lhs : Hask.t) (rhs : Hask.t) : Prop := inhabited (Equipotent lhs rhs).

  Local Instance Equipotent_Equivalence
    : Equivalence haveSameCard.
  Proof.
    split.
    - intros A.
      econstructor. exists (fun x : A => x).
      + intros x1 x2 H_x_EQ. congruence.
      + intros x. exists (x). exact (@eq_refl A x).
    - intros A B [[bijection_A_to_B bijection_A_to_B_inj bijection_A_to_B_surj]].
      econstructor. exists (fun y : B => proj1_sig (bijection_A_to_B_surj y)).
      + intros y1 y2 H_EQ. destruct (bijection_A_to_B_surj y1) as [x1 y1_is]. destruct (bijection_A_to_B_surj y2) as [x2 y2_is]. unnw. subst y1 y2. simpl in *. congruence.
      + intros x. exists (bijection_A_to_B x). destruct (bijection_A_to_B_surj (bijection_A_to_B x)) as [x' H_x_EQ]. unnw. simpl in *. exact (bijection_A_to_B_inj x x' H_x_EQ).
    - intros A B C [[bijection_A_to_B bijection_A_to_B_inj bijection_A_to_B_surj]] [[bijection_B_to_C bijection_B_to_C_inj bijection_B_to_C_surj]].
      econstructor. exists (fun x : A => bijection_B_to_C (bijection_A_to_B x)).
      + intros x1 x2 H_EQ. eapply bijection_A_to_B_inj, bijection_B_to_C_inj. exact (H_EQ).
      + intros z. destruct (bijection_B_to_C_surj z) as [y z_is]. destruct (bijection_A_to_B_surj y) as [x y_is]. unnw. exists (x). congruence.
  Qed.

  Global Instance Hask_isSetoid : isSetoid Hask.t :=
    { eqProp := haveSameCard
    ; eqProp_Equivalence := Equipotent_Equivalence
    }
  .

  End CARDINALITY_EQUIVALENCE.

  Class isCountable (dom : Hask.t) : Type :=
    { enum : nat -> dom
    ; enum_isSurjective : isSurjective enum
    }
  .

  Class isRecursivelyEnumerable (dom : Hask.t) : Type :=
    { RecursivelyEnumerable_requiresCountable :> isCountable dom
    ; enum_isSurjection : isSurjection enum
    }
  .

  Definition isDecidable {X : Hask.t} (Y : ensemble X) : Type :=
    forall y : X, {member y Y} + {~ member y Y}
  .

  Class EqDec (dom : Hask.t) : Type := eq_dec (x : dom) : isDecidable (@eq dom x).

  Global Arguments eq_dec {dom} {EqDec} (x) (y) : simpl nomatch.

  Global Instance boolEqDec : EqDec bool :=
    { eq_dec (x : bool) (y : bool) :=
      match x as lhs, y as rhs return {lhs = rhs} + {lhs <> rhs} with
      | true, true => left (@eq_refl bool true)
      | true, false => right (fun H_EQ : true = false => @eq_ind bool true (fun b : bool => if b then True else False) I false H_EQ)
      | false, true => right (fun H_EQ : false = true => @eq_ind bool false (fun b : bool => if b then False else True) I true H_EQ)
      | false, false => left (@eq_refl bool false)
      end
    }
  .

  Section ORDER_THEORIC_CONCEPTS.

  Local Notation " x '>=' y " := (leProp y x) (only parsing) : type_scope.

  Context {D : Type}.

  Definition PrefixedPoints {requiresPoset : isPoset D} (f : D -> D) : ensemble D :=
    fun x : D => (x >= f x)%type
  .

  Definition FixedPoints {requiresSetoid : isSetoid D} (f : D -> D) : ensemble D :=
    fun x : D => (x == f x)%type
  .

  Definition PostfixedPoints {requiresPoset : isPoset D} (f : D -> D) : ensemble D :=
    fun x : D => (x =< f x)%type
  .

  Definition UpperBoundsOf {requiresPoset : isPoset D} (X : ensemble D) : ensemble D :=
    fun upper_bound : D => forall x : D, << H_IN : member x X >> -> (x =< upper_bound)%type
  .

  Definition LowerBoundsOf {requiresPoset : isPoset D} (X : ensemble D) : ensemble D :=
    fun lower_bound : D => forall x : D, << H_IN : member x X >> -> (x >= lower_bound)%type
  .

  Definition isSupremumOf {requiresPoset : isPoset D} (sup_X : D) (X : ensemble D) : Prop :=
    forall upper_bound : D, << SUPREMUM_LE_UPPER_BOUND : (sup_X =< upper_bound)%type >> <-> << UPPER_BOUND : member upper_bound (UpperBoundsOf X) >>
  .

  Definition isInfimumOf {requiresPoset : isPoset D} (inf_X : D) (X : ensemble D) : Prop :=
    forall lower_bound : D, << LOWER_BOUND_LE_INFIMUM : (inf_X >= lower_bound)%type >> <-> << LOWER_BOUND : member lower_bound (LowerBoundsOf X) >>
  .

  End ORDER_THEORIC_CONCEPTS.

End MathProps.

Export MathProps.

Module Ensembles.

  Import ListNotations.

  Global Infix " \in " := member (at level 70, no associativity) : type_scope.

  Inductive union {A : Hask.t} (X1 : ensemble A) (X2 : ensemble A) (z : A) : Prop :=
  | In_union_l
    (z_in_X1 : z \in X1)
    : z \in union X1 X2
  | In_union_r
    (z_in_X2 : z \in X2)
    : z \in union X1 X2
  .

  Inductive unions_i {A : Hask.t} {I : Hask.t} (Xs : Hask.arrow I (ensemble A)) (z : A) : Prop :=
  | In_unions_i (i : I)
    (z_in_Xs_i : z \in Xs i)
    : z \in unions_i Xs
  .

  Inductive unions {A : Hask.t} (Xs : ensemble (ensemble A)) (z : A) : Prop :=
  | In_unions (X : ensemble A)
    (z_in_X : z \in X)
    (X_in_Xs : X \in Xs)
    : z \in unions Xs
  .

  Inductive image {A : Hask.t} {B : Hask.t} (f : Hask.arrow A B) (X : ensemble A) (y : B) : Prop :=
  | In_image (x : A)
    (x_in_X : x \in X)
    (y_eq_f_x : y = f x)
    : y \in image f X
  .

  Inductive preimage {A : Hask.t} {B : Hask.t} (f : Hask.arrow A B) (Y : ensemble B) (x : A) : Prop :=
  | In_preimage
    (f_x_in_Y : f x \in Y)
    : x \in preimage f Y
  .

  Inductive finite {A : Hask.t} (xs : list A) (z : A) : Prop :=
  | In_finite
    (z_in_xs : In z xs)
    : z \in finite xs
  .

  Inductive intersection {A : Hask.t} (X1 : ensemble A) (X2 : ensemble A) (z : A) : Prop :=
  | In_intersection
    (z_in_X1 : z \in X1)
    (z_in_X2 : z \in X2)
    : z \in intersection X1 X2
  .

  Inductive full {A : Hask.t} (z : A) : Prop :=
  | In_full
    : z \in full
  .

  Inductive empty {A : Hask.t} (z : A) : Prop :=
  .

  Local Hint Constructors union unions_i unions image preimage finite intersection full empty : core.

  Definition complement {A : Hask.t} (X : ensemble A) : ensemble A := fun z : A => ~ z \in X.

  Definition setminus {A : Hask.t} (X1 : ensemble A) (X2 : ensemble A) : ensemble A := intersection X1 (complement X2).

  Definition singleton {A : Hask.t} (x : A) : ensemble A := fun z : A => x = z.

  Definition delete {A : Hask.t} (x : A) (X : ensemble A) : ensemble A := setminus X (singleton x).

  Definition insert {A : Hask.t} (x : A) (X : ensemble A) : ensemble A := union (singleton x) X.

  Lemma in_union_iff {A : Hask.t} (X1 : ensemble A) (X2 : ensemble A)
    : forall z : A, z \in union X1 X2 <-> (z \in X1 \/ z \in X2).
  Proof. intros z; split; intros [H_l | H_r]; eauto. Qed.

  Lemma in_unions_i_iff {A : Hask.t} {I : Hask.t} (Xs : Hask.arrow I (ensemble A))
    : forall z : A, z \in unions_i Xs <-> (exists i : I, z \in Xs i).
  Proof. intros z; split; intros [i H_i]; eauto. Qed.

  Lemma in_unions_iff {A : Hask.t} (Xs : ensemble (ensemble A))
    : forall z : A, z \in unions Xs <-> (exists X : ensemble A, z \in X /\ X \in Xs).
  Proof. intros z; split; [intros [X H_X H_Xs] | intros [X [H_X H_Xs]]]; eauto. Qed.

  Lemma in_image_iff {A : Hask.t} {B : Hask.t} (f : Hask.arrow A B) (X : ensemble A)
    : forall y : B, y \in image f X <-> (exists x : A, y = f x /\ x \in X).
  Proof. intros y; split; [intros [x H_x H_y] | intros [x [H_x H_y]]]; eauto. Qed.

  Lemma in_preimage_iff {A : Hask.t} {B : Hask.t} (f : Hask.arrow A B) (Y : ensemble B)
    : forall x : A, x \in preimage f Y <-> (exists y : B, y = f x /\ y \in Y).
  Proof. intros x; split; [intros [H_x] | intros [y [H_x H_y]]; subst]; eauto. Qed.

  Lemma in_finite_iff {A : Hask.t} (xs : list A)
    : forall z : A, z \in finite xs <-> (In z xs).
  Proof. intros z; split; [intros [H_x] | intros H_x]; eauto. Qed.

  Lemma in_intersection_iff {A : Hask.t} (X1 : ensemble A) (X2 : ensemble A)
    : forall z : A, z \in intersection X1 X2 <-> (z \in X1 /\ z \in X2).
  Proof. intros z; split; intros [H_l H_r]; eauto. Qed.

  Lemma in_full_iff {A : Hask.t}
    : forall z : A, z \in full <-> (True).
  Proof. intros z; split; eauto. Qed.

  Lemma in_empty_iff {A : Hask.t}
    : forall z : A, z \in empty <-> (False).
  Proof. intros z; split; intros []. Qed.

  Lemma in_complement_iff {A : Hask.t} (X : ensemble A)
    : forall z : A, z \in complement X <-> (~ z \in X).
  Proof. reflexivity. Qed.

  Lemma in_setminus_iff {A : Hask.t} (X1 : ensemble A) (X2 : ensemble A)
    : forall z : A, z \in setminus X1 X2 <-> (z \in X1 /\ ~ z \in X2).
  Proof. intros z. unfold setminus. rewrite in_intersection_iff, in_complement_iff. tauto. Qed.

  Lemma in_singleton_iff {A : Hask.t} (x : A)
    : forall z : A, z \in singleton x <-> (x = z).
  Proof. intros z. reflexivity. Qed.

  Lemma in_delete_iff {A : Hask.t} (x : A) (X : ensemble A)
    : forall z : A, z \in delete x X <-> (x <> z /\ z \in X).
  Proof. intros z. unfold delete. rewrite in_setminus_iff, in_singleton_iff. tauto. Qed.

  Lemma in_insert_iff {A : Hask.t} (x : A) (X : ensemble A)
    : forall z : A, z \in insert x X <-> (x = z \/ z \in X).
  Proof. intros z. unfold insert. rewrite in_union_iff, in_singleton_iff. tauto. Qed.

  Local Instance Powerset_isCovariantFunctor : isCovariantFunctor ensemble := { fmap {A : Hask.t} {B : Hask.t} := image (A := A) (B := B) }.
  Local Instance Powerset_isContravariantFunctor : isContravariantFunctor ensemble := { contramap {B : Hask.t} {A : Hask.t} := preimage (A := A) (B := B) }.

  Create HintDb ensemble_hints.
  Global Hint Rewrite @in_union_iff @in_unions_i_iff @in_image_iff @in_preimage_iff @in_finite_iff @in_intersection_iff @in_full_iff @in_empty_iff @in_complement_iff @in_setminus_iff @in_singleton_iff @in_delete_iff @in_insert_iff using eauto : ensemble_hints.

  Global Add Parametric Morphism (A : Type) :
    (@member A) with signature (eq ==> leProp ==> impl)
    as member_eq_leProp_with_impl.
  Proof. ii. cbv in *. eauto. Qed.

  Global Add Parametric Morphism (A : Type) :
    (@member A) with signature (eq ==> eqProp ==> iff)
    as member_eq_eqProp_with_iff.
  Proof. ii. cbv in *. eauto. Qed.

  Section POWERSET_MONAD.

  Definition ensemble_pure {A : Hask.t} (x : A) : ensemble A := fun z : A => x = z.

  Definition ensemble_bind {A : Hask.t} {B : Hask.t} (X : ensemble A) (k : A -> ensemble B) : ensemble B := fun z : B => exists x : A, member x X /\ member z (k x).

  Global Instance ensemble_isMonad : isMonad ensemble :=
    { pure {A : Hask.t} := ensemble_pure (A := A)
    ; bind {A : Hask.t} {B : Hask.t} := ensemble_bind (A := A) (B := B)
    }
  .

  Local Instance ensemble_isSetoid1 : isSetoid1 ensemble :=
    { liftSetoid1 {X : Hask.t} (X_isSetoid : isSetoid X) := @ensemble_isSetoid X
    }
  .

  Global Instance ensemble_obeyMonadLaws
    : LawsOfMonad ensemble.
  Proof with try now firstorder. split; vm_compute... all: des... Qed.

  End POWERSET_MONAD.

  Section WITH_LIST.

  Definition isFiniteSubsetOf {A : Type} (xs : list A) (X : ensemble A) : Prop := forall z : A, In z xs -> member z X.

  Definition isListRepOf {A : Type} (xs : list A) (X : ensemble A) : Prop := forall z : A, In z xs <-> member z X.

  Context {A : Type}.

  Lemma isFiniteSubsetOf_nil
    : isFiniteSubsetOf [] (@empty A).
  Proof. unfold isFiniteSubsetOf in *. simpl. tauto. Qed.

  Lemma isListRepOf_nil
    : isListRepOf [] (@empty A).
  Proof.
    unfold isListRepOf in *. intro. simpl.
    rewrite in_empty_iff. tauto.
  Qed.

  Lemma isFiniteSubsetOf_cons (x : A) (xs : list A) (X : ensemble A)
    (xs_isFiniteSubsetOf_X : isFiniteSubsetOf xs X)
    : isFiniteSubsetOf (x :: xs) (insert x X).
  Proof. unfold isFiniteSubsetOf in *. simpl. now firstorder. Qed.

  Lemma isListRepOf_cons (x : A) (xs : list A) (X : ensemble A)
    (xs_isListRepOf_X : isListRepOf xs X)
    : isListRepOf (x :: xs) (insert x X).
  Proof. unfold isListRepOf in *. simpl. now firstorder. Qed.

  Lemma isFiniteSubsetOf_append (xs1 : list A) (xs2 : list A) (X : ensemble A)
    (xs1_isFiniteSubsetOf_X : isFiniteSubsetOf xs1 X)
    (xs2_isFiniteSubsetOf_X : isFiniteSubsetOf xs2 X)
    : isFiniteSubsetOf (xs1 ++ xs2) X.
  Proof.
    unfold isFiniteSubsetOf in *. intro.
    rewrite in_app_iff. now firstorder.
  Qed.

  Lemma isListRepOf_append (xs1 : list A) (xs2 : list A) (X1 : ensemble A) (X2 : ensemble A)
    (xs1_isListRepOf_X : isListRepOf xs1 X1)
    (xs2_isListRepOf_X : isListRepOf xs2 X2)
    : isListRepOf (xs1 ++ xs2) (union X1 X2).
  Proof.
    unfold isListRepOf in *. intro.
    rewrite in_app_iff. now firstorder.
  Qed.

  Lemma isFiniteSubsetOf_remove {requireEqDec : EqDec A} (x : A) (xs : list A) (X : ensemble A)
    (xs_isFiniteSubsetOf_insert_x_X : isFiniteSubsetOf xs (insert x X))
    : isFiniteSubsetOf (remove eq_dec x xs) X.
  Proof.
    unfold isListRepOf in *. intros z z_in.
    exploit (in_remove eq_dec xs z x z_in) as [z_in_xs z_ne_x].
    pose proof (xs_isFiniteSubsetOf_insert_x_X z z_in_xs) as claim1.
    eapply in_insert_iff in claim1. destruct claim1 as [x_eq_z | z_in_X].
    - now contradiction (z_ne_x).
    - now firstorder.
  Qed.

  Lemma isListRepOf_remove {requireEqDec : EqDec A} (x : A) (xs : list A) (X : ensemble A)
    (xs_isListRepOf_insert_x_X : isListRepOf xs X)
    : isListRepOf (remove eq_dec x xs) (delete x X).
  Proof.
    unfold isListRepOf in *. intros z.
    pose proof (in_remove eq_dec xs z x) as claim1.
    pose proof (in_in_remove eq_dec xs) as claim2.
    rewrite in_delete_iff. now firstorder.
  Qed.

  End WITH_LIST.

  Global Hint Unfold isFiniteSubsetOf isListRepOf : khan_hints.

  Section SUBSET_INTRO.

  Context {A : Type}.

  Lemma isSubsetOf_insert_if (x : A) (X1 : ensemble A) (X2 : ensemble A)
    (X1_isSubsetOf_X2 : isSubsetOf X1 X2)
    : isSubsetOf (insert x X1) (insert x X2).
  Proof. intros z. rewrite in_insert_iff. unfold isSubsetOf in *. now firstorder. Qed.

  Lemma isSubsetOf_singleton_if (x : A) (X : ensemble A)
    (x_in_X : member x X)
    : isSubsetOf (singleton x) X.
  Proof. intros z. rewrite in_singleton_iff. des. now firstorder. Qed.

  Lemma isSubsetOf_empty_if (X : ensemble A)
    : isSubsetOf empty X.
  Proof. intros z. rewrite in_empty_iff. tauto. Qed.

  End SUBSET_INTRO.

  Global Hint Resolve isSubsetOf_insert_if isSubsetOf_singleton_if isSubsetOf_empty_if : ensemble_hints.

  Definition isFilterReprOf {A : Hask.t} (phi : A -> Prop) (X_repr : ensemble (@sig A phi)) (X : ensemble A) : Prop :=
    forall z : @sig A phi, member (proj1_sig z) X <-> member z X_repr
  .

  Global Hint Unfold isFilterReprOf : khan_hints.

  Theorem isFilterReprOf_iff {A : Hask.t} (phi : A -> Prop) (X : ensemble A)
    : forall X_repr : ensemble (@sig A phi), << FILTER_REPR : isFilterReprOf phi X_repr X >> <-> << REPR_IS_PREIMAGE : X_repr == preimage (@proj1_sig A phi) X >>.
  Proof with eauto with *.
    iis.
    { intros H_REPR z; desnw. rewrite <- FILTER_REPR, in_preimage_iff. des... }
    { intros H_preimage z; desnw. rewrite REPR_IS_PREIMAGE, in_preimage_iff; des... }
  Qed.

  Corollary isFilterReprOf_implies {A : Hask.t} (phi : A -> Prop) (X_repr : ensemble (@sig A phi)) (X : ensemble A)
    (X_repr_isFilterReprOf_X : isFilterReprOf phi X_repr X)
    : image (@proj1_sig A phi) X_repr == intersection X phi.
  Proof with eauto with *.
    intros z. split.
    - intros z_in. inversion z_in; subst. econstructor.
      + eapply X_repr_isFilterReprOf_X...
      + exact (@proj2_sig A phi x).
    - intros z_in. apply in_intersection_iff in z_in. destruct z_in as [z_in_X phi_z].
      pose proof (proj1 (X_repr_isFilterReprOf_X (exist _ z phi_z)) z_in_X) as z_in_X_repr...
  Qed.

  Definition fromSequence {I : Type} {A : Type} (x_i : I -> A) : ensemble A :=
    fun x : A => exists i : I, x = x_i i
  .

  Definition Rel_id {A : Type} : ensemble (A * A) :=
    fun '(lhs, rhs) => lhs = rhs
  .

  Definition Rel_flip {A : Type} {B : Type} (X : ensemble (A * B)) : ensemble (B * A) :=
    fun '(lhs, rhs) => member (rhs, lhs) X
  .

  Definition Rel_compose {A : Type} {B : Type} {C : Type} (X : ensemble (A * B)) (X' : ensemble (B * C)) : ensemble (A * C) :=
    fun '(lhs, rhs) => exists x : B, member (lhs, x) X /\ member (x, rhs) X'
  .

  Global Add Parametric Morphism (A : Type) :
    (@union A) with signature (eqProp ==> eqProp ==> eqProp)
    as union_lifts_eqProp.
  Proof.
    intros X X' X_eq_X' Y Y' Y_eq_Y' z.
    do 2 rewrite in_union_iff.
    do 3 red in X_eq_X', Y_eq_Y'. now firstorder.
  Qed.

  Global Add Parametric Morphism (A : Type) :
    (@insert A) with signature (eq ==> eqProp ==> eqProp)
    as insert_lifts_eqProp.
  Proof.
    intros x X X' X_eq_X' z.
    do 2 rewrite in_insert_iff.
    do 3 red in X_eq_X'. now firstorder.
  Qed.

  Global Add Parametric Morphism (A : Type) :
    (@intersection A) with signature (eqProp ==> eqProp ==> eqProp)
    as intersection_lifts_eqProp.
  Proof.
    intros X X' X_eq_X' Y Y' Y_eq_Y' z.
    do 2 rewrite in_intersection_iff.
    do 3 red in X_eq_X', Y_eq_Y'. now firstorder.
  Qed.

(** "Ensemble Tactics" *)

  Ltac ensemble_rewrite := autorewrite with ensemble_hints using eauto.

End Ensembles.

Module E := Ensembles.

Export Ensembles.

Module MathNotations.

  Global Declare Custom Entry math_term_scope.
  Global Declare Custom Entry math_form_scope.
  Global Declare Scope math_scope.
  Global Bind Scope math_scope with Funclass Sortclass.
  Global Open Scope math_scope.

(** "Auxiliary Symbols" *)
  Global Notation " t " := t (t ident, in custom math_term_scope at level 0).
  Global Notation " '(' t ')' " := t (in custom math_term_scope at level 0, t custom math_term_scope at level 11).
  Global Notation " x '↦' t " := (fun x => t) (x pattern, in custom math_term_scope at level 11, right associativity).
  Global Notation " '⟦' t '⟧' " := t (t constr, in custom math_term_scope at level 0).
  Global Notation " P " := P (P custom math_term_scope at level 11, in custom math_form_scope at level 0).
  Global Notation " '(' P ')' " := P (in custom math_form_scope at level 0, P custom math_form_scope at level 11).
  Global Notation " '⟪' '_' '⋯' P '⟫' " := << P >> (P custom math_form_scope at level 11, in custom math_form_scope at level 0).
  Global Notation " '⟪' H_P '⋯' P '⟫' " := ⟪ H_P : P ⟫ (H_P name, P custom math_form_scope at level 11, in custom math_form_scope at level 0).
  Global Notation " '⟪' P '⟫' " := P (P custom math_form_scope at level 11, in custom math_term_scope at level 0).

(** "Terms" *)
  (* Data Constructor *)
  Global Notation " '()' " := (tt)
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " '𝐓' " := (true)
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " '𝐅' " := (false)
    (in custom math_term_scope at level 0, no associativity).
  (* Bool *)
  Global Notation " 'if' b 'then' t 'else' s 'end' " := (if b then t else s)
    (in custom math_term_scope at level 0, no associativity, format "'[v' 'if'  b '//' '[' 'then'  t ']' '//' '[' 'else'  s ']' '//' 'end' ']'").
  Global Notation " s '≟' t " := (MathProps.eq_dec s t)
    (in custom math_term_scope at level 6, no associativity).
  (* Category *)
  Global Notation " s '∘' t " := (Cat.compose s t)
    (in custom math_term_scope at level 1, left associativity).
  Global Notation " 'id' " := (Cat.id)
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " s '→' t " := (Cat.hom s t)
    (in custom math_term_scope at level 10, right associativity).
  Global Notation " '★' " := (Hask.t)
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " 'ℍ𝕒𝕤𝕜' " := (Hask.cat)
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " s '----->' t " := (Cat.Functor_t s t)
    (in custom math_term_scope at level 10, no associativity).
  Global Notation " s '=====>' t " := (Cat.isNaturalTransformation s t)
    (in custom math_term_scope at level 10, no associativity).
  (* Ensemble *)
  Global Notation " s '∪' t " := (union s t)
    (in custom math_term_scope at level 1, left associativity).
  Global Notation " '⋃_{' i '∈' t  '}' s " := (unions_i (fun i : t => s))
    (i pattern, in custom math_term_scope at level 1, no associativity).
  Global Notation " '⋃' s " := (unions s)
    (in custom math_term_scope at level 1, no associativity).
  Global Notation " f '^{→}' '[' X ']' " := (image f X)
    (in custom math_term_scope at level 1, left associativity).
  Global Notation " f '^{←}' '[' X ']' " := (preimage f X)
    (in custom math_term_scope at level 1, left associativity).
  Global Notation " '\{' s ',' t ',' .. ',' u '\}' " := (finite (cons s (cons t .. (cons u nil) ..)))
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " s '∩' t " := (intersection s t)
    (in custom math_term_scope at level 1, left associativity).
  Global Notation " 'Univ_{' A  '}' " := (@full A)
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " '∅' " := (empty)
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " s '^{c}' " := (complement s)
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " s '∖' t " := (setminus s t)
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " '\{' s '\}' " := (singleton s)
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " t `Set.delete` s " := (delete t s)
    (in custom math_term_scope at level 1, left associativity).
  Global Notation " t `Set.insert` s " := (insert t s)
    (in custom math_term_scope at level 1, left associativity).

(** "Atomic Formulas" *)
  (* Setoid *)
  Global Notation " t '≡' s " := (eqProp t s)
    (t custom math_term_scope at level 6, s custom math_term_scope at level 6, in custom math_form_scope at level 7, no associativity).
  (* Poset *)
  Global Notation " t '≦' s " := (leProp t s)
    (t custom math_term_scope at level 6, s custom math_term_scope at level 6, in custom math_form_scope at level 7, no associativity).
  (* Ensemble *)
  Global Notation " t '∈' s " := (member t s)
    (t custom math_term_scope at level 6, s custom math_term_scope at level 6, in custom math_form_scope at level 7, no associativity).
  Global Notation " t '⊆' s " := (isSubsetOf t s)
    (t custom math_term_scope at level 6, s custom math_term_scope at level 6, in custom math_form_scope at level 7, no associativity).

(** "Logical Connectives" *)
  (* Propositional logic *)
  Global Notation " '⊤' " := (True)
    (in custom math_form_scope at level 0, no associativity).
  Global Notation " '⊥' " := (False)
    (in custom math_form_scope at level 0, no associativity).
  Global Notation " '¬' P " := (not P)
    (P custom math_form_scope, in custom math_form_scope at level 7, right associativity).
  Global Notation " P '∧' Q " := (and P Q)
    (P custom math_form_scope, Q custom math_form_scope, in custom math_form_scope at level 8, right associativity).
  Global Notation " P '∨' Q " := (or P Q)
    (P custom math_form_scope, Q custom math_form_scope, in custom math_form_scope at level 9, right associativity).
  Global Notation " P '⟶' Q " := (impl P Q)
    (P custom math_form_scope, Q custom math_form_scope, in custom math_form_scope at level 10, right associativity).
  Global Notation " P '⟷' Q " := (iff P Q)
    (P custom math_form_scope, Q custom math_form_scope, in custom math_form_scope at level 10, no associativity).
  (* First-order logic *)
  Global Notation " '(∀' x '∈' A ')'  '⟪' P '⟫' " := (forall x : A, P)
    (x binder, A custom math_term_scope at level 0, P custom math_form_scope at level 11, in custom math_form_scope at level 1, no associativity).
  Global Notation " '(∃' x '∈' A ')'  '⟪' P '⟫' " := (exists x : A, P)
    (x binder, A custom math_term_scope at level 0, P custom math_form_scope at level 11, in custom math_form_scope at level 1, no associativity).
  Global Notation " t '=' s " := (t = s)
    (t custom math_term_scope at level 6, s custom math_term_scope at level 6, in custom math_form_scope at level 7, no associativity).
  Global Notation " t '≠' s " := (t <> s)
    (t custom math_term_scope at level 6, s custom math_term_scope at level 6, in custom math_form_scope at level 7, no associativity).

(** "Type" *)
  Global Notation " '𝟘' " := (Empty_set)
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " '𝟙' " := (unit)
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " '𝟚' " := (bool)
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " A '×' B " := (prod A B)
    (in custom math_term_scope at level 6, no associativity).
  Global Notation " A '⊔' B " := (sum A B)
    (in custom math_term_scope at level 6, no associativity).
  Global Notation " '⨆_{' x '∈' A  '}' B " := (@sigT A (fun x => B))
    (x pattern, A custom math_term_scope at level 6, B custom math_term_scope at level 1, in custom math_term_scope at level 1).
  Global Notation " '\{' x '∈' A '|' B '\}' " := (@sig A (fun x => B))
    (x pattern, A custom math_term_scope at level 6, B custom math_form_scope at level 11, in custom math_term_scope at level 0).
  Global Notation " 'ℕ' " := (nat)
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " '𝐏𝐫𝐨𝐩' " := (Prop)
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " '𝐒𝐞𝐭' " := (Set)
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " '𝐓𝐲𝐩𝐞' " := (Type)
    (in custom math_term_scope at level 0, no associativity).
  Global Notation " '℘' A " := (ensemble A)
    (A constr, in custom math_term_scope at level 1, no associativity).
  Global Notation " P '->' Q " := (forall _ : P, Q)
    (P custom math_form_scope, Q custom math_form_scope, in custom math_term_scope at level 11, right associativity).

(** "Entry Points" *)
  Global Notation " '$' t '$' " := t (only printing, t custom math_term_scope at level 11, at level 0, no associativity) : math_scope.
  Global Notation " '$$' P '$$' " := P (only printing, P custom math_form_scope at level 11, at level 0, no associativity) : math_scope.

(** "MathNotations Test #1" *)
(* Check (Cat.compose (fun x : nat => x) (fun x : nat => x)). *)
(* "$ (x ↦ x) ∘ (x ↦ x) $ : $ ℕ → ℕ $" *)

(** "MathNotations Test #2" *)
(* Check (Cat.compose Cat.id (fun x : nat => x + 1)). *)
(* "$ id ∘ (x ↦ ⟦ x + 1 ⟧) $ : $ ℕ → ℕ $" *)

(** "MathNotations Test #3" *)
(* Check (fun x : nat => x + 1 = 2). *)
(* "$ x ↦ ⟪ ⟦ x + 1 ⟧ = ⟦ 2 ⟧ ⟫ $ : $ ℕ -> 𝐏𝐫𝐨𝐩 $" *)

(** "MathNotations Test #4" *)
(* Check (fun x : nat => exists y : nat, x + 1 = y + 1). *)
(* "$ x ↦ ⟪ (∃y ∈ ℕ) ⟪ ⟦ x + 1 ⟧ = ⟦ y + 1 ⟧ ⟫ ⟫ $ : $ ℕ -> 𝐏𝐫𝐨𝐩 $" *)

(** "MathNotations Test #5" *)
(* Check (fun x : nat => {y : nat | x + 1 = y + 1}). *)
(* "$ x ↦ \{ y ∈ ℕ | ⟦ x + 1 ⟧ = ⟦ y + 1 ⟧ \} $ : $ ℕ -> 𝐒𝐞𝐭 $" *)

(** "MathNotations Test #6" *)
(* Check (fun x : nat => {'(z, y) : nat * nat | x + 1 = y + 1 /\ z = 1}). *)
(* "$ x ↦ \{ (z, y) ∈ ℕ × ℕ | ⟦ x + 1 ⟧ = ⟦ y + 1 ⟧ ∧ z = ⟦ 1 ⟧ \} $ : $ ℕ -> 𝐒𝐞𝐭 $" *)

(** "MathNotations Test #7" *)
(* Check (forall x : nat, x = 1 -> x = 1). *)
(* "$$ (∀x ∈ ℕ) ⟪ x = ⟦ 1 ⟧ -> x = ⟦ 1 ⟧ ⟫ $$ : $ 𝐏𝐫𝐨𝐩 $" *)

End MathNotations.

Module MathClasses.

  Import MathProps.

  Section AXIOMS.

  Context (S : Hask.t) {requireSetoid : isSetoid S}.

  Class Magma_axiom (bin_op : S -> S -> S) : Prop := Magma_requiresCongruence :> preserves_eqProp2 bin_op.

  Class Semigroup_axiom (add : S -> S -> S) : Prop :=
    { Semigroup_requiresMagma :> Magma_axiom add
    ; Semigroup_requiresAssoc :> Assoc add
    }
  .

  Class Monoid_axiom (add : S -> S -> S) (zero : S) : Prop :=
    { Monoid_requiresSemigroup :> Semigroup_axiom add
    ; Monoid_requiresIdElem :> zero `isIdentityOf` add
    }
  .

  Class Group_axiom (add : S -> S -> S) (zero : S) (neg : S -> S) : Prop :=
    { Group_requiresMonoid :> Monoid_axiom add zero
    ; Group_requiresInvOp :> neg `isInverseOpFor` add
    }
  .

  Global Instance neg_preserves_eqProp_inGroup {add : S -> S -> S} {zero : S} {neg : S -> S}
    (requiresGroup : Group_axiom add zero neg)
    : preserves_eqProp1 neg.
  Proof.
    ii. destruct requiresGroup as [requiresMonoid [neg_left_inv_add neg_right_inv_add]].
    rewrite <- right_id. rewrite <- neg_right_inv_add with (x := rhs1).
    assert (claim1 : add (neg lhs1) rhs1 == zero) by now rewrite <- H_EQ1.
    now rewrite associativity, claim1, left_id.
  Qed.

  End AXIOMS.

  Class Has_add (S : Hask.t) : Type := add : S -> S -> S.

  Class Has_zero (M : Hask.t) : Type := zero : M.

  Class Has_neg (G : Hask.t) : Type := neg : G -> G.

  Class Has_mul (R : Hask.t) : Type := mul : R -> R -> R.

  Class Has_unity (R : Hask.t) : Type := unity : R.

  Global Notation " x '+' y " := (add x y) (in custom math_term_scope at level 4, left associativity).
  Global Notation " '0' " := (zero) (in custom math_term_scope at level 0, no associativity).
  Global Notation " '-' x " := (neg x) (in custom math_term_scope at level 2, right associativity).
  Global Notation " x '-' y " := (add x (neg y)) (in custom math_term_scope at level 4, left associativity).
  Global Notation " x '*' y " := (mul x y) (in custom math_term_scope at level 3, left associativity).
  Global Notation " '1' " := (unity) (in custom math_term_scope at level 0, no associativity).

  Definition nonzero {K : Hask.t} {requireSetoid : isSetoid K} {requires_zero : Has_zero K} (x : K) : Prop := ~ x == zero.

  Definition zero_removed (K : Hask.t) {requireSetoid : isSetoid K} {requires_zero : Has_zero K} : Hask.t := @sig K nonzero.

  Class isSemigroup (S : Hask.t) {requireSetoid : isSetoid S} : Type :=
    { Semigroup_has_add :> Has_add S
    ; Semigroup_add_congru :> preserves_eqProp2 add
    ; Semigroup_add_assoc :> Assoc add
    }
  .

  Class isMonoid (M : Hask.t) {requireSetoid : isSetoid M} : Type :=
    { Monoid_hasSemigroup :> isSemigroup M
    ; Monoid_has_zero :> Has_zero M
    ; Monoid_zero_id_add :> zero `isIdentityOf` add
    }
  .

  Class isGroup (G : Hask.t) {requireSetoid : isSetoid G} : Type :=
    { Group_hasMonoid :> isMonoid G
    ; Group_has_neg :> Has_neg G
    ; Group_neg_inv_add :> neg `isInverseOpFor` add
    }
  .

  Class isRig (R : Hask.t) {requireSetoid : isSetoid R} : Type :=
    { Rig_hasAdditiveMonoid :> isMonoid R
    ; Rig_has_mul :> Has_mul R
    ; Rig_has_unity :> Has_unity R
    ; Rig_add_comm :> Comm add
    ; Rig_hasMultiplicateMonoid :> Monoid_axiom R mul unity
    ; Rig_mul_distr_add :> mul `distributesOver` add
    }
  .

  Class isRng (R : Hask.t) {requireSetoid : isSetoid R} : Type :=
    { Rng_hasAdditiveGroup :> isGroup R
    ; Rng_has_mul :> Has_mul R
    ; Rng_add_comm :> Comm add
    ; Rng_hasMultiplicateSemigroup :> Semigroup_axiom R mul
    ; Rng_mul_distr_add :> mul `distributesOver` add
    }
  .

  Class isRing (R : Hask.t) {requireSetoid : isSetoid R} : Type :=
    { Ring_hasRng :> isRng R
    ; Ring_has_unity :> Has_unity R
    ; Ring_unity_id_mul :> unity `isIdentityOf` mul
    }
  .

  Class isField (K : Hask.t) {requireSetoid : isSetoid K} : Type :=
    { Field_hasRing :> isRing K
    ; recip : zero_removed K -> zero_removed K
    ; Field_unity_nonzero : nonzero unity
    ; Field_absenceOfZeroDivisor
      : forall x : zero_removed K, forall y : zero_removed K, nonzero (mul (proj1_sig x) (proj1_sig y))
    ; Field_hasMultiplicateGroup :> Group_axiom (zero_removed K) (fun x : zero_removed K => fun y : zero_removed K => @exist K nonzero (mul (proj1_sig x) (proj1_sig y)) (Field_absenceOfZeroDivisor x y)) (@exist K nonzero unity Field_unity_nonzero) recip
    ; Field_mul_comm :> Comm mul
    }
  .

End MathClasses.


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

 Product of enriched categories

 We show that the product of enriched categories is again enriched over the same
 monoidal category. For this, we assume that the monoidal category is cartesian.

 Note that this is different from what is usual in enriched category theory.
 Suppose that we have two category `E₁` and `E₂` enriched over some monoidal
 category `V`. Their product is usually defined as follows:
 - Objects: pairs `x : E₁` and y : E₂`
 - Morphisms from `(x₁ ,, y₁)` to `(x₂ ,, y₂)` are given by
 ```
 E₁ ⦃ x₁ , x₂ ⦄ ⊗ E₂ ⦃ y₁ , y₂ ⦄
 ```
 To guarantee that the composition can be defined, we need to assume that `V` is
 symmetric.

 In our setting, we would like the construction to be compatible with univalence.
 As such, the isomorphisms are determined: by univalence, isomorphisms from
 `(x₁ ,, y₁)` to `(x₂ ,, y₂)` should be the same as pairs of isomorphisms from
 `x₁` to `x₂` and `y₁` to `y₂`. For that reason, we would like the morphisms in
 the product to be pairs of morphisms in `E₁` and in `E₂`.

 This is not the case in general for arbitrary monoidal categories. For example,
 if we look at the category of abelian groups with the tensor product, then
 morphisms in the product are not necessarily pairs of morphisms. For that reason,
 we assume that `V` is cartesian, which is sufficient to guarantee that the
 morphisms in the product are pairs of morphisms.

 *********************************************************************************)
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.opp_precat.
Require Import UniMath.CategoryTheory.Core.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
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.Structure.Cartesian.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.binproducts.

Local Open Scope cat.
Local Open Scope moncat.
Import MonoidalNotations.

Section ProductEnrichment.
  Context (V : monoidal_cat)
          (HV : is_cartesian V)
          {C₁ C₂ : category}
          (E₁ : enrichment C₁ V)
          (E₂ : enrichment C₂ V).

  Definition product_enrichment_hom
             (x₁ y₁ : C₁)
             (x₂ y₂ : C₂)
    : V
    := (E₁ ⦃ x₁ , y₁ ⦄) ⊗ (E₂ ⦃ x₂ , y₂ ⦄).

  Definition product_enrichment_id
             (x₁ : C₁)
             (x₂ : C₂)
    : I_{V} --> product_enrichment_hom x₁ x₁ x₂ x₂.
  Proof.
    use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)).
    - exact (enriched_id E₁ x₁).
    - exact (enriched_id E₂ x₂).
  Defined.

  Proposition product_enrichment_id_pr1
              (x₁ : C₁)
              (x₂ : C₂)
    : product_enrichment_id x₁ x₂ · semi_cart_tensor_pr1 HV _ _
      =
      enriched_id E₁ x₁.
  Proof.
    apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
  Qed.

  Proposition product_enrichment_id_pr2
              (x₁ : C₁)
              (x₂ : C₂)
    : product_enrichment_id x₁ x₂ · semi_cart_tensor_pr2 HV _ _
      =
      enriched_id E₂ x₂.
  Proof.
    apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
  Qed.

  Definition product_enrichment_pr1_comp
             (x₁ y₁ z₁ : C₁)
             (x₂ y₂ z₂ : C₂)
    : product_enrichment_hom y₁ z₁ y₂ z₂ ⊗ product_enrichment_hom x₁ y₁ x₂ y₂
      -->
      (E₁ ⦃ y₁, z₁ ⦄) ⊗ (E₁ ⦃ x₁, y₁ ⦄).
  Proof.
    use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)).
    - exact (semi_cart_tensor_pr1 HV _ _ · semi_cart_tensor_pr1 HV _ _).
    - exact (semi_cart_tensor_pr2 HV _ _ · semi_cart_tensor_pr1 HV _ _).
  Defined.

  Proposition product_enrichment_pr1_comp_pr1
              (x₁ y₁ z₁ : C₁)
              (x₂ y₂ z₂ : C₂)
    : product_enrichment_pr1_comp x₁ y₁ z₁ x₂ y₂ z₂
      · semi_cart_tensor_pr1 HV _ _
      =
      semi_cart_tensor_pr1 HV _ _ · semi_cart_tensor_pr1 HV _ _.
  Proof.
    apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
  Qed.

  Proposition product_enrichment_pr1_comp_pr2
              (x₁ y₁ z₁ : C₁)
              (x₂ y₂ z₂ : C₂)
    : product_enrichment_pr1_comp x₁ y₁ z₁ x₂ y₂ z₂
      · semi_cart_tensor_pr2 HV _ _
      =
      semi_cart_tensor_pr2 HV _ _ · semi_cart_tensor_pr1 HV _ _.
  Proof.
    apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
  Qed.

  Definition product_enrichment_pr2_comp
             (x₁ y₁ z₁ : C₁)
             (x₂ y₂ z₂ : C₂)
    : product_enrichment_hom y₁ z₁ y₂ z₂ ⊗ product_enrichment_hom x₁ y₁ x₂ y₂
      -->
      (E₂ ⦃ y₂, z₂ ⦄) ⊗ (E₂ ⦃ x₂, y₂ ⦄).
  Proof.
    use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)).
    - exact (semi_cart_tensor_pr1 HV _ _ · semi_cart_tensor_pr2 HV _ _).
    - exact (semi_cart_tensor_pr2 HV _ _ · semi_cart_tensor_pr2 HV _ _).
  Defined.

  Proposition product_enrichment_pr2_comp_pr1
              (x₁ y₁ z₁ : C₁)
              (x₂ y₂ z₂ : C₂)
    : product_enrichment_pr2_comp x₁ y₁ z₁ x₂ y₂ z₂
      · semi_cart_tensor_pr1 HV _ _
      =
      semi_cart_tensor_pr1 HV _ _ · semi_cart_tensor_pr2 HV _ _.
  Proof.
    apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
  Qed.

  Proposition product_enrichment_pr2_comp_pr2
              (x₁ y₁ z₁ : C₁)
              (x₂ y₂ z₂ : C₂)
    : product_enrichment_pr2_comp x₁ y₁ z₁ x₂ y₂ z₂
      · semi_cart_tensor_pr2 HV _ _
      =
      semi_cart_tensor_pr2 HV _ _ · semi_cart_tensor_pr2 HV _ _.
  Proof.
    apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
  Qed.

  Definition product_enrichment_comp
             (x₁ y₁ z₁ : C₁)
             (x₂ y₂ z₂ : C₂)
    : product_enrichment_hom y₁ z₁ y₂ z₂ ⊗ product_enrichment_hom x₁ y₁ x₂ y₂
      -->
      product_enrichment_hom x₁ z₁ x₂ z₂.
  Proof.
    use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)).
    - exact (product_enrichment_pr1_comp x₁ y₁ z₁ x₂ y₂ z₂ · enriched_comp E₁ x₁ y₁ z₁).
    - exact (product_enrichment_pr2_comp x₁ y₁ z₁ x₂ y₂ z₂ · enriched_comp E₂ x₂ y₂ z₂).
  Defined.

  Proposition product_enrichment_comp_pr1
              (x₁ y₁ z₁ : C₁)
              (x₂ y₂ z₂ : C₂)
    : product_enrichment_comp x₁ y₁ z₁ x₂ y₂ z₂
      · semi_cart_tensor_pr1 HV _ _
      =
      product_enrichment_pr1_comp x₁ y₁ z₁ x₂ y₂ z₂ · enriched_comp E₁ x₁ y₁ z₁.
  Proof.
    apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
  Qed.

  Proposition product_enrichment_comp_pr2
              (x₁ y₁ z₁ : C₁)
              (x₂ y₂ z₂ : C₂)
    : product_enrichment_comp x₁ y₁ z₁ x₂ y₂ z₂
      · semi_cart_tensor_pr2 HV _ _
      =
      product_enrichment_pr2_comp x₁ y₁ z₁ x₂ y₂ z₂ · enriched_comp E₂ x₂ y₂ z₂.
  Proof.
    apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
  Qed.

  Definition product_enrichment_from_arr
             {x₁ y₁ : C₁}
             {x₂ y₂ : C₂}
             (f : x₁ --> y₁)
             (g : x₂ --> y₂)
    : I_{V} --> product_enrichment_hom x₁ y₁ x₂ y₂.
  Proof.
    use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)).
    - exact (enriched_from_arr E₁ f).
    - exact (enriched_from_arr E₂ g).
  Defined.

  Proposition product_enrichment_from_arr_pr1
             {x₁ y₁ : C₁}
             {x₂ y₂ : C₂}
             (f : x₁ --> y₁)
             (g : x₂ --> y₂)
    : product_enrichment_from_arr f g
      · semi_cart_tensor_pr1 HV _ _
      =
      enriched_from_arr E₁ f.
  Proof.
    apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
  Qed.

  Proposition product_enrichment_from_arr_pr2
             {x₁ y₁ : C₁}
             {x₂ y₂ : C₂}
             (f : x₁ --> y₁)
             (g : x₂ --> y₂)
    : product_enrichment_from_arr f g
      · semi_cart_tensor_pr2 HV _ _
      =
      enriched_from_arr E₂ g.
  Proof.
    apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
  Qed.

  Definition product_enrichment_to_arr
             {x₁ y₁ : C₁}
             {x₂ y₂ : C₂}
             (fg : I_{V} --> product_enrichment_hom x₁ y₁ x₂ y₂)
    : (x₁ --> y₁) × (x₂ --> y₂)
    := enriched_to_arr E₁ (fg · semi_cart_tensor_pr1 HV _ _)
       ,,
       enriched_to_arr E₂ (fg · semi_cart_tensor_pr2 HV _ _).

  Definition triple_pr1_pr1
             (w₁ x₁ y₁ z₁ : C₁)
             (w₂ x₂ y₂ z₂ : C₂)
    : product_enrichment_hom y₁ z₁ y₂ z₂
      ⊗ product_enrichment_hom x₁ y₁ x₂ y₂
      ⊗ product_enrichment_hom w₁ x₁ w₂ x₂
      -->
      (E₁ ⦃ y₁ , z₁ ⦄) ⊗ (E₁ ⦃ x₁ , y₁ ⦄).
  Proof.
    use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)).
    - exact (semi_cart_tensor_pr1 HV _ _
             · semi_cart_tensor_pr1 HV _ _
             · semi_cart_tensor_pr1 HV _ _).
    - exact (semi_cart_tensor_pr1 HV _ _
             · semi_cart_tensor_pr2 HV _ _
             · semi_cart_tensor_pr1 HV _ _).
  Defined.

  Definition triple_pr1
             (w₁ x₁ y₁ z₁ : C₁)
             (w₂ x₂ y₂ z₂ : C₂)
    : product_enrichment_hom y₁ z₁ y₂ z₂
      ⊗ product_enrichment_hom x₁ y₁ x₂ y₂
      ⊗ product_enrichment_hom w₁ x₁ w₂ x₂
      -->
      (E₁ ⦃ y₁ , z₁ ⦄) ⊗ (E₁ ⦃ x₁ , y₁ ⦄) ⊗ (E₁ ⦃ w₁ , x₁ ⦄).
  Proof.
    use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)).
    - apply triple_pr1_pr1.
    - exact (semi_cart_tensor_pr2 HV _ _ · semi_cart_tensor_pr1 HV _ _).
  Defined.

  Proposition triple_pr1_eq
              (w₁ x₁ y₁ z₁ : C₁)
              (w₂ x₂ y₂ z₂ : C₂)
    : product_enrichment_comp x₁ y₁ z₁ x₂ y₂ z₂ #⊗ identity _
      · product_enrichment_pr1_comp w₁ x₁ z₁ w₂ x₂ z₂
      =
      triple_pr1 _ _ _ _ _ _ _ _
      · enriched_comp E₁ x₁ y₁ z₁ #⊗ identity _.
  Proof.
    use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn.
    - rewrite !assoc'.
      rewrite product_enrichment_pr1_comp_pr1.
      rewrite !assoc.
      rewrite cartesian_tensor_pr1.
      rewrite !assoc'.
      rewrite product_enrichment_comp_pr1.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        apply cartesian_tensor_pr1.
      }
      rewrite !assoc.
      apply maponpaths_2.
      etrans.
      {
        apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
      }
      use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn.
      + etrans.
        {
          apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
        }
        rewrite !assoc'.
        rewrite product_enrichment_pr1_comp_pr1.
        apply idpath.
      + etrans.
        {
          apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
        }
        rewrite !assoc'.
        rewrite product_enrichment_pr1_comp_pr2.
        apply idpath.
    - rewrite !assoc'.
      rewrite product_enrichment_pr1_comp_pr2.
      rewrite !assoc.
      rewrite cartesian_tensor_pr2.
      rewrite !assoc'.
      rewrite id_left.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        apply cartesian_tensor_pr2.
      }
      rewrite id_right.
      etrans.
      {
        apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
      }
      apply idpath.
  Qed.

  Definition triple_pr2_pr1
             (w₁ x₁ y₁ z₁ : C₁)
             (w₂ x₂ y₂ z₂ : C₂)
    : product_enrichment_hom y₁ z₁ y₂ z₂
      ⊗ product_enrichment_hom x₁ y₁ x₂ y₂
      ⊗ product_enrichment_hom w₁ x₁ w₂ x₂
      -->
      (E₂ ⦃ y₂ , z₂ ⦄) ⊗ (E₂ ⦃ x₂ , y₂ ⦄).
  Proof.
    use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)).
    - exact (semi_cart_tensor_pr1 HV _ _
             · semi_cart_tensor_pr1 HV _ _
             · semi_cart_tensor_pr2 HV _ _).
    - exact (semi_cart_tensor_pr1 HV _ _
             · semi_cart_tensor_pr2 HV _ _
             · semi_cart_tensor_pr2 HV _ _).
  Defined.

  Definition triple_pr2
             (w₁ x₁ y₁ z₁ : C₁)
             (w₂ x₂ y₂ z₂ : C₂)
    : product_enrichment_hom y₁ z₁ y₂ z₂
      ⊗ product_enrichment_hom x₁ y₁ x₂ y₂
      ⊗ product_enrichment_hom w₁ x₁ w₂ x₂
      -->
      (E₂ ⦃ y₂ , z₂ ⦄) ⊗ (E₂ ⦃ x₂ , y₂ ⦄) ⊗ (E₂ ⦃ w₂ , x₂ ⦄).
  Proof.
    use (BinProductArrow _ (is_cartesian_BinProduct HV _ _)).
    - apply triple_pr2_pr1.
    - exact (semi_cart_tensor_pr2 HV _ _ · semi_cart_tensor_pr2 HV _ _).
  Defined.

  Proposition triple_pr2_eq
              (w₁ x₁ y₁ z₁ : C₁)
              (w₂ x₂ y₂ z₂ : C₂)
    : product_enrichment_comp x₁ y₁ z₁ x₂ y₂ z₂ #⊗ identity _
      · product_enrichment_pr2_comp w₁ x₁ z₁ w₂ x₂ z₂
      =
      triple_pr2 _ _ _ _ _ _ _ _
      · enriched_comp E₂ x₂ y₂ z₂ #⊗ identity _.
  Proof.
    use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn.
    - rewrite !assoc'.
      rewrite product_enrichment_pr2_comp_pr1.
      rewrite !assoc.
      rewrite cartesian_tensor_pr1.
      rewrite !assoc'.
      rewrite product_enrichment_comp_pr2.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        apply cartesian_tensor_pr1.
      }
      rewrite !assoc.
      apply maponpaths_2.
      etrans.
      {
        apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
      }
      use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn.
      + etrans.
        {
          apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
        }
        rewrite !assoc'.
        rewrite product_enrichment_pr2_comp_pr1.
        apply idpath.
      + etrans.
        {
          apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
        }
        rewrite !assoc'.
        rewrite product_enrichment_pr2_comp_pr2.
        apply idpath.
    - rewrite !assoc'.
      rewrite product_enrichment_pr2_comp_pr2.
      rewrite !assoc.
      rewrite cartesian_tensor_pr2.
      rewrite !assoc'.
      rewrite id_left.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        apply cartesian_tensor_pr2.
      }
      rewrite id_right.
      etrans.
      {
        apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
      }
      apply idpath.
  Qed.

  Definition product_enrichment_data
    : enrichment_data (category_binproduct C₁ C₂) V.
  Proof.
    simple refine (_ ,, _ ,, _ ,, _ ,, _).
    - exact (λ xy₁ xy₂, product_enrichment_hom (pr1 xy₁) (pr1 xy₂) (pr2 xy₁) (pr2 xy₂)).
    - exact (λ xy, product_enrichment_id (pr1 xy) (pr2 xy)).
    - exact (λ xy₁ xy₂ xy₃, product_enrichment_comp _ _ _ _ _ _).
    - exact (λ xy₁ xy₂ fg, product_enrichment_from_arr (pr1 fg) (pr2 fg)).
    - exact (λ xy₁ xy₂ fg, product_enrichment_to_arr fg).
  Defined.

  Proposition product_enrichment_laws
    : enrichment_laws product_enrichment_data.
  Proof.
    repeat split.
    - intros xy₁ xy₂.
      use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)).
      + cbn.
        refine (mon_lunitor_pr1 _ _ _ @ _).
        rewrite enrichment_id_left.
        rewrite !assoc'.
        rewrite product_enrichment_comp_pr1.
        rewrite !assoc.
        apply maponpaths_2.
        use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn.
        * rewrite !assoc'.
          rewrite product_enrichment_pr1_comp_pr1.
          etrans.
          {
            apply maponpaths.
            apply cartesian_tensor_pr1.
          }
          refine (!_).
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            apply cartesian_tensor_pr1.
          }
          rewrite !assoc'.
          etrans.
          {
            apply maponpaths.
            apply product_enrichment_id_pr1.
          }
          rewrite !assoc.
          apply maponpaths_2.
          rewrite cartesian_tensor_pr1.
          rewrite id_right.
          apply idpath.
        * rewrite !assoc'.
          rewrite product_enrichment_pr1_comp_pr2.
          etrans.
          {
            apply maponpaths.
            apply cartesian_tensor_pr2.
          }
          rewrite id_right.
          refine (!_).
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            apply cartesian_tensor_pr2.
          }
          rewrite id_right.
          rewrite cartesian_tensor_pr2.
          apply idpath.
      + cbn.
        refine (mon_lunitor_pr2 _ _ _ @ _).
        rewrite enrichment_id_left.
        rewrite !assoc'.
        rewrite product_enrichment_comp_pr2.
        rewrite !assoc.
        apply maponpaths_2.
        use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn.
        * rewrite !assoc'.
          rewrite product_enrichment_pr2_comp_pr1.
          etrans.
          {
            apply maponpaths.
            apply cartesian_tensor_pr1.
          }
          refine (!_).
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            apply cartesian_tensor_pr1.
          }
          rewrite !assoc'.
          etrans.
          {
            apply maponpaths.
            apply product_enrichment_id_pr2.
          }
          rewrite !assoc.
          apply maponpaths_2.
          rewrite cartesian_tensor_pr1.
          rewrite id_right.
          apply idpath.
        * rewrite !assoc'.
          rewrite product_enrichment_pr2_comp_pr2.
          etrans.
          {
            apply maponpaths.
            apply cartesian_tensor_pr2.
          }
          rewrite id_right.
          refine (!_).
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            apply cartesian_tensor_pr2.
          }
          rewrite id_right.
          rewrite cartesian_tensor_pr2.
          apply idpath.
    - intros xy₁ xy₂.
      use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)).
      + cbn.
        refine (mon_runitor_pr1 _ _ _ @ _).
        rewrite enrichment_id_right.
        rewrite !assoc'.
        rewrite product_enrichment_comp_pr1.
        rewrite !assoc.
        apply maponpaths_2.
        use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn.
        * rewrite !assoc'.
          rewrite product_enrichment_pr1_comp_pr1.
          etrans.
          {
            apply maponpaths.
            apply cartesian_tensor_pr1.
          }
          refine (!_).
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            apply cartesian_tensor_pr1.
          }
          rewrite !assoc'.
          rewrite id_left, id_right.
          rewrite cartesian_tensor_pr1.
          apply idpath.
        * rewrite !assoc'.
          rewrite product_enrichment_pr1_comp_pr2.
          etrans.
          {
            apply maponpaths.
            apply cartesian_tensor_pr2.
          }
          rewrite !assoc.
          rewrite !cartesian_tensor_pr2.
          rewrite id_right.
          rewrite !assoc'.
          apply maponpaths.
          refine (!_).
          apply product_enrichment_id_pr1.
      + cbn.
        refine (mon_runitor_pr2 _ _ _ @ _).
        rewrite enrichment_id_right.
        rewrite !assoc'.
        rewrite product_enrichment_comp_pr2.
        rewrite !assoc.
        apply maponpaths_2.
        use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn.
        * rewrite !assoc'.
          rewrite product_enrichment_pr2_comp_pr1.
          etrans.
          {
            apply maponpaths.
            apply cartesian_tensor_pr1.
          }
          refine (!_).
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            apply cartesian_tensor_pr1.
          }
          rewrite !assoc'.
          rewrite id_left, id_right.
          rewrite cartesian_tensor_pr1.
          apply idpath.
        * rewrite !assoc'.
          rewrite product_enrichment_pr2_comp_pr2.
          etrans.
          {
            apply maponpaths.
            apply cartesian_tensor_pr2.
          }
          rewrite !assoc.
          rewrite !cartesian_tensor_pr2.
          rewrite id_right.
          rewrite !assoc'.
          apply maponpaths.
          refine (!_).
          apply product_enrichment_id_pr2.
    - intros w x y z.
      use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn.
      + rewrite !assoc'.
        rewrite !product_enrichment_comp_pr1.
        rewrite !assoc.
        rewrite triple_pr1_eq.
        rewrite !assoc'.
        rewrite enrichment_assoc.
        rewrite !assoc.
        apply maponpaths_2.
        use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn.
        * rewrite !assoc'.
          etrans.
          {
            do 2 apply maponpaths.
            apply cartesian_tensor_pr1.
          }
          rewrite id_right.
          rewrite mon_lassociator_pr1.
          rewrite product_enrichment_pr1_comp_pr1.
          refine (!_).
          etrans.
          {
            apply maponpaths.
            rewrite !assoc.
            apply maponpaths_2.
            apply cartesian_tensor_pr1.
          }
          rewrite id_right.
          rewrite !assoc.
          rewrite mon_lassociator_pr1.
          refine (!_).
          etrans.
          {
            apply maponpaths_2.
            apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
          }
          apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
        * rewrite !assoc'.
          etrans.
          {
            do 2 apply maponpaths.
            apply cartesian_tensor_pr2.
          }
          rewrite product_enrichment_pr1_comp_pr2.
          refine (!_).
          etrans.
          {
            apply maponpaths.
            rewrite !assoc.
            apply maponpaths_2.
            apply cartesian_tensor_pr2.
          }
          rewrite !assoc'.
          rewrite product_enrichment_comp_pr1.
          rewrite !assoc.
          apply maponpaths_2.
          rewrite !assoc'.
          rewrite mon_lassociator_pr2.
          use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn.
          ** rewrite !assoc'.
             rewrite product_enrichment_pr1_comp_pr1.
             rewrite !assoc.
             rewrite mon_lassociator_pr2.
             rewrite cartesian_tensor_pr1.
             refine (!_).
             rewrite !assoc'.
             etrans.
             {
               apply maponpaths.
               apply cartesian_tensor_pr1.
             }
             rewrite !assoc.
             etrans.
             {
               apply maponpaths_2.
               apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
             }
             apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
          ** rewrite !assoc'.
             rewrite product_enrichment_pr1_comp_pr2.
             rewrite !assoc.
             rewrite mon_lassociator_pr2.
             rewrite cartesian_tensor_pr2.
             refine (!_).
             rewrite !assoc'.
             etrans.
             {
               apply maponpaths.
               apply cartesian_tensor_pr2.
             }
             rewrite !assoc.
             etrans.
             {
               apply maponpaths_2.
               apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
             }
             rewrite !id_right.
             apply idpath.
      + rewrite !assoc'.
        rewrite !product_enrichment_comp_pr2.
        rewrite !assoc.
        rewrite triple_pr2_eq.
        rewrite !assoc'.
        rewrite enrichment_assoc.
        rewrite !assoc.
        apply maponpaths_2.
        use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn.
        * rewrite !assoc'.
          etrans.
          {
            do 2 apply maponpaths.
            apply cartesian_tensor_pr1.
          }
          rewrite id_right.
          rewrite mon_lassociator_pr1.
          rewrite product_enrichment_pr2_comp_pr1.
          refine (!_).
          etrans.
          {
            apply maponpaths.
            rewrite !assoc.
            apply maponpaths_2.
            apply cartesian_tensor_pr1.
          }
          rewrite id_right.
          rewrite !assoc.
          rewrite mon_lassociator_pr1.
          refine (!_).
          etrans.
          {
            apply maponpaths_2.
            apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
          }
          apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
        * rewrite !assoc'.
          etrans.
          {
            do 2 apply maponpaths.
            apply cartesian_tensor_pr2.
          }
          rewrite product_enrichment_pr2_comp_pr2.
          refine (!_).
          etrans.
          {
            apply maponpaths.
            rewrite !assoc.
            apply maponpaths_2.
            apply cartesian_tensor_pr2.
          }
          rewrite !assoc'.
          rewrite product_enrichment_comp_pr2.
          rewrite !assoc.
          apply maponpaths_2.
          rewrite !assoc'.
          rewrite mon_lassociator_pr2.
          use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn.
          ** rewrite !assoc'.
             rewrite product_enrichment_pr2_comp_pr1.
             rewrite !assoc.
             rewrite mon_lassociator_pr2.
             rewrite cartesian_tensor_pr1.
             refine (!_).
             rewrite !assoc'.
             etrans.
             {
               apply maponpaths.
               apply cartesian_tensor_pr1.
             }
             rewrite !assoc.
             etrans.
             {
               apply maponpaths_2.
               apply (BinProductPr1Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
             }
             apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
          ** rewrite !assoc'.
             rewrite product_enrichment_pr2_comp_pr2.
             rewrite !assoc.
             rewrite mon_lassociator_pr2.
             rewrite cartesian_tensor_pr2.
             refine (!_).
             rewrite !assoc'.
             etrans.
             {
               apply maponpaths.
               apply cartesian_tensor_pr2.
             }
             rewrite !assoc.
             etrans.
             {
               apply maponpaths_2.
               apply (BinProductPr2Commutes _ _ _ (is_cartesian_BinProduct HV _ _)).
             }
             rewrite !id_right.
             apply idpath.
    - intros x y f ; cbn.
      use pathsdirprod.
      + rewrite product_enrichment_from_arr_pr1.
        rewrite enriched_to_from_arr.
        apply idpath.
      + rewrite product_enrichment_from_arr_pr2.
        rewrite enriched_to_from_arr.
        apply idpath.
    - intros x y f ; cbn.
      use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn.
      + refine (product_enrichment_from_arr_pr1 _ _ @ _).
        apply enriched_from_to_arr.
      + refine (product_enrichment_from_arr_pr2 _ _ @ _).
        apply enriched_from_to_arr.
    - intros x ; cbn.
      use pathsdirprod.
      + rewrite product_enrichment_id_pr1.
        apply enriched_to_arr_id.
      + rewrite product_enrichment_id_pr2.
        apply enriched_to_arr_id.
    - intros x y z f g ; cbn.
      use pathsdirprod.
      + rewrite (enriched_to_arr_comp E₁).
        apply maponpaths.
        rewrite !assoc'.
        apply maponpaths.
        rewrite product_enrichment_comp_pr1.
        rewrite !assoc.
        apply maponpaths_2.
        use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn.
        * rewrite !assoc'.
          rewrite product_enrichment_pr1_comp_pr1.
          rewrite !assoc.
          rewrite !cartesian_tensor_pr1.
          rewrite !assoc'.
          refine (cartesian_tensor_pr1 _ _ _ @ _).
          apply maponpaths.
          refine (!_).
          apply product_enrichment_from_arr_pr1.
        * rewrite !assoc'.
          rewrite product_enrichment_pr1_comp_pr2.
          rewrite !assoc.
          rewrite !cartesian_tensor_pr2.
          rewrite !assoc'.
          refine (cartesian_tensor_pr2 _ _ _ @ _).
          apply maponpaths.
          refine (!_).
          apply product_enrichment_from_arr_pr1.
      + rewrite (enriched_to_arr_comp E₂).
        apply maponpaths.
        rewrite !assoc'.
        apply maponpaths.
        rewrite product_enrichment_comp_pr2.
        rewrite !assoc.
        apply maponpaths_2.
        use (BinProductArrowsEq _ _ _ (is_cartesian_BinProduct HV _ _)) ; cbn.
        * rewrite !assoc'.
          rewrite product_enrichment_pr2_comp_pr1.
          rewrite !assoc.
          rewrite !cartesian_tensor_pr1.
          rewrite !assoc'.
          refine (cartesian_tensor_pr1 _ _ _ @ _).
          apply maponpaths.
          refine (!_).
          apply product_enrichment_from_arr_pr2.
        * rewrite !assoc'.
          rewrite product_enrichment_pr2_comp_pr2.
          rewrite !assoc.
          rewrite !cartesian_tensor_pr2.
          rewrite !assoc'.
          refine (cartesian_tensor_pr2 _ _ _ @ _).
          apply maponpaths.
          refine (!_).
          apply product_enrichment_from_arr_pr2.
  Qed.

  Definition product_enrichment
    : enrichment (category_binproduct C₁ C₂) V
    := product_enrichment_data ,, product_enrichment_laws.
End ProductEnrichment.


From Coq Require Import Lists.List.
From Coq Require Import micromega.Lia.
From Coq Require Import ZArith.ZArith.

From VST Require Import floyd.proofauto.

From CertiGraph Require Import graph.graph_gen.
From CertiGraph Require Import graph.graph_model.
From CertiGraph Require Import lib.List_ext.

From CertiGC Require Import model.heapgraph.block.block.
From CertiGC Require Import model.heapgraph.graph.

Local Open Scope Z.

Definition heapgraph_generations (g : HeapGraph) : Generations := g.(glabel).

Definition heapgraph_generation
  (g : HeapGraph) (gen : nat) : Generation :=
  nth gen (heapgraph_generations g).(generations) null_generation.

Definition heapgraph_generation_block_count
  (g : HeapGraph) (gen : nat) : nat :=
  generation_block_count (heapgraph_generation g gen).

Lemma heapgraph_generation_block_count__labeledgraph_gen_dst
  (g : HeapGraph) (e : Field)
  (v : Addr) (to : nat) :
  heapgraph_generation_block_count (labeledgraph_gen_dst g e v) to = heapgraph_generation_block_count g to.
Proof.
  reflexivity.
Qed.

Definition heapgraph_generation_sh (g : HeapGraph) (gen : nat) : share := generation_sh (heapgraph_generation g gen).

Definition heapgraph_has_gen
  (g : HeapGraph) (n : nat) : Prop :=
  (n < length (heapgraph_generations g).(generations))%nat.

Definition heapgraph_has_gen_dec
  g n : {heapgraph_has_gen g n} + {~ heapgraph_has_gen g n} :=
  lt_dec n (length (generations (heapgraph_generations g))).

Lemma heapgraph_has_gen__O (g : HeapGraph) : heapgraph_has_gen g O.
Proof.
  (hnf).
  (destruct (generations (heapgraph_generations g)) as [| x xx] eqn:E; simpl; try lia).
  now pose proof (generations__not_nil (heapgraph_generations g)).
Qed.

Lemma lgd_graph_has_gen : forall g e v x, heapgraph_has_gen (labeledgraph_gen_dst g e v) x <-> heapgraph_has_gen g x.
Proof.
  (intros; unfold heapgraph_has_gen; intuition idtac).
Qed.

Definition heapgraph_generation_has_index
  (g : HeapGraph) (gen index : nat) : Prop :=
  (index < generation_block_count (heapgraph_generation g gen))%nat.

Definition heapgraph_generation_size
  (g : HeapGraph) (gen : nat) : Z :=
  heapgraph_block_size_prev g gen (generation_block_count (heapgraph_generation g gen)).

Lemma heapgraph_generation_size__nonneg (g : HeapGraph) (gen : nat):
  0 <= heapgraph_generation_size g gen.
Proof.
  unfold heapgraph_generation_size.
  pose proof (heapgraph_block_size_prev__nonneg g gen (generation_block_count (heapgraph_generation g gen))).
  lia.
Qed.

Lemma heapgraph_block_offset__heapgraph_generation_size
  (g : HeapGraph) (v : Addr)
  (Hgv : heapgraph_generation_has_index g (addr_gen v) (addr_block v)) :
  heapgraph_block_offset g v < heapgraph_generation_size g (addr_gen v).
Proof.
  (unfold heapgraph_block_offset, heapgraph_generation_size).
  (red in Hgv).
  (remember (generation_block_count (heapgraph_generation g (addr_gen v))) as n eqn:En ).
  (remember (addr_gen v) as gen eqn:Egen ).
  (assert (S (addr_block v) <= n)%nat by lia).
  (apply Z.lt_le_trans with (heapgraph_block_size_prev g gen (S (addr_block v)))).
  - (rewrite heapgraph_block_size_prev__S).
    pose proof (heapgraph_block_size__one g ({| addr_gen := gen; addr_block := addr_block v |})).
    lia.
  - pose proof (heapgraph_block_size_prev__mono g gen (S (addr_block v)) n ltac:(easy)).
    lia.
Qed.

Definition heapgraph_generations_append
  (g : HeapGraph) (gen_i : Generation) : HeapGraph :=
  {|
    pg_lg := pg_lg g;
    vlabel := heapgraph_block g;
    elabel := elabel g;
    glabel := generations_append (heapgraph_generations g) gen_i
  |}.

Lemma heapgraph_has_gen__heapgraph_generations_append
  (g : HeapGraph) (gi : Generation)
  (gen : nat) :
  heapgraph_has_gen (heapgraph_generations_append g gi) gen <->
  heapgraph_has_gen g gen \/ gen = length (generations (heapgraph_generations g)).
Proof.
  (unfold heapgraph_has_gen; simpl).
  (rewrite app_length; simpl).
  lia.
Qed.

Lemma heapgraph_generation__heapgraph_generations_append__old
  (g : HeapGraph) (gi : Generation)
  (gen : nat) (Hgen : heapgraph_has_gen g gen) :
  heapgraph_generation (heapgraph_generations_append g gi) gen = heapgraph_generation g gen.
Proof.
  (unfold heapgraph_generation; simpl).
  now rewrite app_nth1.
Qed.

Lemma heapgraph_generation__heapgraph_generations_append__new
  (g : HeapGraph) (gi : Generation) :
  heapgraph_generation (heapgraph_generations_append g gi) (length (generations (heapgraph_generations g))) = gi.
Proof.
  (unfold heapgraph_generation; simpl).
  (rewrite app_nth2 by lia).
  now rewrite Nat.sub_diag.
Qed.

Definition heapgraph_generation_base
  (g : HeapGraph) (gen : nat) : val :=
  if heapgraph_has_gen_dec g gen then generation_base (heapgraph_generation g gen) else Vundef.

Lemma ang_graph_gen_size_old :
  forall g gi gen,
  heapgraph_has_gen g gen ->
  heapgraph_generation_size g gen = heapgraph_generation_size (heapgraph_generations_append g gi) gen.
Proof.
  (intros).
  (unfold heapgraph_generation_size).
  (rewrite heapgraph_generation__heapgraph_generations_append__old by assumption).
  (now apply fold_left_ext).
Qed.

Lemma heapgraph_generation_base__isptr
  (g : HeapGraph) (n : nat)
  (Hgn : heapgraph_has_gen g n) :
  isptr (heapgraph_generation_base g n).
Proof.
  (unfold heapgraph_generation_base).
  (if_tac; try easy).
  (apply generation_base__isptr).
Qed.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW
  Require Import utils pos vec subcode sss compiler_correction.

From Undecidability.MinskyMachines.MMA
  Require Import mma_defs mma_utils.

Set Implicit Arguments.

Set Default Proof Using "Type".

Tactic Notation "rew" "length" := autorewrite with length_db.

Local Notation "e #> x" := (vec_pos e x).
Local Notation "e [ v / x ]" := (vec_change e x v).

Local Notation "P //ₐ s -+> t" := (sss_progress (@mma_sss _) P s t) (at level 70, no associativity).
Local Notation "P //ₐ s ->> t" := (sss_compute (@mma_sss _) P s t) (at level 70, no associativity).
Local Notation "P //ₐ s ~~> t" := (sss_output (@mma_sss _) P s t) (at level 70, no associativity).
Local Notation "P //ₐ s ↓" := (sss_terminates (@mma_sss _) P s) (at level 70, no associativity).

(* We use the generic compiler with an identity map on instructions
    to simulate termination with termination on (0,vec_zero) *)

Section mma_sim.

  Variables (n : nat).

  (* The identity compiler, just the jump address changes according to the linker *)

  Definition mma_instr_compile lnk (_ : nat) (ii : mm_instr (pos n)) :=
    match ii with
      | INCₐ k   => INCₐ k :: nil
      | DECₐ k j => DECₐ k (lnk j) :: nil
    end.

  Definition mma_instr_compile_length (ii : mm_instr (pos n)) := 1.

  Fact mma_instr_compile_length_eq lnk i ii : length (mma_instr_compile lnk i ii) = mma_instr_compile_length ii.
  Proof. destruct ii; simpl; auto. Qed.

  Fact mma_instr_compile_length_geq ii : 1 <= mma_instr_compile_length ii.
  Proof. cbv; lia. Qed.

  Hint Resolve mma_instr_compile_length_eq mma_instr_compile_length_geq : core.
  Hint Resolve subcode_refl : core.

  (* This main soundness lemma per simulated instruction *)

  Lemma mma_instr_compile_sound : instruction_compiler_sound mma_instr_compile (@mma_sss _) (@mma_sss _) eq.
  Proof.
    intros lnk I i1 v1 i2 v2 w1 H; revert H w1.
    change v1 with (snd (i1,v1)) at 2.
    change i1 with (fst (i1,v1)) at 2 3 4 6 7 8.
    change v2 with (snd (i2,v2)) at 2.
    change i2 with (fst (i2,v2)) at 2.
    generalize (i1,v1) (i2,v2); clear i1 v1 i2 v2.
    induction 1
      as [ i x k | i x k v H | i x k v u H ];
      simpl; intros w1 H0 ->.
    + exists (w1 [(S (w1#>x))/x]); split; auto.
      mma sss INC with x.
      mma sss stop; now f_equal.
    + exists w1; split; auto.
      mma sss DEC zero with x (lnk k).
      mma sss stop; now f_equal.
    + exists (w1[u/x]); split; auto.
      mma sss DEC S with x (lnk k) u.
      mma sss stop.
  Qed.

  Hint Resolve mma_instr_compile_sound : core.

  Section mma_sim.

    Variable (iP : nat) (cP : list (mm_instr (pos n))).

    Local Definition lnk_Q_pair := @gen_compiler_correction _ _ _ _ mma_instr_compile_length_eq _ _ _ _  (@mma_sss_total_ni _)
                     (@mma_sss_fun _) _ mma_instr_compile_sound (iP,cP) 1.

    Local Definition lnk := projT1 lnk_Q_pair.
    Local Definition Q := proj1_sig (projT2 lnk_Q_pair).

    Local Lemma Hlnk : fst Q = 1 /\ lnk iP = 1 /\ forall i, out_code i (iP,cP) -> lnk i = code_end Q.
    Proof.
      repeat split; apply (proj2_sig (projT2 lnk_Q_pair)).
    Qed.

    Infix "⋈" := (@eq (vec nat n)) (at level 70, no associativity).

    Local Lemma HQ1 : forall i1 v1 w1 i2 v2, v1 ⋈ w1 /\ (iP,cP) //ₐ (i1,v1) ~~> (i2,v2)
                    -> exists w2,    v2 ⋈ w2 /\ Q //ₐ (lnk i1,w1) ~~> (lnk i2,w2).
    Proof. apply (proj2_sig (projT2 lnk_Q_pair)). Qed.

    Local Lemma HQ1' i1 v1 i2 v2 : (iP,cP) //ₐ (i1,v1) ~~> (i2,v2)
                        ->   Q //ₐ (lnk i1,v1) ~~> (lnk i2,v2).
    Proof.
      intros H; destruct (@HQ1 i1 v1 v1 i2 v2) as (w2 & <- & ?); auto.
    Qed.

    Local Lemma HQ2 : forall i1 v1 w1 j2 w2, v1 ⋈ w1 /\ Q //ₐ (lnk i1,w1) ~~> (j2,w2)
                    -> exists i2 v2, v2 ⋈ w2 /\ (iP,cP) //ₐ (i1,v1) ~~> (i2,v2) /\ j2 = lnk i2.
    Proof. apply (proj2_sig (projT2 lnk_Q_pair)). Qed.

    Local Lemma HQ2' i1 v1 j2 v2 :         Q //ₐ (lnk i1,v1) ~~> (j2,v2)
               -> exists i2, (iP,cP) //ₐ (i1,v1) ~~> (i2,v2) /\ j2 = lnk i2.
    Proof.
      intros H; destruct (@HQ2 i1 v1 v1 j2 v2) as (i2 & ? & <- & ? & ->); auto.
      exists i2; auto.
    Qed.

    Variable v : vec nat n.

    (* Q simulates termination of (iP,cP) while ensuring tmp1 and tmp2 stay void when it terminates *)

    Local Lemma Q_spec1 : (iP,cP) //ₐ (iP,v) ↓ -> exists w', Q //ₐ (1,v) ~~> (code_end Q, w').
    Proof.
      intros ((i1,v1) & H1).
      exists v1.
      rewrite <- (proj2 (proj2 Hlnk) i1), <- (proj1 (proj2 Hlnk)); auto using HQ1'.
      destruct H1; auto.
    Qed.

    Local Lemma Q_spec2 : Q //ₐ (1,v) ↓ -> (iP,cP) //ₐ (iP,v) ↓.
    Proof.
      intros ((j,w2) & H1).
      rewrite <- (proj1 (proj2 Hlnk)) in H1.
      destruct HQ2' with (1 := H1) as (i2 & ? & ->).
      exists (i2,w2); auto.
    Qed.

    Definition mma_sim := snd Q.
    Definition mma_sim_end := code_end Q.

    Theorem mma_sim_spec : ((iP,cP) //ₐ (iP,v) ↓ -> exists w', (1,mma_sim) //ₐ (1,v) ~~> (1+length mma_sim, w'))
                        /\ ((1,mma_sim) //ₐ (1,v) ↓ -> (iP,cP) //ₐ (iP,v) ↓).
    Proof.
      replace (1+length mma_sim) with (code_end Q).
      replace (1,mma_sim) with Q.
      + split; (auto using Q_spec1, Q_spec2).
      + rewrite (surjective_pairing Q); f_equal; auto.
        apply (proj1 Hlnk).
      + unfold code_end; f_equal.
        apply (proj1 Hlnk).
    Qed.

  End mma_sim.

End mma_sim.

Section mma2_simul.

  (* To generalize for n register, we need a recursive nullifying code
     not complicated though *)

  Variable (iP : nat) (cP : list (mm_instr (pos 2))).

  Let Q := mma_sim iP cP.
  Local Definition eQ := 1+length Q.

  Local Definition cN : list (mm_instr (pos 2)) := mma_null pos0 eQ ++ mma_null pos1 (1+eQ) ++ mma_jump 0 pos0.

  Local Definition L1 := @mma_null_length 2 pos0 eQ.
  Local Definition L2 := @mma_null_length 2 pos1 (1+eQ).

  Let N_spec v : (eQ,cN) //ₐ (eQ,v) -+> (0,vec_zero).
  Proof.
    unfold cN.
    apply sss_progress_trans with (1+eQ,v[0/pos0]).
    1: { apply subcode_sss_progress with (P := (eQ,mma_null pos0 eQ)); auto.
         apply mma_null_progress; auto. }
    apply sss_progress_trans with (2+eQ,(v[0/pos0])[0/pos1]).
    1: { pose proof L1 as L1.
         apply subcode_sss_progress with (P := (1+eQ,mma_null pos1 (1+eQ))); auto.
         apply mma_null_progress; auto. }
    replace ((v[0/pos0])[0/pos1]) with (@vec_zero 2).
    2: { apply vec_pos_ext; intros p.
         repeat (invert pos p; rew vec). }
    pose proof L1 as L1. pose proof L2 as L2.
    apply subcode_sss_progress with (P := (2+eQ,mma_jump 0 pos0)); auto.
    apply mma_jump_progress; auto.
  Qed.

  Definition mma2_simul := Q ++ cN.

  Let cQ_sim : (1,Q) <sc (1,mma2_simul).
  Proof. unfold mma2_simul; auto. Qed.

  Let cN_sim : (eQ,cN) <sc (1,mma2_simul).
  Proof. unfold mma2_simul, eQ; auto. Qed.

  Theorem mma2_simul_spec v : (iP,cP) //ₐ (iP,v) ↓ <-> (1,mma2_simul) //ₐ (1,v) ~~> (0,vec_zero).
  Proof.
    split.
    * intros H; apply mma_sim_spec in H; revert H.
      intros (w & Hw & _).
      split; try (simpl; lia).
      apply sss_compute_trans with (eQ,w).
      + revert Hw; apply subcode_sss_compute; auto.
      + apply sss_progress_compute.
        generalize (N_spec w).
        apply subcode_sss_progress; auto.
    * intros H1.
      apply mma_sim_spec; fold Q.
      apply subcode_sss_terminates with (1 := cQ_sim).
      now exists (0,vec_zero).
  Qed.

End mma2_simul.

(* Termination can be simulated with termination on (0,vec_zero) *)

Theorem mma2_simulator i (P : list (mm_instr (pos 2))) :
  { Q | forall v, (i,P) //ₐ (i,v) ↓ <-> (1,Q) //ₐ (1,v) ~~> (0,vec_zero) }.
Proof. exists (mma2_simul i P); apply mma2_simul_spec. Qed.


(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
(*    MiniJl:
        Decidable, Tag-Based Semantic Subtyping
        for Nominal Types, Pairs, and Unions.  *)

(** * MiniJl: Propositions about Reductive Subtyping *)
(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)

Add LoadPath "../..". (* root directory of the repo *)

Require Import Mechanization.Aux.Identifier.

Require Import Mechanization.MiniJl.BaseDefs.
Require Import Mechanization.MiniJl.BaseProps.
Require Import Mechanization.MiniJl.MatchProps.

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.

Close Scope btj_scope.
Open  Scope btjm_scope.
Open  Scope btjnf_scope.
Open  Scope btjr_scope.

(* ################################################################# *)
(** ** Auxiliary Statements *)
(* ################################################################# *)

(* ================================================================= *)
(** *** Union of Normal Form *)
(* ================================================================= *)

(* DEP: mk_nf_nf__equal *)
Lemma union_nf_sub_r__components_sub_r : forall (t1 t2 t' : ty),
    |- TUnion t1 t2 << t' ->
    InNF(t1) -> InNF(t2) ->
    |- t1 << t' /\ |- t2 << t'.
Proof.
  intros t1 t2 t' H. remember (TUnion t1 t2) as t eqn:Heq.
  induction H; intros Hnf1 Hnf2; try solve [inversion Heq].
  - (* UnionL *)
    inversion Heq; subst. split; assumption.
  - (* UnionR1 *)
    inversion Heq; subst. specialize (IHsub_r H0).
    split; (apply SR_UnionR1 || apply SR_UnionR2); tauto.
  - (* UnionR2 *)
    inversion Heq; subst. specialize (IHsub_r H0).
    split; (apply SR_UnionR2 || apply SR_UnionR2); tauto.
  - (* NF *)
    subst. simpl in *. apply IHsub_r; try assumption.
    rewrite (mk_nf_nf__equal _ Hnf1).
    rewrite (mk_nf_nf__equal _ Hnf2).
    reflexivity.
Qed.

(* ================================================================= *)
(** *** About [unite_pairs] *)
(* ================================================================= *)

(* DEP: sub_r__rflxv, unite_pairs_t_union, unite_pairs_union_t,
        union_in_nf__components_in_nf,
        mk_nf_nf__equal, mk_nf__in_nf *)
Lemma unite_pairs_of_nf__preserves_sub_r : forall (t1 t2 t1' t2' : ty),
    |- t1 << t1' ->
    |- t2 << t2' ->
    InNF(t1) -> InNF(t1') ->
    InNF(t2) -> InNF(t2') ->
    |- unite_pairs t1 t2 << unite_pairs t1' t2'.
Proof.
  intros ta tb ta' tb' Hsub1.
  generalize dependent tb'. generalize dependent tb.
  induction Hsub1; intros tb tb' Hsub2;
    try solve [
          induction Hsub2; intros Hnfa Hnfa' Hnfb Hnfb';
          try solve [
                simpl; constructor; constructor; assumption
              (* UnionL *)
              | rewrite unite_pairs_t_union; try resolve_not_union;
                destruct (union_in_nf__components_in_nf _ _ Hnfb) as [Hnfb1 Hnfb2];
                constructor; [apply IHHsub2_1 | apply IHHsub2_2];
                assumption || constructor
              (* UnionR1 *)
              | rewrite unite_pairs_t_union; try resolve_not_union;
                destruct (union_in_nf__components_in_nf _ _ Hnfb') as [Hnfb1 Hnfb2];
                apply SR_UnionR1; apply IHHsub2; assumption || constructor
              (* UnionR2 *)
              | rewrite unite_pairs_t_union; try resolve_not_union;
                destruct (union_in_nf__components_in_nf _ _ Hnfb') as [Hnfb1 Hnfb2];
                apply SR_UnionR2; apply IHHsub2; assumption || constructor
              (* NF *)
              | rewrite <- (mk_nf_nf__equal _ Hnfb);
                apply IHHsub2; try assumption; apply mk_nf__in_nf ]
        ].
  - (* UnionL, tb *)
    intros Hnfa Hnfa' Hnfb Hnfb'. rewrite unite_pairs_union_t.
    destruct (union_in_nf__components_in_nf _ _ Hnfa) as [Hnfa1 Hnfa2].
    constructor; [apply IHHsub1_1 | apply IHHsub1_2]; assumption.
  - (* UnionR1, tb *)
    intros Hnfa Hnfa' Hnfb Hnfb'. rewrite unite_pairs_union_t.
    destruct (union_in_nf__components_in_nf _ _ Hnfa') as [Hnfa1 Hnfa2].
    apply SR_UnionR1; apply IHHsub1; assumption.
  - (* UnionR2, tb *)
    intros Hnfa Hnfa' Hnfb Hnfb'. rewrite unite_pairs_union_t.
    destruct (union_in_nf__components_in_nf _ _ Hnfa') as [Hnfa1 Hnfa2].
    apply SR_UnionR2; apply IHHsub1; assumption.
  - (* NF, tb *)
    intros Hnfa Hnfa' Hnfb Hnfb'.
    rewrite <- (mk_nf_nf__equal _ Hnfa).
    apply IHHsub1; try assumption. apply mk_nf__in_nf.
Qed.

(* DEP: unite_pairs_t_union, unite_pairs_union_t,
        union_in_nf__components_in_nf, union_nf_sub_r__components_sub_r *)
Lemma unite_pairs_of_nf__preserves_sub_r1 : forall (t1 t2 t1' t2' : ty),
    InNF(t1) -> |- t1 << t1' ->
    InNF(t2) -> |- t2 << t2' ->
    |- unite_pairs t1 t2 << TPair t1' t2'.
Proof.
  intros ta; induction ta;
    intros tb; induction tb;
      intros ta' tb' Hnf1 Hsub1 Hnf2 Hsub2;
      try solve [
            simpl; constructor; assumption
          | match goal with
            | [Hnf1: InNF(?t), Hnf2: InNF(TUnion ?t1 ?t2),
               Hsub: |- TUnion ?t1 ?t2 << _
               |- |- unite_pairs ?t (TUnion ?t1 ?t2) << TPair _ _] =>
              rewrite unite_pairs_t_union; try resolve_not_union;
              destruct (union_in_nf__components_in_nf _ _ Hnf2) as [Hnfb1 Hnfb2];
              destruct (union_nf_sub_r__components_sub_r _ _ _ Hsub Hnfb1 Hnfb2) as [Hsubb1 Hsubb2];
              constructor; [apply IHtb1 | apply IHtb2]; assumption
            | [Hnf1: InNF(?t), Hnf2: InNF(TUnion ?t1 ?t2),
               Hsub: |- TUnion ?t1 ?t2 << _
               |- |- unite_pairs (TUnion ?t1 ?t2) ?t << TPair _ _] =>
              rewrite unite_pairs_union_t;
              destruct (union_in_nf__components_in_nf _ _ Hnf2) as [Hnfb1 Hnfb2];
              destruct (union_nf_sub_r__components_sub_r _ _ _ Hsub Hnfb1 Hnfb2) as [Hsubb1 Hsubb2];
              constructor; [apply IHta1 | apply IHta2]; assumption
            end
          ].
Qed.

(* ================================================================= *)
(** *** About [MkNF] *)
(* ================================================================= *)

(* DEP: unite_pairs_of_nf__preserves_sub_r1 *)
Lemma sub_r__mk_nf_sub_r1 : forall (t t' : ty),
    |- t << t' ->
    |- MkNF(t) << t'.
Proof.
  intros t t' Hsub; induction Hsub;
    try solve [simpl; constructor; constructor].
  - (* Pair *)
    simpl.
    apply unite_pairs_of_nf__preserves_sub_r1;
      assumption || apply mk_nf__in_nf.
  - (* Union *)
    simpl. constructor; assumption.
  - (* UnionR1 *)
    apply SR_UnionR1; assumption.
  - (* UnionR2 *)
    apply SR_UnionR2; assumption.
  - (* NF *)
    assumption.
Qed.

(* DEP: unite_pairs_of_nf__preserves_sub_r1, mk_nf__in_nf *)
Lemma mk_nf__sub_r1 : forall (t : ty),
    |- MkNF(t) << t.
Proof.
  intros t.
  apply sub_r__mk_nf_sub_r1.
  apply sub_r__rflxv.
Qed.

Lemma mk_nf__sub_r2 : forall (t : ty),
    |- t << MkNF(t).
Proof.
  intros t.
  apply SR_NormalForm.
  apply sub_r__rflxv.
Qed.

(* ================================================================= *)
(** *** Related to Transitivity *)
(* ================================================================= *)

(* DEP: sub_r__mk_nf_sub_r1, union_nf_sub_r__components_sub_r *)
Lemma union_sub_r__components_sub_r : forall (t1 t2 t' : ty),
    |- TUnion t1 t2 << t' ->
    |- t1 << t' /\ |- t2 << t'.
Proof.
  intros t1 t2 t' Hsub.
  pose proof (sub_r__mk_nf_sub_r1 _ _ Hsub).
  simpl in H.
  assert (Hsubnf: |- MkNF(t1) << t' /\ |- MkNF(t2) << t').
  { apply union_nf_sub_r__components_sub_r;
      assumption || apply mk_nf__in_nf. }
  split; apply SR_NormalForm; tauto.
Qed.

(* DEP: sub_r_value_types__equal, union_in_nf__components_in_nf,
        mk_nf_nf__equal *)
Lemma sub_r_nf__transitive : forall (t1 t2 t3 : ty),
    |- t1 << t2 ->
    InNF(t1) -> InNF(t2) ->
    |- t2 << t3 ->
    |- t1 << t3.
Proof.
  intros t1 t2 t3 Hsub1. generalize dependent t3.
  induction Hsub1; intros t3 Hnf1 Hnf2 Hsub2;
    try solve [
          assumption
        | inversion Hnf2; subst;
          match goal with [H: value_type _ |- _] => inversion H end
        ].
  - (* Pair *)
    inversion Hnf1; subst. inversion Hnf2; subst.
    inversion H; inversion H0; subst.
    pose proof (sub_r_value_types__equal _ _ Hsub1_1 H3 H7).
    pose proof (sub_r_value_types__equal _ _ Hsub1_2 H4 H8).
    subst. assumption.
  - (* UnionL *)
    destruct (union_in_nf__components_in_nf _ _ Hnf1) as [Hnfa1 Hnfa2].
    constructor; [apply IHHsub1_1 | apply IHHsub1_2]; assumption.
  - (* UnionR1 *)
    destruct (union_in_nf__components_in_nf _ _ Hnf2) as [Hnfa1 Hnfa2].
    apply IHHsub1; try assumption.
    pose proof (union_nf_sub_r__components_sub_r _ _ _ Hsub2 Hnfa1 Hnfa2); tauto.
  - (* UnionR2 *)
    destruct (union_in_nf__components_in_nf _ _ Hnf2) as [Hnfa1 Hnfa2].
    apply IHHsub1; try assumption.
    pose proof (union_nf_sub_r__components_sub_r _ _ _ Hsub2 Hnfa1 Hnfa2); tauto.
  - (* NF *)
    rewrite mk_nf_nf__equal in IHHsub1; try assumption.
    apply IHHsub1; assumption.
Qed.

(* ################################################################# *)
(** ** Properties related to matching *)
(* ################################################################# *)

(* ================================================================= *)
(** *** Correctness of Subtyping with respect to Matching *)
(* ================================================================= *)

Theorem match_ty__sub_r_sound : forall (v t : ty),
    |- v <$ t ->
    |- v << t.
Proof.
  intros v t H; induction H; try solve [constructor].
  (* Pair *)   constructor; assumption.
  (* Union1 *) apply SR_UnionR1; assumption.
  (* Union2 *) apply SR_UnionR2; assumption.
Qed.

(* ================================================================= *)
(** ** Matching value Type is Complete for Subtyping *)
(* ================================================================= *)

(* DEP: match_valty__rflxv, mk_nf_valty__equal *)
Theorem match_valty__sub_r_complete : forall (v t : ty),
    |- v << t ->
    value_type v ->
    |- v <$ t.
Proof.
  intros v t H; induction H; subst; intros Hval;
    try solve [constructor | inversion Hval].
  - (* Pair *)
    inversion Hval; subst.
    constructor; tauto.
  - (* UnionR1 *)
    apply MT_Union1; tauto.
  - (* UnionR2 *)
    apply MT_Union2; tauto.
  - (* NF *)
    rewrite (mk_nf_valty__equal _ Hval) in *.
    tauto.
Qed.

(* ################################################################# *)
(** ** Properties related to Normal Form *)
(* ################################################################# *)

(** If types are subtypes, their normal forms are also subtypes. *)
(* DEP: unite_pairs_of_nf__preserves_sub_r,
        mk_nf__in_nf, mk_nf__idempotent *)
Lemma sub_r__mk_nf_sub_r : forall (t t' : ty),
    |- t << t' ->
    |- MkNF(t) << MkNF(t').
Proof.
  intros t t' Hsub; induction Hsub;
    try solve [simpl; do 4 constructor].
  - (* Pair *)
    simpl.
    apply unite_pairs_of_nf__preserves_sub_r;
      assumption || apply mk_nf__in_nf.
  - (* Union *)
    simpl. constructor; assumption.
  - (* UnionR1 *)
    apply SR_UnionR1; assumption.
  - (* UnionR2 *)
    apply SR_UnionR2; assumption.
  - (* NF *)
    rewrite <- mk_nf__idempotent. assumption.
Qed.

(* DEP: mk_nf__in_nf *)
Lemma mk_nf_sub_r__sub_r : forall (t t' : ty),
    |- MkNF(t) << MkNF(t') ->
    |- t << t'.
Proof.
  intros t t' Hsub.
  apply SR_NormalForm.
  apply sub_r_nf__transitive with (MkNF(t')); try (apply mk_nf__in_nf).
  assumption. apply  mk_nf__sub_r1.
Qed.

(* DEP: match_ty__sub_r_sound, match_valty__rflxv *)
Theorem nf_sem_sub__sub_r : forall (t : ty),
    InNF(t) ->
    forall (t' : ty),
      ||- [t] <= [t'] ->
      |- t << t'.
Proof.
  intros t Hnf; induction Hnf; intros t' Hval;
    unfold sem_sub.
  - (* Value *)
    apply match_ty__sub_r_sound. apply Hval.
    assumption. apply match_valty__rflxv. assumption.
  - (* Union *)
    constructor; [apply IHHnf1 | apply IHHnf2]; intros v Hv Hsub;
      try assumption; apply Hval; try assumption.
    apply MT_Union1; assumption.
    apply MT_Union2; assumption.
Qed.

(* ################################################################# *)
(** ** Properties related to Declarative Subtyping *)
(* ################################################################# *)

(* ================================================================= *)
(** *** Reflexivity *)
(* ================================================================= *)

(* DEP: sub_r__rflxv *)
Lemma sub_r__reflexive : forall (t : ty),
    |- t << t.
Proof.
  apply sub_r__rflxv.
Qed.

(* ================================================================= *)
(** *** Transitivity *)
(* ================================================================= *)

(* DEP: sub_r__mk_nf_sub_r, sub_r_nf__transitive,
        mk_nf__in_nf, union_sub_r__components_sub_r *)
Lemma sub_r__transitive : forall (t1 t2 t3 : ty),
    |- t1 << t2 ->
    |- t2 << t3 ->
    |- t1 << t3.
Proof.
  intros t1 t2 t3 Hsub1. generalize dependent t3.
  induction Hsub1; intros t3 Hsub2;
    try (apply sub_r__mk_nf_sub_r1 in Hsub2; simpl in Hsub2;
         destruct (union_sub_r__components_sub_r _ _ _ Hsub2) as [Hsub21 Hsub22]);
    try (destruct (union_sub_r__components_sub_r _ _ _ Hsub21));
    try auto.
  (* Pair *)
  remember (TPair t1' t2') as tm eqn:Heq.
  induction Hsub2; try solve [inversion Heq].
  - (* Pair *)
    inversion Heq; subst.
    constructor; auto.
  - (* UnionR1 *)
    apply SR_UnionR1; tauto.
  - (* UnionR2 *)
    apply SR_UnionR2; tauto.
  - (* NF *)
    inversion Heq; subst. clear H.
    assert (Hsub1: |- TPair t1 t2 << TPair t1' t2') by (constructor; assumption).
    pose proof (sub_r__mk_nf_sub_r _ _ Hsub1) as Hsub1nf.
    apply SR_NormalForm.
    apply sub_r_nf__transitive with (MkNF( TPair t1' t2'));
      assumption || apply mk_nf__in_nf.
Qed.

(* ================================================================= *)
(** *** Distributivity *)
(* ================================================================= *)

(* ----------------------------------------------------------------- *)
(** **** Aux *)
(* ----------------------------------------------------------------- *)

(* DEP: unite_pairs_t_union, unite_pairs_union_t,
        sub_r__reflexive, sub_r__transitive *)
Lemma unite_pairs__distr21 : forall (t1 t21 t22 : ty),
    InNF(t1) ->
    |- unite_pairs t1 (TUnion t21 t22) <<
       TUnion (unite_pairs t1 t21) (unite_pairs t1 t22).
Proof.
  intros t1 t21 t22 Hnf1.
  generalize dependent t22. generalize dependent t21.
  induction Hnf1; intros t21 t22.
  - (* Value *)
    rewrite unite_pairs_t_union; try resolve_not_union.
    apply sub_r__reflexive. subst; inversion H.
  - (* Union *)
    repeat rewrite unite_pairs_union_t.
    constructor.
    + apply sub_r__transitive with (TUnion (unite_pairs t1 t21) (unite_pairs t1 t22)).
      apply IHHnf1_1. constructor.
      apply SR_UnionR1; apply SR_UnionR1; apply sub_r__reflexive.
      apply SR_UnionR2; apply SR_UnionR1; apply sub_r__reflexive.
    + apply sub_r__transitive with (TUnion (unite_pairs t2 t21) (unite_pairs t2 t22)).
      apply IHHnf1_2. constructor.
      apply SR_UnionR1; apply SR_UnionR2; apply sub_r__reflexive.
      apply SR_UnionR2; apply SR_UnionR2; apply sub_r__reflexive.
Qed.

(* ----------------------------------------------------------------- *)
(** **** Main Properties *)
(* ----------------------------------------------------------------- *)

(* DEP: unite_pairs_union_t, sub_r__reflexive *)
Lemma mk_nf__distr11 : forall (t11 t12 t2 : ty),
    |- MkNF(TPair (TUnion t11 t12) t2) << MkNF(TUnion (TPair t11 t2) (TPair t12 t2)).
Proof.
  intros t11 t12 t2.
  change (|- MkNF( TPair (TUnion t11 t12) t2) << TUnion (MkNF(TPair t11 t2)) (MkNF(TPair t12 t2))).
  change (|- unite_pairs (MkNF(TUnion t11 t12)) (MkNF(t2)) <<
             TUnion (MkNF(TPair t11 t2)) (MkNF(TPair t12 t2))).
  change (|- unite_pairs (TUnion (MkNF(t11)) (MkNF(t12))) (MkNF(t2)) <<
             TUnion (MkNF(TPair t11 t2)) (MkNF(TPair t12 t2))).
  rewrite unite_pairs_union_t.
  apply sub_r__reflexive.
Qed.

(* DEP: unite_pairs__distr21, mk_nf__in_nf *)
Lemma mk_nf__distr21 : forall (t1 t21 t22 : ty),
    |- MkNF(TPair t1 (TUnion t21 t22)) << MkNF(TUnion (TPair t1 t21) (TPair t1 t22)).
Proof.
  intros t1 t21 t22.
  change (|- MkNF(TPair t1 (TUnion t21 t22)) << TUnion (MkNF(TPair t1 t21)) (MkNF(TPair t1 t22))).
  change (|- unite_pairs (MkNF(t1)) (TUnion (MkNF(t21)) (MkNF(t22))) <<
             TUnion (MkNF(TPair t1 t21)) (MkNF(TPair t1 t22))).
  change (|- unite_pairs (MkNF(t1)) (TUnion (MkNF(t21)) (MkNF(t22))) <<
                               TUnion (unite_pairs (MkNF(t1)) (MkNF(t21))) (unite_pairs (MkNF(t1)) (MkNF(t22)))).
  apply unite_pairs__distr21.
  apply mk_nf__in_nf.
Qed.

(* ################################################################# *)
(** ** Decidability *)
(* ################################################################# *)

(** Reductive subtyping of a normalized term on the left
    is decidable. *)
(* DEP: match_ty__dcdbl, match_ty__sub_r_sound *)
Lemma nf_sub_r__decidable : forall (t1 t2 : ty),
    InNF(t1) ->
    Decidable.decidable (|- t1 << t2).
Proof.
  intros t1 t2 Hnf1. generalize dependent t2.
  induction Hnf1.
  - (* Value *)
    intros t2. destruct (match_ty__dcdbl v t2) as [Hm | Hm].
    + left. apply match_ty__sub_r_sound. assumption.
    + right; intros Hcontra.
      assert (Hcontra': |- v <$ t2)
        by (apply match_valty__sub_r_complete; assumption).
      contradiction.
  - (* Union *)
    intros t'.
    destruct (IHHnf1_1 t') as [IH1 | IH1];
      destruct (IHHnf1_2 t') as [IH2 | IH2];
      try solve [
            right; intros Hcontra;
            destruct (union_sub_r__components_sub_r _ _ _ Hcontra) as [Hsub1 Hsub2];
            contradiction ].
    left; constructor; assumption.
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.