Require Export Category.

Close Scope nat_scope.
Open Scope category_scope.

Generalizable All Variables.

Class Functor {C : Category} {D : Category} :=
{ fobj : C → D
; fmap : ∀ {X Y : C}, (X ~> Y) → (fobj X ~> fobj Y)

; functor_id_law : ∀ {X : C}, fmap (id (A := X)) = id
; functor_compose_law : ∀ {X Y Z : C} (f : Y ~> Z) (g : X ~> Y),
    fmap f ∘ fmap g = fmap (f ∘ g)
}.

Notation "C ⟶ D" := (@Functor C D) (at level 90, right associativity).

(* Functors used as functions will map objects of categories, similar to the
   way type constructors behave in Haskell. *)
Coercion fobj : Functor >-> Funclass.

(* jww (2014-08-11): Have the ∘ symbol refer to morphisms in any category, so
   that it can be used for both arrows and functors (which are arrows in
   Cat). *)
#[export]
Program Instance fun_compose
  {C : Category} {D : Category} {E : Category}
  (F : D ⟶ E) (G : C ⟶ D) : C ⟶ E := {
    fobj := fun x => fobj (fobj x);
    fmap := fun _ _ f => fmap (fmap f)
}.
Obligation 1.
  rewrite functor_id_law.
  apply functor_id_law.
Defined.
Obligation 2.
  rewrite functor_compose_law.
  rewrite functor_compose_law.
  reflexivity.
Defined.

Lemma fun_irrelevance `(C : Category) `(D : Category)
  : ∀ (a : C → D)
      (f g : ∀ {X Y : C}, (X ~> Y) → (a X ~> a Y))
      i i' c c',
  @f = @g →
  {| fobj := @a
   ; fmap := @f
   ; functor_id_law      := i
   ; functor_compose_law := c |} =
  {| fobj := @a
   ; fmap := @g
   ; functor_id_law      := i'
   ; functor_compose_law := c' |}.
Proof.
  intros. subst. f_equal.
  apply proof_irrelevance.
  apply proof_irrelevance.
Qed.

(* The Identity [Functor] *)

Definition Id `{C : Category} : C ⟶ C.
  apply Build_Functor with
    (fobj := fun X => X)
    (fmap := fun X X f => f); crush.
Defined.

Lemma fun_left_identity `(F : C ⟶ D) : fun_compose Id F = F.
Proof.
  destruct F.
  unfold fun_compose.
  apply fun_irrelevance.
  extensionality h.
  extensionality h0.
  extensionality f. crush.
Qed.

Lemma fun_right_identity `(F : C ⟶ D) : fun_compose F Id = F.
Proof.
  destruct F.
  unfold fun_compose.
  apply fun_irrelevance.
  extensionality h.
  extensionality h0.
  extensionality f. crush.
Qed.

(** [Cat] is the category whose morphisms are functors betwen categories.
    jww (2014-08-24): Coq 8.5 with universe polymorphism is needed. *)

(*
Section Hidden.

#[export]
Program Instance Cat : Category :=
{ ob      := Category
; hom     := @Functor
; id      := @Id
; compose := @fun_compose
}.
Obligation 1.
  unfold fun_compose.
  destruct f.
  apply fun_irrelevance.
  extensionality e.
  extensionality f.
  extensionality g.
  reflexivity.
Defined.
Obligation 2.
  unfold fun_compose.
  destruct f.
  apply fun_irrelevance.
  extensionality e.
  extensionality f.
  extensionality g.
  reflexivity.
Defined.
Obligation 3.
  unfold fun_compose.
  destruct f.
  apply fun_irrelevance.
  extensionality e.
  extensionality f.
  reflexivity.
Defined.

#[export]
Program Instance One : Category := {
    ob      := unit;
    hom     := fun _ _ => unit;
    id      := fun _ => tt;
    compose := fun _ _ _ _ _ => tt
}.
Obligation 1. destruct f. reflexivity. Qed.
Obligation 2. destruct f. reflexivity. Qed.

#[export]
Program Instance Fini `(C : Category) : C ⟶ One := {
    fobj    := fun _ => tt;
    fmap    := fun _ _ _ => id
}.

#[export]
Program Instance Zero : Category := {
    ob      := Empty_set;
    hom     := fun _ _ => Empty_set
}.
Obligation 3.
    unfold Zero_obligation_1.
    unfold Zero_obligation_2.
    destruct A.
Defined.

#[export]
Program Instance Init `(C : Category) : Zero ⟶ C.
Obligation 1. destruct C. crush. Defined.
Obligation 2.
  unfold Init_obligation_1.
  destruct C. crush.
Defined.
Obligation 3.
  unfold Zero_obligation_1.
  unfold Init_obligation_1.
  unfold Init_obligation_2.
  destruct C. crush.
Defined.
Obligation 4.
  unfold Init_obligation_2.
  unfold Zero_obligation_2.
  destruct C. crush.
Qed.

Class HasInitial (C : Category) :=
{ init_obj    : C
; init_mor    : ∀ {X}, init_obj ~> X
; initial_law : ∀ {X} (f g : init_obj ~> X), f = g
}.

#[export]
Program Instance Cat_HasInitial : HasInitial Cat := {
    init_obj := Zero;
    init_mor := Init
}.
Obligation 1.
  induction f as [F].
  induction g as [G].
  assert (F = G).
    extensionality e.
    crush.
  replace F with G. subst.
  assert (fmap0 = fmap1).
    extensionality e.
    extensionality f.
    extensionality g.
    crush.
  apply fun_irrelevance.
  assumption.
Qed.

Class HasTerminal (C : Category) :=
{ term_obj     : C
; term_mor     : ∀ {X}, X ~> term_obj
; terminal_law : ∀ {X} (f g : X ~> term_obj), f = g
}.

#[export]
Program Instance Cat_HasTerminal : HasTerminal Cat := {
    term_obj := One;
    term_mor := Fini
}.
Obligation 1.
  destruct f as [F].
  destruct g as [G].
  assert (F = G).
    extensionality e.
    crush.
  replace F with G. subst.
  assert (fmap0 = fmap1).
    extensionality e.
    extensionality f.
    extensionality g.
    crush.
  apply fun_irrelevance.
  assumption.
Qed.

End Hidden.
*)

Class Natural `(F : @Functor C D) `(G : @Functor C D) :=
{ transport  : ∀ {X}, F X ~> G X
; naturality : ∀ {X Y} (f : X ~> Y),
    fmap f ∘ transport = transport ∘ fmap f
}.

Notation "transport/ N" := (@transport _ _ _ _ N _) (at level 24).
Notation "F ⟾ G" := (Natural F G) (at level 90, right associativity).

(* Natural transformations can be applied directly to functorial values to
   perform the functor mapping they imply. *)
Coercion transport : Natural >-> Funclass.

#[export]
Program Instance nat_identity `{F : Functor} : F ⟾ F := {
    transport := fun _ => id
}.
Obligation 1.
  rewrite right_identity.
  rewrite left_identity.
  reflexivity.
Defined.

#[export]
Program Instance nat_compose `{F : C ⟶ D} `{G : C ⟶ D} `{K : C ⟶ D}
  (f : G ⟾ K) (g : F ⟾ G) : F ⟾ K := {
    transport := fun X =>
      @transport C D G K f X ∘ @transport C D F G g X
}.
Obligation 1.
  rewrite comp_assoc.
  rewrite naturality.
  rewrite <- comp_assoc.
  rewrite naturality.
  rewrite comp_assoc.
  reflexivity.
Defined.

Section NaturalEquiv.

Context `{C : Category}.
Context `{D : Category}.
Context `{F : C ⟶ D}.
Context `{G : C ⟶ D}.

Lemma nat_irrelevance : ∀ (f g : ∀ {X}, F X ~> G X) n n',
  @f = @g ->
  {| transport := @f; naturality := n |} =
  {| transport := @g; naturality := n' |}.
Proof.
  intros. subst. f_equal.
  apply proof_irrelevance.
Qed.

Definition nat_equiv (x y : F ⟾ G) : Prop :=
  match x with
  | Build_Natural _ _ _ _ transport0 _ => match y with
    | Build_Natural _ _ _ _ transport1 _ =>
        forall {X}, transport0 X = transport1 X
    end
  end.

#[export]
Program Instance nat_equivalence : Equivalence nat_equiv.
Obligation 1.
  unfold Reflexive, nat_equiv. intros.
  destruct x. auto.
Defined.
Obligation 2.
  unfold Symmetric, nat_equiv. intros.
  destruct x. destruct y. intros.
  specialize (H X).
  symmetry; assumption.
Defined.
Obligation 3.
  unfold Transitive, nat_equiv. intros.
  destruct x. destruct y. destruct z.
  intros. specialize (H X). specialize (H0 X).
  transitivity (transport1 X); assumption.
Defined.

End NaturalEquiv.

Add Parametric Relation
  `(C : Category) `(D : Category) `(F : C ⟶ D) `(G : C ⟶ D)
  : (F ⟾ G) (@nat_equiv C D F G)
  reflexivity proved by  (@Equivalence_Reflexive  _ _ (@nat_equivalence C D F G))
  symmetry proved by     (@Equivalence_Symmetric  _ _ (@nat_equivalence C D F G))
  transitivity proved by (@Equivalence_Transitive _ _ (@nat_equivalence C D F G))
    as parametric_relation_nat_eqv.

  Add Parametric Morphism
    `(C : Category) `(D : Category) `(F : C ⟶ D) `(G : C ⟶ D) `(K : C ⟶ D)
    : (@nat_compose C D F G K)
    with signature (nat_equiv ==> nat_equiv ==> nat_equiv)
      as parametric_morphism_nat_comp.
    intros. unfold nat_equiv, nat_compose.
    destruct x. destruct y. destruct x0. destruct y0.
    simpl in *. intros.
    specialize (H0 X). rewrite H0. crush.
Defined.

(* Nat is the category whose morphisms are natural transformations between
   Functors from C ⟶ D. *)

#[export]
Program Instance Nat (C : Category) (D : Category) : Category :=
{ ob      := @Functor C D
; hom     := @Natural C D
; id      := @nat_identity C D
; compose := @nat_compose C D
}.
Obligation 1. (* right_identity *)
  destruct f. intros.
  apply nat_irrelevance.
  extensionality x. crush.
Defined.
Obligation 2. (* left_identity *)
  destruct f. intros.
  apply nat_irrelevance.
  extensionality x. crush.
Defined.
Obligation 3. (* comp_assoc *)
  destruct f. destruct g. destruct h.
  apply nat_irrelevance.
  extensionality x. unfold nat_compose.
  simpl. rewrite <- comp_assoc. reflexivity.
Defined.

Notation "[ C , D ]" := (Nat C D) (at level 90, right associativity).

Definition Copresheaves (C : Category) := [C, Sets].
Definition Presheaves   (C : Category) := [C^op, Sets].

(*
Bifunctors can be curried:

  C × D ⟶ E   -->  C ⟶ [D, E]
  ~~~
  (C, D) -> E  -->  C -> D -> E

Where ~~~ should be read as "Morally equivalent to".

Note: We do not need to define Bifunctors as a separate class, since they can
be derived from functors mapping to a category of functors.  So in the
following two definitions, [P] is effectively our bifunctor.

The trick to [bimap] is that both the [Functor] instances we need (for [fmap]
and [fmap1]), and the [Natural] instance, can be found in the category of
functors we're mapping to by applying [P].
*)

Definition fmap1 `{P : C ⟶ [D, E]} {A : C} `(f : X ~{D}~> Y) :
  P A X ~{E}~> P A Y := fmap f.

Definition bimap `{P : C ⟶ [D, E]} {X W : C} {Y Z : D} (f : X ~{C}~> W) (g : Y ~{D}~> Z) :
  P X Y ~{E}~> P W Z := let N := @fmap _ _ P _ _ f in transport/N ∘ fmap1 g.

Definition contramap `{F : C^op ⟶ D} `(f : X ~{C}~> Y) :
  F Y ~{D}~> F X := fmap (unop f).

Definition dimap `{P : C^op ⟶ [D, E]} `(f : X ~{C}~> W) `(g : Y ~{D}~> Z) :
  P W Y ~{E}~> P X Z := bimap (unop f) g.

(* jww (2014-08-24): Waiting on Coq 8.5. *)
(*
#[export]
Program Instance Hom `(C : Category) : C^op ⟶ [C, Sets] :=
{ fobj := fun X =>
  {| fobj := @hom C X
   ; fmap := @compose C X
   |}
; fmap := fun _ _ f => {| transport := fun X g => g ∘ unop f |}
}.
Obligation 1. extensionality x. crush. Defined.
Obligation 2. extensionality x. crush. Defined.
Obligation 3. extensionality x. crush. Defined.
Obligation 4.
  unfold nat_identity.
  apply nat_irrelevance.
  extensionality e.
  extensionality f.
  unfold unop.
  rewrite right_identity.
  auto.
Defined.
Obligation 5.
  unfold nat_compose, nat_identity.
  apply nat_irrelevance.
  extensionality e.
  simpl.
  unfold unop.
  extensionality h.
  crush.
Defined.

Coercion Hom : Category >-> Functor.
*)

(*
(** This is the Yoneda embedding. *)
(* jww (2014-08-10): It should be possible to get rid of Hom here, but the
   coercion isn't firing. *)
#[export]
Program Instance Yoneda `(C : Category) : C ⟶ [C^op, Sets] := Hom (C^op).
Obligation 1. apply op_involutive. Defined.
*)

(*
#[export]
Program Instance YonedaLemma `(C : Category) `(F : C ⟶ Sets) {A : C^op}
    : (C A ⟾ F) ≅Sets F A.
Obligation 1.
  intros.
  destruct X.
  apply transport0.
  simpl.
  destruct C.
  crush.
Defined.
Obligation 2.
  intros.
  simpl.
  pose (@fmap C Sets F A).
  apply Build_Natural with (transport := fun Y φ => h Y φ X).
  intros.
  inversion F. simpl.
  extensionality e.
  unfold h.
  rewrite <- functor_compose_law.
  crush.
Defined.
Obligation 3.
  extensionality e.
  pose (f := fun (_ : unit) => e).
  destruct C.
  destruct F. simpl.
  rewrite functor_id_law0.
  crush.
Qed.
Obligation 4.
  extensionality e.
  destruct e.
  simpl.
  apply nat_irrelevance.
  extensionality f.
  extensionality g.
  destruct C as [ob0 uhom0 hom0 id0].
  destruct F.
  simpl.
  assert (fmap0 A f g (transport0 A (id0 A)) =
          (fmap0 A f g ∘ transport0 A) (id0 A)).
    crush. rewrite H. clear H.
  rewrite naturality0.
  crush.
Qed.
*)

Class FullyFaithful `(F : @Functor C D) :=
{ unfmap : ∀ {X Y : C}, (F X ~> F Y) → (X ~> Y)
}.

(*
#[export]
Program Instance Hom_Faithful (C : Category) : FullyFaithful C :=
{ unfmap := fun _ _ f => (transport/f) id
}.
*)

(*
#[export]
Program Instance Hom_Faithful_Co (C : Category) {A : C} : FullyFaithful (C A).
Obligation 1.
  destruct C. crush.
  clear left_identity.
  clear right_identity.
  clear comp_assoc.
  specialize (compose X A Y).
  apply compose in X0.
    assumption.
  (* jww (2014-08-12): Is this even provable?  Ed thinks no. *)
*)

(** ** Opposite functor[edit]

Every functor [F: C ⟶ D] induces the opposite functor [F^op]: [C^op ⟶ D^op],
where [C^op] and [D^op] are the opposite categories to [C] and [D].  By
definition, [F^op] maps objects and morphisms identically to [F].

*)

#[export]
Program Instance Opposite_Functor `(F : C ⟶ D) : C^op ⟶ D^op := {
    fobj := @fobj C D F;
    fmap := fun X Y f => @fmap C D F Y X (op f)
}.
Obligation 1. unfold op. apply functor_id_law. Defined.
Obligation 2. unfold op. apply functor_compose_law. Defined.

(* jww (2014-08-10): Until I figure out how to make C^op^op implicitly unify
   with C, I need a way of undoing the action of Opposite_Functor. *)
(*
#[export]
Program Instance Reverse_Opposite_Functor `(F : C^op ⟶ D^op) : C ⟶ D := {
    fobj := @fobj _ _ F;
    fmap := fun X Y f => unop (@fmap _ _ F Y X f)
}.
Obligation 1.
  unfold unop.
  unfold fmap. simpl.
  pose (@functor_id_law _ _ F).
  unfold fmap in e. simpl in e.
  specialize (e X). auto.
Qed.
Obligation 2.
  unfold unop.
  unfold fmap. simpl.
  pose (@functor_compose_law _ _ F).
  unfold fmap in e. simpl in e.
  specialize (e Z Y X g f).
  auto.
Qed.
*)

(* Definition Coerce_Functor `(F : C ⟶ D) := Opposite_Functor F. *)

(* Coercion Coerce_Functor : Functor >-> Functor. *)

(*
Lemma op_functor_involutive `(F : Functor)
  : Reverse_Opposite_Functor (Opposite_Functor F) = F.
Proof.
  unfold Reverse_Opposite_Functor.
  unfold Opposite_Functor.
  destruct F.
  apply fun_irrelevance.
  auto.
Qed.
*)

(*
Class Adjunction `{C : Category} `{D : Category}
    `(F : @Functor D C) `(U : @Functor C D) := {
    adj : ∀ (a : D) (b : C), (C (F a) b) ≅ (D a (U b))
}.

Notation "F ⊣ G" := (Adjunction F G) (at level 70) : category_scope.

#[export]
Program Instance adj_identity `{C : Category} : Id ⊣ Id.

(* Definition adj' `{C : Category} `{D : Category} `{E : Category} *)
(*    (F : Functor D C) (U : Functor C D) *)
(*    (F' : Functor E D) (U' : Functor D E)  (a : E) (b : C) *)
(*    : (C (fun_compose F F' a) b) ≅ (E a (fun_compose U' U b)). *)

Definition adj_compose `{C : Category} `{D : Category} `{E : Category}
   (F : Functor D C) (U : Functor C D)
   (F' : Functor E D) (U' : Functor D E)
   (X : F ⊣ U) (Y : F' ⊣ U')
   : @fun_compose E D C F F' ⊣ @fun_compose C D E U' U.
Proof.
  destruct X.
  destruct Y.
  apply (@Build_Adjunction C E (@fun_compose E D C F F') (@fun_compose C D E U' U)).
  intros.
  specialize (adj0 (F' a) b).
  specialize (adj1 a (U b)).
  replace ((E a) ((fun_compose U' U) b)) with ((E a) ((U' (U b)))).
  replace ((C ((fun_compose F F') a)) b) with ((C (F (F' a))) b).
  apply (@iso_compose Sets ((C (F (F' a))) b) ((D (F' a)) (U b)) ((E a) (U' (U b)))).
  assumption.
  assumption.
  crush.
  crush.
Qed.

Record Adj_Morphism `{C : Category} `{D : Category} := {
    free_functor : Functor D C;
    forgetful_functor : Functor C D;
    adjunction : free_functor ⊣ forgetful_functor
}.

(* Lemma adj_left_identity `(F : @Functor D C) `(U : @Functor C D) *)
(*   : adj_compose Id Id F U adj_identity (F ⊣ U) = F ⊣ U. *)
(* Proof. *)
(*   destruct F. *)
(*   unfold fun_compose. *)
(*   simpl. *)
(*   apply fun_irrelevance. *)
(*   extensionality e. *)
(*   extensionality f. *)
(*   extensionality g. *)
(*   reflexivity. *)
(* Qed. *)

(* Lemma adj_right_identity `(F : @Functor C D) : fun_compose F Id = F. *)
(* Proof. *)
(*   destruct F. *)
(*   unfold fun_compose. *)
(*   simpl. *)
(*   apply fun_irrelevance. *)
(*   extensionality e. *)
(*   extensionality f. *)
(*   extensionality g. *)
(*   reflexivity. *)
(* Qed. *)

Lemma adj_irrelevance
   `{C : Category} `{D : Category} `{E : Category}
   (F F' : Functor D C) (U U' : Functor C D)
  : ∀ (X : F ⊣ U) (X' : F' ⊣ U'),
  @F = @F' →
  @U = @U' →
  {| free_functor      := @F
   ; forgetful_functor := @U
   ; adjunction        := @X
   |} =
  {| free_functor      := @F'
   ; forgetful_functor := @U'
   ; adjunction        := @X'
   |}.
Proof.
  intros. subst. f_equal.
  apply proof_irrelevance.
Qed.

#[export]
Program Instance Adj : Category := {
    ob := Category;
    hom := @Adj_Morphism
}.
Obligation 1.
  apply Build_Adj_Morphism
    with (free_functor      := Id)
         (forgetful_functor := Id).
  apply adj_identity.
Defined.
Obligation 2.
  destruct X.
  destruct X0.
  apply Build_Adj_Morphism
    with (free_functor      := fun_compose free_functor1 free_functor0)
         (forgetful_functor := fun_compose forgetful_functor0 forgetful_functor1).
  apply adj_compose.
  assumption.
  assumption.
Defined.
Obligation 3.
  unfold Adj_obligation_2.
  unfold Adj_obligation_1.
  destruct f.
  destruct adjunction0.
  simpl.
  pose (fun_left_identity free_functor0).
  pose (fun_right_identity forgetful_functor0).
  apply adj_irrelevance.
  rewrite e. reflexivity.
  rewrite e0. reflexivity.
Qed.
Obligation 4.
  unfold Adj_obligation_2.
  unfold Adj_obligation_1.
  destruct f.
  destruct adjunction0.
  simpl.
  pose (fun_left_identity forgetful_functor0).
  pose (fun_right_identity free_functor0).
  apply adj_irrelevance.
  rewrite e0. reflexivity.
  rewrite e. reflexivity.
Qed.
Obligation 5.
  admit.
Qed.
*)

(* Inductive Const := Const_ : Type → Const. *)

(* Definition getConst `{C : Category} (c : @Const C) : C := *)
(*   match c with *)
(*   | Const_ x => x *)
(*   end. *)

#[export]
Program Instance Const `{C : Category} `{J : Category} (x : C) : J ⟶ C := {
    fobj := fun _ => x;
    fmap := fun _ _ _ => id
}.

Lemma Const_Iso `{C : Category} : ∀ a b, Const a b ≅ a.
Proof. crush. Qed.

Definition Sets_getConst `{J : Category} (a : Type) (b : J)
  (c : @Const Sets J a b) : Type := @fobj J Sets (@Const Sets J a) b.

#[export]
Program Instance Const_Transport `(C : Category) `(J : Category) `(x ~> y)
  : @Natural C J (Const x) (Const y) := {
    transport := fun X => _
}.
Obligation 2.
  rewrite left_identity.
  rewrite right_identity. reflexivity.
Defined.

#[export] Hint Unfold Const_Transport : core.

#[export]
Program Instance Delta `{C : Category} `{J : Category} : C ⟶ [J, C] := {
    fobj := @Const C J;
    fmap := @Const_Transport J C
}.
Obligation 1.
  autounfold.
  unfold nat_compose.
  apply nat_irrelevance.
  extensionality x0. crush.
Qed.
Obligation 2.
  autounfold.
  unfold nat_compose.
  apply nat_irrelevance.
  extensionality x0. crush.
Qed.

(*
Class Complete `(C : Category) := {
    complete : ∀ (J : Category), { Lim : [J, C] ⟶ C & @Delta C J ⊣ Lim }
}.
*)

(* Here F is a diagram of type J in C. *)
Record Cone `{C : Category} `{J : Category} (n : C) `(F : @Functor J C) := {
    cone_mor : ∀ j : J, n ~> F j;
    cone_law : ∀ i j (f : i ~{J}~> j), (@fmap J C F i j f) ∘ cone_mor i = cone_mor j
}.

Definition Const_to_Cone `(F : J ⟶ C) {a} : (Const a ⟾ F) → Cone a F.
Proof.
  intros.
  destruct X.
  apply Build_Cone
    with (cone_mor := transport0).
  intros. simpl in *.
  specialize (naturality0 i j f).
  rewrite right_identity in naturality0.
  apply naturality0.
Defined.

Definition Cone_to_Const `(F : J ⟶ C) {a} : Cone a F → (Const a ⟾ F).
Proof.
  unfold Const. intros.
  destruct X. destruct F.
  refine (Build_Natural _ _ _ _ _ _); intros; simpl.
  crush. rewrite right_identity.
  apply cone_law0.
Defined.

(* jww (2014-08-24): Need Coq 8.5
#[export]
Program Instance Const_Cone_Iso `(F : J ⟶ C)
  : ∀ a, (Const a ⟾ F) ≅Sets Cone a F := {
    to   := @Const_to_Cone J C F a;
    from := @Cone_to_Const J C F a
}.
Obligation 1.
  extensionality x.
  destruct x. destruct F.
  simpl in *. f_equal.
  extensionality i.
  extensionality j.
  extensionality f.
  destruct C.
  destruct J. simpl. crush.
Qed.
Obligation 2.
Abort.
*)

(*
#[export]
Program Instance Lim_Sets `(J : Category) : [J, Sets] ⟶ Sets := {
    fobj := fun F =>
    fmap := fun _ _ n F_x z => (transport/n) (F_x z)
}.

Lemma distribute_forall : ∀ a {X} P, (a → ∀ (x : X), P x) → (∀ x, a → P x).
Proof.
  intros.
  apply X0.
  assumption.
Qed.

Lemma forall_distribute : ∀ a {X} P, (∀ x, a → P x) → (a → ∀ (x : X), P x).
Proof.
  intros.
  apply X0.
  assumption.
Qed.

#[export]
Program Instance Sets_Const_Nat (J : Category) (F : [J, Sets])
  (a : Type) (f : a → ∀ x : J, F x) : @Const Sets J a ⟾ F.
Obligation 2.
  extensionality e.
  unfold Sets_Const_Nat_obligation_1.
  remember (f e) as j.
  destruct F. simpl. clear.
  destruct J.
  crush. clear.
  (* jww (2014-08-12): We don't believe this is true. *)

#[export]
Program Instance Sets_Const_Lim_Iso (J : Category) (a : Sets) (F : [J, Sets])
  : @Isomorphism Sets (Const a ⟾ F) (a → Lim_Sets J F).
Obligation 1.
  destruct F. simpl.
  destruct X.
  apply transport0.
  auto.
Defined.
Obligation 2.
  apply Sets_Const_Nat.
  auto.
Defined.
Obligation 3.
  extensionality e.
  unfold Sets_Const_Lim_Iso_obligation_1.
  unfold Sets_Const_Lim_Iso_obligation_2.
  extensionality f.
  extensionality g.
  destruct F. simpl.
  unfold Sets_Const_Nat_obligation_1.
  reflexivity.
Qed.
Obligation 4.
  extensionality e.
  unfold Sets_Const_Lim_Iso_obligation_1.
  unfold Sets_Const_Lim_Iso_obligation_2.
  unfold Sets_Const_Nat.
  destruct e.
  unfold Sets_Const_Nat_obligation_1.
  unfold Sets_Const_Nat_obligation_2.
  apply nat_irrelevance.
  extensionality f.
  extensionality g.
  destruct F. simpl.
  reflexivity.
Qed.

#[export]
Program Instance Sets_Complete : Complete Sets.
Obligation 1.
  exists (Lim_Sets J).
  apply Build_Adjunction.
  intros. simpl.
  apply Sets_Const_Lim_Iso.
Qed.
*)

Definition EndoFunctor `(C : Category) := C ⟶ C.

Definition CoqEndoFunctor := Sets ⟶ Sets.

Reserved Notation "X ⊗ Y" (at level 27, right associativity).

Class MonoidalCategory := {
    is_category :> Category;

    mult  : is_category ⟶ [is_category, is_category] where "X ⊗ Y" := (mult X Y);
    nelem : is_category;

    mc_left_id  : ∀ X, X ⊗ nelem ≅ X;
    mc_right_id : ∀ X, nelem ⊗ X ≅ X;
    mc_assoc    : ∀ X Y Z, (X ⊗ Y) ⊗ Z ≅ X ⊗ (Y ⊗ Z)
}.

Infix "⊗" := mult (at level 27, right associativity) : category_scope.

Coercion is_category : MonoidalCategory >-> Category.

#[export]
Program Instance Tuple_Functor (X : Type) : Sets ⟶ Sets := {
    fobj := fun Y => (X * Y);
    fmap := fun _ _ f p => match p with
      (x, y) => (x, f y)
    end
}.
Obligation 1.
  extensionality p.
  destruct p. reflexivity.
Qed.
Obligation 2.
  extensionality p.
  destruct p. reflexivity.
Qed.

#[export]
Program Instance Tuple_Bifunctor : Sets ⟶ [Sets, Sets] := {
    fobj := Tuple_Functor;
    fmap := fun _ _ f =>
      {| transport := fun _ p =>
           match p with (x, y) => (f x, y) end
       |}
}.
Obligation 1.
  extensionality p.
  destruct p. reflexivity.
Qed.
Obligation 2.
  unfold nat_identity.
  apply nat_irrelevance.
  extensionality H.
  extensionality p.
  destruct p. reflexivity.
Qed.
Obligation 3.
  unfold nat_compose.
  apply nat_irrelevance.
  extensionality H.
  extensionality p.
  destruct p. reflexivity.
Qed.

#[export]
Program Instance LTuple_Isomorphism {A} : (unit * A) ≅Sets A :=
{ to   := @snd unit A
; from := pair tt
}.
Obligation 2.
  extensionality x. destruct x. destruct u. reflexivity.
Qed.

#[export]
Program Instance RTuple_Isomorphism {A} : (A * unit) ≅Sets A :=
{ to   := @fst A unit
; from := fun x => (x, tt)
}.
Obligation 2.
  extensionality x. destruct x. destruct u. reflexivity.
Qed.

Definition tuple_swap_a_bc_to_ab_c {A B C} (x : A * (B * C)) : A * B * C :=
  match x with (a, (b, c)) => ((a, b), c) end.

Definition tuple_swap_ab_c_to_a_bc {A B C} (x : A * B * C) : A * (B * C) :=
  match x with ((a, b), c) => (a, (b, c)) end.

Definition left_triple {A B C} (x : A) (y : B) (z : C) : A * B * C :=
  ((x, y), z).

Definition right_triple {A B C} (x : A) (y : B) (z : C) : A * (B * C) :=
  (x, (y, z)).

#[export]
Program Instance Tuple_Assoc {A B C} : (A * B * C) ≅Sets (A * (B * C)) :=
{ to   := tuple_swap_ab_c_to_a_bc
; from := tuple_swap_a_bc_to_ab_c
}.
Next Obligation. (* iso_to *)
  intros.
  extensionality x.
  unfold compose.
  destruct x.
  destruct p.
  unfold id.
  unfold tuple_swap_a_bc_to_ab_c, tuple_swap_ab_c_to_a_bc.
  reflexivity.
Defined.
Next Obligation. (* iso_from *)
  intros.
  extensionality x.
  unfold compose.
  destruct x.
  destruct p.
  unfold id.
  unfold tuple_swap_a_bc_to_ab_c, tuple_swap_ab_c_to_a_bc.
  reflexivity.
Defined.

Definition uncurry {X Y Z} (f : X -> Y -> Z) (xy : X * Y) : Z :=
  match xy with (x, y) => f x y end.

Theorem uncurry_works : forall {X Y Z} (x : X) (y : Y) (f : X -> Y -> Z),
  uncurry f (x, y) = f x y.
Proof. reflexivity. Qed.

#[export]
Program Instance Sets_with_Products : MonoidalCategory := {
    is_category := Sets;

    mult  := Tuple_Bifunctor;
    nelem := unit;

    mc_left_id  := @RTuple_Isomorphism;
    mc_right_id := @LTuple_Isomorphism;
    mc_assoc    := @Tuple_Assoc
}.

Reserved Notation "f ** g" (at level 28, left associativity).

Class LaxMonoidalFunctor `(C : MonoidalCategory) `(D : MonoidalCategory) := {
    lmf_functor :> C ⟶ D;

    lmf_id  : nelem ~> fobj nelem;
    ap_prod : ∀ X Y, fobj X ⊗ fobj Y ~> fobj (X ⊗ Y)
      where "f ** g" := (ap_prod f g);

    lmf_left_id  : ∀ X, fobj X ⊗ nelem ≅ fobj (X ⊗ nelem);
    lmf_right_id : ∀ X, nelem ⊗ fobj X ≅ fobj (nelem ⊗ X);
    lmf_assoc    : ∀ X Y Z, (fobj X ⊗ fobj Y) ⊗ fobj Z ≅ fobj (X ⊗ (Y ⊗ Z))
}.


(*

  Copyright 2016 University of Luxembourg

  This file is part of our formalization of Platzer's
    "A Complete Uniform Substitution Calculus for Differential Dynamic Logic"
  available here: http://arxiv.org/pdf/1601.06183.pdf.
  We refer to this formalization as DdlCoq here.

  DdlCoq is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  DdlCoq is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with DdlCoq.  If not, see <http://www.gnu.org/licenses/>.

  authors:
    Vincent Rahli
    Marcus Völp
    Ivana Vukotic

 *)

Require Export deriv_util.
Require Export multiplication.

(**

  This file introduces lemma which checks if nth derivative of division of two functions exists.

 *)

(* Regarding division:
https://www.physicsforums.com/threads/quotient-rule-for-higher-order-derivatives.289320/
 *)

(** does derivative of two functions exists *)
Lemma ex_derive_n_div :
  forall (n : nat) (f g : R -> R) (pt : R),
    (forall pt, g pt <> 0)
    -> (forall pt k, (k <= n)%nat -> ex_derive_n f k pt)
    -> (forall pt k, (k <= n)%nat -> ex_derive_n g k pt)
    -> ex_derive_n (fun x => (f x) / (g x)) n pt.
Proof.
  induction n as [n IHn] using comp_ind; introv d loc1 loc2; destruct n;[simpl;auto|].
  simpl.

  apply ex_derive_n_S_if; auto.

  {
    apply ex_derive_div; auto.
    { pose proof (loc1 pt 1%nat) as q1; simpl in q1; apply q1; try omega. }
    { pose proof (loc2 pt 1%nat) as q2; simpl in q2; apply q2; try omega. }
  }

  {
    apply (@ex_derive_n_ext (fun x => (Derive f x * g x - f x * Derive g x) / g x ^ 2) _).

    { introv.
      rewrite (Derive_div f g); auto; simpl.
      { pose proof (loc1 t 1%nat) as q1; simpl in q1; apply q1; try omega. }
      { pose proof (loc2 t 1%nat) as q2; simpl in q2; apply q2; try omega. }
    }

    {
      pose proof (IHn n) as h; clear IHn.
      repeat (autodimp h hyp).
      pose proof (h (fun x => (Derive f x * g x - f x * Derive g x))
                    (fun x => g x ^ 2)
                    pt) as q; clear h.
      repeat (autodimp q hyp).

      {
        introv.
        apply pow_nonzero; auto.
      }

      {
        introv w.
        apply ex_derive_n_minus.

        {
          exists R1pos; introv w1 w2.
          apply ex_derive_n_mult_gen; introv w3.

          {
            pose proof (loc1 y0 (S k1)) as q.
            autodimp q hyp; try omega.
            apply ex_derive_n_S_implies; auto.
            pose proof (loc1 y0 1%nat) as z; apply z; try omega.
          }

          {
            pose proof (loc2 y0 k1) as q.
            autodimp q hyp; try omega.
          }
        }

        {
          exists R1pos; introv w1 w2.
          apply ex_derive_n_mult_gen; introv w3.

          {
            pose proof (loc1 y0 k1) as q.
            autodimp q hyp; try omega.
          }

          {
            pose proof (loc2 y0 (S k1)) as q.
            autodimp q hyp; try omega; auto.
            apply ex_derive_n_S_implies; auto.
            pose proof (loc2 y0 1%nat) as z; apply z; try omega.
          }
        }
      }

      {
        introv w.
        apply ex_derive_n_pow.
        introv w1.
        apply loc2; try omega.
      }
    }
  }
Qed.


(* Lemma 2.2 of the proof of the sensitivity conjecture *)
(* sequence A_n of matrices and the proof their square is "n * I_n" *)

Set Nested Proofs Allowed.
Set Implicit Arguments.

Require Import Utf8 Arith.
Import List List.ListNotations.

Require Import Misc Matrix BlockMat.
Require Import Semiring Field2.
Require Import SRsummation SRproduct SRpolynomial.
Require Import CharacPolyn.
Import matrix_Notations.
Import bmatrix_Notations.

Section in_ring.

Context {T : Type}.
Context (so : semiring_op T).
Context {ro : ring_op T}.
Context {sp : semiring_prop T}.
Context {rp : ring_prop T}.
Context {scp : sring_comm_prop T}.
Context {sdp : sring_dec_prop T}.
Context {fo : field_op T}.

Add Parametric Relation : _ (@bmat_fit_for_add T)
 reflexivity proved by bmat_fit_for_add_refl
 symmetry proved by bmat_fit_for_add_symm
 transitivity proved by bmat_fit_for_add_trans
 as bmat_fit_for_add_equivalence.

(* sequence "An" *)

Fixpoint mA n : bmatrix T :=
  match n with
  | 0 => BM_1 0%Srng
  | S n' =>
       BM_M
         (mat_of_list_list (BM_1 0%Srng)
            [[mA n'; I_2_pow n'];
             [I_2_pow n'; bmat_opp (mA n')]])
  end.

Theorem bmat_fit_for_add_IZ_A : ∀ u n,
  bmat_fit_for_add (IZ_2_pow u n) (mA n).
Proof.
intros.
revert u.
induction n; intros; [ easy | cbn ].
split; [ easy | ].
split; [ easy | ].
intros * Hi Hj.
destruct i. {
  destruct j; [ apply IHn | ].
  destruct j; [ cbn | flia Hj ].
  apply bmat_fit_for_add_IZ_IZ.
}
destruct i; [ | flia Hi ].
destruct j; [ apply bmat_fit_for_add_IZ_IZ | ].
destruct j; [ cbn | flia Hj ].
transitivity (mA n); [ easy | ].
apply bmat_fit_for_add_opp_r.
Qed.

Theorem sizes_of_bmatrix_A : ∀ n,
  sizes_of_bmatrix (mA n) = repeat 2 n.
Proof.
intros.
induction n; [ easy | now cbn; f_equal ].
Qed.

Theorem A_is_square_bmat : ∀ n,
  is_square_bmat (mA n).
Proof.
intros.
induction n; [ easy | cbn ].
split; [ easy | ].
split; [ easy | ].
intros i j Hi Hj.
destruct i; cbn. {
  destruct j; [ easy | cbn ].
  destruct j; [ | flia Hj ].
  rewrite sizes_of_bmatrix_A.
  rewrite <- (sizes_of_bmatrix_IZ n 1%Srng).
  apply IZ_is_square_bmat.
}
destruct i; [ cbn | flia Hi ].
destruct j; cbn. {
  rewrite sizes_of_bmatrix_A.
  rewrite <- (sizes_of_bmatrix_IZ n 1%Srng).
  apply IZ_is_square_bmat.
}
destruct j; [ | flia Hj ].
apply is_square_bmat_loop_opp.
apply IHn.
Qed.

Theorem bmat_zero_like_A_eq_Z :
  ∀ n, bmat_zero_like (mA n) = Z_2_pow n.
Proof.
intros.
induction n; [ easy | cbn ].
f_equal.
apply matrix_eq; cbn; [ easy | easy | ].
intros i j Hi Hj.
destruct i; cbn. {
  destruct j; cbn; [ easy | ].
  destruct j; [ cbn | flia Hj ].
  apply bmat_zero_like_IZ_eq_Z.
}
destruct i; [ cbn | flia Hi ].
destruct j; cbn. {
  apply bmat_zero_like_IZ_eq_Z.
}
destruct j; [ | flia Hj ].
rewrite fold_bmat_zero_like.
rewrite bmat_zero_like_opp; [ easy | ].
apply A_is_square_bmat.
Qed.

Theorem Tr_A : ∀ n, Tr (mA n) = 0%Srng.
Proof.
intros.
induction n; [ easy | cbn ].
rewrite IHn.
do 2 rewrite srng_add_0_l.
rewrite Tr_opp; [ | easy | easy | apply A_is_square_bmat ].
rewrite IHn.
apply rng_opp_0.
Qed.

(* "We prove by induction that A_n^2 = nI" *)

Theorem lemma_2_A_n_2_eq_n_I : ∀ n,
  (mA n * mA n = bmat_nat_mul_l n (I_2_pow n))%BM.
Proof.
intros.
induction n; intros; [ now cbn; rewrite srng_mul_0_l | ].
cbn; f_equal.
apply matrix_eq; cbn; [ easy | easy | ].
intros * Hi Hj.
destruct i. {
  destruct j. {
    cbn.
    rewrite bmat_nat_mul_l_succ; [ | easy ].
    rewrite <- IHn.
    rewrite old_bmat_mul_1_r; [ | easy | easy | easy ].
    f_equal.
    rewrite <- bmat_zero_like_sqr; [ | apply A_is_square_bmat ].
    now apply bmat_add_0_l.
  }
  destruct j; [ cbn | flia Hj ].
  rewrite bmat_nat_mul_l_succ; [ | easy ].
  rewrite old_bmat_mul_1_r; [ | easy | easy | ]. 2: {
    unfold I_2_pow.
    apply bmat_fit_for_add_IZ_A.
  }
  rewrite old_bmat_mul_1_l; [ | easy | ]. 2: {
    unfold I_2_pow.
    transitivity (mA n); [ apply bmat_fit_for_add_IZ_A | ].
    apply bmat_fit_for_add_opp_r.
  }
  rewrite bmat_add_0_l; [ | easy ].
  rewrite bmat_add_opp_r; [ | easy | easy ].
  rewrite fold_Z_2_pow.
  rewrite old_bmat_add_0_r; [ | easy | ]. 2: {
    now apply bmat_fit_for_add_Z_2_pow_bmat_nat_mul_l.
  }
  rewrite bmat_nat_mul_0_r; [ | easy ].
  now apply bmat_zero_like_A_eq_Z.
}
destruct i; [ | flia Hi ].
destruct j; cbn. {
  rewrite old_bmat_mul_1_l; [ | easy | ]. 2: {
    apply bmat_fit_for_add_IZ_A.
  }
  rewrite old_bmat_mul_1_r; [ | easy | easy | ]. 2: {
    transitivity (mA n); [ | apply bmat_fit_for_add_opp_r ].
    apply bmat_fit_for_add_IZ_A.
  }
  rewrite bmat_add_0_l; [ | easy ].
  rewrite bmat_add_opp_r; [ | easy | easy ].
  rewrite bmat_nat_mul_l_succ; [ | easy ].
  rewrite fold_Z_2_pow.
  rewrite bmat_nat_mul_0_r; [ | easy ].
  rewrite old_bmat_add_0_r; [ | easy | easy ].
  now apply bmat_zero_like_A_eq_Z.
}
destruct j; [ cbn | flia Hj ].
rewrite old_bmat_mul_1_l; [ | easy | easy ].
rewrite bmat_mul_sqr_opp; [ | easy | easy | easy | apply A_is_square_bmat ].
rewrite bmat_nat_mul_l_succ; [ | easy ].
rewrite <- IHn.
rewrite bmat_zero_like_A_eq_Z.
rewrite old_bmat_add_0_l; [ | easy | apply bmat_fit_for_add_IZ_IZ ].
apply bmat_add_comm; [ easy | ].
transitivity (mA n). 2: {
  apply (is_square_bmat_fit_for_add (sizes_of_bmatrix (mA n))). {
    apply A_is_square_bmat.
  }
  apply is_square_bmat_loop_mul; apply A_is_square_bmat.
}
apply bmat_fit_for_add_IZ_A.
Qed.

Fixpoint first_non_zero_in_col (M : matrix T) it i j :=
  match it with
  | 0 => None
  | S it' =>
      if srng_eq_dec (mat_el M i j) 0 then
        first_non_zero_in_col M it' (i + 1) j
      else Some i
  end.

Theorem first_non_zero_Some : ∀ M it i j k,
  first_non_zero_in_col M it i j = Some k
  → k < i + it ∧
    (∀ h, i ≤ h < k → mat_el M h j = 0%Srng) ∧
    mat_el M k j ≠ 0%Srng.
Proof.
intros * Hk.
revert i j k Hk.
induction it; intros; [ easy | cbn ].
cbn in Hk.
destruct (srng_eq_dec (mat_el M i j) 0) as [Hmz| Hmz]. {
  specialize (IHit _ _ _ Hk) as H1.
  destruct H1 as (H1 & H2 & H3).
  rewrite <- Nat.add_assoc in H1.
  split; [ easy | ].
  split; [ | easy ].
  intros h Hh.
  destruct (Nat.eq_dec i h) as [Hih| Hih]; [ now subst h | ].
  apply H2; flia Hh Hih.
}
injection Hk; intros; subst k.
split; [ flia | ].
split; [ flia | easy ].
Qed.

Theorem first_non_zero_None : ∀ M it i j,
  mat_nrows M ≤ i + it
  → first_non_zero_in_col M it i j = None
  → ∀ h, i ≤ h < mat_nrows M → mat_el M h j = 0%Srng.
Proof.
intros * Hm Hz h Hh.
revert i j h Hz Hh Hm.
induction it; intros; [ flia Hh Hm | ].
cbn in Hz.
destruct (srng_eq_dec (mat_el M i j) 0) as [Hmz| Hmz]; [ | easy ].
destruct (Nat.eq_dec i h) as [Hih| Hih]; [ now subst h | ].
apply (IHit (i + 1)); [ easy | flia Hh Hih | flia Hm ].
Qed.

(* Matrix operator, swapping the rows i1 and i2 of a matrix.

   When multiplying this matrix with another matrix, it returns that
   other matrix where the rows i1 and i2 are swapped
     It is the identity matrix where the 1s at (i1,i1) and (i2,i2)
   are replaced by 0s, and the 0s at (i1,i2) and (i2,i1) are replaced
   by 1s.
     Example swapping rows 1 and 2 (indices start at 0) of a 5×5
   matrix
     1 0 0 0 0
     0 0 1 0 0
     0 1 0 0 0
     0 0 0 1 0
     0 0 0 0 1

   Works even if i1=i2; in that case it is the identity matrix *)

(* perhaps should be defined with "mat_swap_rows" of Matrix.v *)
Definition mat_id_swap_rows sz i1 i2 :=
  mk_mat
    (λ i j,
     if Nat.eq_dec i i1 then if Nat.eq_dec j i2 then 1%Srng else 0%Srng
     else if Nat.eq_dec i i2 then if Nat.eq_dec j i1 then 1%Srng else 0%Srng
     else if Nat.eq_dec i j then 1%Srng else 0%Srng)
    sz sz.

(* Matrix operator, multiplying row k of a matrix by a scalar s

   When multiplying this matrix with another matrix, it returns that
   other matrix where all coefficients in row k are multiplied by s.
     It is the identity matrix where the 1 at (k,k) is replaced by s.
     Example for row 3 (staring at 0) of a 5x5 matrix
       1 0 0 0 0
       0 1 0 0 0
       0 0 1 0 0
       0 0 0 s 0
       0 0 0 0 1
*)

(* perhaps redundant; see Matrix.v *)
Definition mat_id_mul_row_by_scal sz k s :=
  mk_mat
    (λ i j,
     if Nat.eq_dec i j then if Nat.eq_dec i k then s else 1%Srng
     else 0%Srng)
    sz sz.

Arguments mat_id_mul_row_by_scal sz k s%F.

(* Matrix operator, subtracting, to all rows k but row i, the row i multiplied
   by the coefficient in (k,j).

     When multiplying this matrix with another matrix, it returns that
   other matrix where all rows k (but row i) are replaced by themselves
   minus the value in row k of the same column times the value in (k,j).

     Example for row 2 column 4 where "*" contains the opposite of
   the value in the other matrix at its column 4
     1 0 * 0 0
     0 1 * 0 0
     0 0 1 0 0
     0 0 * 1 0
     0 0 * 0 1
*)

(* perhaps redundant; see Matrix.v *)
Definition mat_id_add_rows_mul_scal_row M i j :=
  mk_mat
    (λ i' j',
     if Nat.eq_dec i' j' then 1%Srng
     else if Nat.eq_dec j' i then (- mat_el M i' j)%Rng
     else 0%Srng)
   (mat_nrows M) (mat_nrows M).

(* Gauss-Jordan elimination *)

Definition gauss_jordan_step_op M i j k :=
  (mat_id_swap_rows (mat_nrows M) i k *
   mat_id_add_rows_mul_scal_row M k j *
   mat_id_mul_row_by_scal (mat_nrows M) k (/ mat_el M k j))%M.

Fixpoint gauss_jordan_loop (M : matrix T) i j it :=
  match it with
  | 0 => M
  | S it' =>
      match first_non_zero_in_col M (mat_nrows M - i) i j with
      | Some k =>
          let M' := (gauss_jordan_step_op M i j k * M)%M in
          gauss_jordan_loop M' (i + 1) (j + 1) it'
      | None =>
          gauss_jordan_loop M i (j + 1) it'
      end
  end.

Definition gauss_jordan (M : matrix T) :=
  gauss_jordan_loop (M : matrix T) 0 0 (mat_ncols M).

(* version returning the list of matrices whose product is the
   gauss-jordan elimination of the initial matrix *)

Definition gauss_jordan_step_list M i j k :=
  [mat_id_swap_rows (mat_nrows M) i k;
   mat_id_add_rows_mul_scal_row M k j;
   mat_id_mul_row_by_scal (mat_nrows M) k (/ mat_el M k j)%F].

Fixpoint gauss_jordan_list_loop (M : matrix T) i j it :=
  match it with
  | 0 => []
  | S it' =>
      match first_non_zero_in_col M (mat_nrows M - i) i j with
      | Some k =>
          let ml := gauss_jordan_step_list M i j k in
          let M' := fold_right mat_mul M ml in
          (i, j, k) :: gauss_jordan_list_loop M' (i + 1) (j + 1) it'
      | None =>
          gauss_jordan_list_loop M i (j + 1) it'
      end
  end.

Definition gauss_jordan_list (M : matrix T) :=
  gauss_jordan_list_loop M 0 0 (mat_ncols M).

Definition gauss_jordan' (M : matrix T) :=
  fold_left
    (λ A '(i, j, k),
     let ml := gauss_jordan_step_list A i j k in
     fold_right mat_mul A ml)
    (gauss_jordan_list M) M.

Theorem gauss_jordan_list_loop_gauss_jordan_loop : ∀ M i j it,
  fold_left
    (λ (A : matrix T) '(i, j, k),
       fold_right mat_mul A (gauss_jordan_step_list A i j k))
    (gauss_jordan_list_loop M i j it) M =
  gauss_jordan_loop M i j it.
Proof.
intros.
revert M i j.
induction it; intros; [ easy | ].
cbn - [ gauss_jordan_step_list ].
remember (first_non_zero_in_col M (mat_nrows M - i) i j) as k eqn:Hk.
symmetry in Hk.
destruct k as [k| ]; [ | apply IHit ].
cbn - [ gauss_jordan_step_list ].
rewrite IHit.
unfold gauss_jordan_step_op.
f_equal; cbn.
rewrite mat_mul_assoc; [ | easy | easy ].
now apply mat_mul_assoc.
Qed.

Theorem gauss_jordan_list_gauss_jordan : ∀ (M : matrix T),
  gauss_jordan' M = gauss_jordan M.
Proof.
intros.
unfold gauss_jordan', gauss_jordan.
unfold gauss_jordan_list.
apply gauss_jordan_list_loop_gauss_jordan_loop.
Qed.

(* matrix whose k-th column is replaced by a vector *)

Definition mat_repl_vect k (M : matrix T) V :=
  mk_mat (λ i j, if Nat.eq_dec j k then vect_el V i else mat_el M i j)
    (mat_nrows M) (mat_ncols M).

(* resolve a system of n equations with n variables whose determinant
   is not zero; Cramer's method *)

Definition resolve_system (M : matrix T) (V : vector T) :=
  map (λ j, (determinant (mat_repl_vect j M V) / determinant M)%F)
    (seq 0 (mat_ncols M)).

(* closing the section and re-open it in order to generalize 'resolve_system'
   to any field T *)

End in_ring.

Arguments mat_id_swap_rows {T so}.
Arguments first_non_zero_in_col {T so sdp} M%M.
Arguments gauss_jordan_step_list {T so ro fo}.
Arguments gauss_jordan_step_op {T so ro fo}.
Arguments resolve_system {T so ro fo}.

Section in_field.

Context {T : Type}.
Context {ro : ring_op T}.
Context (so : semiring_op T).
Context {sp : semiring_prop T}.
Context {rp : ring_prop T}.
Context {scp : sring_comm_prop T}.
Context {sdp : sring_dec_prop T}.
Context {fo : field_op T}.
Context {fp : field_prop T}.

(* resolving a system of n equations with n variables even
   in the case when the determinant is 0 *)
(* returns one only solution (if any); to return the set of solutions,
   we must build a field holding constants a, b, c, etc.; polynomials
   could help but we need polynomials with several variables *)

Fixpoint resolve_loop n (M : matrix T) (V : vector T) :=
  match n with
  | 0 => []
  | S n' =>
      if srng_eq_dec (determinant M) 0%Srng then
        let MV := mat_vect_concat M V in
        let A := gauss_jordan MV in
        (* deletion last row which, normally, contains only zeros
           and the last variable is given the value 1 *)
        let B := mk_mat (mat_el A) (mat_nrows M - 1) (mat_ncols M - 1) in
        let U :=
          let rhs :=
            mk_vect (vect_el (vect_of_mat_col A (mat_ncols M)))
              (mat_nrows M - 1)
          in
          let last_col :=
            mk_vect (vect_el (vect_of_mat_col A (mat_ncols M - 1)))
              (mat_nrows M - 1)
          in
          vect_sub rhs last_col
        in
        resolve_loop n' B U ++ [1%Srng]
      else
        (* resolve for example by Cramer the system of equations Mx=V *)
        resolve_system M V
  end.

Definition resolve (M : matrix T) V :=
  vect_of_list 0%Srng (resolve_loop (mat_nrows M) M V).

(* pivot *)

Fixpoint pivot_index_loop (M : matrix T) i j it :=
  match it with
  | 0 => j
  | S it' =>
      if srng_eq_dec (mat_el M i j) 0 then pivot_index_loop M i (j + 1) it'
      else j
  end.

Definition pivot_index (M : matrix T) i :=
  pivot_index_loop M i 0 (mat_ncols M).

Definition pivot (M : matrix T) i :=
  mat_el M i (pivot_index M i).

Theorem fold_pivot : ∀ M i,
  mat_el M i (pivot_index M i) = pivot M i.
Proof. easy. Qed.

(* row echelon form *)
(* a matrix is in row echelon form if the pivot shifts at each row *)

Definition in_row_echelon_form (M : matrix T) :=
  ∀ i, i < mat_nrows M - 1 → pivot_index M (i + 1) < mat_ncols M →
  pivot_index M i < pivot_index M (i + 1).

(* reduced row echelon form *)
(* a matrix is in reduced row echelon form if
   1/ it is in row echelon form
   2/ the column of pivots hold 1 at pivot and 0 everywhere else
*)

Definition in_reduced_row_echelon_form (M : matrix T) :=
  in_row_echelon_form M ∧
  (∀ i, i < mat_nrows M → ∀ k, k < mat_nrows M →
   pivot_index M i < mat_ncols M
   → mat_el M k (pivot_index M i) = if Nat.eq_dec k i then 1%Srng else 0%Srng).

(* proof that Gauss-Jordan algorithm returns a matrix in row
   echelon form *)

Theorem gauss_jordan_step_op_nrows : ∀ M i j k,
  mat_nrows (gauss_jordan_step_op M i j k) = mat_nrows M.
Proof. easy. Qed.

Theorem gauss_jordan_step_op_ncols : ∀ M i j k,
  mat_ncols (gauss_jordan_step_op M i j k) = mat_nrows M.
Proof. easy. Qed.

Theorem gauss_jordan_loop_nrows : ∀ M i j it,
  mat_nrows (gauss_jordan_loop M i j it) = mat_nrows M.
Proof.
intros.
revert M i j.
induction it; intros; [ easy | ].
cbn - [ gauss_jordan_step_op ].
remember (first_non_zero_in_col _ _ _ _) as k eqn:Hk.
symmetry in Hk.
destruct k as [k| ]. {
  rewrite IHit.
  rewrite mat_mul_nrows.
  apply gauss_jordan_step_op_nrows.
}
apply IHit.
Qed.

Theorem gauss_jordan_loop_ncols : ∀ M i j it,
  mat_ncols (gauss_jordan_loop M i j it) = mat_ncols M.
Proof.
intros.
revert M i j.
induction it; intros; [ easy | ].
cbn - [ gauss_jordan_step_op ].
remember (first_non_zero_in_col _ _ _ _) as k eqn:Hk.
symmetry in Hk.
destruct k as [k| ]. {
  rewrite IHit.
  apply mat_mul_ncols.
}
apply IHit.
Qed.

Theorem gauss_jordan_nrows : ∀ M,
  mat_nrows (gauss_jordan M) = mat_nrows M.
Proof.
intros.
apply gauss_jordan_loop_nrows.
Qed.

Theorem gauss_jordan_ncols : ∀ M,
  mat_ncols (gauss_jordan M) = mat_ncols M.
Proof.
intros.
apply gauss_jordan_loop_ncols.
Qed.

Theorem mat_swap_row_mul_l_lemma : ∀ M i j sz,
  i < sz
  → (Σ (k = 0, sz - 1), (if Nat.eq_dec k i then 1 else 0) * mat_el M k j)%Rng
    = mat_el M i j.
Proof.
intros * His.
rewrite (srng_summation_split _ i); [ | flia His ].
rewrite srng_summation_split_last; [ | flia His ].
rewrite all_0_srng_summation_0; [ | easy | ]. 2: {
  intros k Hk.
  destruct (Nat.eq_dec (k - 1) i) as [H| H]; [ flia Hk H | clear H ].
  apply srng_mul_0_l.
}
rewrite srng_add_0_l.
destruct (Nat.eq_dec i i) as [H| H]; [ clear H | easy ].
rewrite srng_mul_1_l.
rewrite all_0_srng_summation_0; [ | easy | ]. 2: {
  intros k Hk.
  destruct (Nat.eq_dec k i) as [H| H]; [ flia Hk H | clear H ].
  apply srng_mul_0_l.
}
apply srng_add_0_r.
Qed.

Theorem mat_id_swap_rows_mul_l : ∀ M sz i1 i2,
  sz = mat_nrows M
  → i1 < sz
  → i2 < sz
  → (mat_id_swap_rows sz i1 i2 * M)%M = mat_swap_rows M i1 i2.
Proof.
intros * Hsz Hi1s Hi2s.
apply matrix_eq; [ easy | easy | ].
cbn - [ Nat.eq_dec iter_seq ].
intros i j Hi Hj.
destruct (Nat.eq_dec i i1) as [Hii1| Hii1]. {
  now apply mat_swap_row_mul_l_lemma.
}
destruct (Nat.eq_dec i i2) as [Hii2| Hii2]. {
  now apply mat_swap_row_mul_l_lemma.
}
rewrite (srng_summation_split _ i); [ | flia Hi ].
rewrite srng_summation_split_last; [ | flia ].
destruct (Nat.eq_dec i i) as [H| H]; [ clear H | flia H ].
rewrite srng_mul_1_l.
rewrite all_0_srng_summation_0; [ | easy | ]. 2: {
  intros k Hk.
  destruct (Nat.eq_dec i (k - 1)) as [H| H]; [ flia Hk H | clear H ].
  apply srng_mul_0_l.
}
rewrite srng_add_0_l.
rewrite all_0_srng_summation_0; [ | easy | ]. 2: {
  intros k Hk.
  destruct (Nat.eq_dec i k) as [H| H]; [ flia Hk H | clear H ].
  apply srng_mul_0_l.
}
apply srng_add_0_r.
Qed.

(* Multiplicative factor for computing determinant from gauss-jordan form.
   We have
      det (M) = this_mult_fact * det (gauss_jordan M)
   We know that the determinant of a gauss_jordan form is 1 or 0.
 *)

Fixpoint det_mult_fact_from_gjl_loop (M : matrix T) i j it :=
  match it with
  | 0 => 1%Srng
  | S it' =>
      match first_non_zero_in_col M (mat_nrows M - i) i j with
      | Some k =>
          let ml := gauss_jordan_step_list M i j k in
          let M' := fold_right mat_mul M ml in
          let v :=
            ((if Nat.eq_dec i k then 1 else (- (1))) * mat_el M k j)%Rng
          in
          (v * det_mult_fact_from_gjl_loop M' (S i) (S j) it')%Srng
      | None =>
          det_mult_fact_from_gjl_loop M i (S j) it'
      end
  end.

Definition det_mult_fact_from_gjl M :=
  det_mult_fact_from_gjl_loop M 0 0 (mat_ncols M).

(* *)

Theorem resolved_with_det_neq_0 : ∀ M V R,
  is_square_mat M
  → mat_nrows M = vect_nrows R
  → determinant M ≠ 0%F
  → V = vect_of_list 0%F (resolve_system M R)
  → (M · V)%V = R.
Proof.
intros * Hsm Hmr Hdz Hv.
unfold is_square_mat in Hsm.
unfold resolve_system in Hv.
unfold mat_mul_vect_r.
apply vector_eq; [ easy | ].
cbn - [ iter_seq ].
intros i Hi.
subst V.
cbn - [ iter_seq ].
erewrite srng_summation_eq_compat. 2: {
  intros j Hj.
  rewrite (List_map_nth_in _ 0); [ | rewrite seq_length; flia Hsm Hi Hj ].
  rewrite seq_nth; [ | flia Hsm Hi Hj ].
  rewrite Nat.add_0_l.
  easy.
}
cbn - [ iter_seq ].
(* should try to replace both determinants by a version going through
   column i0 instead of row 0: this way the sub-determinants are the
   same. *)
(* but in that case, I need that a determinant going through any row
   or any column are equal to the determinant I defined (going through
   the first row; I started that in Matrix.v, but I am blocked *)
(* well, I don't really need this theorem since my problem is about
   matrices the discriminants of which are equal to zero *)
(* but I wanted to prove it anyway, for the sport; I thought it was
   easy but it is not *)
Abort. (* for the moment
...
*)

Theorem resolved : ∀ M V R,
  is_square_mat M
  → mat_nrows M = vect_nrows R
  → V = resolve M R
  → (M · V)%V = R.
Proof.
intros * Hsm Hrr Hv.
unfold is_square_mat in Hsm.
unfold resolve in Hv.
remember (mat_nrows M) as r eqn:Hr; symmetry in Hr.
destruct r. {
  cbn in Hv.
  subst V.
  unfold mat_mul_vect_r.
  destruct R as (fr, rr).
  cbn in Hrr; subst rr; rewrite Hr.
  now apply vector_eq.
}
rename Hr into Hmr.
symmetry in Hsm, Hrr.
cbn in Hv.
destruct (srng_eq_dec (determinant M) 0) as [Hdz| Hdz]. 2: {
Abort. (* for the moment...
  apply resolved_with_det_neq_0.
...
remember (gauss_jordan_loop (mat_vect_concat M R) 0 0 (mat_ncols M + 1))
  as MGJ eqn:Hmgj.
remember
  {| mat_el :=
       mat_el (gauss_jordan_loop (mat_vect_concat M R) 0 0 (mat_ncols M + 1));
     mat_nrows := mat_nrows M - 1;
     mat_ncols := mat_ncols M - 1 |}
  as A eqn:Ha.
remember {|
             vect_el := λ i : nat,
                          mat_el
                            (gauss_jordan_loop (mat_vect_concat M R) 0 0
                               (mat_ncols M + 1)) i
                            (mat_ncols M);
             vect_nrows := mat_nrows M - 1 |} as Vrhs eqn:Hvrhs.
remember {|
             vect_el := λ i : nat,
                          mat_el
                            (gauss_jordan_loop (mat_vect_concat M R) 0 0
                               (mat_ncols M + 1)) i
                            (mat_ncols M - 1);
             vect_nrows := mat_nrows M - 1 |} as Vlast eqn:Hvlast.
Print resolve_loop.
...
*)

(* Eigenvector property: the fact that V is such that MV=λV *)

Definition eval_mat_polyn M x :=
  mk_mat (λ i j, eval_polyn (mat_el M i j) x) (mat_nrows M) (mat_ncols M).

Theorem eigenvector_prop : ∀ M μ V S,
  eval_polyn (charac_polyn M) μ = 0%Srng
  → S = eval_mat_polyn (xI_sub_M M) μ
  → V = resolve S (vect_zero (mat_ncols M))
  → (M · V = μ × V)%V ∧ V ≠ vect_zero (vect_nrows V).
Proof.
intros * Hμ Hs Hv.
unfold charac_polyn in Hμ.
Abort. (* for the moment...
...
specialize (resolved Hv) as H1.
...
*)

Theorem gauss_jordan_in_reduced_row_echelon_form : ∀ (M : matrix T),
  mat_ncols M ≠ 0
  → in_reduced_row_echelon_form (gauss_jordan M).
Proof.
intros * Hcz.
(*
split. {
  unfold in_row_echelon_form.
  intros i Hi Hp.
...
  Hcz : mat_ncols M ≠ 0
  Hi : i < mat_nrows (gauss_jordan M) - 1
  Hp : pivot_index (gauss_jordan M) (i + 1) < mat_ncols (gauss_jordan M)
  ============================
  pivot_index (gauss_jordan M) i < pivot_index (gauss_jordan M) (i + 1)
*)
split. 2: {
  intros i Hi k Hk Hp.
  move k before i.
  rewrite gauss_jordan_nrows in Hi, Hk.
  rewrite gauss_jordan_ncols in Hp.
  destruct (Nat.eq_dec k i) as [Hki| Hki]. {
    subst i; clear Hi.
    rewrite <- gauss_jordan_list_gauss_jordan in Hp |-*; cycle 1. {
      easy.
    } {
      easy.
    } {
      easy.
Abort. (* for the moment...
...
(*trying to prove it just for the upper left number of the matrix*)
destruct k. {
  unfold gauss_jordan in Hp |-*.
  unfold pivot_index in Hp |-*.
  rewrite gauss_jordan_loop_ncols in Hp |-*.
  remember (mat_ncols M) as it eqn:Hit; symmetry in Hit.
  destruct it; [ easy | clear Hcz ].
  cbn - [ gauss_jordan_step_op ] in Hp |-*.
  rewrite Nat.sub_0_r in Hp |-*.
  remember (first_non_zero_in_col _ _ _ _) as k1 eqn:Hk1.
  symmetry in Hk1.
  destruct k1 as [k1| ]. {
    remember (gauss_jordan_loop _ _ _ _) as A eqn:Ha.
    destruct (srng_eq_dec (mat_el A 0 0) 0) as [Hmz| Hmz]. {
      unfold gauss_jordan_step_op in Ha.
      specialize (first_non_zero_prop _ _ _ _ Hk1) as (H1 & H2 & H3).
      cbn in H1.
...
      remember (multiply_row_by_scalar _ _ _ _) as A' eqn:Ha'.
      remember (swap_rows M 0 k1) as A'' eqn:Ha''.
      assert (H4 : mat_el A'' 0 0 ≠ 0%Srng). {
        rewrite Ha''.
        cbn - [ iter_seq Nat.eq_dec ].
        rewrite srng_summation_split_first; [ | easy | flia H1 ].
        destruct (Nat.eq_dec 0 0) as [H| H]; [ clear H | easy ].
        destruct (Nat.eq_dec 0 k1) as [Hk1z| Hk1z]. {
          subst k1; rewrite srng_mul_1_l.
          rewrite all_0_srng_summation_0; [ | easy | ]. 2: {
            intros i Hi.
            destruct (Nat.eq_dec i 0) as [Hiz| Hiz]; [ flia Hi Hiz | ].
            apply srng_mul_0_l.
          }
          now rewrite srng_add_0_r.
        }
        rewrite srng_mul_0_l, srng_add_0_l.
        rewrite (srng_summation_split _ k1); [ | flia H1 ].
        rewrite srng_summation_split_last; [ | flia Hk1z ].
        destruct (Nat.eq_dec k1 k1) as [H| H]; [ clear H | easy ].
        rewrite srng_mul_1_l.
        rewrite all_0_srng_summation_0; [ | easy | ]. 2: {
          intros i Hi.
          destruct (Nat.eq_dec (i - 1) k1) as [H| H]; [ flia H Hi | ].
          apply srng_mul_0_l.
        }
        rewrite srng_add_0_l.
        rewrite all_0_srng_summation_0; [ | easy | ]. 2: {
          intros i Hi.
          destruct (Nat.eq_dec i k1) as [H| H]; [ flia H Hi | ].
          apply srng_mul_0_l.
        }
        now rewrite srng_add_0_r.
      }
      assert (H5 : mat_el A' 0 0 = 1%Srng). {
        rewrite Ha', Ha''.
        cbn - [ iter_seq Nat.eq_dec ].
...
        apply fld_mul_inv_l.
        rewrite srng_summation_split_first; [ | easy | flia H1 ].
        destruct (Nat.eq_dec 0 0) as [H| H]; [ clear H | easy ].
...
        rewrite srng_mul_0_l, srng_add_0_l.
        erewrite srng_summation_eq_compat; [ | easy | ]. 2: {
          intros i Hi.
          destruct (Nat.eq_dec 0 i) as [H| H]; [ flia Hi H | clear H ].
          easy.
        }
        cbn - [ iter_seq Nat.eq_dec ].
        rewrite (srng_summation_split _ k1); [ | flia H1 ].
        destruct (Nat.eq_dec k1 0) as [Hk1z| Hk1z]. {
          exfalso; subst k1.
          (* mmm... pas si simple *)
...
        apply (first_non_zero_prop _ _ _ _ Hk1).
      }
      move Hmz at bottom.
      (* normalement, contradiction entre H4 et Hmz
         parce que gauss_jordan_loop ne modifie pas
         mat_el A' 0 0 *)
      rewrite Ha in Hmz.
      specialize (List_app_fold_left) as H5.
      specialize (H5 nat (matrix T) T A').
      specialize (H5 (seq 0 (mat_nrows M))).
      remember (λ (B : matrix T) (i' : nat),
               if Nat.eq_dec i' 0
               then B
               else
                add_one_row_scalar_multiple_another so B i'
                  (- mat_el B i' 0)%F 0) as f eqn:Hf.
      specialize (H5 f).
      specialize (H5 (λ A', mat_el (gauss_jordan_loop A' 1 1 it) 0 0)).
      cbn in H5.
      rewrite H5 in Hmz; [ clear H5 | ]. 2: {
        intros A''' i Hi.
        rewrite Hf.
        destruct (Nat.eq_dec i 0) as [Hiz| Hiz]; [ easy | ].
        destruct i; [ easy | clear Hiz ].
Theorem glop : ∀ A i j it,
  mat_el (gauss_jordan_loop A (S i) (S j) it) 0 0 = mat_el A 0 0.
Proof.
intros.
revert i j A.
induction it; intros; [ easy | ].
cbn - [ gauss_jordan_step ].
remember (first_non_zero_in_col A (mat_nrows A - S i) (S i) (S j)) as k eqn:Hk.
symmetry in Hk.
destruct k as [k| ]; [ | apply IHit ].
rewrite IHit.
unfold gauss_jordan_step.
rewrite multiply_row_by_scalar_nrows.
rewrite swap_rows_nrows.
remember (swap_rows _ _ _) as A' eqn:Ha'.
remember (multiply_row_by_scalar _ _ _ _) as A'' eqn:Ha''.
move A'' before A'.
remember (mat_nrows A) as r eqn:Hr; symmetry in Hr.
destruct r; [ easy | ].
rewrite <- (Nat.add_1_l r).
rewrite seq_app.
rewrite fold_left_app; cbn.
remember (add_one_row_scalar_multiple_another _ _ _ _ _) as A''' eqn:Ha'''.
move A''' before A''.
...
rewrite List_app_fold_left with
  (g := (λ f b c a, f a b c) (mat_el (T := T)) 0 0). 2: {
  intros A'''' i' Hi'.
  destruct (Nat.eq_dec i' (S i)) as [Hii| Hii]; [ easy | ].
  destruct i'. {
    cbn.
    rewrite <- srng_add_0_r.
    f_equal.
...
(*end trying to prove it for the upper left number of the matrix*)
...
    unfold gauss_jordan in Hp |-*.
    unfold pivot_index in Hp |-*.
    rewrite gauss_jordan_loop_ncols in Hp |-*.
    remember (mat_ncols M) as it eqn:Hit; symmetry in Hit.
    destruct it; [ easy | clear Hcz ].
    cbn - [ gauss_jordan_step ] in Hp |-*.
    rewrite Nat.sub_0_r in Hp |-*.
    remember (first_non_zero_in_col _ _ _ _) as k1 eqn:Hk1.
    symmetry in Hk1.
    destruct k1 as [k1| ]. {
      remember (gauss_jordan_loop _ _ _ _) as A eqn:Ha.
      destruct (srng_eq_dec (mat_el A k 0) 0) as [Hmz| Hmz]. {
        destruct it; [ cbn in Hp; flia Hp | ].
        cbn in Hp |-*.
        destruct (srng_eq_dec (mat_el A k 1) 0) as [Hm1z| Hm1z]. {
          destruct it; [ cbn in Hp; flia Hp | ].
          cbn in Hp |-*.
          destruct (srng_eq_dec (mat_el A k 2) 0) as [Hm2z| Hm2z]. {
            destruct it; [ cbn in Hp; flia Hp | ].
            cbn in Hp |-*.
            destruct (srng_eq_dec (mat_el A k 3) 0) as [Hm3z| Hm3z]. {
...
            }
            rewrite Ha.
            remember (S (S it)) as sit eqn:Hsit.
            cbn - [ gauss_jordan_step ].
            rewrite gauss_jordan_step_nrows.
            remember (gauss_jordan_step so M 0 0 k1) as A' eqn:Ha'.
            remember (first_non_zero_in_col A' _ 1 1) as k2 eqn:Hk2.
            symmetry in Hk2.
            move k2 before k1.
            move Hk2 before Hk1.
            move A before M; move A' before A.
            destruct k2 as [k2| ]. {
              remember (gauss_jordan_step so A' _ _ _) as A2 eqn:Ha2.
              remember (gauss_jordan_loop A2 _ _ _) as A'2 eqn:Ha'2.
              move A2 before A'; move A'2 before A2.
              move Ha2 before Ha; move Ha'2 before Ha2.
clear Hp.
rewrite Hsit in Ha'2.
(*
...
  Ha'2 : A'2 = gauss_jordan_loop A2 2 2 (S (S it))
  ============================
  mat_el A'2 k 3 = 1%F
...
*)
Theorem glop : ∀ A A' k j it i,
   A = gauss_jordan_loop A' i i (it + j)
  → pivot_index_loop A k (S j) it < it + S j
  → mat_el A k (pivot_index_loop A k (S j) it) = 1%Srng.
Proof.
intros A * Ha Hp.
revert A A' k j i Ha Hp.
induction it; intros A A' k j i Ha Hp; [ cbn in Hp; flia Hp | ].
cbn in Hp |-*.
destruct (srng_eq_dec (mat_el A k (S j)) 0) as [Hmjz| Hmjz]. {
  apply IHit with (A' := A') (i := i); [ | flia Hp ].
  now replace (it + (j + 1)) with (S it + j) by flia.
}
clear Hp.
cbn - [ gauss_jordan_step ] in Ha.
rewrite Ha.
remember (first_non_zero_in_col A' (mat_nrows A' - i) i i) as k1 eqn:Hk1.
symmetry in Hk1.
destruct k1 as [k1| ]. {
  remember (gauss_jordan_step so A' i i k1) as A'' eqn:Ha''.
  specialize (IHit A A'' 42 j (i + 1) Ha) as H1.
(* ouais, c'pas clair... *)
...
  Hmjz : mat_el A k (S j) ≠ 0%F
  ============================
  mat_el A k (S j) = 1%F
...
    subst k; clear Hk.
    unfold gauss_jordan.
    remember (mat_ncols M) as c eqn:Hc; symmetry in Hc.
    destruct c; [ easy | clear Hcz ].
    cbn - [ gauss_jordan_step ].
    rewrite Nat.sub_0_r.
    remember (mat_nrows M) as r eqn:Hr; symmetry in Hr.
    move Hr after Hc.
    destruct r; [ easy | ].
    cbn - [ gauss_jordan_step ].
    destruct (srng_eq_dec (mat_el M 0 0) 0) as [Hmz| Hmz]. {
      remember (first_non_zero_in_col _ _ _ _) as k eqn:Hk.
      symmetry in Hk.
      destruct k as [k| ]. {
        remember (gauss_jordan_loop _ _ _ _) as A eqn:HA.
        revert M A c i k Hi Hr Hc Hmz Hk HA.
        induction r; intros; [ easy | ].
        rename A0 into A.
        cbn in Hk.
        destruct (srng_eq_dec (mat_el M 1 0) 0) as [Hm1z| Hm1z]. {
          destruct i. {
            clear IHr Hi.
...
*)

Arguments mA {T so ro}.

(*
Check mat_of_list_list.
About bmat_el.
Check mat_of_squ_bmat.
Check mA.
Require Import ZArith Zring.
Open Scope Z.
Existing Instance Z_semiring_op.
Existing Instance Z_ring_op.
Definition glop n := list_list_of_mat (mat_of_squ_bmat (mA n)).
Definition glip n := list_list_of_mat (mat_of_squ_bmat (bmat_merge_fst_2_layers (mA n))).
Compute glop 3.
Compute glip 3.
*)

Fixpoint srng_of_nat n :=
  match n with
  | 0 => 0%Srng
  | S n' => (1 + srng_of_nat n')%Srng
  end.

(* A² = nI in matrices (instead of block matrices) *)
Theorem lemma_2_A_n_2_eq_n_I' : ∀ n,
  (mat_of_squ_bmat (mA n) * mat_of_squ_bmat (mA n) =
   srng_of_nat n × mat_of_squ_bmat (I_2_pow n))%M.
Proof.
intros.
specialize (lemma_2_A_n_2_eq_n_I n) as H1.
...
(* I though I could use this theorem, started in BlockMat.v
   but I cannot finish it up. Anyway, I am not sure it would
   resolve the problem; it could add one step, but afterwards?
   I have to think of it
Theorem mat_of_squ_bmat_mul : ∀ A B,
  is_square_bmat A
  → is_square_bmat B
  → sizes_of_bmatrix A = sizes_of_bmatrix B
  → mat_of_squ_bmat (A * B) = (mat_of_squ_bmat A * mat_of_squ_bmat B)%M.
...
*)

(* here, I would like to prove that, knowing that An^2 = nI, the
   eigenvalues of An are √n and -√n, as the Lemma 2.2. claims *)

Theorem A_eigenvalue : ∀ n μ,
  (μ * μ = srng_of_nat n)%Rng
  → ∃ V,
      V ≠ vect_zero (vect_nrows V) ∧
      (mat_of_squ_bmat (mA n) · V = μ × V)%V.
Proof.
intros * Hμ2n.
specialize (lemma_2_A_n_2_eq_n_I' n) as H1.
...

End in_field.


(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2021                                          *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

Require Import Bool OrderedType.

(** This file defines a number of typeclasses which are useful to build the
    terms of SMT (in particular arrays indexed by instances of these
    classes). *)

(** Boolean equality to decidable equality *)
Definition eqb_to_eq_dec :
  forall T (eqb : T -> T -> bool) (eqb_spec : forall x y, eqb x y = true <-> x = y) (x y : T),
    { x = y } + { x <> y }.
  intros.
  case_eq (eqb x y); intro.
  left. apply eqb_spec; auto.
  right. red. intro. apply eqb_spec in H0. rewrite H in H0. now contradict H0.
  Defined.

(** Types with a Boolean equality that reflects Leibniz equality *)
Class EqbType T := {
 eqb : T -> T -> bool;
 eqb_spec : forall x y, eqb x y = true <-> x = y
}.

(** Types with a decidable equality *)
Class DecType T := {
 eq_dec : forall x y : T, { x = y } + { x <> y }
}.

(** Types equipped with Boolean equality are decidable *)
Section EqbToDecType.
  Generalizable Variable T.
  Context `{ET : EqbType T}.

  Instance EqbToDecType : DecType T.
  Proof.
    destruct ET as [eqb0 Heqb0]. split.
    apply (eqb_to_eq_dec _ eqb0); auto.
  Defined.
End EqbToDecType.

(** Basic properties on types with Boolean equality *)
Section EqbTypeProp.
  Generalizable Variable T.
  Context `{ET : EqbType T}.

  Lemma eqb_refl x : eqb x x = true.
  Proof. now rewrite eqb_spec. Qed.

  Lemma eqb_sym x y : eqb x y = true -> eqb y x = true.
  Proof. rewrite !eqb_spec. now intros ->. Qed.

  Lemma eqb_trans x y z : eqb x y = true -> eqb y z = true -> eqb x z = true.
  Proof. rewrite !eqb_spec. now intros ->. Qed.

  Lemma eqb_spec_false x y : eqb x y = false <-> x <> y.
  Proof.
    split.
    - intros H1 H2. subst y. rewrite eqb_refl in H1. inversion H1.
    - intro H. case_eq (eqb x y); auto. intro H1. elim H. now rewrite <- eqb_spec.
  Qed.

  Lemma reflect_eqb x y : reflect (x = y) (eqb x y).
  Proof.
    case_eq (eqb x y); intro H; constructor.
    - now rewrite eqb_spec in H.
    - now rewrite eqb_spec_false in H.
  Qed.

  Lemma eqb_sym2 x y : eqb x y = eqb y x.
  Proof.
    case_eq (eqb y x); intro H.
    - now apply eqb_sym.
    - rewrite eqb_spec_false in *. auto.
  Qed.
End EqbTypeProp.

(** Class of types with a partial order *)
Class OrdType T := {
  lt: T -> T -> Prop;
  lt_trans : forall x y z : T, lt x y -> lt y z -> lt x z;
  lt_not_eq : forall x y : T, lt x y -> x <> y
}.

Hint Resolve lt_not_eq lt_trans.

Global Instance StrictOrder_OrdType T `(OrdType T) :
  StrictOrder (lt : T -> T -> Prop).
Proof.
  split.
  unfold Irreflexive, Reflexive, complement.
  intros. apply lt_not_eq in H0; auto.
  unfold Transitive. intros x y z. apply lt_trans.
Qed.

(** Augment class of partial order with a compare function to obtain a total
    order *)
Class Comparable T {ot:OrdType T} := {
  compare : forall x y : T, Compare lt eq x y
}.

(* A Comparable type is also an EqbType *)
Section Comparable2EqbType.
  Generalizable Variable T.
  Context `{OTT : OrdType T}.
  Context `{CT : Comparable T}.

  Definition compare2eqb (x y:T) : bool :=
    match compare x y with
    | EQ _ => true
    | _ => false
    end.

  Lemma compare2eqb_spec x y : compare2eqb x y = true <-> x = y.
  Proof.
    unfold compare2eqb.
    case_eq (compare x y); simpl; intros e He; split; try discriminate;
      try (intros ->; elim (lt_not_eq _ _ e (eq_refl _))); auto.
  Qed.

  Instance Comparable2EqbType : EqbType T := Build_EqbType _ _ compare2eqb_spec.
End Comparable2EqbType.

(** Class of inhabited types *)
Class Inhabited T := {
  default_value : T
}.

(** * CompDec: Merging all previous classes *)

Class CompDec T := {
  ty := T;                      (* This is redundant for performance reasons *)
  Eqb :> EqbType ty;             (* This is redundant since implied by Comp, but it actually allows us to choose a specific equality function *)
  Ordered :> OrdType ty;
  Comp :> @Comparable ty Ordered;
  Inh :> Inhabited ty
}.

Global Instance eqbtype_of_compdec {t} `{c: CompDec t} : (EqbType t) :=
  let (_, eqb, _, _, _) := c in eqb.

Global Instance ord_of_compdec {t} `{c: CompDec t} : (OrdType t) :=
  let (_, _, ord, _, _) := c in ord.

Global Instance inh_of_compdec {t} `{c: CompDec t} : (Inhabited t) :=
  let (_, _, _, _, inh) := c in inh.

Global Instance comp_of_compdec {t} `{c: CompDec t} : @Comparable t (ord_of_compdec (t:=t)).
  destruct c; trivial.
Defined.

Definition type_compdec {ty:Type} (cd : CompDec ty) := ty.

Definition eqb_of_compdec {t} (c : CompDec t) : t -> t -> bool :=
  match eqbtype_of_compdec (t:=t) with
  | {| eqb := eqb |} => eqb
  end.

Lemma compdec_eq_eqb {T:Type} {c : CompDec T} : forall x y : T,
    x = y <-> eqb_of_compdec c x y = true.
Proof.
  intros x y. destruct c as [TY [E HE] O C I]. unfold eqb_of_compdec. simpl. now rewrite HE.
Qed.

Record typ_compdec : Type := Typ_compdec {
  te_carrier : Type;
  te_compdec : CompDec te_carrier
}.

Section CompDec_from.

  Variable T : Type.

  Variable eqb' : T -> T -> bool.
  Variable eqb'_spec : forall x y, eqb' x y = true <-> x = y.

  Variable lt' : T -> T -> Prop.
  Hypothesis lt'_trans : forall x y z : T, lt' x y -> lt' y z -> lt' x z.
  Hypothesis lt'_neq : forall x y : T, lt' x y -> x <> y.

  Variable compare': forall x y : T, Compare lt' eq x y.

  Variable d : T.

  Program Instance CompDec_from : (CompDec T) := {|
    Eqb := {| eqb := eqb'; eqb_spec := eqb'_spec |};
    Ordered := {| lt := lt'; lt_trans := lt'_trans |};
    Comp := {| compare := compare' |};
    Inh := {| default_value := d |}
  |}.

  Definition typ_compdec_from : typ_compdec :=
    Typ_compdec T CompDec_from.

End CompDec_from.


Require Import List.

Require Import option.

Definition func1 (x y:option nat) : option nat :=
    match x with
    | None      => None
    | Some n    =>
        match y with
        | None      => None
        | Some m    => Some (n + m)
        end
    end.

Definition func2 (x y:option nat) : option nat :=
    x >>= (fun n  =>
    y >>= (fun m  =>
    ret (n + m))).

Definition func3 (x y:option nat) : option nat :=
    n <- x ;
    m <- y ;
    ret (n + m).

Definition func4 (x y:option nat) : option nat :=
    n <- x ;
    m <- y ;
    ret $ n + m.

Definition sample : list ((option nat) * ( option nat)) :=
    (cons (None,None)
        (cons (Some 5, None)
            (cons (None,Some 5)
                (cons (Some 4,Some 5) nil)))).

Definition wrap (f:option nat -> option nat -> option nat) : list (option nat) :=
    map (fun x =>
            match x with
            | (u,v)     => f u v
            end) sample.

Definition test (f:option nat -> option nat -> option nat) : Prop :=
    wrap f = wrap func1.

Lemma test1 : test func1.
Proof. reflexivity. Qed.

Lemma test2 : test func2.
Proof. reflexivity. Qed.

Lemma test3 : test func3.
Proof. reflexivity. Qed.

Lemma test4 : test func4.
Proof. reflexivity. Qed.

Fixpoint even (n:nat) : bool :=
    match n with
    | 0     => true
    | S n   =>
        match n with
        | 0     => false
        | S n   => even n
        end
    end.

(* testing guards *)
Definition func5 (x y:option nat) : option nat :=
    n <- x ;
    m <- y ;
    _ <- guard (even n);
    _ <- guard (even m);
    ret (n + m).

Lemma test5 : func5 None None = None.
Proof. reflexivity. Qed.

Lemma test6 : func5 None (Some 4) = None.
Proof. reflexivity. Qed.

Lemma test7 : func5 (Some 4) None = None.
Proof. reflexivity. Qed.

Lemma test8 : func5 (Some 3) (Some 5) = None.
Proof. reflexivity. Qed.

Lemma test9 : func5 (Some 4) (Some 5) = None.
Proof. reflexivity. Qed.

Lemma test10 : func5 (Some 3) (Some 6) = None.
Proof. reflexivity. Qed.

Lemma test11 : func5 (Some 4) (Some 6) = (Some 10). (* both even *)
Proof. reflexivity. Qed.


Require Export BagsInterface.
Unset Implicit Arguments.

Open Scope list.

Section CountingListBags.

  Context {TItem : Type}
          {TUpdateTerm : Type}
          (bupdate_transform : TUpdateTerm -> TItem -> TItem).

  Record CountingList :=
    {
      clength   : nat;
      ccontents : list TItem
    }.

  Lemma empty_length :
    List.length (@nil TItem) = 0.
  Proof.
    reflexivity.
  Qed.

  Definition CountingList_empty : CountingList :=
    {|
      clength := 0;
      ccontents := @nil TItem
    |}.

  Fixpoint MatchAgainstMany
           (search_terms : list (TItem -> bool))
           (item: TItem) :=
    match search_terms with
      | nil                      => true
      | cons is_match more_terms => andb (is_match item) (MatchAgainstMany more_terms item)
    end.

  Definition CountingListAsBag_bfind
             (container: CountingList)
             (search_terms: list (TItem -> bool)) :=
    match search_terms with
      | nil                      => ccontents container
      | cons is_match more_terms => List.filter (MatchAgainstMany search_terms) (ccontents container)
    end.

  Definition CountingListAsBag_binsert
             (container: CountingList)
             (item: TItem) : CountingList :=
    {| clength := S (clength container);
       ccontents := cons item (ccontents container) |}.

  Definition CountingListAsBag_bcount
             (container: CountingList)
             (search_terms: list (TItem -> bool)) :=
    match search_terms with
      | nil => clength container
      | _   => List.fold_left (fun acc x => acc + if (MatchAgainstMany search_terms x) then 1 else 0)
                              (ccontents container) 0
    end.

  Fixpoint CountingListPartition
           (contents : list TItem)
           (search_term : TItem -> bool)
  : prod CountingList CountingList :=
    match contents with
      | nil => (CountingList_empty, CountingList_empty)
      | x :: tl => let (g,d) := CountingListPartition tl search_term in
                   if search_term x then
                     (CountingListAsBag_binsert g x, d)
                   else
                     (g, CountingListAsBag_binsert d x)
    end.

  Definition CountingListAsBag_bdelete
             (container : CountingList)
             (search_terms : list (TItem -> bool)) :=
    let (d, r) := (CountingListPartition (ccontents container) (MatchAgainstMany search_terms))
    in (ccontents d, r).

  Definition CountingListMap
             (container: CountingList)
             (update_f : TItem -> TItem)
  : CountingList :=
    {| clength := clength container;
       ccontents := List.map update_f (ccontents container) |}.

  Definition CountingListAsBag_bupdate
          (container : CountingList)
          (search_terms : list (TItem -> bool))
          (update_term : TUpdateTerm)
  :
    CountingList :=
    {| clength := clength container;
       ccontents :=
         let (g, d) := (CountingListPartition (ccontents container)
                                              (MatchAgainstMany search_terms)) in
         (ccontents d) ++ (List.map (bupdate_transform update_term) (ccontents g)) |}.

  Instance CountingListAsBag
  : Bag CountingList TItem _ _ :=
    {|

      bempty := CountingList_empty;
      bstar  := nil;
      bfind_matcher := MatchAgainstMany;
      bupdate_transform := bupdate_transform;

      benumerate := ccontents;
      bfind      := CountingListAsBag_bfind;
      binsert    := CountingListAsBag_binsert;
      bcount     := CountingListAsBag_bcount;
      bdelete    := CountingListAsBag_bdelete;
      bupdate    := CountingListAsBag_bupdate
    |}.

  Definition CountingList_RepInv (container : CountingList) :=
    List.length (ccontents container) = clength container.
  Definition CountingList_ValidUpdate (_ : TUpdateTerm) := True.

  Lemma CountingList_binsert_Preserves_RepInv :
    binsert_Preserves_RepInv CountingList_RepInv CountingListAsBag_binsert.
  Proof.
    unfold binsert_Preserves_RepInv, CountingList_RepInv;
    intros; simpl; rewrite containerCorrect; reflexivity.
  Qed.

  Lemma CountingList_bdelete_Preserves_RepInv :
    bdelete_Preserves_RepInv CountingList_RepInv CountingListAsBag_bdelete.
  Proof.
    unfold bdelete_Preserves_RepInv, CountingList_RepInv, CountingListAsBag_bdelete;
    destruct container as [n l]; revert n; induction l; intros; simpl in *; eauto.
    destruct (MatchAgainstMany search_term a); simpl.
    destruct n; simpl in *; [ discriminate | injection containerCorrect]; intros.
    pose proof (IHl n search_term H).
    destruct (CountingListPartition l (MatchAgainstMany search_term)); simpl in *; eauto.
    destruct n; simpl in *; [ discriminate | injection containerCorrect]; intros.
    pose proof (IHl n search_term H).
    destruct (CountingListPartition l (MatchAgainstMany search_term)); simpl in *; eauto.
  Qed.

  Lemma CountingListMap_consistent
        (container: CountingList)
        (cconsistent : CountingList_RepInv container)
        (update_f : TItem -> TItem)
  : length (List.map update_f (ccontents container)) = clength container.
  Proof.
    rewrite List.map_length; auto using cconsistent.
  Qed.

  Lemma CountingListAsBag_Partition_App
        (container : CountingList)
        (search_term : TItem -> bool)
        (cconsistent : CountingList_RepInv container)
  : length
      (let (g, d) :=
           CountingListPartition (ccontents container) search_term in
       ccontents d ++ ccontents g) =
    let (g, d) :=
        CountingListPartition (ccontents container) search_term in
    (clength g) + (clength d).
  Proof.
    unfold CountingList_RepInv in *.
    destruct container as [n l]; simpl; revert n cconsistent;
    induction l; simpl; intros; eauto.
    destruct (search_term a); simpl;
    destruct (CountingListPartition l search_term); simpl.
    erewrite <- IHl, !List.app_length; simpl; auto with arith.
    erewrite IHl; auto with arith.
    simpl; eauto.
  Qed.

  Lemma CountingList_bupdate_Preserves_RepInv
  : bupdate_Preserves_RepInv CountingList_RepInv CountingList_ValidUpdate CountingListAsBag_bupdate.
  Proof.
    unfold bupdate_Preserves_RepInv, CountingList_RepInv.
    destruct container as [n l]; simpl; revert n;
    induction l; simpl; intros; auto.
    erewrite <- containerCorrect; simpl; erewrite <- (IHl (length l) search_term update_term); auto.
    destruct (CountingListPartition l (MatchAgainstMany search_term)); simpl.
    destruct (MatchAgainstMany search_term a); simpl;
    rewrite List.app_length; simpl; rewrite List.map_length;
    repeat rewrite containerCorrect; auto.
    rewrite List.app_length; simpl; rewrite List.map_length;
    repeat rewrite cconsistent; auto.
  Qed.

  Lemma CountingList_BagInsertEnumerate :
      BagInsertEnumerate CountingList_RepInv ccontents CountingListAsBag_binsert.
  Proof.
    firstorder.
  Qed.

  Lemma CountingList_BagEnumerateEmpty :
    BagEnumerateEmpty ccontents CountingList_empty.
  Proof.
    firstorder.
  Qed.

  Lemma CountingList_Empty_RepInv :
    CountingList_RepInv CountingList_empty.
  Proof.
    firstorder.
  Qed.

  Lemma CountingList_BagFindStar :
      BagFindStar CountingList_RepInv CountingListAsBag_bfind ccontents nil.
  Proof.
    firstorder.
 Qed.

  Require Import AdditionalLemmas.

  Lemma CountingList_BagFindCorrect :
    BagFindCorrect CountingList_RepInv CountingListAsBag_bfind MatchAgainstMany ccontents.
  Proof.
    destruct search_term; simpl; [ rewrite filter_all_true | ]; reflexivity.
  Qed.

  Require Import Omega.
  Lemma CountingList_BagCountCorrect_aux :
    forall (container: list TItem) (search_term: list (TItem -> bool)) default,
      length (List.filter (MatchAgainstMany search_term) container) + default =
      List.fold_left
        (fun (acc : nat) (x : TItem) =>
           acc + (if MatchAgainstMany search_term x then 1 else 0))
        container default.
  Proof.
    induction container; intros.

    + trivial.
    + simpl; destruct (MatchAgainstMany search_term a);
      simpl; rewrite <- IHcontainer; omega.
  Qed.

  Lemma CountingList_BagCountCorrect :
    BagCountCorrect CountingList_RepInv CountingListAsBag_bcount CountingListAsBag_bfind.
  Proof.
    unfold BagCountCorrect, CountingListAsBag_bcount, CountingListAsBag_bfind,
    CountingList_RepInv; intros;
    pose proof (CountingList_BagCountCorrect_aux (ccontents container) search_term 0) as temp;
    rewrite plus_0_r in temp; simpl in temp.
    destruct search_term; simpl; [ apply containerCorrect | apply temp ].
  Qed.

  Lemma CountingList_BagDeleteCorrect :
      BagDeleteCorrect CountingList_RepInv CountingListAsBag_bfind MatchAgainstMany ccontents
                       CountingListAsBag_bdelete.
  Proof.
    unfold BagDeleteCorrect, CountingList_RepInv; destruct container as [n l];
    revert n; induction l; simpl; intros; split.
    + constructor.
    + constructor.
    + simpl in *; destruct (IHl _ search_term (refl_equal _)).
      unfold CountingListAsBag_bdelete in *; simpl in *.
      destruct (MatchAgainstMany search_term a);
        destruct (CountingListPartition l (MatchAgainstMany search_term));
        destruct (List.partition (MatchAgainstMany search_term) l); simpl; auto.
    +  simpl in *; destruct (IHl _ search_term (refl_equal _)).
      unfold CountingListAsBag_bdelete in *; simpl in *.
      destruct (MatchAgainstMany search_term a);
        destruct (CountingListPartition l (MatchAgainstMany search_term));
        destruct (List.partition (MatchAgainstMany search_term) l); simpl; auto.
  Qed.

  Lemma CountingList_BagUpdateCorrect :
    BagUpdateCorrect CountingList_RepInv CountingList_ValidUpdate
                     CountingListAsBag_bfind MatchAgainstMany ccontents
                     bupdate_transform CountingListAsBag_bupdate.
  Proof.
    unfold BagUpdateCorrect, CountingList_RepInv; destruct container as [n l];
    revert n; induction l; simpl; intros.
    constructor.
    simpl in *; pose proof (IHl _ search_term update_term (refl_equal _) ).
    unfold CountingListAsBag_bdelete in *; simpl in *.
    destruct (MatchAgainstMany search_term a);
      destruct (CountingListPartition l (MatchAgainstMany search_term));
      destruct (List.partition (MatchAgainstMany search_term) l); simpl in *; auto.
    rewrite Permutation_app_comm; simpl.
    apply Permutation_cons_app; rewrite Permutation_app_comm; auto.
  Qed.

  Instance CountingListAsCorrectBag
  : CorrectBag CountingList_RepInv CountingList_ValidUpdate CountingListAsBag :=
    {|
       bempty_RepInv     := CountingList_Empty_RepInv;
       binsert_RepInv    := CountingList_binsert_Preserves_RepInv;
       bdelete_RepInv    := CountingList_bdelete_Preserves_RepInv;
       bupdate_RepInv    := CountingList_bupdate_Preserves_RepInv;

       binsert_enumerate := CountingList_BagInsertEnumerate;
       benumerate_empty  := CountingList_BagEnumerateEmpty;
       bfind_star        := CountingList_BagFindStar;
       bfind_correct     := CountingList_BagFindCorrect;
       bcount_correct    := CountingList_BagCountCorrect;
       bdelete_correct   := CountingList_BagDeleteCorrect;
       bupdate_correct   := CountingList_BagUpdateCorrect
    |}.

End CountingListBags.


Require Import Ring.
Require Import ArithRing.

Ltac ring_simplify_neq :=
  match goal with
  | [ H: ?X <> ?Y |- _ ] => progress ring_simplify X Y in H
  end.

Lemma toto : forall x y, x*1 <> y*1 -> y*1 <> x*1 -> x<>y.
Proof.
  intros.
  ring_simplify_neq.
  ring_simplify_neq.
  (* make sure ring_simplify has simplified both hypotheses *)
  match goal with
  | [ H: context[_*1] |- _ ] => fail 1
  | _ => idtac
  end.
  auto.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool ssrint eqtype ssrnat seq choice fintype rat finfun.
From mathcomp Require Import bigop ssralg div ssrnum ssrint finset ssrnum ssrnat.

Require Import PIOA Meas Posrat CompPIOA Lems CompPIOAProps.

Definition measFilter {A : eqType} (m : Meas A) (f : A -> bool) :=
  filter (fun p => f p.2) m.

Check integ.

Lemma integ_filter {A : eqType} (m : Meas A) (f : A -> bool) f2 :
  integ (measFilter m f) f2 =
  integ m (fun x => if f x then f2 x else 0).
  induction m.
  simpl.
  rewrite !integ_nil //=.
  simpl.
  rewrite integ_cons.
  caseOn (f a.2); intro He.
  rewrite He.
  rewrite integ_cons.
  rewrite IHm.
  done.
  rewrite (negbTE He).
  rewrite pmulr0 padd0r.
  done.
Qed.

Lemma measSupport_measFilter {A : eqType} (m : Meas A) (f : A -> bool) x :
  x \in measSupport (measFilter m f) -> (x \in measSupport m) && (f x).
  induction m.
  simpl.
  rewrite /measSupport //=.
  simpl.
  caseOn (f a.2).
  intro He; rewrite He.
  rewrite !measSupport_cons.
  caseOn (a.1 == 0).
  intro He2; rewrite He2.
  done.
  intro He2; rewrite (negbTE He2).
  rewrite in_cons.
  move/orP; elim.
  move/eqP; intro; subst.
  rewrite in_cons.
  apply/andP; split.
  rewrite eq_refl orTb; done.
  done.
  intros.
  move/andP: (IHm H).
  elim.
  rewrite in_cons.
  intros.
  rewrite H0 H1.
  rewrite orbT //=.
  intro He; rewrite (negbTE He).
  intro.
  move/andP: (IHm H).
  elim.
  intros.
  rewrite measSupport_cons.
  caseOn (a.1 == 0); intro He2.
  rewrite He2.
  rewrite H0 H1; done.
  rewrite (negbTE He2).
  rewrite in_cons H0 H1 orbT //=.
Qed.

Lemma measFilter_cong {A : eqType} (m1 m2 : Meas A) (f : A -> bool) :
  m1 ~~ m2 @ 0 -> measFilter m1 f ~~ measFilter m2 f @ 0.
  intros; rewrite /measEquiv; intros.
  rewrite pdist_le0.
  rewrite !integ_filter.
  have: forall x, (fun y => if f y then f0 y else 0) x <= 1.
  intros; caseOn (f x).
  intro He; rewrite He.
  done.
  intro He; rewrite (negbTE He).
  done.
  intros.
  have H2 := H _ x.
  rewrite pdist_le0 in H2.
  done.
Qed.

Lemma filter_subDist {A} (M : Meas A) f :
  isSubdist M -> isSubdist (measFilter M f).
  have: measMass (measFilter M f) <= measMass M.
  rewrite /measMass /measFilter.
  induction M.
  rewrite big_nil; done.
  rewrite big_filter !big_cons.
  caseOn (f a.2).
  intro He; rewrite He.
  apply ple_add_lr.
  apply ple_refl.
  rewrite big_filter in IHM; done.
  intro He; rewrite (negbTE He).
  rewrite -(padd0r (\big[padd/0]_(j <- M | f j.2) j.1)).
  apply ple_add_lr.
  destruct a.
  destruct p; done.
  rewrite big_filter in IHM; done.
  intros.
  rewrite /isSubdist.
  eapply ple_trans.
  apply x.
  done.
Qed.

Lemma measFilter_disj {A} (M : Meas A) f :
  M ~~ (measFilter M f) ++ (measFilter M (fun x => negb (f x))) @ 0.
  rewrite /measEquiv; intros.
  rewrite pdist_le0.
  rewrite /integ.
  rewrite big_cat.
  simpl.
  induction M.
  rewrite //= !big_nil; done.
  rewrite //= !big_cons.
  caseOn (f a.2); intro He; rewrite He //=.
  rewrite big_cons.
  rewrite -paddrA.
  rewrite -(eqP IHM).
  done.
  rewrite (negbTE He).
  rewrite big_cons.
  rewrite paddrA.
  rewrite (paddrC (\big[padd/0]_(i <- measFilter M f) (i.1 * f0 i.2)) (a.1 * f0 a.2)).
  rewrite -paddrA.
  rewrite -(eqP IHM).
  done.
Qed.

Definition pc_pairwise_disj {A : eqType} (l : seq (pred A)) := forall f g x,
    List.In f l -> List.In g l -> ~~ (f x && g x).

Definition pc_complete {A : eqType} (l : seq (pred A)) (g : pred A) := forall x, g x -> exists f,
      List.In f l /\ f x.

(* filtering m by a series of pairwise disjoint predicates which are collectively complete gives back m *)
Lemma measFilter_pc {A} (m : Meas A) (l : seq (pred A)) :
  pc_pairwise_disj l -> pc_complete l (fun x => x \in measSupport m) ->
  m ~~ (measSum (map (fun f => measFilter m f) l)) @ 0.
  move: l m.
  induction l.
  induction m.
  rewrite //=.
  reflexivity.
  simpl.
  simpl in IHm.
  intros.
  caseOn (fst a == 0).
  intros.
  have: m ~~ [::] @ 0.
  apply IHm.
  done.
  rewrite /pc_complete.
  rewrite /pc_complete in H0.
  rewrite measSupport_cons in H0.
  rewrite H1 in H0.
  done.
  intros.
  rewrite /measEquiv; intros; rewrite pdist_le0.
  rewrite integ_cons.
  rewrite (eqP H1).
  have H3 := x f H2.
  rewrite pdist_le0 in H3.
  rewrite (eqP H3).
  rewrite !integ_nil.
  rewrite pmul0r padd0r; done.
  intros.
  rewrite /pc_complete in H0.
  have: a.2 \in measSupport (a :: m).
  rewrite measSupport_cons (negbTE H1) in_cons eq_refl orTb; done.
  intros.
  destruct (H0 _ x).
  destruct H2.
  inversion H2.

intros.
  simpl.
  have mH := measFilter_disj m a.
  etransitivity.
  apply mH.
  rewrite -(paddr0 0).
  apply measEquiv_app_cong.
  reflexivity.

  etransitivity.
  apply IHl.

  rewrite /pc_pairwise_disj.
  intros.
  apply H.
  apply List.in_cons; done.
  apply List.in_cons; done.
  intros.

  rewrite /pc_complete.
  intros.
  rewrite /pc_complete in H0.
  apply measSupport_measFilter in H1.
  move/andP: H1; elim; intros.
  destruct (H0 _ H1).
  destruct H3.
  exists x0.
  simpl in H3.
  destruct H3.
  subst.
  rewrite H4 in H2; done.
  split; done.

  have: [seq measFilter (measFilter m (fun x : A => ~~ a x)) f | f <- l] =
        [seq measFilter m f | f <- l].
  clear IHl H0 mH.
  induction l.
  done.
  simpl.
  rewrite IHl.
  congr (_ :: _).
  clear IHl.
  induction m.
  done.
  simpl.
  caseOn (a a1.2).
  intros.
  rewrite H0 //=.
  have: ~~ a0 a1.2.
  rewrite -(andbT (a0 a1.2)).
  rewrite -H0.
  apply H.
  apply List.in_cons.
  constructor; done.
  constructor; done.
  intros.
  rewrite (negbTE x).
  done.
  intro He; rewrite (negbTE He).
  simpl.
  caseOn (a0 a1.2).
  intro He2; rewrite He2.
  rewrite IHm; done.
  intro He2; rewrite (negbTE He2).
  done.
  rewrite /pc_pairwise_disj; intros.
  apply H.
  destruct H0.
  constructor; done.
  apply List.in_cons.
  apply List.in_cons.
  done.
  destruct H1.
  constructor; done.
  apply List.in_cons; apply List.in_cons; done.

  intros.
  rewrite x.
  reflexivity.
Qed.


Require Import Coq.ZArith.ZArith Coq.micromega.Lia Coq.omega.Omega.
Require Import Crypto.Util.ZUtil.Hints.Core.
Local Open Scope Z_scope.

Module Z.
  Lemma sub_same_minus (x y : Z) : x - (x - y) = y.
  Proof. lia. Qed.
  Hint Rewrite sub_same_minus : zsimplify.
  Lemma sub_same_plus (x y : Z) : x - (x + y) = -y.
  Proof. lia. Qed.
  Hint Rewrite sub_same_plus : zsimplify.
  Lemma sub_same_minus_plus (x y z : Z) : x - (x - y + z) = y - z.
  Proof. lia. Qed.
  Hint Rewrite sub_same_minus_plus : zsimplify.
  Lemma sub_same_plus_plus (x y z : Z) : x - (x + y + z) = -y - z.
  Proof. lia. Qed.
  Hint Rewrite sub_same_plus_plus : zsimplify.
  Lemma sub_same_minus_minus (x y z : Z) : x - (x - y - z) = y + z.
  Proof. lia. Qed.
  Hint Rewrite sub_same_minus_minus : zsimplify.
  Lemma sub_same_plus_minus (x y z : Z) : x - (x + y - z) = z - y.
  Proof. lia. Qed.
  Hint Rewrite sub_same_plus_minus : zsimplify.
  Lemma sub_same_minus_then_plus (x y w : Z) : x - (x - y) + w = y + w.
  Proof. lia. Qed.
  Hint Rewrite sub_same_minus_then_plus : zsimplify.
  Lemma sub_same_plus_then_plus (x y w : Z) : x - (x + y) + w = w - y.
  Proof. lia. Qed.
  Hint Rewrite sub_same_plus_then_plus : zsimplify.
  Lemma sub_same_minus_plus_then_plus (x y z w : Z) : x - (x - y + z) + w = y - z + w.
  Proof. lia. Qed.
  Hint Rewrite sub_same_minus_plus_then_plus : zsimplify.
  Lemma sub_same_plus_plus_then_plus (x y z w : Z) : x - (x + y + z) + w = w - y - z.
  Proof. lia. Qed.
  Hint Rewrite sub_same_plus_plus_then_plus : zsimplify.
  Lemma sub_same_minus_minus_then_plus (x y z w : Z) : x - (x - y - z) + w = y + z + w.
  Proof. lia. Qed.
  Hint Rewrite sub_same_minus_minus : zsimplify.
  Lemma sub_same_plus_minus_then_plus (x y z w : Z) : x - (x + y - z) + w = z - y + w.
  Proof. lia. Qed.
  Hint Rewrite sub_same_plus_minus_then_plus : zsimplify.

  Lemma simplify_twice_sub_sub x y : 2 * x - (x - y) = x + y.
  Proof. lia. Qed.
  Hint Rewrite simplify_twice_sub_sub : zsimplify.

  Lemma simplify_twice_sub_add x y : 2 * x - (x + y) = x - y.
  Proof. lia. Qed.
  Hint Rewrite simplify_twice_sub_add : zsimplify.

  Lemma simplify_2XmX X : 2 * X - X = X.
  Proof. omega. Qed.
  Hint Rewrite simplify_2XmX : zsimplify.

  Lemma simplify_add_pos x y : Z.pos x + Z.pos y = Z.pos (x + y).
  Proof. reflexivity. Qed.
  Hint Rewrite simplify_add_pos : zsimplify_Z_to_pos.
  Lemma simplify_add_pos10 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9
    : Z.pos x0 + (Z.pos x1 + (Z.pos x2 + (Z.pos x3 + (Z.pos x4 + (Z.pos x5 + (Z.pos x6 + (Z.pos x7 + (Z.pos x8 + Z.pos x9))))))))
      = Z.pos (x0 + (x1 + (x2 + (x3 + (x4 + (x5 + (x6 + (x7 + (x8 + x9))))))))).
  Proof. reflexivity. Qed.
  Hint Rewrite simplify_add_pos10 : zsimplify_Z_to_pos.
  Lemma simplify_mul_pos x y : Z.pos x * Z.pos y = Z.pos (x * y).
  Proof. reflexivity. Qed.
  Hint Rewrite simplify_mul_pos : zsimplify_Z_to_pos.
  Lemma simplify_mul_pos10 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9
    : Z.pos x0 * (Z.pos x1 * (Z.pos x2 * (Z.pos x3 * (Z.pos x4 * (Z.pos x5 * (Z.pos x6 * (Z.pos x7 * (Z.pos x8 * Z.pos x9))))))))
      = Z.pos (x0 * (x1 * (x2 * (x3 * (x4 * (x5 * (x6 * (x7 * (x8 * x9))))))))).
  Proof. reflexivity. Qed.
  Hint Rewrite simplify_mul_pos10 : zsimplify_Z_to_pos.
  Lemma simplify_sub_pos x y : Z.pos x - Z.pos y = Z.pos_sub x y.
  Proof. reflexivity. Qed.
  Hint Rewrite simplify_sub_pos : zsimplify_Z_to_pos.

  Lemma two_sub_sub_inner_sub x y z : 2 * x - y - (x - z) = x - y + z.
  Proof. clear; lia. Qed.
  Hint Rewrite two_sub_sub_inner_sub : zsimplify.

  Lemma minus_minus_one : - -1 = 1.
  Proof. reflexivity. Qed.
  Hint Rewrite minus_minus_one : zsimplify.
End Z.