(******************************************************************************)
(**)
(******************************************************************************)
(*         M1 \oplus M2 == the zmodType given by pair_lmodType in ssralg.v    *)
(*                         This is an implementation of the direct sum of two *)
(*                         zmodTypes.                        *)
(* \bigoplus_(f in L) I == the lmodType built up iteratively, where L : seq S *)
(*                         for S : eqType and I : S -> lmodType R             *)
(*                         \bigoplus_(f in nil) I is zmodNullType whilst      *)
(*                         \bigoplus_(f in a::L) I is                         *)
(*                               (I a) \oplus (\bigoplus_(f in L) I)          *)
(*                         This is an implementation of the direct sum of an  *)
(*                         arbitrary number of zmodTypes. Note that L is not  *)
(*                         a list of zmodTypes but of some eqType S, which    *)
(*                         are 'converted' to zmodTypes by                    *)
(*                           I : S -> zmodType.                               *)
(*  \bigoplus_(f : F) I == the zmodType equal to \bigoplus_(f in (enum F)) I  *)
(*        \bigoplus_F I == equivalent to \bigoplus_(f : F) I                  *)
(*          \bigoplus I == equivalent to \bigoplus_(f : F) I                  *)
(*                         where I : F -> zmodType                            *)
(******************************************************************************)
(* The following constructions and lemmas relate to M \oplus N,               *)
(* the direct sum of the pair of zmodTypes M and N                            *)
(******************************************************************************)
(*  \proj1^(M,N)   == the additive projection from M \oplus N to M            *)
(*  \proj2^(M,N)   == the additive projection from M \oplus N to N            *)
(*  \incl1^(M,N)   == the additive inclusion from M to M \oplus N             *)
(*  \incl2^(M,N)   == the additive inclusion from N to M \oplus N             *)
(*  incl1_injective  == a proof that \incl1^(M,N) is injective                *)
(*  incl2_injective  == a proof that \incl2^(M,N) is injective                *)
(*  proj1_incl1K     == a proof of \proj1^(M,N) (\incl1^(M,N) x) = x          *)
(*  proj2_incl2K     == a proof of \proj2^(M,N) (\incl2^(M,N) x) = x          *)
(*  proj1_incl20     == a proof of \proj1^(M,N) (\incl2^(M,N) x) = 0          *)
(*  proj2_incl10     == a proof of \proj2^(M,N) (\incl1^(M,N) x) = 0          *)
(*  incl_proj12_sum  == a proof that any x : M \oplus N can be written        *)
(*                         x = \incl1^(M,N) (\proj1^(M,N) x)                  *)
(*                              + \incl2^(M,N) (\proj2^(M,N) x)               *)
(*  incl_proj12_idem == a proof that rewriting with incl_proj12_sum is        *)
(*                         idempotent                                         *)
(******************************************************************************)
(* Let M N M1 M2 N1 N2 : zmodType                                             *)
(* We define construction for combining linear maps so to be compatible       *)
(* with direct sums                                                           *)
(******************************************************************************)
(* Let f1 : {additive M1 -> N1} and f2 : {additive M2 -> N2}                  *)
(* \diagmap(f,g) == the additive map : M1 \oplus M2 -> N1 \oplus N2           *)
(*                         given by \diagmap(f,g) (x,y) = (f x, g y)          *)
(******************************************************************************)
(* Let f1 : {additive M1 -> N} and f2 : {additive M2 -> N}                    *)
(* \rowmap(f,g) == the additive map : M1 \oplus M2 -> N                       *)
(*                         given by \rowmap(f,g) (x,y) = f x + g y            *)
(******************************************************************************)
(* Let f1 : {additive M -> N1} and f2 : {additive M -> N2}                    *)
(* \colmap(f,g) == the additive map : M -> N1 \oplus N2                       *)
(*                         given by \colmap(f,g) x = (f x, g x)               *)
(******************************************************************************)
(* The following constructions and lemmas relate to \bigoplus_(f : F) I,      *)
(* the direct sum of the zmodTypes given by (I : F -> zmodType), and F is a   *)
(* finite index set (i.e. a finType)                                          *)
(******************************************************************************)
(*  \proj_f^(I)    == the additive projection from \bigoplus I to (I f),      *)
(*                 for f : F. This function is surjective                     *)
(*  \incl_f^(I)    == the additive inclusion from (I f) to \bigoplus I,       *)
(*                 for f : F. This function is injective                      *)
(*  incl_injective == a proof that \incl_f^(I) is injective for f : F         *)
(*  proj_inclK     == a proof that \incl_f^(I) and \proj_f^(I) cancel         *)
(*  proj_incl0     == a proof that \incl_f^(I) and \proj_(f')^(I) equals zero *)
(*                    if f != f'                                              *)
(*  incl_proj_sum  == rewrites element x : \bigoplus I as                     *)
(*                        \sum_(f : F)\incl_f^(I) (\proj_f^(I) x)             *)
(*  incl_proj_idem       ==  a proof that rewriting with incl_proj_sum is     *)
(*                         idempotent                                         *)
(******************************************************************************)
(* The following constructions are used to split and unsplit the direct sum   *)
(* of two direct sums, that is (\bigoplus J) \oplus (\bigoplus K).            *)
(* Doing this involves:                                                       *)
(*  1) three index sets F, G and H,                                           *)
(*  2) a function GH_F : G + H -> F, connecting the sum of G and H to F       *)
(*  3) a proof enumB : enum F = map F_GH (enum sum_finType G H) which         *)
(* establishes that GH_F is an 'isomorphism' of G + H and F as finTypes,      *)
(* and the notations J = I \o GH_F \o inl and K = I \o GH_F \o inr.           *)
(******************************************************************************)
(*     split == a additive function from \bigoplus I to                       *)
(*                    (\bigoplus J) \oplus (\bigoplus K)                      *)
(*   unsplit == a additive function from (\bigoplus J) \oplus (\bigoplus K)   *)
(*                    to \bigoplus I                                          *)
(*  splitK   == a proof that split and unsplit cancel                         *)
(*  unsplitK == a proof that unsplit and split cancel                         *)
(******************************************************************************)
(* DirectSum_UniversalProperty == *)
(******************************************************************************)

From Coq.Init Require Import Notations Datatypes.
Require Import Coq.Program.Tactics.
From Coq.Logic Require Import FunctionalExtensionality.
From mathcomp Require Import ssreflect ssrfun seq.
From mathcomp Require Import eqtype fintype bigop.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool ssrnat.
Set Warnings "parsing".

Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Require Import AbGroups Additives.
Open Scope ring_scope.
Set Implicit Arguments.
Unset Strict Implicit.
Include GRing.

Open Scope  zmod_scope.

Section Helpers.
  Variable (S : finType) (X : zmodType) (f : S*S -> X).
  Lemma big_pair_diag_eq :
    \sum_(i : S*S | i.2 == i.1)f i
      = \sum_(i : S) f (i, i).
  Proof.
    have : forall (i : S) (_ : true), f (i, i) = \sum_(j : S) if (j == i) then f (i, j) else 0
    by move=>i _;
    rewrite -big_mkcond (big_pred1 i).
    move=> H; rewrite (eq_bigr _ H); clear H.
    by rewrite pair_bigA -big_mkcond
    (eq_bigr (fun i => f (i.1,i.2)) _)=>/=;
      [|move=>i _; destruct i=>/=].
  Qed.
End Helpers.

Reserved Notation "\bigoplus_ i F"
(at level 36, F at level 36, i at level 50,
  right associativity,
        format "'[' \bigoplus_ i '/ ' F ']'").

Reserved Notation "\bigoplus F"
(at level 36, F at level 36,
  right associativity,
        format "'[' \bigoplus F ']'").

Reserved Notation "\bigoplus_ ( i : t ) F"
(at level 36, F at level 36, i at level 50,
        format "'[' \bigoplus_ ( i : t ) '/ ' F ']'").

Reserved Notation "\bigoplus_ ( i < n ) F"
(at level 36, F at level 36, i, n at level 50,
        format "'[' \bigoplus_ ( i < n ) F ']'").

Reserved Notation "\bigoplus_ ( i 'in' A ) F"
(at level 36, F at level 36, i, A at level 50,
        format "'[' \bigoplus_ ( i 'in' A ) '/ ' F ']'").

Reserved Notation "\proj^( I )_ f "
(at level 36, f at level 36, I at level 36,
  format "'[' \proj^( I )_ f ']'").

Reserved Notation "\inj^( I )_ f "
(at level 36, f at level 36, I at level 36,
  format "'[' \inj^( I )_ f ']'").

Reserved Notation "\proj_ f ^( I ) "
(at level 36, f at level 36, I at level 36,
  format "'[' \proj_ f '^(' I ) ']'").

Reserved Notation "\inj_ f ^( I )"
(at level 36, f at level 36, I at level 36,
  format "'[' \inj_ f '^(' I ) ']'").

Module dsZmod.
  Module Pair.
    Section Def.
      Variable (m1 m2 : zmodType).

      Section Injection.
        Definition inj1_raw := fun x : m1 => (x,zero m2) : pair_zmodType m1 m2.
        Definition inj2_raw := fun x : m2 => (zero m1, x) : pair_zmodType m1 m2.

        Lemma inj1_add : additive inj1_raw.
        Proof. rewrite /inj1_raw/==>x y.
          by symmetry; rewrite /(add _)/=/add_pair/=subr0. Qed.
        Lemma inj2_add : additive inj2_raw.
        Proof. rewrite /inj2_raw/==>x y.
          by symmetry; rewrite /(add _)/=/add_pair/=subr0. Qed.

        Lemma inj1_injective : injective inj1_raw.
        Proof. by move=>x y H; inversion H. Qed.
        Lemma inj2_injective : injective inj2_raw.
        Proof. by move=>x y H; inversion H. Qed.

        Definition inj1 := Additive inj1_add.
        Definition inj2 := Additive inj2_add.

        Lemma inj1_unraw x : inj1_raw x = inj1 x. Proof. by []. Qed.
        Lemma inj2_unraw x : inj2_raw x = inj2 x. Proof. by []. Qed.
      End Injection.

      Section Projection.
        Definition proj1_raw := fun x : pair_zmodType m1 m2 => x.1.
        Definition proj2_raw := fun x : pair_zmodType m1 m2 => x.2.

        Lemma proj1_add : additive proj1_raw.
        Proof. rewrite /proj1_raw/==>x y; destruct x as [x1 x2], y as [y1 y2].
          by rewrite /(add _)/=/add_pair. Qed.
        Lemma proj2_add : additive proj2_raw.
        Proof. rewrite /proj1_raw/==>x y; destruct x as [x1 x2], y as [y1 y2].
          by rewrite /(add _)/=/add_pair. Qed.

        Definition proj1 := Additive proj1_add.
        Definition proj2 := Additive proj2_add.

        Lemma proj1_unraw x : proj1_raw x = proj1 x. Proof. by []. Qed.
        Lemma proj2_unraw x : proj2_raw x = proj2 x. Proof. by []. Qed.

        Lemma proj1_inj1K x : proj1 (inj1 x) = x. Proof. by []. Qed.
        Lemma proj2_inj2K x : proj2 (inj2 x) = x. Proof. by []. Qed.
        Lemma proj1_inj20 x : proj1 (inj2 x) = 0. Proof. by []. Qed.
        Lemma proj2_inj10 x : proj2 (inj1 x) = 0. Proof. by []. Qed.
      End Projection.

      Lemma inj_proj_sum x : x = inj1 (proj1 x) + inj2 (proj2 x).
      Proof.
        rewrite /inj1/proj1/inj2/proj2/(add _)/=
         /add_pair addr0 add0r;
        by destruct x.
      Qed.
    End Def.

    Section Morphisms.
      Section MorphismsToDS.
        Variable (M N1 N2 : zmodType)
          (f1 : {additive M -> N1}) (f2 : {additive M -> N2}).

        Definition to_ds_raw : M -> (pair_zmodType N1 N2)
          := fun x => (inj1 _ _ (f1 x)) + (inj2  _ _ (f2 x)).

        Lemma to_ds_add : additive to_ds_raw.
        Proof. rewrite/to_ds_raw=>x y.
        by rewrite !raddfD !raddfN addrACA. Qed.
        Definition to_ds : {additive M -> (pair_zmodType N1 N2)}
          := Additive to_ds_add.

      End MorphismsToDS.

      Section MorphismsFromDS.
        Variable (M1 M2 N : zmodType)
          (f1 : {additive M1 -> N}) (f2 : {additive M2 -> N}).

        Definition from_ds_raw : (pair_zmodType M1 M2) -> N
          := fun x => (f1 (proj1 _ _ x)) + (f2 (proj2  _ _ x)).

        Lemma from_ds_add : additive from_ds_raw.
        Proof. rewrite/from_ds_raw=>x y.
        by rewrite !raddfD !raddfN addrACA. Qed.

        Definition from_ds : {additive (pair_zmodType M1 M2) -> N}
          := Additive from_ds_add.

      End MorphismsFromDS.

      Section MorphismsDiag.
        Variable (M1 M2 N1 N2 : zmodType)
          (f1 : {additive M1 -> N1}) (f2 : {additive M2 -> N2}).

        Definition diag_raw : (pair_zmodType M1 M2) -> (pair_zmodType N1 N2)
          := fun x => (inj1 _ _ (f1 (proj1 _ _ x))) + (inj2 _ _ (f2 (proj2  _ _ x))).

        Lemma diag_add : additive diag_raw.
        Proof. rewrite/diag_raw=>x y.
        by rewrite !raddfD !raddfN addrACA. Qed.

        Definition diag : {additive (pair_zmodType M1 M2) -> (pair_zmodType N1 N2)}
          := Additive diag_add.

      End MorphismsDiag.

      Section MorphismsDiagCompositions.
        Variable (M1 M2 N1 N2 O1 O2 : zmodType)
          (f1 : {additive M1 -> N1}) (f2 : {additive M2 -> N2})
          (g1 : {additive N1 -> O1}) (g2 : {additive N2 -> O2}).

        Lemma diag_id : diag (\id_M1) (\id_M2) = \id_(pair_zmodType M1 M2).
        Proof.
          rewrite additive_eq.
          apply functional_extensionality=>x/=.
          by rewrite /diag_raw /addID.map -!(lock) -(inj_proj_sum x).
        Qed.

        Lemma diag_comp : (diag g1 g2) \oAdd (diag f1 f2) = diag (g1 \oAdd f1) (g2 \oAdd f2).
        Proof.
          rewrite additive_eq.
          apply functional_extensionality=>x.
          rewrite -!addCompChain=>/=.
          rewrite /diag_raw -!addCompChain=>/=.
          by rewrite addr0 add0r.
        Qed.

      End MorphismsDiagCompositions.
    End Morphisms.

    Module Exports.
      Notation zmodDSPairType := pair_zmodType.
      Infix "\oplus" := (pair_zmodType) (at level 35) : zmod_scope.
      Notation "\diagmap( f , g )" := (diag f g) (at level 35) : zmod_scope.
      Notation "\rowmap( f , g )" := (from_ds f g) (at level 35) : zmod_scope.
      Notation "\colmap( f , g )" := (to_ds f g) (at level 35) : zmod_scope.
    End Exports.
  End Pair.
  Export Pair.Exports.

  Module Seq.
    Section Ring.
      Section Environment.
        Variable (T : eqType) (I : T -> zmodType).

        Section Def.
          Definition Nth := (fun L n => match (seq.nth None (map Some L) n) with
          |Some t => I t
          |None => zmodZeroType
          end).

          Fixpoint DS (L : seq T) : zmodType := match L with
            |nil => zmodZeroType
            |a'::L' => (I a') \oplus (DS L')
          end.
        End Def.

        Section Injection.
        Fixpoint inj_raw (L : seq T) (n : nat) {struct n} :
          Nth L n -> DS L
        := match L as LL return Nth LL n -> DS LL with
          |nil => fun _ => tt
          |a::L' => match n as nn return Nth (a::L') nn -> DS (a::L') with
            |0    => fun x => @Pair.inj1 (I a) (DS L') x
            |S n' => fun x => @Pair.inj2 (I a) (DS L') ((@inj_raw L' n') x)
            end
          end.

          Lemma inj_add (L : seq T) (n : nat) : additive (@inj_raw L n).
          Proof. move: n; induction L.
            induction n=>//.
            move : L IHL; induction n=>// x y.
            apply (@Pair.inj1_add (I a) (DS L)).
            by rewrite /=-(@Pair.inj2_add (I a) (DS L)) (IHL n).
          Qed.

          Lemma inj_injective
            (L : seq T) (n : nat) : injective (@inj_raw L n).
          Proof. move: n; induction L=>//=.
          { induction n; by move=> x y; destruct x, y. }
            move: L IHL.
            induction n=>/= x y H.
            apply (@Pair.inj1_injective _ _ x y H).
            apply (IHL n x y (@Pair.inj2_injective _ _ (@inj_raw L n x) (@inj_raw L n y) H)).
          Qed.
        End Injection.
        Definition inj (L : seq T) (n : nat)
          := Additive (@inj_add L n).

        Section Projection.
          Fixpoint proj_raw (L : seq T) (n : nat) {struct n} :
          DS L -> Nth L n
        := match L as LL return DS LL -> Nth LL n with
          |nil => match n as nn return zmodZero.type -> Nth nil nn with
            |0    => fun _ => tt
            |S n' => fun _ => tt
            end
          |a::L' => match n as nn return DS (a::L') -> Nth (a::L') nn with
            |0    => fun x => @Pair.proj1 (I a) (DS L') x
            |S n' => fun x => (@proj_raw L' n') (@Pair.proj2 (I a) (DS L') x)
            end
          end.

          Lemma proj_add (L : seq T) (n : nat) : additive (@proj_raw L n).
          Proof. move: n; induction L=>//=. induction n=>//.
            move: L IHL; induction n=>//=; move=> x y.
            by rewrite !Pair.proj2_unraw raddfD -(IHL n).
          Qed.
        End Projection.
        Definition proj (L : seq T) (n : nat)
          := Additive (@proj_add L n).

        Section Results.
          Section Lemmas.
            Variable (L : seq T).
            Lemma nth_cons {a d} {n : nat} : seq.nth d (a::L) (S n) = seq.nth d L n.
            Proof. by induction n. Qed.

            Lemma inj_cons n a x : @inj (a::L) (S n) x = Pair.inj2 (I a) _ (@inj L n x).
            Proof. by []. Qed.

            Lemma proj_cons n a x : @proj (a::L) (S n) (Pair.inj2 (I a) _ x) = @proj L n x.
            Proof. by []. Qed.

            Lemma proj_inj_cons (n n' : nat) a x
            : @proj (a::L) (n.+1) (@inj (a::L) (n'.+1) x) = @proj L n (@inj L n' x).
            Proof. by []. Qed.
          End Lemmas.
          Variable (L : seq T).

          (* The following two lemmas are used for cancellation *)
          Lemma proj_injK_ofsize (n : 'I_(size L)) x : @proj L (nat_of_ord n) (@inj L (nat_of_ord n) x) = x.
          Proof.
            induction L=>//; destruct n as [n N]=>//.
            induction n=>//; move:x; simpl (Ordinal N : nat)=>x.
            rewrite -ltn_predRL in N.
            by rewrite proj_inj_cons (IHl (Ordinal N)).
          Qed.

          Lemma proj_inj0_ofsize (n n' : 'I_(size L)) x : (nat_of_ord n) != n' -> @proj L n (@inj L n' x) = 0.
          Proof.
            induction L; destruct n as [n N], n' as [n' N']=>//.
            simpl in x, IHl, N, N'=>H.
            induction n.
              apply (rwP negP) in H.
              by induction n'=>/=; [contradiction H|].
            induction n'=>//=.
              by (have: proj l n 0 = 0 by rewrite raddf0).
            clear IHn' IHn;
            rewrite eqSS in H;
            rewrite ltnS in N;
            rewrite ltnS in N';
            by apply (IHl (Ordinal N) (Ordinal N') x H).
          Qed.

          (* The following two lemmas are the same as above but more versitile,
          in that they don't require the index to be an ordinal of size L, simply
          that they are naturals less than size L *)
          Lemma proj_injK (n : nat) x (M : n < size L) : @proj L n (@inj L n x) = x.
          Proof. apply (@proj_injK_ofsize (Ordinal M)). Qed.

          Lemma proj_inj0 m1 m2 (n : 'I_m1) (n' : 'I_m2) x (M1 : m1 <= (size L)) (M2 : m2 <= (size L))
            : (nat_of_ord n) != n' -> @proj L n (@inj L n' x) = 0.
          Proof. apply (@proj_inj0_ofsize (widen_ord M1 n) (widen_ord M2 n')). Qed.

          (* this lemma expresses any element as a sum of projections *)
          Lemma inj_proj_sum x : x = \sum_(n < size L) inj L (nat_of_ord n) (@proj L (nat_of_ord n) x).
          Proof.
            induction L.
            by rewrite /size big_ord0; case x.
            destruct x as [Ia DSl].
            by rewrite big_ord_recl {1}(IHl DSl)
            (Pair.inj_proj_sum (Ia, _)) raddf_sum.
          Qed.
        End Results.

        (* Given a direct sum indexed by a seq, we define a function to reform
        the direct sum into the direct sum of two smaller direct sums. *)
        Section Operations.
          Variable (L1 L2 : seq T).
          (*Tr = truncate, Ap = Append, R = right, L = left*)
          Section L1.
            Variable (n : 'I_(size L1)).
            Lemma catTrR_eq : (Nth (L1 ++ L2) n) = (Nth L1 n).
            Proof. destruct n as [n' H].
            by rewrite/Nth map_cat nth_cat size_map H. Qed.

            Definition catTrR : (Nth (L1 ++ L2) n) -> (Nth L1 n).
            Proof. by rewrite catTrR_eq. Defined.

            Definition catApR : (Nth L1 n) -> (Nth (L1 ++ L2) n).
            Proof. by rewrite catTrR_eq. Defined.

            Lemma catTrApR_add : additive catTrR /\ additive catApR.
            Proof. split; rewrite/catTrR/catApR=>x y; by destruct(catTrR_eq). Qed.

            Lemma catApTrRK : cancel catTrR catApR /\ cancel catApR catTrR.
            Proof. split; rewrite/catApR/catTrR=>x; by destruct(catTrR_eq). Qed.

            Definition catifyL1 : addIsomType (Nth (L1 ++ L2) n) (Nth L1 n)
            := addIsomBuildPack catTrApR_add catApTrRK.
          End L1.
          Section L2.
            Variable (n : 'I_(size L2)).

            Lemma catTrL_eq : (Nth (L1 ++ L2) (rshift (size L1) n)) = (Nth L2 n).
            Proof. by simpl; rewrite/Nth map_cat nth_cat size_map
            -{2}(addn0 (size L1)) ltn_add2l addnC addnK. Qed.

            Definition catTrL : (Nth (L1 ++ L2) (rshift (size L1) n)) -> (Nth L2 n).
            Proof.  by rewrite catTrL_eq. Defined.

            Definition catApL : (Nth L2 n) -> (Nth (L1 ++ L2) (rshift (size L1) n)).
            Proof. by rewrite catTrL_eq. Defined.

            Lemma catTrApL_add : additive catTrL /\ additive catApL.
            Proof. split; rewrite/catTrL/catApL=>x y;by destruct (catTrL_eq). Qed.

            Lemma catApTrLK : cancel catTrL catApL /\ cancel catApL catTrL.
            Proof. split; rewrite/catApL/catTrL=>x; by destruct(catTrL_eq). Qed.

            Definition catifyL2 : addIsomType (Nth (L1 ++ L2) (rshift (size L1) n)) (Nth L2 n)
            := addIsomBuildPack catTrApL_add catApTrLK.
          End L2.

          Definition split_raw : DS (L1 ++ L2) -> DS L1 \oplus DS L2
            := fun x =>
            (\sum_(n < size L1)(inj L1 n \oAdd catifyL1 n \oAdd proj (L1 ++ L2) n ) x,
            \sum_(n < size L2)(inj L2 n \oAdd catifyL2 n \oAdd proj (L1 ++ L2) (rshift (size L1) n)) x).

          Definition unsplit_raw : DS L1 \oplus DS L2 -> DS (L1 ++ L2)
          := fun x =>
            \sum_(n < size L1)((inj (L1 ++ L2) n                     \oAdd inv(catifyL1 n) \oAdd proj L1 n) x.1) +
            \sum_(n < size L2)((inj (L1 ++ L2) (rshift (size L1) n)  \oAdd inv(catifyL2 n) \oAdd proj L2 n) x.2).

          Lemma split_add : additive split_raw.
          Proof. rewrite/split_raw=>x y/=.
            by rewrite (rwP eqP)/eq_op -(rwP andP) -!(rwP eqP)/=
             -!sumrB !(eq_bigr _ (fun i _ => raddfB _ _ _)).
          Qed.

          Lemma unsplit_add : additive unsplit_raw.
          Proof. rewrite/unsplit_raw=>x y/=.
            rewrite !(eq_bigr _ (fun i _ => raddfB _ _ _)) !sumrB/=.
            Admitted.

          Definition split := Additive split_add.
          Definition unsplit := Additive unsplit_add.

          Lemma unsplitK : cancel split unsplit.
          Proof. simpl; rewrite /unsplit_raw/split_raw=>x.
            under eq_bigr do rewrite raddf_sum.
            under eq_bigr do under eq_bigr do rewrite -!addCompChain.
            under[\sum_(_ < size L2) _] eq_bigr do rewrite raddf_sum.
            under[\sum_(_ < size L2) _] eq_bigr do under eq_bigr do rewrite -!addCompChain.
            rewrite!pair_bigA.
            rewrite (eq_bigr (fun p : 'I_(size L1)*'I_(size L1)
            => if p.2 == p.1
              then inj _ p.1 (proj _ p.1 x)
              else 0 ) _).
            rewrite (eq_bigr (fun p : 'I_(size L2)*'I_(size L2)
              => if p.2 == p.1
              then inj _ (rshift (size L1) p.2) (proj _ (rshift (size L1) p.2) x)
              else 0 ) _).
            by rewrite -!big_mkcond !big_pair_diag_eq {3}(@inj_proj_sum _ x)
            size_cat (@big_split_ord _ _ _ (size L1) (size L2)).
            by move=>p _; case (p.2 == p.1) as []eqn:E;
            [apply (rwP eqP) in E; rewrite E proj_injK_ofsize (isomaK (catifyL2 p.1)) |
            rewrite proj_inj0_ofsize; [rewrite !raddf0|
              rewrite eq_sym/eq_op in E; simpl in E; rewrite E]].
            by move=>p _; case (p.2 == p.1) as []eqn:E;
            [ apply (rwP eqP) in E; rewrite E proj_injK_ofsize (isomaK (catifyL1 p.1))|
            rewrite proj_inj0_ofsize; [rewrite !raddf0|
              rewrite eq_sym/eq_op in E; simpl in E; rewrite E]].
          Qed.

          Lemma splitK : cancel unsplit split.
          Proof. simpl; rewrite /unsplit_raw/split_raw=>x.
          under eq_bigr do rewrite !raddfD.
          under[\sum_(n < _) ((_ \oAdd _ \oAdd proj _ (rshift _ n)) _)]
            eq_bigr do rewrite !raddfD.

          rewrite !big_split !(eq_bigr _ (fun i _ => raddf_sum _ _ _ _)) !pair_bigA.
          rewrite (eq_bigr (fun p : 'I_(size L1)*'I_(size L1)
          => if(p.2 == p.1)
            then inj L1 p.1 (proj L1 p.1 x.1)
            else 0) _).
          rewrite (eq_bigr (fun p : 'I_(size L2)*'I_(size L2)
          => if(p.2 == p.1)
            then inj L2 p.2 (proj L2 p.2 x.2)
            else 0) _).
          {
            destruct x as [x1 x2];
            rewrite -!big_mkcond !big_pair_diag_eq
            (eq_bigr (fun p : 'I_(size L1) => inj _ p (proj _ p x1)) _);[|by move].
            rewrite (eq_bigr (fun p : 'I_(size L2) => inj _ p (proj _ p x2)) _); [| by []].
            rewrite {4}(inj_proj_sum x1) {4}(inj_proj_sum x2) (rwP eqP) /eq_op -(rwP andP).
            split; rewrite -subr_eq0.

            rewrite {1}addrC addrA addNr add0r (eq_bigr (fun _ => 0) _).
            rewrite big_const cardE /iter enumT;
            induction(Finite.enum _)=>//=; by rewrite add0r.

            move =>[[p1 H1] [p2 H2]] _;
            rewrite -!addCompChain proj_inj0;[by rewrite !raddf0 |by rewrite size_cat leq_addr|by rewrite size_cat|];
            rewrite -(rwP negP)/not -(rwP eqP)=>/=N;
            by rewrite N -{2}(addn0 (size L1)) ltn_add2l in H1.

            rewrite -addrA addrN addr0 (eq_bigr (fun _ => 0) _).
            rewrite big_const cardE /iter enumT;
            induction(Finite.enum _)=>//=; by rewrite add0r.

            move =>[[p1 H1] [p2 H2]] _;
            rewrite -!addCompChain proj_inj0;[by rewrite !raddf0 |by rewrite size_cat|by rewrite size_cat leq_addr|];
            rewrite -(rwP negP)/not -(rwP eqP)=>/=N.
            by rewrite -N -{2}(addn0 (size L1)) ltn_add2l in H2.
          }
          move=>p _; case(p.2 == p.1) as []eqn:E.
          move/eqP in E; rewrite E -!addCompChain.
          rewrite proj_injK; [by rewrite isomKa|].
          destruct p as [[p1 H1] [p2 H2]].
          by rewrite size_cat ltn_add2l.
          rewrite -!addCompChain proj_inj0; [by rewrite !raddf0|by rewrite size_cat|by rewrite size_cat|].
          rewrite /eq_op in E; simpl in E.
          by rewrite /rshift eqn_add2l eq_sym E.

          move=>p _; case(p.2 == p.1) as []eqn:E.
          apply (rwP eqP) in E; rewrite -E -!addCompChain.
          rewrite proj_injK; [by rewrite isomKa|].
          destruct p as [[p1 H1] [p2 H2]]=>/=.
          by rewrite size_cat addnC (ltn_addl _ H2).
          rewrite -!addCompChain proj_inj0; [by rewrite !raddf0|by rewrite size_cat leq_addr|by rewrite size_cat leq_addr|].
          rewrite /eq_op in E; simpl in E.
          by rewrite eq_sym E.
          Qed.
        End Operations.
      End Environment.

      Section Hom.
        Variable (S T : eqType) (I : T -> zmodType) (T_S : S -> T).

        Fixpoint homify_raw (L : seq S) : DS (I \o T_S) L -> DS I (map T_S L)
          := match L with
          |nil => id
          |a::l => fun x => (x.1 , homify_raw x.2)
          end.
        Fixpoint unhomify_raw (L : seq S) : DS I (map T_S L) -> DS (I \o T_S) L
          := match L with
          |nil => id
          |a::l => fun x => (x.1 , unhomify_raw x.2)
          end.

        Variable (L : seq S).
        Lemma homify_add : additive (@homify_raw L) /\ additive (@unhomify_raw L).
        Proof. split; induction L=>//=x y;
          by rewrite IHl/homify_raw/unhomify_raw.
        Qed.
        Lemma homifyK : cancel (@homify_raw L) (@unhomify_raw L) /\ cancel (@unhomify_raw L) (@homify_raw L).
        Proof. split; induction L=>//=x; destruct x;
          by rewrite IHl.
        Qed.
        Definition homify := addIsomBuildPack homify_add homifyK.
      End Hom.

      Section Bijection.
        Variable (S T : eqType) (I : T -> zmodType)
            (T_S : S -> T) (S_T : T -> S) (Inj : cancel S_T T_S).

        Variable (L : seq T).
        Definition mapify_raw : DS I (map T_S (map S_T L)) -> DS I L.
        by rewrite mapK. Defined.
        Definition unmapify_raw : DS I L -> DS I (map T_S (map S_T L)).
        by rewrite mapK. Defined.
        Lemma mapify_add : additive mapify_raw /\ additive unmapify_raw.
        Proof. split; by rewrite/mapify_raw/unmapify_raw; destruct mapK. Qed.
        Lemma mapifyK : cancel mapify_raw unmapify_raw /\ cancel unmapify_raw mapify_raw.
        Proof. split; by rewrite/mapify_raw/unmapify_raw; destruct mapK. Qed.
        Definition mapify := addIsomBuildPack mapify_add mapifyK.

        Definition bijectify := addIsomConcat (homify I T_S (map S_T L)) mapify.
      End Bijection.
    End Ring.
  End Seq.

  Section General.
    Section Def.
      Variable (F : finType) (I : F -> zmodType).

      Definition DS : zmodType := Seq.DS I (enum F).

      Section Components.
        Variable (f : F).

        Lemma cardElt : nat_of_ord (enum_rank f) < size (enum F).
        Proof. rewrite -cardE; apply ltn_ord. Qed.

        Definition Ord := Ordinal cardElt.
        Definition Nth := Seq.Nth I (enum F) Ord.

        Section TypeConversion.
          Lemma Nth_If_eq : Nth = I f.
          Proof. by rewrite /Nth/Seq.Nth -codomE nth_codom enum_rankK. Qed.
          Lemma If_Nth_eq : I f = Nth.
          Proof. by rewrite Nth_If_eq. Qed.

          Definition finify_raw : Nth -> I f := (fun fn : Nth
            -> Nth => eq_rect_r (fun M : zmodType => Nth -> M)
              fn If_Nth_eq) id.
          Definition unfinify_raw : I f -> Nth := (fun fn : Nth
            -> Nth => eq_rect_r (fun M : zmodType => M -> Nth)
              fn If_Nth_eq) id.
          Lemma finify_add : additive finify_raw /\ additive unfinify_raw.
          Proof. split; by rewrite /finify_raw/unfinify_raw=>x y; destruct If_Nth_eq. Qed.
          Lemma finifyK : cancel finify_raw unfinify_raw /\ cancel unfinify_raw finify_raw.
          Proof. split; by rewrite/finify_raw/unfinify_raw; destruct If_Nth_eq. Qed.

          Definition finify := addIsomBuildPack finify_add finifyK.

        End TypeConversion.

        Section Projection.
          Definition proj_raw : DS -> I f
          := finify \oAdd (@Seq.proj F I (enum F) Ord).

          Lemma proj_add : additive proj_raw.
          Proof. rewrite/proj_raw=> x y; by rewrite !raddfB. Qed.

          Definition proj : {additive DS -> I f} := Additive proj_add.
        End Projection.

        Section Injection.
          Definition inj_raw : I f -> DS
          := (@Seq.inj F I (enum F) Ord) \oAdd inv(finify).

          Lemma inj_add : additive inj_raw.
          Proof. rewrite/inj_raw=> x y; by rewrite !raddfB. Qed.

          Lemma inj_injective : injective inj_raw.
          Proof. rewrite/inj_raw=>x y; rewrite -!addCompChain=>H.
            apply Seq.inj_injective in H.
            apply (congr1 finify) in H.
            by rewrite !isomKa in H.
          Qed.

          Definition inj : {additive I f -> DS} := Additive inj_add.
        End Injection.
      End Components.

      Section Results.
        Lemma proj_injK (f : F) x : proj f (inj f x) = x.
        Proof. by rewrite /proj_raw/inj_raw -!addCompChain
          Seq.proj_injK; [rewrite -{2}(isomKf (finify f) x) | apply cardElt].
        Qed.

        Lemma proj_inj0 (f f' : F) x : f != f' -> @proj f (@inj f' x) = 0.
        Proof.
          rewrite-(rwP negP)/not -!addCompChain=>H.
          case((nat_of_ord (enum_rank f) != enum_rank f')) as []eqn:E.
          rewrite (@Seq.proj_inj0_ofsize _ _ _ (Ord f) (Ord f') _ E).
          by rewrite raddf0.
          assert (E' := contraFeq (fun B : enum_rank f != enum_rank f' => B) E).
          apply enum_rank_inj in E'.
          rewrite E' eq_refl in H.
          by assert (H' := H is_true_true).
        Qed.

        Lemma inj_proj_sum x : x = \sum_(f : F) inj f (proj f x).
        Proof.
          rewrite big_enum_val.
          rewrite {1}(Seq.inj_proj_sum x) -!big_enum  -cardT.
          refine (eq_bigr _ _).
          move=> i _; rewrite /inj_raw/proj_raw/Seq.inj/Seq.proj
          -!addCompChain (isomaK (finify _))/Ord=>/=.
          by rewrite enum_valK.
        Qed.

        Lemma inj_proj_idem x : \sum_(f : F) inj f (proj f (\sum_(f : F) inj f (proj f x))) = \sum_(f : F) inj f (proj f x).
        Proof. by rewrite -inj_proj_sum. Qed.
      End Results.
    End Def.
    Section Hom.
(*      Variable (F G : finType) (I : F -> lmodType R) (J : G -> lmodType R)
      (J = I \o F_G)
      (F_G : G -> F) (enumB : enum F = map F_G (enum G)).

      Definition enumify_raw : Seq.DS I (map F_G (enum G)) -> DS I.
      by rewrite /DS enumB. Defined.
      Definition unenumify_raw : DS I -> Seq.DS I (map F_G (enum G)).
      by rewrite /DS enumB. Defined.
      Lemma enumify_lin : linear enumify_raw /\ linear unenumify_raw.
      Proof. split; rewrite /enumify_raw/unenumify_raw; by destruct enumB. Qed.
      Lemma enumifyK : cancel enumify_raw unenumify_raw /\ cancel unenumify_raw enumify_raw .
      Proof. split; rewrite /enumify_raw/unenumify_raw; by destruct enumB. Qed.
      Definition enumify := linIsomBuildPack enumify_lin enumifyK.

      Definition homify : {linear DS (I \o F_G) -> DS I}
      := enumify \oLin (@Seq.homify _ _ _ I F_G (enum G)).
      Definition unhomify : {linear DS I -> DS (I \o F_G)}
      := inv(@Seq.homify _ _ _ I F_G (enum G)) \oLin inv(enumify).*)
    End Hom.
    Section Bijection.
    (*
      Variable (F G : finType) (I : F -> lmodType R) (J : G -> lmodType R)
        (F_G : G -> F) (G_F : F -> G)
        (I_J : I = J \o G_F) (J_I : J = I \o F_G)
        (Inj : cancel F_G G_F) (Surj : cancel G_F F_G) (enumB : enum F = map F_G (enum G)).

        Definition mapify_raw : DS (I \o S_T \o T_S) -> DS I.
        by rewrite mapK. Defined.
        Definition unmapify_raw : DS I L -> DS I (map T_S (map S_T L)).
        by rewrite mapK. Defined.
        Lemma mapify_lin : linear mapify_raw /\ linear unmapify_raw.
        Proof. split; by rewrite/mapify_raw/unmapify_raw; destruct mapK. Qed.
        Lemma mapifyK : cancel mapify_raw unmapify_raw /\ cancel unmapify_raw mapify_raw.
        Proof. split; by rewrite/mapify_raw/unmapify_raw; destruct mapK. Qed.
        Definition mapify := linIsomBuildPack mapify_lin mapifyK.

        Definition bijectify := linIsomConcat (homify I T_S (map S_T L)) mapify.*)
    End Bijection.

    Section Operations.
      Variable (F G : finType) (I : F + G -> zmodType).
      Definition J : F -> zmodType := I \o inl.
      Definition K : G -> zmodType := I \o inr.

      Lemma sumify_eq : (enum (sum_finType F G)) = ((map inl (enum F)) ++ (map inr (enum G))).
      Proof. by rewrite/DS enumT(unlock _)/=/sum_enum -!enumT. Qed.

      Definition sumify_raw : DS I -> Seq.DS I ((map inl (enum F)) ++ (map inr (enum G))).
      by rewrite /DS sumify_eq. Defined.
      Definition unsumify_raw : Seq.DS I ((map inl (enum F)) ++ (map inr (enum G))) -> DS I.
      by rewrite /DS sumify_eq. Defined.

      Lemma sumify_add : additive sumify_raw /\ additive unsumify_raw.
        Proof. split; rewrite/sumify_raw/unsumify_raw=>x y;
        by destruct sumify_eq. Qed.
      Lemma sumifyK : cancel sumify_raw unsumify_raw /\ cancel unsumify_raw sumify_raw.
        Proof. split; rewrite/sumify_raw/unsumify_raw=>x;
        by destruct sumify_eq. Qed.
	    Definition sumify := addIsomBuildPack sumify_add sumifyK.

      Definition split : DS I -> DS J \oplus DS K
       := \diagmap(inv(Seq.homify _ inl _), inv(Seq.homify _ inr _))
			      \oAdd (Seq.split I _ _) \oAdd sumify.

      Definition unsplit : {additive DS J \oplus DS K -> DS I}
      := inv(sumify) \oAdd (Seq.unsplit I _ _) \oAdd
          \diagmap(Seq.homify _ inl _, Seq.homify _ inr _).

      Lemma unsplitK : cancel split unsplit.
      Proof. rewrite /unsplit/split=>x.
        by rewrite -!addCompChain (addCompChain (\diagmap(_,_)) (\diagmap(_,_)))
        Pair.diag_comp !addIsom.concatKa Pair.diag_id -addIDChain
        Seq.unsplitK (isomaK sumify).
      Qed.

      Lemma splitK : cancel unsplit split.
      Proof. rewrite /unsplit/split=>x.
        by rewrite -!addCompChain isomKa Seq.splitK
        (addCompChain (\diagmap(_,_)) (\diagmap(_,_)))
        Pair.diag_comp !addIsom.concataK Pair.diag_id -addIDChain.
      Qed.

    End Operations.

  End General.
  Section Results.
  Variable (M N : zmodType) (m : M) (n : N).
  Lemma pair_eq_seq (F G : eqType) (f : F -> M) (g : G -> N)
    (L1 : seq F) (L2 : seq G) :
    \sum_(i <- L1) (f i, 0)%R + \sum_(i <- L2) (0, g i) == (m,n)
    <-> (\sum_(i <- L1) f i == m /\ \sum_(i <- L2) g i == n).
  Proof. split; [move=> H|move=> [H1 H2]]. {
    have:(\sum_(i <- L1) (dsZmod.Pair.inj1 M N (f i)) + \sum_(i <- L2) (dsZmod.Pair.inj2 M N (g i)) == (m, n))
      by apply H .
    rewrite -!raddf_sum/Pair.inj1/Pair.inj2/(@add _)/=
     /add_pair add0r addr0 -(rwP eqP)=>H0;
    by inversion H0.
  }
  move: H1 H2; rewrite -!(rwP eqP)=>H1 H2.
  have:(\sum_(i <- L1) (Pair.inj1 _ _  (f i)) == (m, @zero N))
    by rewrite -raddf_sum/Pair.inj1 H1.
  have:(\sum_(i <- L2) (Pair.inj2 _ _ (g i)) == (@zero M, n))
    by rewrite -raddf_sum/Pair.inj2 H2=>/=.
  rewrite -!(rwP eqP)=>H H0.
  have:(\sum_(i <- L1) (dsZmod.Pair.inj1 _ _ (f i)) + \sum_(i <- L2) (dsZmod.Pair.inj2 _ _ (g i)) == (m, n))
    by rewrite H H0 {1}/(@add (pair_zmodType M N))/=
    /add_pair add0r addr0.
  by rewrite /Pair.inj1/Pair.inj2 -(rwP eqP).
  Qed.

    Lemma pair_eq (F G : finType) (f : F -> M) (g : G -> N) :
    \sum_i (f i, 0)%R + \sum_i (0, g i) == (m,n)
    <-> (\sum_i f i == m /\ \sum_i g i == n).
  Proof. by rewrite -big_enum/=pair_eq_seq big_enum/=. Qed.
  End Results.
End dsZmod.

Definition dsProj (F : finType) (I : F -> zmodType) (f : F) := @dsZmod.proj F I f.
Definition dsInj (F : finType) (I : F -> zmodType) (f : F) := @dsZmod.inj F I f.

Export dsZmod.Pair.Exports.
Notation "\bigoplus_ i F" := (dsZmod.DS (fun i => F i)) : zmod_scope.
Notation "\bigoplus F" := (dsZmod.DS F) : zmod_scope.
Notation "\bigoplus_ ( i : t ) F" := (dsZmod.DS (fun i : t => F i)) : zmod_scope.
Notation "\bigoplus_ ( i 'in' A ) F" := (dsZmod.Seq.DS (filter F (fun i => i \in A))) : zmod_scope.
Notation "\proj^( I )_ f " := (dsZmod.proj I f ) : zmod_scope.
Notation "\inj^( I )_ f " := (dsZmod.inj I f ) : zmod_scope.
Notation "\proj_ f ^( I )" := (dsZmod.proj I f ) : zmod_scope.
Notation "\inj_ f ^( I )" := (dsZmod.inj I f ) : zmod_scope.

Theorem DirectSum_UniversalProperty (F : finType)
  (I : F -> zmodType)
    : forall (f : forall i : F, {additive \bigoplus I -> (I i)}),
      exists (g : forall i : F, {additive (I i) -> (I i)}),
        forall i : F, f i \oAdd \inj_i^(I) = g i.
Proof. move=> f.
  by refine(ex_intro _ (fun i => f i \oAdd \inj_i^(I)) _ ).
Qed.

Close Scope  zmod_scope.
Close Scope  ring_scope.


(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Problem(s):
    Simple Semi-unification (SSemiU)
    Semi-unification (SemiU)
    Right-uniform Two-Inequality Semi-unification (RU2SemiU)
    Left-uniform Two-Inequality Semi-unification (LU2SemiU)
*)

(*
  Literature:
  [1] Andrej Dudenhefner. "Undecidability of Semi-Unification on a Napkin"
      5th International Conference on Formal Structures for Computation and Deduction (FSCD 2020): 9:1-9:16
      https://drops.dagstuhl.de/opus/volltexte/2020/12331
*)

Require Import List.

(* terms are built up from atoms and a binary term constructor arr *)
Inductive term : Set :=
  | atom : nat -> term
  | arr : term -> term -> term.

Definition valuation : Set := nat -> term.

(* substitute atoms n of a term t by (f n) *)
Fixpoint substitute (f: valuation) (t: term) : term :=
  match t with
  | atom n => f n
  | arr s t => arr (substitute f s) (substitute f t)
  end.

(* Simple Semi-unification Definition *)

(* simple semi unification constraint
  ((a, x), (y, b)) mechanizes the constraint (a|x|ϵ ≐ ϵ|y|b) *)
Definition constraint : Set := ((bool * nat) * (nat * bool)).

(* constraint semantics,
  (φ, ψ0, ψ1) models a|x|ϵ ≐ ϵ|y|b if ψa (φ (x)) = πb (φ (y)) *)
Definition models (φ ψ0 ψ1: valuation) : constraint -> Prop :=
  fun '((a, x), (y, b)) =>
    match φ y with
    | atom _ => False
    | arr s t => (if b then t else s) = substitute (if a then ψ1 else ψ0) (φ x)
    end.

(* Simple Semi-unification *)
(* are there substitutions (φ, ψ0, ψ1) that model each constraint? *)
Definition SSemiU (p : list constraint) :=
  exists (φ ψ0 ψ1: valuation), forall (c : constraint), In c p -> models φ ψ0 ψ1 c.

(* Semi-unification Definition *)

(* inequality: s ≤ t *)
Definition inequality : Set := (term * term).

(* φ solves s ≤ t, if there is ψ such that ψ (φ (s)) = φ (s) *)
Definition solution (φ : valuation) : inequality -> Prop :=
  fun '(s, t) => exists (ψ : valuation), substitute ψ (substitute φ s) = substitute φ t.

(* Semi-unification *)
(* is there a substitution φ that solves all inequalities? *)
Definition SemiU (p: list inequality) :=
  exists (φ: valuation), forall (c: inequality), In c p -> solution φ c.

(* Right-uniform Two-Inequality Semi-unification *)
(* All right-hand sides of inequalities are identical, there are exactly two inequlities *)
Definition RU2SemiU : term * term * term -> Prop :=
  fun '(s0, s1, t) => exists (φ ψ0 ψ1: valuation),
    substitute ψ0 (substitute φ s0) = substitute φ t /\ substitute ψ1 (substitute φ s1) = substitute φ t.

(* Left-uniform Two-Inequality Semi-unification *)
(* All right-hand sides of inequalities are identical, there are exactly two inequlities *)
Definition LU2SemiU : term * term * term -> Prop :=
  fun '(s, t0, t1) => exists (φ ψ0 ψ1: valuation),
    substitute ψ0 (substitute φ s) = substitute φ t0 /\ substitute ψ1 (substitute φ s) = substitute φ t1.


Require Import Lists.List.

Fixpoint sum (xs: list nat) : nat :=
  match xs with
    | nil => 0
    | x :: xs => x + sum xs
  end.

Theorem Pigeon_Hole_Principle :
  forall (xs : list nat), length xs < sum xs -> (exists x, 1 < x /\ In x xs).
Proof.
  intros.
  induction (xs).
  inversion H.


(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2012: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * positives: basic facts about binary positive numbers *)

Require Export BinNums.
Require Import comparisons.

(** positives as a [cmpType] *)

Fixpoint eqb_pos i j :=
  match i,j with
    | xH,xH => true
    | xI i,xI j | xO i, xO j => eqb_pos i j
    | _,_ => false
  end.

Lemma eqb_pos_spec: forall i j, reflect (i=j) (eqb_pos i j).
Proof. induction i; intros [j|j|]; simpl; (try case IHi); constructor; congruence. Qed.

Fixpoint pos_compare i j :=
  match i,j with
    | xH, xH => Eq
    | xO i, xO j | xI i, xI j => pos_compare i j
    | xH, _ => Lt
    | _, xH => Gt
    | xO _, _ => Lt
    | _,_ => Gt
  end.

Lemma pos_compare_spec: forall i j, compare_spec (i=j) (pos_compare i j).
Proof. induction i; destruct j; simpl; try case IHi; try constructor; congruence. Qed.

Canonical Structure cmp_pos := mk_cmp _ eqb_pos_spec _ pos_compare_spec.

(** positive maps (for making environments) *)
(** we redefine such trees here rather than importing them from the standard library:
   since we do not need any proof about them, this avoids us a heavy Require Import *)
Section e.
Variable A: Type.
Inductive sigma := sigma_empty | N(l: sigma)(o: option A)(r: sigma).
Fixpoint sigma_get default m i :=
  match m with
    | N l o r =>
      match i with
        | xH => match o with None => default | Some a => a end
        | xO i => sigma_get default l i
        | xI i => sigma_get default r i
      end
    | _ => default
  end.
Fixpoint sigma_add i v m :=
    match m with
    | sigma_empty =>
        match i with
        | xH => N sigma_empty (Some v) sigma_empty
        | xO i => N (sigma_add i v sigma_empty) None sigma_empty
        | xI i => N sigma_empty None (sigma_add i v sigma_empty)
        end
    | N l o r =>
        match i with
        | xH => N l (Some v) r
        | xO i => N (sigma_add i v l) o r
        | xI i => N l o (sigma_add i v r)
        end
    end.
End e.


Require Export Coq.Lists.List.
Require Export Iron.Language.DelayedSimple.Tactics.Chargueraud.

(********************************************************************)
(* Forall Lemmas *)

Lemma Forall_inst
 :  forall {A B} a' xs (P: A -> B -> Prop)
 ,  Forall (fun x => forall a, P a x) xs
 -> Forall (fun x => P a' x) xs.
Proof.
 intros.
 induction xs.
 - auto.
 - eapply Forall_cons.
   + inverts H. eapply H2.
   + inverts H. eapply IHxs. assumption.
Qed.

Lemma Forall_mp
 :  forall {A} (P Q: A -> Prop)  xs
 ,  Forall (fun x => P x -> Q x) xs
 -> Forall (fun x => P x)        xs
 -> Forall (fun x => Q x)        xs.
Proof.
 intros.
 induction xs.
 - auto.
 - eapply Forall_cons.
   + inverts H. inverts H0. auto.
   + inverts H. inverts H0. auto.
Qed.

Lemma Forall_mp_const
 :  forall {A} P (Q: A -> Prop)  xs
 ,  P
 -> Forall (fun x => P -> Q x) xs
 -> Forall (fun x => Q x)      xs.
Proof.
 intros.
 induction H.
 - auto.
 - apply Forall_cons.
   + auto.
   + auto.
Qed.

Lemma Forall_map
 :  forall {A B}
    (P: B -> Prop) (f: A -> B) (xs: list A)
 ,  Forall (fun x => P (f x)) xs
 -> Forall P (map f xs).
Proof.
 intros. induction xs.
  apply Forall_nil.
  inverts H. simpl. intuition.
Qed.

(********************************************************************)
(* Forall2 Lemmas *)

Lemma Forall2_mp
 :  forall {A B} (P Q: A -> B -> Prop)  aa bb
 ,  Forall2 (fun a b => P a b -> Q a b) aa bb
 -> Forall2 (fun a b => P a b)          aa bb
 -> Forall2 (fun a b => Q a b)          aa bb.
Proof.
 intros.
 induction H0.
 - auto.
 - inverts H.
   apply Forall2_cons; auto.
Qed.

Lemma Forall2_map
 :  forall {A B C D}
    (P:  B -> D -> Prop) (f:  A -> B) (g:  C -> D)
    (xs: list A) (ys: list C)
 ,  Forall2 (fun x y => P (f x) (g y)) xs ys
 -> Forall2 P (map f xs) (map g ys).
Proof.
 intros.
 induction H.
 - simpl. auto.
 - simpl. apply Forall2_cons; auto.
Qed.

Lemma Forall2_map'
 :  forall {A B C D}
    (P: B -> D -> Prop) (f:  A -> B) (g:  C -> D)
    (xs: list A) (ys: list C)
 ,  Forall2 P (map f xs) (map g ys)
 -> Forall2 (fun x y => P (f x) (g y)) xs ys.
Proof.
 intros. gen ys.
 induction xs; intros.
  induction ys; intros.
   auto.
   inverts H.
   destruct ys.
    inverts H.
    simpl in H.
    inverts H. eauto.
Qed.

(********************************************************************)
(* Convert Forall to Forall2 *)
Lemma Forall_Forall2_right
 :  forall  {A B C}
    (P: B -> C -> Prop)
    (f: A -> B) (g: A -> C) (aa: list A)
 ,  Forall  (fun b => forall c, P b c) (map f aa)
 -> Forall2 P (map f aa) (map g aa).
Proof.
 intros.
 induction aa.
 - simpl. auto.
 - simpl in *.
   inverts H.
   apply Forall2_cons.
   auto. auto.
Qed.


(*|
#################################################
Stuck on a simple proof about regular expressions
#################################################

:Link: https://stackoverflow.com/q/40796214
|*)

(*|
Question
********

I'm trying to formalize some properties on regular expressions (REs)
using Coq. But, I've got some troubles to prove a rather simple
property:

    For all strings ``s``, if ``s`` is in the language of
    ``(epsilon)*`` RE, then ``s = ""``, where ``epsilon`` and ``*``
    denotes the empty string RE and Kleene star operation.

This seems to be an obvious application of induction / inversion
tactics, but I couldn't make it work.

The minimal working code with the problematic lemma is in the
following `gist
<https://gist.github.com/rodrigogribeiro/e8f6bde70b54c871f8c744a9b3570bb2>`__.
Any tip on how should I proceed will be appreciated.

**EDIT**: One of my tries was something like:

.. coq:: none
|*)

Set Implicit Arguments.

Require Import Ascii String.

Inductive regex : Set :=
| Emp : regex
| Eps : regex
| Chr : ascii -> regex
| Cat : regex -> regex -> regex
| Choice : regex -> regex -> regex
| Star : regex -> regex.

Open Scope string_scope.

Notation "'#0'" := Emp.
Notation "'#1'" := Eps.
Notation "'$' c" := (Chr c) (at level 40).
Notation "e '@' e1" := (Cat e e1) (at level 15, left associativity).
Notation "e ':+:' e1" := (Choice e e1) (at level 20, left associativity).
Notation "e '^*'" := (Star e) (at level 40).

(** Semantics of regular expressions *)

Reserved Notation "s '<<-' e" (at level 40).

Inductive in_regex : string -> regex -> Prop :=
| InEps : "" <<- #1
| InChr : forall c, (String c EmptyString) <<- ($ c)
| InCat : forall e e' s s' s1,
    s <<- e -> s' <<- e' -> s1 = s ++ s' -> s1 <<- (e @ e')
| InLeft : forall s e e', s <<- e -> s <<- (e :+: e')
| InRight : forall s' e e',  s' <<- e' -> s' <<- (e :+: e')
| InStar : forall s e, s <<- (#1 :+: (e @ (e ^*))) -> s <<- (e ^*)
where "s '<<-' e" := (in_regex s e).

Hint Constructors in_regex.

(*||*)

Lemma star_lemma : forall s, s <<- (#1 ^*) -> s = "".
Proof.
  intros s H. inversion_clear H. inversion_clear H0.
  - now inversion_clear H.
  - inversion_clear H.
    inversion_clear H2. clear s.
    inversion_clear H0. clear s0.
    simpl.

(*| that leave me with the following goal: |*)

    Show. (* .unfold .messages *)

(*|
At least to me, it appears that using induction would finish the
proof, since I could use ``H1`` in induction hypothesis to finish the
proof, but when I start the proof using
|*)

    Restart. (* .none *) intros s H. (* .none *)
    induction H.

(*| instead of |*)

    Restart. (* .none *) intros s H. (* .none *)
    inversion_clear H.
Abort. (* .none *)

(*|
I got some (at least for me) senseless goals. In Idris / Agda, such
proof just follows by pattern matching and recursion over the
structure of ``s <<- (#1 ^*\ )``. My point is how to do such recursion
in Coq.
|*)

(*|
Answer (Anton Trunov)
*********************

Here is one possible solution of the original problem:
|*)

Lemma star_lemma : forall s, s <<- (#1 ^*) -> s = "".
Proof.
  refine (fix star_lemma s prf {struct prf} : s = "" := _).
  inversion_clear prf; subst.
  inversion_clear H; subst.
  - now inversion H0.
  - inversion_clear H0; subst. inversion_clear H; subst.
    rewrite (star_lemma s' H1).
    reflexivity.
Qed.

(*|
The main idea is to introduce a term in the context which will
resemble the recursive call in a typical Idris proof. The approaches
with ``remember`` and ``dependent induction`` don't work well (without
modifications of ``in_regex``) because they introduce impossible to
satisfy equations as induction hypotheses' premises.

*Note*: it can take a while to check this lemma (around 40 seconds on
my machine under Coq 8.5pl3). I think it's due to the fact that the
``inversion`` tactic tends to generate big proof terms.

----

**A:** Nice! I really don't see how to prove it without using an
hand-crafted fixpoint. Following your example, `I factored the proof
<https://gist.github.com/gallais/58b42d5d9571ff0e6a432a9f40cf06c9>`__
through a ``star_unfold`` lemma which says that if ``s <<- (e ^*\ )``
then ``exists n, s <<- ntimes n e``. In the case of a full-blown
library, this should isolate the expensive check to ``star_unfold``
alone given that later proofs can simply use induction on a natural
number.

**A:** Very good point! Please consider making your comment into an
answer -- I hear comments are not very reliable on SO. You could've
also used ``Nat.iter`` instead of ``ntimes`` to make the code shorter:
``exists n, s <<- Nat.iter n (Cat e) #1.`` (But maybe it hurts
readability a bit).
|*)

(*|
Answer (eponier)
****************

This problem has obsessed me for a week, and I have finally found a
solution that I find elegant.

I had already read that when an induction principle does not fit your
needs, you can write and prove another one, more adapted to your
problem. That is what I have done in this case. What we would want is
the one obtained when using the more natural definition given in `this
answer <https://stackoverflow.com/a/40806050/5153939>`__. By doing
this, we can keep the same definition (if changing it implies too many
changes, for example) and reason about it more easily.

Here is the proof of the induction principle (I use a section to
specify precisely the implicit arguments, since otherwise I observe
strange behaviours with them, but the section mechanism is not
necessary at all here).
|*)

Reset star_lemma. (* .none *)
Section induction_principle.

Context (P : string -> regex -> Prop)
  (H_InEps : P "" #1)
  (H_InChr : forall c, P (String c "") ($ c))
  (H_InCat : forall {e e' s s' s1}, s <<- e -> P s e -> s' <<- e' ->
    P s' e' -> s1 = s ++ s' -> P s1 (e @ e'))
  (H_InLeft : forall {s e e'}, s <<- e -> P s e -> P s (e :+: e'))
  (H_InRight : forall {s' e e'}, s' <<- e' -> P s' e' -> P s' (e :+: e'))
  (H_InStar_Eps : forall e, P "" (e ^*))
  (H_InStar_Cat : forall {s1 s2 e}, s1 <<- e -> s2 <<- (e ^*) ->
    P s1 e -> P s2 (e ^*) -> P (s1 ++ s2) (e ^*)).

Arguments H_InCat {_ _ _ _ _} _ _ _ _ _.
Arguments H_InLeft {_ _ _} _ _.
Arguments H_InRight {_ _ _} _ _.
Arguments H_InStar_Cat {_ _ _} _ _ _ _.

Definition in_regex_ind2 : forall (s : string) (r : regex), s <<- r -> P s r.
Proof
  using H_InCat H_InChr H_InEps H_InLeft H_InRight H_InStar_Cat H_InStar_Eps.
  refine (fix in_regex_ind2 {s r} prf {struct prf} : P s r :=
    match prf with
    | InEps => H_InEps
    | InChr c => H_InChr c
    | InCat prf1 prf2 eq1 =>
        H_InCat prf1 (in_regex_ind2 prf1) prf2 (in_regex_ind2 prf2) eq1
    | InLeft _ prf => H_InLeft prf (in_regex_ind2 prf)
    | InRight _ prf => H_InRight prf (in_regex_ind2 prf)
    | InStar prf => _
    end).
  inversion prf; subst.
  - inversion H1. apply H_InStar_Eps.
  - inversion H1; subst.
    apply H_InStar_Cat; try assumption; apply in_regex_ind2; assumption.
Qed.

End induction_principle.

(*|
And it turned out that the ``Qed`` of this proof was not instantaneous
(probably due to ``inversion`` producing large terms as in `this
answer <https://stackoverflow.com/a/40807209/5153939>`__), but took
less than 1s (maybe because the lemma is more abstract).

The ``star_lemma`` becomes nearly trivial to prove (as soon as we know
the ``remember`` trick), as with the natural definition.
|*)

Lemma star_lemma : forall s, s <<- (#1 ^*) -> s = "".
Proof.
  intros s H. remember (#1 ^*) as r.
  induction H using in_regex_ind2; try discriminate.
  - reflexivity.
  - inversion Heqr; subst.
    inversion H. rewrite IHin_regex2 by reflexivity. reflexivity.
Qed.

(*|
Answer (Zimm i48)
*****************

I modified a bit the definition of your in_regex predicate:
|*)

Reset in_regex. (* .none *)
Inductive in_regex : string -> regex -> Prop :=
| InEps : "" <<- #1
| InChr : forall c, (String c EmptyString) <<- ($ c)
| InCat : forall e e' s s' s1,
    s <<- e -> s' <<- e' -> s1 = s ++ s' -> s1 <<- (e @ e')
| InLeft : forall s e e', s <<- e -> s <<- (e :+: e')
| InRight : forall s' e e',  s' <<- e' -> s' <<- (e :+: e')
| InStarLeft : forall e, "" <<- (e ^*)
| InStarRight : forall s s' e, s <<- e -> s' <<- (e ^*) -> (s ++ s') <<- (e ^*)
where "s '<<-' e" := (in_regex s e).

(*| and could prove your lemma: |*)

Lemma star_lemma : forall s, s <<- (#1 ^*) -> s = "".
Proof.
  intros s H.
  remember (#1 ^*) as r.
  induction H; inversion Heqr; clear Heqr; trivial.
  subst e.
  rewrite IHin_regex2; trivial.
  inversion H; trivial.
Qed.

(*|
Some explanations are necessary.

1. I did an induction on ``H``. The reasoning is: if I have a proof of
   ``s <<- (#1 ^*\ )`` then this proof must have the following form...
2. The tactic `remember
   <https://coq.inria.fr/refman/proof-engine/tactics.html#coq:tacv.remember>`__
   create a new hypothesis ``Heqr`` which, combined with `inversion
   <https://coq.inria.fr/refman/proof-engine/tactics.html#coq:tacn.inversion>`__
   will help get rid of cases which cannot possibly give this proof
   (in fact all the cases minus the ones where ``^*`` is in the
   conclusion).
3. Unfortunately, this path of reasoning does not work with the
   definition you had for the ``in_regex`` predicate because it will
   create an unsatisfiable condition to the induction hypothesis.
   That's why I modified your inductive predicate as well.
4. The modified inductive tries to give a more basic definition of
   being in ``(e ^*\ )``. Semantically, I think this is equivalent.

I would be interested to read a proof on the original problem.

----

**A:** The proof of the original problem is `here
<http://stackoverflow.com/a/40807209/2747511>`__ :).
|*)


Require Import Omega.

(* Submitted by Xavier Urbain 18 Jan 2002 *)

Lemma lem1 :
 forall x y : Z, (-5 < x < 5)%Z -> (-5 < y)%Z -> (-5 < x + y + 5)%Z.
Proof.
intros x y.
 omega.
Qed.

(* Proposed by Pierre Crégut *)

Lemma lem2 : forall x : Z, (x < 4)%Z -> (x > 2)%Z -> x = 3%Z.
intro.
 omega.
Qed.

(* Proposed by Jean-Christophe Filliâtre *)

Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z.
Proof.
intros.
 omega.
Qed.

(* Proposed by Jean-Christophe Filliâtre: confusion between an Omega *)
(* internal variable and a section variable (June 2001) *)

Section A.
Variable x y : Z.
Hypothesis H : (x > y)%Z.
Lemma lem4 : (x > y)%Z.
 omega.
Qed.
End A.

(* Proposed by Yves Bertot: because a section var, L was wrongly renamed L0 *)
(* May 2002 *)

Section B.
Variable R1 R2 S1 S2 H S : Z.
Hypothesis I : (R1 < 0)%Z -> R2 = (R1 + (2 * S1 - 1))%Z.
Hypothesis J : (R1 < 0)%Z -> S2 = (S1 - 1)%Z.
Hypothesis K : (R1 >= 0)%Z -> R2 = R1.
Hypothesis L : (R1 >= 0)%Z -> S2 = S1.
Hypothesis M : (H <= 2 * S)%Z.
Hypothesis N : (S < H)%Z.
Lemma lem5 : (H > 0)%Z.
 omega.
Qed.
End B.

(* From Nicolas Oury (bug #180): handling -> on Set (fixed Oct 2002) *)
Lemma lem6 :
 forall (A : Set) (i : Z), (i <= 0)%Z -> ((i <= 0)%Z -> A) -> (i <= 0)%Z.
intros.
 omega.
Qed.

(* Adapted from an example in Nijmegen/FTA/ftc/RefSeparating (Oct 2002) *)
Require Import Omega.
Section C.
Parameter g : forall m : nat, m <> 0 -> Prop.
Parameter f : forall (m : nat) (H : m <> 0), g m H.
Variable n : nat.
Variable ap_n : n <> 0.
Let delta := f n ap_n.
Lemma lem7 : n = n.
 omega.
Qed.
End C.

(* Problem of dependencies *)
Require Import Omega.
Lemma lem8 : forall H : 0 = 0 -> 0 = 0, H = H -> 0 = 0.
intros;  omega.
Qed.

(* Bug that what caused by the use of intro_using in Omega *)
Require Import Omega.
Lemma lem9 :
 forall p q : nat, ~ (p <= q /\ p < q \/ q <= p /\ p < q) -> p < p \/ p <= p.
intros;  omega.
Qed.

(* Check that the interpretation of mult on nat enforces its positivity *)
(* Submitted by Hubert Thierry (bug #743) *)
(* Postponed... problem with goals of the form "(n*m=0)%nat -> (n*m=0)%Z" *)
Lemma lem10 : forall n m:nat, le n (plus n (mult n m)).
Proof.
intros; omega with *.
Qed.


From mathcomp Require Import ssreflect.

Require Import collect_operator.
Require Import direct_product.
Require Import mapping.
Require Import mapping_space.

(* 族:X_iは添字集合:Iから集合:Xへの写像である. X_i:I->X *)
(* family X_i is alias of mapping indexing set I to set X *)
Definition TypeOfFamily (U V:Type) := U -> V.
Definition IndexedFamily {U V:Type} (map:TypeOfFamily U V) (I:Collection U) (X: Collection V) :=
  forall i:U, i ∈ I -> exists Xi:V, Xi = map i /\ Xi ∈ X.

(* 族で添字に対応する要素が集合である場合,集合族と言う. 集合族は関数,写像 *)
(* 添字集合の要素iからと集合の集合より紐付いた集合を取り出す関数 *)
Definition FamilyOfSetsWithFunction {U:Type} (map:U -> Collection U) (I:Collection U) (X: Collection (Collection U)) :=
  IndexedFamily map I X.

Definition TypeOfGraphOfFamilyOfSets U := Collection (TypeOfOrderedPair (Collection U)).

(* 族のGraphは添字集合と集合の直積の部分集合である *)
(* Graph of family is subset of direct product of indexing set I to set X *)
(* 集合族のGraph *)
Inductive GraphOfFamilyOfSets {U:Type} (map: TypeOfFamily U (Collection U)) (I:Collection U) (X: Collection (Collection U)) :
  TypeOfGraphOfFamilyOfSets U :=
| definition_of_graph_of_family_set:
    forall Z:TypeOfOrderedPair (Collection U),
      (exists i:U, exists x':Collection U, Z=<|{|i|},x'|> /\ x' = map i /\ i ∈ I /\ x' ∈ X) ->
      Z ∈ GraphOfFamilyOfSets map I X.

(* 集合族から添字により集合を得ます *)
Definition PickIndexedSetByFamilyOfSets {U V:Type} (map:V -> Collection U) (i:V) : Collection U := map i.

(* ⌞ Unicode: 231E BOTTOM LEFT CORNER *)
Notation "X_I ⌞ i" := (PickIndexedSetByFamilyOfSets X_I i) (left associativity, at level 20).

(* 部分集合族 *)
Definition FamilyOFSubsetsWithFunction {U:Type} (X_I:U -> Collection U) (I:Collection U) (X: Collection U) :=
  forall i:U, i ∈ I ->  (X_I ⌞ i) ⊂ X /\ exists X':Collection (Collection U), (X_I ⌞ i) ∈ X' /\ FamilyOfSetsWithFunction X_I I X'.

Inductive BigCupOfFamilySet {U V:Type} (I:Collection V) (X_I: V -> Collection U): Collection U :=
| intro_of_bigcup_of_family: forall x:U, (exists i:V, i ∈ I /\ x ∈ (X_I ⌞ i)) -> x ∈ BigCupOfFamilySet I X_I.

Notation "⋃{ I , X_I }" := (BigCupOfFamilySet I X_I).

Inductive BigCapOfFamilySet {U V:Type} (I:Collection V) (X_I: V -> Collection U) : Collection U :=
| intro_of_bigcap_of_family: forall x: U, (forall i:V, i ∈ I -> x ∈ (X_I ⌞ i)) -> x ∈ BigCapOfFamilySet I X_I.

Notation "⋂{ I , X_I }" := (BigCapOfFamilySet I X_I).

(* 被覆 *)
Definition CoveringByFamilySet {U V:Type} (I:Collection V) (X:Collection U) (X_I:V->Collection U) := X ⊂ ⋃{ I , X_I }.

Section FamilyCollection.
  Variable U:Type.

  (* 添字集合の要素iと集合族の要素は一意に決まる. *)
  Theorem indexed_set_is_unique:
    forall (X_I:TypeOfFamily U (Collection U)) (I:Collection U) (X': Collection (Collection U)),
      FamilyOfSetsWithFunction X_I I X' ->
      forall (i:U), i ∈ I -> exists! X_i:Collection U, X_I i = X_i.
  Proof.
    move => f_i I X' HF i HiI.
    apply HF in HiI.
    inversion HiI as [X_i].
    inversion H.
    exists X_i.
    split.
    apply sym_eq.
    apply H0.
    move => x' HF'.
    rewrite -HF'.
    trivial.
  Qed.

  (* 添字集合が空なら集合族の合併は空 *)
  Theorem indexed_set_eq_empty_to_bigcup_eq_empty:
    forall (X_I: TypeOfFamily U (Collection U)) (I:Collection U),
      I = `Ø` ->
      ⋃{ I , (fun i:U => X_I ⌞ i) } = `Ø`.
  Proof.
    move => X_I I HIE.
    apply mutally_included_to_eq.
    split => x H.
    inversion H as [x0].
    inversion H0 as [i0].
    inversion H2.
    rewrite HIE in H3.
    apply DoubleNegativeElimination.
    move => HxE.
    move: H3.
    apply noone_in_empty.
    apply DoubleNegativeElimination.
    move => HxE.
    move: H.
    apply noone_in_empty.
  Qed.

  (* 添字集合が空なら集合族の交わりは全体集合 *)
  Theorem indexed_set_eq_empty_to_bigcap_eq_full:
    forall (X_I: TypeOfFamily U (Collection U)) (I:Collection U),
      I = `Ø` ->
      ⋂{ I , (fun i:U => X_I ⌞ i) } = (FullCollection U).
  Proof.
    move => X_I I HIE.
    apply mutally_included_to_eq.
    split => x H.
    apply intro_full_collection.
    split => i HiI.
    apply DoubleNegativeElimination => HXI.
    rewrite HIE in HiI.
    move: HiI.
    apply noone_in_empty.
  Qed.

  (* 添字集合が空なら部分集合族の交わりはもとの集合の全体 *)
  Theorem indexed_subset_eq_empty_to_bigcap_eq_full:
    forall (X_I: TypeOfFamily U (Collection U)) (I:Collection U) (X:Collection U),
    forall i:U, i ∈ I ->
    I = `Ø` ->
    ⋂{ I , (fun i:U => X_I ⌞ i) } = X.
  Proof.
    move => X_I I X i HiI HIE.
    have L1: forall i:U, i ∉ I.
    rewrite HIE.
    apply noone_in_empty.
    apply DoubleNegativeElimination => HnxX.
    apply (L1 i).
    apply HiI.
  Qed.

  Theorem LawOfDeMorganOfBigcup:
    forall (X_I: TypeOfFamily U (Collection U)) (I:Collection U),
      (⋃{ I , (fun i:U => X_I ⌞ i) })^c = ⋂{ I , (fun i:U => (X_I ⌞ i)^c) }.
  Proof.
    move => X_I I.
    apply mutally_included_to_eq.
    split => x H0.
    split => i HiI HxnXi.
    apply H0.
    split.
    exists i.
    split.
    apply HiI.
    trivial.
    move => HUc.
    inversion HUc.
    inversion H as [i [HiI HxXi]].
    inversion H0.
    apply H2 in HiI.
    apply HiI.
    trivial.
  Qed.

  Theorem LawOfDeMorganOfBigcap:
    forall (X_I: TypeOfFamily U (Collection U)) (I:Collection U),
      (⋂{ I , (fun i:U => X_I ⌞ i) })^c = ⋃{ I , (fun i:U => (X_I ⌞ i)^c) }.
  Proof.
    move => X_I I.
    apply mutally_included_to_eq.
    split => x H.
    +apply notin_collect_iff_in_complement in H.
     apply DoubleNegativeElimination => HnxX.
     apply H.
     split.
     move => i HiI.
     apply DoubleNegativeElimination => HnxXi.
     apply HnxX.
     split.
     exists i.
     split. trivial.
     move => HxXi.
     apply HnxXi.
     trivial.
    +move => HxCap.
     inversion H.
     inversion H0 as [i [HiI HnxX]].
     apply HnxX.
     inversion HxCap as [x1].
     apply H2 in HiI.
     trivial.
  Qed.

  (* 978-4-489-02249-4 P67 *)
  Theorem a_set_includes_bigcup_of_sets_of_family_to_a_set_includes_element_of_sets_of_family:
    forall (I Y:Collection U) (X_I: TypeOfFamily U (Collection U)),
      ⋃{ I , (fun i:U => X_I ⌞ i) } ⊂ Y -> forall i:U, i ∈ I -> X_I ⌞ i ⊂ Y.
  Proof.
    move => I Y X_I H i HiI x HxXi.
    apply H.
    split.
    exists i.
    split; trivial.
  Qed.

  Theorem a_set_includes_element_of_sets_of_family_to_a_set_includes_bigcup_of_sets_of_family:
    forall (I Y:Collection U) (X_I: TypeOfFamily U (Collection U)),
    (forall i:U, i ∈ I -> X_I ⌞ i ⊂ Y) -> ⋃{ I , (fun i:U => X_I ⌞ i) } ⊂ Y.
  Proof.
    move => I Y X_I H x HxCup.
    inversion HxCup.
    inversion H0 as [i [H2 H3]].
    apply H in H2.
    apply H2.
    trivial.
  Qed.

  Theorem a_set_includes_bigcup_of_sets_of_family_iff_a_set_includes_element_of_sets_of_family:
    forall (I Y:Collection U) (X_I: TypeOfFamily U (Collection U)),
      ⋃{ I , (fun i:U => X_I ⌞ i) } ⊂ Y <-> forall i:U, i ∈ I -> X_I ⌞ i ⊂ Y.
  Proof.
    move => I Y X_I.
    rewrite /iff.
    split;[apply a_set_includes_bigcup_of_sets_of_family_to_a_set_includes_element_of_sets_of_family|
           apply a_set_includes_element_of_sets_of_family_to_a_set_includes_bigcup_of_sets_of_family].
  Qed.

  Theorem a_element_of_sets_of_family_includes_a_set_to_bigcap_of_sets_of_family_includes_a_set:
    forall (I Y:Collection U) (X_I: TypeOfFamily U (Collection U)),
      (forall i:U, i ∈ I -> Y ⊂ X_I ⌞ i) -> Y ⊂ ⋂{ I , (fun i:U => X_I ⌞ i) }.
  Proof.
    move => I Y X_I H x HxY.
    split => i HiI.
    apply H in HiI.
    apply HiI.
    assumption.
  Qed.

  Theorem bigcap_of_sets_of_family_includes_a_set_to_a_element_of_sets_of_family_includes_a_set:
    forall (I Y:Collection U) (X_I: TypeOfFamily U (Collection U)),
      Y ⊂ ⋂{ I , (fun i:U => X_I ⌞ i) } -> forall i:U, i ∈ I -> Y ⊂ X_I ⌞ i.
  Proof.
    move => I Y X_I H i HiI x HxY.
    apply H in HxY.
    inversion HxY.
    apply H0 in HiI.
    assumption.
  Qed.

  Theorem a_element_of_sets_of_family_includes_a_set_iff_bigcap_of_sets_of_family_includes_a_set:
    forall (I Y:Collection U) (X_I: TypeOfFamily U (Collection U)),
      (forall i:U, i ∈ I -> Y ⊂ X_I ⌞ i) <-> Y ⊂ ⋂{ I , (fun i:U => X_I ⌞ i) }.
  Proof.
    move => I Y X_I.
    rewrite /iff.
    split;[apply a_element_of_sets_of_family_includes_a_set_to_bigcap_of_sets_of_family_includes_a_set|
           apply bigcap_of_sets_of_family_includes_a_set_to_a_element_of_sets_of_family_includes_a_set].
  Qed.

  Theorem bigcup_union_of_sets_of_family_and_a_set_eq:
    forall (I Y:Collection U) (X_I: TypeOfFamily U (Collection U)),
      I <> `Ø` ->
      ⋃{ I , (fun i:U => (X_I ⌞ i) ∪ Y) } = ⋃{ I , (fun i:U => (X_I ⌞ i)) } ∪ Y.
  Proof.
    move => I Y X_I HnIE.
    apply mutally_included_to_eq.
    split => x.
    +move => H.
     inversion H as [x0].
     inversion H0 as [i].
     inversion H2 as [HiI].
     inversion H3.
     left.
     split.
     exists i.
     split; trivial.
     right.
     trivial.
    +case => x0 H.
     split.
     inversion H.
     inversion H0 as [i].
     inversion H2.
     exists i.
     split.
     trivial.
     left.
     trivial.
     apply not_empty_collection_to_exists_element_in_collection in HnIE.
     inversion HnIE as [i].
     split.
     exists i.
     split;[trivial|right;trivial].
    Qed.

  (* 978-4-489-02249-4 P76 *)
  Theorem union_bigcap_sets_of_family_and_a_set_eq:
    forall (I Y:Collection U) (X_I: TypeOfFamily U (Collection U)),
      ⋂{ I , (fun i:U => (X_I ⌞ i)) } ∪ Y = ⋂{ I , (fun i:U => (X_I ⌞ i) ∪ Y) }.
  Proof.
    move => I Y X_I.
    apply mutally_included_to_eq.
    split => x.
    +case => x0 H.
     ++split => i HiI.
       left.
       inversion H.
       apply H0 in HiI.
       trivial.
     ++split => i HiI.
       right.
       trivial.
    +case: (LawOfExcludedMiddle (x ∈ Y)) => HY H.
     ++right.
       trivial.
       inversion H.
     ++left.
       split.
       move => i HiI.
       apply H0 in HiI.
       inversion HiI.
       apply H2.
       apply DoubleNegativeElimination => Hn.
       apply HY.
       trivial.
  Qed.

  Theorem intersection_bigcap_sets_of_family_and_a_set_eq:
    forall (I Y:Collection U) (X_I: TypeOfFamily U (Collection U)),
      ⋃{ I , (fun i:U => (X_I ⌞ i)) } ∩ Y = ⋃{ I , (fun i:U => (X_I ⌞ i) ∩ Y) }.
  Proof.
    move => I Y X_I.
    apply mutally_included_to_eq.
    split => x H.
    +split.
    ++inversion H.
      inversion H0.
      inversion H3 as [i [HiI HxXi]].
      exists i.
      split; trivial.
      split; trivial.
    ++inversion H.
      inversion H0 as [i [HiI HxXi]].
      inversion HxXi.
      split.
      split.
      exists i.
      split;trivial.
      trivial.
  Qed.

End FamilyCollection.


Inductive SC(T:Type): Type :=
| Value : T -> SC T
| Unknown : SC T.

Inductive Stack(T:Type): Type :=
| Empty : Stack T
| Push:  T -> Stack T -> Stack T.
(* For better readability I renamed Add constructor in Ex1.v to Push *)

(* not_empty checks if the stack is empty or not by returning a Proposition*)
Definition not_empty(T:Type)(s:Stack T):Prop := s <> Empty T.

Definition isEmpty (T:Type)(s:Stack T) : bool :=
match s with
| Empty => true
| Push _ _ => false
end.

(*pop and top are defined by doing the compile-time check that the stack is non empty *)
Definition pop(T:Type)(s:Stack T):not_empty T s -> Stack T :=
match s with
| Empty => (fun proof: not_empty T s => (Empty T))
| Push x r => (fun proof: not_empty T s => r )
end.

Definition top(T:Type)(s:Stack T) : not_empty T s -> SC T :=
match s with
| Empty => (fun proof: not_empty T s => Unknown T)
| Push x _ => (fun proof: not_empty T s => Value T x)
end.

(*post-conditions of push :
Since the precondition of top is not_empty, it is used as an assumption here*)
Theorem push_post_condition : forall t x xs, forall proof:not_empty t xs,(top t (Push t x xs))= (fun proof => Value t x).

Proof.
intros.
simpl.
reflexivity.
Qed.

(*push invariant : all other elements should remain unchanged , pop( push x ts)=ts*)
(*Since the precondition of pop is not_empty, it is used as an assumption here*)

Theorem push_invariant : forall t x xs, forall proof:not_empty t xs, pop t (Push t x xs)=(fun proof =>xs).
Proof.
intros.
simpl.
reflexivity.
Qed.

(* post condition of isEmpty: returns true if the stack is empty*)

Theorem isEmpty_post_condition :forall t, isEmpty t (Empty t)= true.
Proof.
intros.
simpl.
reflexivity.
Qed.

Theorem safe: forall (T:Type)(x y:T)(s:Stack T)(proof:not_empty T (Push T x s))(proof1:not_empty T (Push T y (Push T x s))),
 (s=Empty T)->(pop T ((pop T (Push T y (Push T x s))) proof1)) proof = Empty T.
Proof.
intros.
unfold pop.
rewrite H.
reflexivity.
Qed.

(*
During the second pop, the compile time check sees if the stack is empty or not.
as the stack is empty at this point, it cant return the proof for the not_empty and
the program crashes.
*)
Theorem crash: forall (T:Type)(x:T)(s:Stack T)(proof:not_empty T (Push T x s))(proof1:not_empty T (Push T x (Push T x s))),((pop T ((pop T (Push T x s)) proof)) proof1) = Empty T.
Proof.
Abort.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Cat.Cat.
Require Import Basic_Cons.Terminal.
Require Import Archetypal.Discr.Discr.
Require Import NatTrans.NatTrans NatTrans.NatIso.

(** The unique functor to the terminal category. *)
Program Definition Functor_To_1_Cat (C' : Category) : (C' –≻ 1)%functor :=
{|
  FO := fun x => tt;
  FA := fun a b f => tt;
  F_id := fun _ => eq_refl;
  F_compose := fun _ _ _ _ _ => eq_refl
|}.

(** Terminal category. *)
Program Instance Cat_Term : Terminal Cat :=
{
  terminal := 1%category;

  t_morph := fun x => Functor_To_1_Cat x
}.

Next Obligation. (* t_morph_unique *)
Proof.
  Func_eq_simpl;
  FunExt;
  match goal with
    [|- ?A = ?B] =>
    destruct A;
      destruct B end;
  trivial.
Qed.

(** A functor from terminal category maps all arrows (any arrow is just the identity)
to the identity arrow. *)
Section From_Term_Cat.
  Context {C : Category} (F : (1 –≻ C)%functor).

  Theorem From_Term_Cat : ∀ h, (F @_a tt tt h)%morphism = id.
  Proof.
    destruct h.
    change tt with (id 1 tt).
    apply F_id.
  Qed.

End From_Term_Cat.

(** Any two functors from a category to the terminal categoy are naturally isomorphic. *)
Program Definition Functor_To_1_Cat_Iso
        {C : Category}
        (F F' : (C –≻ 1)%functor)
  : (F ≃ F')%natiso :=
{|
  iso_morphism :=
    {|
      Trans := fun _ => tt
    |};
  inverse_morphism :=
    {|
      Trans := fun _ => tt
    |}
|}.