Require Import Helix.Util.VecUtil.
Require Import Helix.Util.VecSetoid.
Require Import Helix.Util.Misc.
Require Import Helix.SigmaHCOL.Rtheta.

Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Logic.FunctionalExtensionality.

Require Import Helix.Tactics.HelixTactics.

Require Import MathClasses.interfaces.canonical_names.
Require Import MathClasses.interfaces.abstract_algebra.
Require Import MathClasses.theory.rings.

Import VectorNotations.

Require Import ExtLib.Structures.Monads.

Require Import Helix.Util.WriterMonadNoT.

Import Monoid.

Open Scope vector_scope.
Open Scope nat_scope.

(* Vector using Rtheta (exlusive) *)
Notation rvector n := (vector Rtheta n) (only parsing).
(* Vector using RStheta (safe) *)
Notation rsvector n := (vector RStheta n) (only parsing).

Section WithCarrierA.

  Context `{CAPROPS: CarrierProperties}.
  Add Ring RingA: (stdlib_ring_theory CarrierA).

  Definition rvector2rsvector := Vmap Rtheta2RStheta.
  Definition rsvector2rvector := Vmap RStheta2Rtheta.

  Section SvectorBasics.
    Variable fm:Monoid RthetaFlags.

    (* "sparse" vector for CarrierA type elements could be simulated using Rtheta *)
    Definition svector n := (vector (Rtheta' fm) n).

    (* Construct vector of Rtheta values from vector of raw values of it's carrier type *)
    Definition sparsify {n} (v:avector n): svector n :=
      Vmap mkValue v.

    Global Instance sparsify_proper {n:nat}:
      Proper ((=) ==> (=)) (@sparsify n).
    Proof.
      intros x y E.
      unfold sparsify.
      rewrite E.
      reflexivity.
    Qed.

    (* Project out carrier type values from vector of Rheta values *)
    Definition densify {n} (v:svector n): avector n :=
      Vmap (A:=(Rtheta' fm)) (@evalWriter _ _ _) v.

    Global Instance densify_proper {n:nat}:
      Proper ((=) ==> (=)) (@densify n).
    Proof.
      intros x y E.
      unfold densify.
      rewrite E.
      reflexivity.
    Qed.

    (* Construct "Zero svector". All values are structural zeros. *)
    Definition szero_svector n: svector n := Vconst mkSZero n.

    (* "dense" vector means that it does not contain "structural" values *)
    Definition svector_is_dense {n} (v:svector n) : Prop :=
      Vforall (@Is_Val _ fm)  v.

    Lemma Vnth_sparsify:
      ∀ (n i : nat) (ip : i < n) (v : avector n),
        Vnth (sparsify v) ip ≡ mkValue (Vnth v ip).
    Proof.
      intros n i ip v.
      unfold sparsify.
      apply Vnth_map.
    Qed.

    Fixpoint Vin_Rtheta_Val {n} (v : svector n) (x : CarrierA) : Prop :=
      match v with
      | Vnil => False
      | Vcons y w => (WriterMonadNoT.evalWriter y) = x \/ Vin_Rtheta_Val w x
      end.

    Lemma Vbreak_dense_vector {n1 n2} {x: svector (n1+n2)} {x0 x1}:
      Vbreak x ≡ (x0, x1) ->
      svector_is_dense x ->  (svector_is_dense x0) /\ (svector_is_dense x1).
    Proof.
      unfold svector_is_dense.
      apply Vbreak_preserves_P.
    Qed.

    Lemma szero_svector_all_zeros:
      ∀ n : nat, Vforall Is_ValZero (szero_svector n).
    Proof.
      intros n.
      apply Vforall_nth_intro.
      intros i ip.
      unfold szero_svector.
      rewrite Vnth_const.
      apply SZero_is_ValZero.
    Qed.

    Definition svector_is_collision {n} (v:svector n) :=
      Vexists Is_Collision v.

    Definition svector_is_non_collision {n} (v:svector n) :=
      Vforall Not_Collision v.

    Lemma densify_sparsify {n} (x:avector n):
      densify (sparsify x) ≡ x.
    Proof.
      unfold densify, sparsify.
      rewrite Vmap_map.
      apply Vmap_eq_id.
      apply Vforall_intro.
      intros x0 H.
      rewrite evalWriter_mkValue.
      reflexivity.
    Qed.

    Lemma densify_cons {n} {h:Rtheta' fm} {v:svector n}:
      densify (h::v) ≡ (evalWriter h)::densify v.
    Proof.
      reflexivity.
    Qed.

    Lemma sparsify_densify_equiv {n} (x:svector n):
      (sparsify (densify x)) = x.
    Proof.
      unfold densify, sparsify.
      rewrite Vmap_map.
      vec_index_equiv i ip.
      rewrite Vnth_map.
      generalize dependent (Vnth x ip). clear ip i.
      intros r.
      apply mkValue_evalWriter.
    Qed.

    Section WithMonoid.
      Variable fml:@MonoidLaws RthetaFlags fm.

      Lemma sparsify_non_coll: forall n (x:avector n),
          svector_is_non_collision (sparsify x).
      Proof.
        intros n x.
        unfold sparsify.
        unfold svector_is_non_collision, Not_Collision, compose.
        apply Vforall_map_intro.
        apply Vforall_intro.
        intros v N.
        unfold mkValue.
        simpl.
        destruct fml.
        rewrite monoid_runit.
        auto.
      Qed.

      Lemma sparsify_is_dense:
        ∀ (i : nat) (x : vector CarrierA i), svector_is_dense (sparsify x).
      Proof.
        intros i x.
        unfold sparsify, svector_is_dense.
        apply Vforall_map_intro.
        apply Vforall_intro.
        intros v N.
        apply Is_Val_mkValue.
      Qed.

      Lemma sparsify_densify {n} (x:svector n):
        svector_is_dense x ->
        svector_is_non_collision x ->
        (sparsify (densify x)) ≡ x.
      Proof.
        intros D N.
        unfold densify, sparsify.
        rewrite Vmap_map.
        apply Vmap_eq_nth.
        intros i ip.
        unfold svector_is_dense in D.
        apply Vforall_nth with (ip:=ip) in D.
        unfold svector_is_non_collision in N.
        apply Vforall_nth with (ip:=ip) in N.
        generalize dependent (Vnth x ip). clear ip i.
        apply mkValue_evalWriter_VNC.
      Qed.

    End WithMonoid.

  End SvectorBasics.

  Section Union.

    Variable fm:Monoid RthetaFlags.

    Definition Union (dot : CarrierA -> CarrierA -> CarrierA)
      : Rtheta' fm -> Rtheta' fm -> Rtheta' fm := liftM2 dot.

    Lemma Union_comm (dot : CarrierA -> CarrierA -> CarrierA)
          `{C: !Commutative dot}:
      Commutative (Union dot).
    Proof.
      intros x y.
      unfold Union, equiv, Rtheta'_equiv.
      rewrite 2!evalWriter_Rtheta_liftM2.
      apply C.
    Qed.

    Lemma evalWriterUnion {a b: Rtheta' fm} {dot}:
      evalWriter (Union dot a b) ≡
      dot (evalWriter a)
          (evalWriter b).
    Proof.
      unfold Union.
      rewrite evalWriter_Rtheta_liftM2.
      reflexivity.
    Qed.

    Global Instance Union_proper:
      Proper (((=) ==> (=) ==> (=)) ==> (=) ==> (=) ==> (=)) Union.
    Proof.
      intros dot dot' DP a b H x y E.
      unfold Union, equiv, Rtheta'_equiv in *.
      rewrite 2!evalWriter_Rtheta_liftM2.
      - apply DP.
        + apply H.
        + apply E.
    Qed.

    (** Unary union of vector's elements (left fold) *)
    Definition UnionFold
               {n}
               (dot:CarrierA->CarrierA->CarrierA)
               (initial:CarrierA)
               (v: svector fm n): Rtheta' fm :=
      Vfold_left_rev (Union dot) (mkStruct initial) v.

    (** Pointwise union of two vectors *)
    Definition Vec2Union
               {n}
               (dot:CarrierA->CarrierA->CarrierA)
               (a b: svector fm n): svector fm n
      := Vmap2 (Union dot) a b.

    Global Instance Vec2Union_proper {n}
      :
        Proper (((=) ==> (=) ==> (=)) ==> (=) ==> (=) ==> (=)) (Vec2Union (n:=n)).
    Proof.
      intros dot dot' Ed a a' Ea b b' Eb.
      unfold Vec2Union, Union.
      vec_index_equiv j jc.
      rewrite 2!Vnth_map2.
      unfold_Rtheta_equiv.
      rewrite 2!evalWriter_Rtheta_liftM2.
      apply Ed; apply evalWriter_proper; apply Vnth_arg_equiv; assumption.
    Qed.

    (** Matrix-union. *)
    Definition MUnion
               {o n}
               (dot:CarrierA->CarrierA->CarrierA)
               (initial:CarrierA)
               (v: vector (svector fm o) n): svector fm o
      :=  Vfold_left_rev (Vec2Union dot) (Vconst (mkStruct initial) o) v.

    Global Instance MUnion_proper {o n}
      : Proper (((=) ==> (=) ==> (=)) ==> (=) ==> (=) ==> (=)) (@MUnion o n).
    Proof.
      intros dot dot' Ed one one' Eo x y E.
      unfold MUnion.
      eapply Vfold_left_rev_proper.
      apply Vec2Union_proper.
      apply Ed.
      rewrite Eo; reflexivity.
      apply E.
    Qed.

    Definition SumUnion
               {o n}
               (v: vector (svector fm o) n): svector fm o
      := MUnion plus zero v.

    Global Instance SumUnion_proper {o n}
      : Proper ((=) ==> (=)) (@SumUnion o n).
    Proof.
      intros x y E.
      unfold SumUnion.
      rewrite E.
      reflexivity.
    Qed.

    Lemma UnionFold_cons
          m x (xs : svector fm m)
          (dot: CarrierA -> CarrierA -> CarrierA)
          (neutral: CarrierA):
      UnionFold dot neutral (Vcons x xs) ≡ Union dot (UnionFold dot neutral xs) x.
    Proof.
      unfold UnionFold.
      rewrite Vfold_left_rev_cons.
      reflexivity.
    Qed.

    Lemma Vec2Union_comm
          {n}
          (dot: CarrierA -> CarrierA -> CarrierA)
          `{C: !Commutative dot}
      :
        @Commutative (svector fm n) _ (svector fm n) (Vec2Union dot).
    Proof.
      intros a b.
      induction n.
      VOtac; reflexivity.
      VSntac a. VSntac b.
      simpl.
      apply Vcons_proper.
      apply Union_comm, C.
      apply IHn.
    Qed.

    Lemma MUnion_0
          {o: nat}
          (dot: CarrierA -> CarrierA -> CarrierA)
          (initial: CarrierA)
          (v: vector (svector fm o) 0):
      MUnion dot initial v ≡ Vconst (mkStruct initial) o.
    Proof.
      dep_destruct v.
      crush.
    Qed.

    Lemma MUnion_cons {m n}
          (dot: CarrierA -> CarrierA -> CarrierA)
          (neutral: CarrierA)
          (x: svector fm m) (xs: vector (svector fm m) n):
      MUnion dot neutral (Vcons x xs) ≡ Vec2Union dot (MUnion dot neutral xs) x.
    Proof.
      unfold MUnion.
      apply Vfold_left_rev_cons.
    Qed.

    Lemma SumUnion_cons {m n}
          (x: svector fm m) (xs: vector (svector fm m) n):
      SumUnion (Vcons x xs) ≡ Vec2Union plus (SumUnion xs) x.
    Proof.
      unfold SumUnion.
      apply MUnion_cons.
    Qed.

    Lemma AbsorbUnionIndexBinary
          (m k : nat)
          (kc : k < m)
          {dot}
          (a b : svector fm m):
      Vnth (Vec2Union dot a b) kc ≡ Union dot (Vnth a kc) (Vnth b kc).
    Proof.
      unfold Vec2Union.
      apply Vnth_map2.
    Qed.

    Lemma AbsorbMUnionIndex_Vbuild
          {o n}
          (dot:CarrierA -> CarrierA -> CarrierA)
          (neutral:CarrierA)
          (body: forall (i : nat) (ic : i < n), svector fm o)
          k (kc: k<o)
      :
        Vnth (MUnion dot neutral (Vbuild body)) kc ≡
        UnionFold dot neutral
                  (Vbuild
                     (fun (i : nat) (ic : i < n) =>
                        Vnth (body i ic) kc
                  )).
    Proof.
      induction n.
      - rewrite 2!Vbuild_0.
        apply Vnth_const.
      -
        rewrite Vbuild_Sn.
        rewrite MUnion_cons.
        rewrite AbsorbUnionIndexBinary.
        rewrite IHn.
        rewrite <- UnionFold_cons.
        rewrite Vbuild_Sn.
        reflexivity.
    Qed.

    (** Move indexing from outside of Union into the loop. Called 'union_index' in Vadim's paper notes. *)
    Lemma AbsorbMUnionIndex_Vmap
          (dot: CarrierA -> CarrierA -> CarrierA)
          (neutral: CarrierA)
          {m n:nat}
          (x: vector (svector fm m) n) k (kc: k<m):
      Vnth (MUnion dot neutral x) kc ≡
      UnionFold dot neutral
                (Vmap (fun v => Vnth v kc) x).
    Proof.
      induction n.
      + dep_destruct x.
        unfold UnionFold, MUnion, szero_svector; simpl.
        rewrite Vnth_const; reflexivity.
      + dep_destruct x.
        rewrite Vmap_cons, MUnion_cons, AbsorbUnionIndexBinary, IHn, UnionFold_cons.
        reflexivity.
    Qed.

    Lemma AbsorbSumUnionIndex_Vmap
          m n (x: vector (svector fm m) n) k (kc: k<m):
      Vnth (SumUnion x) kc ≡ UnionFold plus zero (Vmap (fun v => Vnth v kc) x).
    Proof.
      unfold SumUnion.
      apply AbsorbMUnionIndex_Vmap.
    Qed.

    Lemma AbsorbISumUnionIndex_Vbuild
          {o n}
          (body: forall (i : nat) (ic : i < n), svector fm o)
          k (kc: k<o)
      :
        Vnth
          (SumUnion (Vbuild body)) kc ≡
        UnionFold plus zero
                  (Vbuild
                     (fun (i : nat) (ic : i < n) =>
                        Vnth (body i ic) kc
                  )).
    Proof.
      apply AbsorbMUnionIndex_Vbuild.
    Qed.

    Lemma Union_SZero_r x:
      (Union plus x mkSZero) = x.
    Proof.
      unfold Union.
      unfold_Rtheta_equiv.
      rewrite evalWriter_Rtheta_liftM2.
      rewrite evalWriter_Rtheta_SZero.
      ring.
    Qed.

    Lemma Union_SZero_l x:
      (Union plus mkSZero x) = x.
    Proof.
      unfold Union.
      unfold_Rtheta_equiv.
      rewrite evalWriter_Rtheta_liftM2.
      rewrite evalWriter_Rtheta_SZero.
      ring.
    Qed.

    Lemma Vec2Union_szero_svector_r {n} {a: svector fm n}:
      Vec2Union plus a (szero_svector fm n) = a.
    Proof.
      unfold szero_svector.
      induction n.
      -
        dep_destruct a; reflexivity.
      -
        simpl.
        unfold equiv, vec_Equiv.
        setoid_rewrite IHn.
        dep_destruct a.
        apply Vforall2_cons_eq.
        split.
        +
          rewrite Union_SZero_r.
          reflexivity.
        +
          reflexivity.
    Qed.

    Lemma Vec2Union_szero_svector_l {n} {a: svector fm n}:
      Vec2Union plus (szero_svector fm n) a = a.
    Proof.
      unfold szero_svector.
      induction n.
      dep_destruct a; reflexivity.
      simpl.
      rewrite IHn by (apply Vforall_tl; assumption). clear IHn.
      rewrite Union_SZero_l.
      dep_destruct a.
      reflexivity.
    Qed.

  End Union.

  Section ExclusiveUnion.

    Lemma UnionCollisionFree (a b : Rtheta) {dot}:
      ¬Is_Collision a →
      ¬Is_Collision b →
      ¬(Is_Val a ∧ Is_Val b)
      → ¬Is_Collision (Union Monoid_RthetaFlags dot a b).
    Proof.
      intros CA CB C.
      unfold Union, Is_Collision, compose.
      rewrite execWriter_Rtheta_liftM2.
      unfold Is_Collision, Is_Val, compose in *.
      destruct (execWriter a) as [str_a col_a].
      destruct (execWriter b) as [str_b col_b].
      unfold RthetaFlagsAppend.
      unfold IsCollision, IsVal in *.
      destr_bool.
      auto.
    Qed.

    (* Conditions under which Union produces value *)
    Lemma ValUnionIsVal (a b : Rtheta) {dot}:
      Is_Val a \/ Is_Val b <-> Is_Val (Union Monoid_RthetaFlags dot a b).
    Proof.
      split.
      - intros [VA | VB]; (
          unfold Union, Is_Val, compose in *;
          rewrite execWriter_Rtheta_liftM2;
          destruct (execWriter a) as [str_a col_a];
          destruct (execWriter b) as [str_b col_b];
          unfold RthetaFlagsAppend;
          unfold IsVal in *;
          destr_bool; auto).
      -
        intros H.
        unfold Union, Is_Val, compose in *.
        rewrite execWriter_Rtheta_liftM2 in H.
        destruct (execWriter a) as [str_a col_a].
        destruct (execWriter b) as [str_b col_b].
        unfold IsVal in *.
        destr_bool; auto.
    Qed.

    (* Conditions under which Union produces struct *)
    Lemma StructUnionIsStruct (a b : Rtheta) {dot}:
      Is_Struct a /\ Is_Struct b <-> Is_Struct (Union Monoid_RthetaFlags dot a b).
    Proof.
      split.
      -
        intros [SA SB].
        unfold Union, Is_Struct, Is_Val, compose in *.
        rewrite execWriter_Rtheta_liftM2.
        destruct (execWriter a) as [str_a col_a].
        destruct (execWriter b) as [str_b col_b].
        unfold RthetaFlagsAppend.
        destr_bool.
      -
        intros H.
        unfold Union, Is_Struct, IsStruct, compose in *.
        rewrite execWriter_Rtheta_liftM2 in H.
        destruct (execWriter a) as [str_a col_a].
        destruct (execWriter b) as [str_b col_b].
        simpl in *.
        unfold RthetaFlagsAppend in H.
        destr_bool; auto.
    Qed.

    Lemma Is_Val_UnionFold {n} {v: rvector n} {dot} {neutral}:
      Vexists Is_Val v <-> Is_Val (UnionFold Monoid_RthetaFlags dot neutral v).
    Proof.
      split.
      - intros H.
        apply Vexists_eq in H.
        unfold UnionFold.
        destruct H as [x [XI XV]].
        induction v.
        + unfold Vin in XI.
          congruence.
        + apply Vin_cons in XI.
          rewrite Vfold_left_rev_cons.
          destruct XI.
          * subst h.
            apply ValUnionIsVal.
            right.
            assumption.
          *
            clear XV.
            apply IHv in H.
            apply ValUnionIsVal.
            left.
            assumption.
      -
        intros H.
        induction v.
        + crush.
        + simpl in *.
          rewrite UnionFold_cons in H.
          apply ValUnionIsVal in H.
          destruct H.
          apply IHv in H.
          right.
          apply H.
          left.
          apply H.
    Qed.

  End ExclusiveUnion.

  Section NonExclusiveUnion.

    (* Could probably proven for [RSTheta], but not generally, as it
     requires complete implementation of [mappend] *)
    Lemma NotValUnionNotIsVal (a b : Rtheta) {dot}:
      ¬ Is_Val (Union Monoid_RthetaFlags dot a b) <-> (not (Is_Val a)) /\ (not (Is_Val b)).
    Proof.
      split.
      -
        intros H.
        split;
          unfold Union, Is_Val, compose in *;
          rewrite execWriter_Rtheta_liftM2 in H;
          destruct (execWriter a) as [str_a col_a];
          destruct (execWriter b) as [str_b col_b];
          unfold monoid_plus, RthetaFlagsAppend in *;
          unfold IsVal in *;
          destr_bool; auto.
      -
        intros [A B].
        unfold Union, Is_Val, compose in *;
          rewrite execWriter_Rtheta_liftM2 in *;
          destruct (execWriter a) as [str_a col_a];
          destruct (execWriter b) as [str_b col_b];
          unfold monoid_plus, RthetaFlagsAppend in *;
          unfold IsVal in *;
          destr_bool; auto.
    Qed.

    (* Conditions under which Union produces value *)
    Lemma ValUnionIsVal_Safe (a b : RStheta) {dot}:
      Is_Val a \/ Is_Val b <-> Is_Val (Union Monoid_RthetaSafeFlags dot a b).
    Proof.
      split.
      - intros [VA | VB]; (
          unfold Union, Is_Val, compose in *;
          rewrite execWriter_Rtheta_liftM2;
          destruct (execWriter a) as [str_a col_a];
          destruct (execWriter b) as [str_b col_b];
          unfold RthetaFlagsAppend;
          unfold IsVal in *;
          destr_bool; auto).
      -
        intros H.
        unfold Union, Is_Val, compose in *.
        rewrite execWriter_Rtheta_liftM2 in H.
        destruct (execWriter a) as [str_a col_a].
        destruct (execWriter b) as [str_b col_b].
        unfold IsVal in *.
        destr_bool; auto.
    Qed.

    Lemma Is_Val_UnionFold_Safe {n} {v: rsvector n} {dot} {neutral}:
      Vexists Is_Val v <-> Is_Val (UnionFold Monoid_RthetaSafeFlags dot neutral v).
    Proof.
      split.
      - intros H.
        apply Vexists_eq in H.
        unfold UnionFold.
        destruct H as [x [XI XV]].
        induction v.
        + unfold Vin in XI.
          congruence.
        + apply Vin_cons in XI.
          rewrite Vfold_left_rev_cons.
          destruct XI.
          * subst h.
            apply ValUnionIsVal_Safe.
            right.
            assumption.
          *
            clear XV.
            apply IHv in H.
            apply ValUnionIsVal_Safe.
            left.
            assumption.
      -
        intros H.
        induction v.
        + crush.
        + simpl in *.
          rewrite UnionFold_cons in H.
          apply ValUnionIsVal_Safe in H.
          destruct H.
          apply IHv in H.
          right.
          apply H.
          left.
          apply H.
    Qed.

    Lemma UnionCollisionFree_Safe (a b : RStheta) {dot}:
      ¬Is_Collision a →
      ¬Is_Collision b →
      ¬Is_Collision (Union Monoid_RthetaSafeFlags dot a b).
    Proof.
      intros CA CB.
      unfold Union, Is_Collision, compose.
      rewrite execWriter_Rtheta_liftM2.
      unfold Is_Collision, Is_Val, compose in *.
      destruct (execWriter a) as [str_a col_a].
      destruct (execWriter b) as [str_b col_b].
      destr_bool.
    Qed.

  End NonExclusiveUnion.

  (* RStheta2Rtheta distributes over Union *)
  Lemma RStheta2Rtheta_over_Union {f a b}:
    RStheta2Rtheta
      (Union Monoid_RthetaSafeFlags f a b) =
    (Union Monoid_RthetaFlags f (RStheta2Rtheta a) (RStheta2Rtheta b)).
  Proof.
    compute.
    destruct CAPROPS.
    reflexivity.
  Qed.

  Lemma densify_rvector2rsvector_eq_densify
        {n: nat}
        {x: rvector n}
    :
      densify _ (rvector2rsvector n x) ≡ densify _ x.
  Proof.
    unfold densify, rvector2rsvector.
    rewrite Vmap_map.
    unfold Rtheta2RStheta.
    apply Vmap_eq_nth.
    intros j jc.
    rewrite WriterMonadNoT.evalWriter_castWriter, Vnth_map.
    reflexivity.
  Qed.

  Lemma densify_rsvector2rvector_eq_densify
        {n: nat}
        {x: rsvector n}
    :
      densify _ (rsvector2rvector n x) ≡ densify _ x.
  Proof.
    unfold densify, rsvector2rvector.
    rewrite Vmap_map.
    unfold RStheta2Rtheta.
    apply Vmap_eq_nth.
    intros j jc.
    rewrite WriterMonadNoT.evalWriter_castWriter, Vnth_map.
    reflexivity.
  Qed.

  (* For the lack of better place ... *)

  Require Import ExtLib.Data.Monads.OptionMonad.
  Require Import Helix.Util.OptionSetoid.

  Global Instance vsequence_option_proper
         {n:nat} {A:Type} `{Ae: Equiv A} `{Aeq: Equivalence A Ae}:
    Proper ((=) ==> (=)) (@vsequence n A option Monad_option).
  Proof.
    intros x y E.
    induction n.
    -
      VOtac.
      simpl.
      f_equiv.
    -
      dep_destruct x.
      dep_destruct y.
      simpl.
      inversion E.
      repeat break_match; try some_none; auto.
      +
        f_equiv.
        apply Vcons_equiv_intro.
        apply Some_inj_equiv, H.
        specialize (IHn x0 x1 H0).
        rewrite Heqo0 in IHn.
        rewrite Heqo2 in IHn.
        apply Some_inj_equiv, IHn.
      +
        specialize (IHn x0 x1 H0).
        rewrite Heqo0 in IHn.
        rewrite Heqo2 in IHn.
        some_none.
      +
        specialize (IHn x0 x1 H0).
        rewrite Heqo0 in IHn.
        rewrite Heqo2 in IHn.
        some_none.
  Qed.

  Lemma vsequence_Vbuild_equiv_Some
        {A: Type}
        `{Ae: Equiv A}
        `{Aeq: Equivalence A Ae}
        {n: nat}
        {f: forall (i:nat), (i < n)%nat -> option A}
        {x: vector A n}
    : Vbuild f = Vmap Some x <->
      (@vsequence n A _ _ (Vbuild f)) = Some x.
  Proof.
    split.
    -
      intros H.
      setoid_rewrite H.
      rewrite vsequence_Vmap_Some.
      f_equiv.
      rewrite Vmap_id.
      reflexivity.
    -
      intros H.
      induction n.
      +
        simpl.
        inversion H.
        dep_destruct x.
        crush.
      +
        rewrite Vbuild_Sn.
        dep_destruct x. rename x0 into xs, h into x0.
        simpl.
        apply Vcons_proper.
        *
          rewrite Vbuild_Sn in H.
          cbn in H.
          repeat break_match_hyp; try some_none.
          some_inv.
          inversion H.
          rewrite <- H0.
          reflexivity.
        *
          specialize (IHn (shrink_vbuild_function_l f) xs).
          rewrite <- IHn; clear IHn.
          --
            unfold shrink_vbuild_function_l.
            f_equiv.
            intros i ic.
            f_equiv.
          --
            rewrite Vbuild_Sn in H. cbn in H.
            repeat break_match_hyp; try some_none.
            some_inv.
            inversion H.
            rewrite <- H1.
            rewrite <- Heqo0.
            f_equiv.
  Qed.

  Close Scope vector_scope.
  Close Scope nat_scope.

End WithCarrierA.


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

Require Import Undecidability.Synthetic.Undecidability.
Require Import Undecidability.Synthetic.ReducibilityFacts.

From Undecidability.ILL
  Require Import ILL CLL ill ill_cll ill_cll_restr.

Theorem rILL_rCLL_cf_PROVABILITY : rILL_cf_PROVABILITY ⪯ rCLL_cf_PROVABILITY.
Proof.
  apply reduces_dependent; exists.
  intros (Γ,A).
  exists (⟦Γ⟧,[A]::nil).
  apply S_ill_cll_restr_equiv.
Qed.


Require Export XRdefinitions.

Local Open Scope XR_scope.

Definition R2 := R1 + R1.
Definition R3 := R2 + R1.
Definition R4 := R2 + R2.
Definition R5 := R3 + R2.
Definition R6 := R3 + R3.
Definition R7 := R4 + R3.
Definition R8 := R4 + R4.
Definition R9 := R3 + R3 + R3.
Definition R10 := R5 + R5.
Definition R12 := R6 + R6.
Definition R14 := R7 + R7.
Definition R16 := R8 + R8.
Definition R18 := R9 + R9.
Definition R20 := R10 + R10.


(* No special notion of 'dagger natural transformation' is required.
   However, some concepts are defined in terms of natural transformations.
   1. The category of dagger functors and natural transformations has the structure of dagger category.
      The dagger of a natural transformation is given by taking the dagger objectwise.
      This is called the 'dagger adjoint'.
   2. A unitary morphism in the dagger functor category is given by a natural isomorphism whose inverse is given objectwise by the dagger [unitary_functors].
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.

Require Import UniMath.CategoryTheory.DaggerCategories.Categories.
Require Import UniMath.CategoryTheory.DaggerCategories.Functors.

Local Open Scope cat.

Section DaggerAdjoint.

  Definition dagger_adjoint_data
             {C D : category}
             {dagC : dagger C} {dagD : dagger D}
             {F G : functor C D}
             (dagF : is_dagger_functor dagC dagD F)
             (dagG : is_dagger_functor dagC dagD G)
             (α : nat_trans F G)
    : nat_trans_data G F
    := λ c, dagD _ _ (α c).

  Definition dagger_adjoint_is_nat_trans
             {C D : category}
             {dagC : dagger C} {dagD : dagger D}
             {F G : functor C D}
             (dagF : is_dagger_functor dagC dagD F)
             (dagG : is_dagger_functor dagC dagD G)
             (α : nat_trans F G)
    : is_nat_trans _ _ (dagger_adjoint_data dagF dagG α).
  Proof.
    intro ; intros.

    apply (dagger_injective dagD).

    refine (dagger_to_law_comp _ _ _ _ _ _ @ _ @ ! dagger_to_law_comp _ _ _ _ _ _).

    refine (maponpaths_2 compose (dagger_to_law_idemp _ _ _ _) _ @ _).
    refine (_ @ ! maponpaths_12 compose  (idpath _) (dagger_to_law_idemp _ _ _ _)).

    refine (! maponpaths (compose (α x')) (dagG _ _ f) @ _).
    refine (_ @ maponpaths_12 compose (dagF _ _ f) (idpath _)).

    apply pathsinv0, (pr2 α).
  Qed.

  Definition dagger_adjoint
             {C D : category}
             {dagC : dagger C} {dagD : dagger D}
             {F G : functor C D}
             (dagF : is_dagger_functor dagC dagD F)
             (dagG : is_dagger_functor dagC dagD G)
             (α : nat_trans F G)
    : nat_trans G F
    := _ ,, dagger_adjoint_is_nat_trans dagF dagG α.

End DaggerAdjoint.

Section UnitaryFunctors.

  Definition unitary_functors
             {C D : category}
             {dagC : dagger C} {dagD : dagger D}
             {F G : functor C D}
             (dagF : is_dagger_functor dagC dagD F)
             (dagG : is_dagger_functor dagC dagD G)
    : UU
    := ∑ α : nat_trans F G,
        (∏ x : C, Isos.is_inverse_in_precat (α x) (dagD _ _ (α x))).

End UnitaryFunctors.


Require Import A1_Plan A2_Orientation A4_Droite A5_Cercle A7_Tactics .
Require Import B2_CollinearProp B5_BetweenProp B7_Tactics .
Require Import C1_Distance C3_SumDistance .
Require Import D3_SecondDimension .
Require Import E4_Tactics .
Require Import F1_IntersectionDiameterProp.

Section MARK_SEGMENT.

Definition AddSegmentPoint (A B C D E : Point) :
	A <> B -> Collinear A B C -> Point.
Proof.
	intros.
	setLine0 A B ipattern:(ab).
	setCircle0 C D E ipattern:(g).
	assert (Diameter ab g).
	 simpl in |- *; immediate4.
	 exact (InterDiameterPoint ab g H1).
Defined.

Definition MarkSegmentPoint (A B C D : Point) :
	A <> B -> Point.
Proof.
	intros.
	 exact (AddSegmentPoint A B A C D H (CollinearABA A B)).
Defined.

Definition OppSegmentPoint (A B C D : Point) :
	A <> B -> Point.
Proof.
	intros.
	 exact (AddSegmentPoint B A A C D (sym_not_eq H) (CollinearABB B A)).
Defined.

Definition SymmetricPoint (A B : Point) :
	A <> B -> Point.
Proof.
	intros H.
	 exact (AddSegmentPoint A B B A B H (CollinearABB A B)).
Defined.

Lemma EquiOrientedAddSegmentPoint : forall A B C D E : Point, forall (H : A <> B) (H0 : Collinear A B C),
	EquiOriented C (AddSegmentPoint A B C D E H H0) A B.
Proof.
	intros; unfold AddSegmentPoint in |- *.
	assert (H1 := EquiOrientedInterDiameterPoint (Ruler A B H) (Compass C D E) H0); immediate4.
Qed.

Lemma EqDistanceAddSegmentPoint :  forall A B C D E : Point, forall (H : A <> B) (H0 : Collinear A B C),
	Distance C (AddSegmentPoint A B C D E H H0) = Distance D E.
Proof.
	intros; unfold AddSegmentPoint in |- *.
	assert (H1 := EqDistanceInterDiameterPoint (Ruler A B H) (Compass C D E) H0); immediate4.
Qed.

Lemma CollinearAddSegmentPoint :  forall A B C D E : Point, forall (H : A <> B) (H0 : Collinear A B C),
	Collinear A B (AddSegmentPoint A B C D E H H0).
Proof.
	intros; unfold AddSegmentPoint in |- *.
	assert (H1 := OnLineInterDiameterPoint (Ruler A B H) (Compass C D E) H0).
	immediate4.
Qed.

Lemma UniqueAddSegmentPoint : forall A B C D E : Point, forall (H : A <> B) (H0 : Collinear A B C), forall M : Point,
	EquiOriented C M A B -> Distance C M = Distance D E ->
	M = AddSegmentPoint A B C D E H H0.
Proof.
	intros; unfold AddSegmentPoint in |- *.
	assert (H3 := UniqueInterDiameterPoint (Ruler A B H) (Compass C D E) H0);
	 simpl in H3; apply H3; immediate4.
Qed.

Lemma ClosedRayMarkSegmentPoint : forall A B C D : Point, forall (H : A <> B),
	ClosedRay A B (MarkSegmentPoint A B C D H).
Proof.
	intros; unfold MarkSegmentPoint in |- *.
	assert (H1 := EquiOrientedAddSegmentPoint A B A C D H (CollinearABA A B)); immediate4.
Qed.

Lemma EqDistanceMarkSegmentPoint :  forall A B C D : Point, forall (H : A <> B),
	Distance A (MarkSegmentPoint A B C D H) = Distance C D.
Proof.
	intros; unfold MarkSegmentPoint in |- *.
	assert (H1 := EqDistanceAddSegmentPoint A B A C D H (CollinearABA A B)); immediate4.
Qed.

Lemma UniqueMarkSegmentPoint : forall A B C D : Point, forall (H : A <> B), forall M : Point,
	ClosedRay A B M -> Distance A M = Distance C D ->
	M = MarkSegmentPoint A B C D H.
Proof.
	intros; unfold MarkSegmentPoint in |- *.
	apply UniqueAddSegmentPoint; immediate4.
Qed.

Lemma SegmentOppSegmentPoint : forall A B C D : Point, forall (H : A <> B),
	Segment (OppSegmentPoint A B C D H) B A.
Proof.
	intros; unfold OppSegmentPoint in |- *.
	assert (H1 := EquiOrientedAddSegmentPoint B A A C D (sym_not_eq H) (CollinearABB B A)).
	apply EquiOrientedSegment.
	immediate4.
Qed.

Lemma EqDistanceOppSegmentPoint :  forall A B C D : Point, forall (H : A <> B),
	Distance A (OppSegmentPoint A B C D H) = Distance C D.
Proof.
	intros; unfold OppSegmentPoint in |- *.
	assert (H1 := EqDistanceAddSegmentPoint B A A C D (sym_not_eq H) (CollinearABB B A)); immediate4.
Qed.

Lemma UniqueOppSegmentPoint : forall A B C D : Point, forall (H : A <> B), forall M : Point,
	Segment B M A -> Distance A M = Distance C D ->
	M = OppSegmentPoint A B C D H.
Proof.
	intros; unfold OppSegmentPoint in |- *.
	apply UniqueAddSegmentPoint.
	 canonize1.
	   step4 H2.
	   step4 H3.
	 immediate4.
Qed.

Lemma BetweenSymmetricPoint : forall A B : Point, forall (H : A <> B),
	Between A B (SymmetricPoint A B H).
Proof.
	intros; unfold SymmetricPoint in |- *.
	assert (H1 := EquiOrientedAddSegmentPoint A B B A B H (CollinearABB A B)); split; immediate4.
	assert (H2 := EqDistanceAddSegmentPoint A B B A B H (CollinearABB A B));  step4 H2.
Qed.

Lemma DistinctBSymmetricPoint : forall A B : Point, forall (H : A <> B),
	B <> SymmetricPoint A B H.
Proof.
	intros; assert (H0 := BetweenSymmetricPoint A B H).
	immediate4.
Qed.

Lemma DistinctASymmetricPoint : forall A B : Point, forall (H : A <> B),
	A <> SymmetricPoint A B H.
Proof.
	intros; assert (H0 := BetweenSymmetricPoint A B H).
	immediate4.
Qed.

Lemma EqDistanceSymmetricPoint :  forall A B : Point, forall (H : A <> B),
	Distance B (SymmetricPoint A B H) = Distance A B.
Proof.
	intros; unfold SymmetricPoint in |- *.
	assert (H1 := EqDistanceAddSegmentPoint A B B A B H (CollinearABB A B));  immediate4.
Qed.

Lemma UniqueSymmetricPoint : forall A B : Point, forall (H : A <> B), forall M : Point,
	EquiOriented A B B M -> Distance B M = Distance A B ->
	M = SymmetricPoint A B H.
Proof.
	intros; unfold SymmetricPoint in |- *.
	apply UniqueAddSegmentPoint; immediate4.
Qed.

Lemma CaseNullDistance : forall A B I : Point, I <> A -> Distance A B = Oo -> A = B.
Proof.
	intros.
	since4 (Collinear I A A).
	since4 (A = AddSegmentPoint I A A A B H H1).
	 apply UniqueAddSegmentPoint.
	  immediate4.
	  immediate4.
	 rewrite H2; apply sym_eq.
	   apply UniqueAddSegmentPoint.
	  canonize1.
	    since4 (Distance A B <> Oo).
	   apply DistanceNotNull; immediate4.
	   contradict1 H0 H4.
	  immediate4.
Qed.

Lemma NullDistanceEq : forall A B : Point, Distance A B = Oo -> A = B.
Proof.
	intros; destruct (Apart Oo Uu A DistinctOoUu).
	 apply (CaseNullDistance A B Oo); trivial.
	 apply (CaseNullDistance A B Uu); trivial.
Qed.

Lemma DistancePlusRightCancell : forall A B C D : Point,
	DistancePlus (Distance A B) (Distance C D) = Distance A B -> C = D.
Proof.
	intros.
	apply NullDistanceEq.
	apply (DistancePlusNeutralRightEq (Distance A B)); immediate4.
Qed.

Lemma DistancePlusLeftCancell : forall A B C D : Point,
	DistancePlus (Distance C D) (Distance A B) = Distance A B -> C = D.
Proof.
	intros.
	apply (DistancePlusRightCancell A B C D).
	immediate4.
Qed.

End MARK_SEGMENT.


From Cat Require Import Cat.
From Cat.Universal Require Import Product Terminal.

Set Implicit Arguments.

Class isIndexedProduct
  (C : Cat) {J : Type} {A : J -> Ob C}
  (P : Ob C) (out : forall j : J, Hom P (A j))
  (tuple : forall {X : Ob C} (f : forall j : J, Hom X (A j)), Hom X P)
  : Prop :=
{
  tuple_out :
    forall {X : Ob C} (f : forall j : J, Hom X (A j)) (j : J),
      tuple f .> out j == f j;
  equiv_indexedProduct :
    forall {X : Ob C} (f g : Hom X P),
      (forall j : J, f .> out j == g .> out j) -> f == g;
}.

#[export] Hint Mode isIndexedProduct ! ! ! ! ! ! : core.
#[export] Hint Mode isIndexedProduct ! ! ! - - - : core.

Lemma equiv_indexedProduct' :
  forall
    {C : Cat} {J : Type} {A : J -> Ob C}
    {P : Ob C} {out : forall j : J, Hom P (A j)}
    {tuple : forall {X : Ob C} (f : forall j : J, Hom X (A j)), Hom X P}
    {isP : isIndexedProduct C P out (@tuple)}
    {X : Ob C} (f g : Hom X P),
      f == g <-> forall j : J, f .> out j == g .> out j.
Proof.
  split.
  - now intros Heq j; rewrite Heq.
  - now apply equiv_indexedProduct.
Qed.

Section isIndexedProduct.

Context
  {C : Cat} {J : Type} {A : J -> Ob C}
  {P : Ob C} {out : forall j : J, Hom P (A j)}
  {tuple : forall {X : Ob C} (f : forall j : J, Hom X (A j)), Hom X P}
  {isP : isIndexedProduct C P out (@tuple)}
  {X Y : Ob C} (f : forall j : J, Hom X (A j)).

Arguments tuple {X} _.

#[global] Instance Proper_tuple :
  Proper (equiv ==> equiv) (@tuple X).
Proof.
  intros h1 h2 Heq.
  apply equiv_indexedProduct; intros j.
  now rewrite !tuple_out.
Defined.

Lemma tuple_universal :
  forall h : Hom X P,
    tuple f == h <-> forall j : J, f j == h .> out j.
Proof.
  now intros; rewrite equiv_indexedProduct'; setoid_rewrite tuple_out.
Qed.

Lemma tuple_unique :
  forall h : Hom X P,
    (forall j : J, h .> out j == f j) -> h == tuple f.
Proof.
  now intros; apply equiv_indexedProduct; setoid_rewrite tuple_out.
Qed.

Lemma tuple_id :
  tuple out == id P.
Proof.
  now rewrite equiv_indexedProduct'; setoid_rewrite tuple_out.
Qed.

Lemma tuple_comp :
  forall h : Hom Y X,
    h .> tuple f == tuple (fun j => h .> f j).
Proof.
  setoid_rewrite equiv_indexedProduct'; intros h j.
  now rewrite comp_assoc, !tuple_out.
Qed.

End isIndexedProduct.

Ltac indexedProduct_simpl := repeat (
  try setoid_rewrite equiv_indexedProduct';
  try setoid_rewrite tuple_out;
  try setoid_rewrite tuple_id;
  try setoid_rewrite tuple_comp;
  try setoid_rewrite comp_id_l;
  try setoid_rewrite comp_id_r;
  try setoid_rewrite <- comp_assoc).

Lemma isIndexedProduct_iso_unique :
  forall
    (C : Cat) (J : Type) (A : J -> Ob C)
    (P1 : Ob C) (proj1 : forall j : J, Hom P1 (A j))
    (tuple1 : forall (X : Ob C) (f : forall j : J, Hom X (A j)), Hom X P1)
    (P2 : Ob C) (proj2 : forall j : J, Hom P2 (A j))
    (tuple2 : forall (X : Ob C) (f : forall j : J, Hom X (A j)), Hom X P2),
      isIndexedProduct C P1 proj1 tuple1 ->
      isIndexedProduct C P2 proj2 tuple2 ->
        P1 ~ P2.
Proof.
  intros * H1 H2.
  exists (tuple2 _ proj1), (tuple1 _ proj2).
  rewrite !tuple_comp, !equiv_indexedProduct'; split; intros.
  - now rewrite !tuple_out, comp_id_l.
  - now rewrite !tuple_out, comp_id_l.
Qed.

Lemma isIndexedProduct_iso_unique2 :
  forall
    (C : Cat) (J : Type) (A B : J -> Ob C)
    (P1 : Ob C) (p1 : forall j : J, Hom P1 (A j))
    (t1 : forall (X : Ob C) (f : forall j : J, Hom X (A j)), Hom X P1)
    (P2 : Ob C) (p2 : forall j : J, Hom P2 (B j))
    (t2 : forall (X : Ob C) (f : forall j : J, Hom X (B j)), Hom X P2),
      (forall j : J, {f : Hom (A j) (B j) & {g : Hom (B j) (A j) |
        f .> g == id (A j) /\ g .> f == id (B j)}}) ->
      isIndexedProduct C P1 p1 t1 ->
      isIndexedProduct C P2 p2 t2 ->
        P1 ~ P2.
Proof.
  unfold isomorphic, isIso.
  intros * H H1 H2.
  split with (t2 _ (fun j => p1 j .> projT1 (H j))).
  split with (t1 _ (fun j => p2 j .> proj1_sig (projT2 (H j)))).
  split.
  - rewrite equiv_indexedProduct'; intros j.
    rewrite comp_assoc, tuple_out, <- comp_assoc, tuple_out, comp_assoc.
    destruct (H j) as (f & g & Hfg & Hgf); cbn.
    now rewrite  Hfg, comp_id_l, comp_id_r.
  - rewrite equiv_indexedProduct'; intros j.
    rewrite comp_assoc, tuple_out, <- comp_assoc, tuple_out, comp_assoc.
    destruct (H j) as (f & g & Hfg & Hgf); cbn.
    now rewrite  Hgf, comp_id_l, comp_id_r.
Defined.

Lemma small_and_isIndexedProducts :
  forall
    {C : Cat} {A B : Ob C}
    (P : Ob C) (pA : Hom P A) (pB : Hom P B)
    (t : forall X : Ob C, Hom X A -> Hom X B -> Hom X P),
      isProduct C P pA pB t
        <->
      exists
        (f := fun b : bool => if b then A else B)
        (p := fun b : bool => if b as b0 return (Hom P (if b0 then A else B))
                then pA else pB)
        (tuple := fun (X : Ob C) (f : forall j : bool, Hom X (if j then A else B)) =>
                    t X (f true) (f false)),
          isIndexedProduct C P p tuple.
Proof.
  split; cbn; intros * HP.
  - split.
    + intros X f [].
      * now rewrite fpair_outl.
      * now rewrite fpair_outr.
    + now intros X f g H; rewrite equiv_product', (H false), (H true).
  - split; cycle 2.
    + now intros * H1 H2; destruct HP; apply equiv_indexedProduct0; intros []; cbn.
    + intros Γ f g.
      pose
      (
        wut := fun j : bool =>
          if j return (Hom Γ (if j then A else B))
          then f
          else g
      ).
      now destruct HP; apply (tuple_out0 _ wut true).
    + intros Γ f g.
      pose
      (
        wut := fun j : bool =>
          if j return (Hom Γ (if j then A else B))
          then f
          else g
      ).
      now destruct HP; apply (tuple_out0 _ wut false).
Qed.

Lemma nullary_product :
  forall
    (C : Cat) (A : Empty_set -> Ob C)
    (T : Ob C) (delete : forall X : Ob C, Hom X T)
    (p : forall j : Empty_set, Hom T (A j))
    (tuple : forall (X : Ob C) (f : forall j : Empty_set, Hom X (A j)), Hom X T),
      isTerminal C T delete -> isIndexedProduct C T p tuple.
Proof.
  easy.
Qed.

Lemma unary_prod_exists :
  forall (C : Cat) (A : unit -> Ob C),
    isIndexedProduct C (A tt) (fun _ : unit => id (A tt)) (fun _ f => f tt).
Proof.
  now split; cat.
Qed.

(* Dependent type bullshit. This is harder than I thought. *)
Lemma isIndexedProduct_comm :
  forall
    (C : Cat) (J : Type) (A : J -> Ob C)
    (P : Ob C) (p : forall j : J, Hom P (A j))
    (tuple : forall (X : Ob C) (f : forall j : J, Hom X (A j)), Hom X P)
    (f : J -> J)
    (p' : forall j : J, Hom P (A (f j)))
    (tuple' : forall (X : Ob C) (f : forall j : J, Hom X (A (f j))), Hom X P),
      (forall j : J, p' j = p (f j)) ->
        bijective f -> isIndexedProduct C P p tuple -> isIndexedProduct C P p' tuple'.
Proof.
  unfold bijective, injective, surjective.
  destruct 2 as [inj sur]; intros.
  assert (g : {g : J -> J | (forall j : J, f (g j) = j) /\ (forall j : J, g (f j) = j)})
    by admit.
  destruct g as [g [g_inv1 g_inv2]].
  assert (h : {h : forall j : J, Hom P (A (f (g j))) |
  (forall j : J, h j = p (f (g j)))}).
Abort.

Class HasIndexedProducts (C : Cat) : Type :=
{
  indexedProduct : forall {J : Type} (A : J -> Ob C), Ob C;
  out :
    forall {J : Type} {A : J -> Ob C} (j : J), Hom (indexedProduct A) (A j);
  tuple :
    forall {J : Type} {A : J -> Ob C} {X : Ob C} (f : forall j : J, Hom X (A j)),
      Hom X (indexedProduct A);
  HasIndexedProducts_isIndexedProduct :>
    forall {J : Type} {A : J -> Ob C},
      isIndexedProduct C (indexedProduct A) (@out J A) (@tuple J A)
}.

Arguments indexedProduct {C _ J} _.
Arguments out            {C _ J A} _.
Arguments tuple          {C _ J A X} _.

Lemma tuple_comp' :
  forall
    {C : Cat} {hip : HasIndexedProducts C}
    {X : Ob C} {J : Type} {A B : J -> Ob C}
    (f : forall j : J, Hom X (A j)) (g : forall j : J, Hom (A j) (B j)),
      tuple (fun j : J => f j .> g j)
        ==
      tuple f .> tuple (fun j : J => out j .> g j).
Proof.
  intros.
  rewrite tuple_comp, equiv_indexedProduct'; intros j.
  now rewrite !tuple_out, <- comp_assoc, tuple_out.
Qed.