Require Import GeoCoq.Tarski_dev.Ch12_parallel_inter_dec.
Require Import Morphisms.
Require Import GeoCoq.Axioms.hilbert_axioms.
Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Meta_theory.Parallel_postulates.tarski_playfair.
Require Import GeoCoq.Meta_theory.Parallel_postulates.SPP_ID.
Require Import GeoCoq.Meta_theory.Dimension_axioms.upper_dim_3.
Require Import GeoCoq.Meta_theory.Parallel_postulates.parallel_postulates.

Require Export GeoCoq.Utils.triples.

Section T.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

(** We need a notion of line. *)

Definition Line := @Couple Tpoint.
Definition Lin := build_couple Tpoint.

Definition IncidentL := fun A l => Col A (P1 l) (P2 l).

(** * Group I Combination *)

(** For every pair of distinct points there is a line containing them. *)

Lemma axiom_line_existence : forall A B, A<>B -> exists l, IncidentL A l /\ IncidentL B l.
Proof.
intros.
exists (Lin A B H).
unfold IncidentL.
intuition.
Qed.

(** We need a notion of equality over lines. *)

Definition EqL : relation Line := fun l m => forall X, IncidentL X l <-> IncidentL X m.

Infix "=l=" := EqL (at level 70):type_scope.

Lemma incident_eq : forall A B l, forall H : A<>B,
 IncidentL A l -> IncidentL B l ->
 (Lin A B H) =l= l.
Proof.
intros.
unfold EqL.
intros.
unfold IncidentL in *.
replace (P1 (Lin A B H)) with A; trivial.
replace (P2 (Lin A B H)) with B; trivial.
split;intro.
assert (T:=Cond l).
elim (eq_dec_points X B); intro.
subst X.
auto.
assert (Col (P1 l) A B).
apply col_transitivity_1 with (P2 l); Col.
assert (Col (P2 l) A B).
apply (col_transitivity_2 (P1 l)); Col.
apply (col3 A B); Col.

assert (U:=Cond l).
apply (col3 (P1 l) (P2 l)); Col.
Qed.

(** Our equality is an equivalence relation. *)

Lemma eq_transitivity : forall l m n, l =l= m -> m =l= n -> l =l= n.
Proof.
unfold EqL,IncidentL.
intros.
assert (T:=H X).
assert (V:= H0 X).
split;intro;intuition.
Qed.

Lemma eq_reflexivity : forall l, l =l= l.
Proof.
intros.
unfold EqL.
intuition.
Qed.

Lemma eq_symmetry : forall l m, l =l= m -> m =l= l.
Proof.
unfold EqL.
intros.
assert (T:=H X).
intuition.
Qed.

Instance EqL_Equiv : Equivalence EqL.
Proof.
split.
unfold Reflexive.
apply eq_reflexivity.
unfold Symmetric.
apply eq_symmetry.
unfold Transitive.
apply eq_transitivity.
Defined.

(** The equality is compatible with IncidentL *)

Lemma eq_incident : forall A l m, l =l= m ->
 (IncidentL A l <-> IncidentL A m).
Proof.
intros.
split;intros;
unfold EqL in *;
assert (T:= H A);
intuition.
Qed.

Instance incident_Proper (A:Tpoint) :
Proper (EqL ==>iff) (IncidentL A).
Proof.
intros a b H .
apply eq_incident.
assumption.
Defined.

Lemma axiom_Incid_morphism :
 forall P l m, IncidentL P l -> EqL l m -> IncidentL P m.
Proof.
intros.
destruct (eq_incident P l m H0).
intuition.
Qed.

Lemma axiom_Incid_dec : forall P l, IncidentL P l \/ ~IncidentL P l.
Proof.
intros.
unfold IncidentL.
apply col_dec.
Qed.

(** There is only one line going through two points. *)

Lemma axiom_line_uniqueness : forall A B l m, A <> B ->
 IncidentL A l -> IncidentL B l -> IncidentL A m -> IncidentL B m ->
 l =l= m.
Proof.
intros.
assert ((Lin A B H) =l= l).
eapply incident_eq;assumption.
assert ((Lin A B H) =l= m).
eapply incident_eq;assumption.
rewrite <- H4.
assumption.
Qed.

(** Every line contains at least two points. *)

Lemma axiom_two_points_on_line : forall l,
  { A : Tpoint & { B | IncidentL B l /\ IncidentL A l /\ A <> B}}.
Proof.
intros.
exists (P1 l).
exists (P2 l).
unfold IncidentL.
repeat split;Col.
exact (Cond l).
Qed.

(** Definition of the collinearity predicate.
 We say that three points are collinear if they belongs to the same line. *)

Definition Col_H := fun A B C =>
  exists l, IncidentL A l /\ IncidentL B l /\ IncidentL C l.

(** We show that the notion of collinearity we just defined is equivalent to the
 notion of collinearity of Tarski. *)

Lemma cols_coincide_1 : forall A B C, Col_H A B C -> Col A B C.
Proof.
intros.
unfold Col_H in H.
DecompExAnd H l.
unfold IncidentL in *.
assert (T:=Cond l).
apply (col3 (P1 l) (P2 l)); Col.
Qed.

Lemma cols_coincide_2 : forall A B C, Col A B C -> Col_H A B C.
Proof.
intros.
unfold Col_H.
elim (eq_dec_points A B); intro.
subst B.
elim (eq_dec_points A C); intro.
subst C.
assert (exists B, A<>B).
eapply another_point.
DecompEx H0 B.
exists (Lin A B H1).
unfold IncidentL;intuition.
exists (Lin A C H0).
unfold IncidentL;intuition.
exists (Lin A B H0).
unfold IncidentL;intuition.
Qed.

Lemma cols_coincide : forall A B C, Col A B C <-> Col_H A B C.
Proof.
intros.
split.
apply cols_coincide_2.
apply cols_coincide_1.
Qed.

Lemma ncols_coincide : forall A B C, ~ Col A B C <-> ~ Col_H A B C.
Proof.
intros.
split; intros HNCol HCol; apply HNCol, cols_coincide, HCol.
Qed.

(** There exists three non collinear points. *)

Lemma lower_dim' : PA <> PB /\ PB <> PC /\ PA <> PC /\ ~ Col_H PA PB PC.
Proof.
assert (HNCol : ~ Col PA PB PC) by (apply lower_dim).
assert_diffs.
apply ncols_coincide in HNCol.
repeat split; auto.
Qed.

(** We need a notion of plane. *)

Record Plane := Plan {M1; M2; M3; NCol : ~ Col_H M1 M2 M3}.

Definition IncidentP := fun A p => Coplanar (M1 p) (M2 p) (M3 p) A.

(** For every triplet of non collinear points there is a plane containing them. *)

Lemma axiom_plane_existence : forall A B C, ~ Col_H A B C ->
  exists p, IncidentP A p /\ IncidentP B p /\ IncidentP C p.
Proof.
intros A B C HNCol.
exists (Plan A B C HNCol).
unfold IncidentP; simpl; repeat split; Cop.
Qed.

(** We need a notion of equality over planes. *)

Definition EqP : relation Plane := fun p q => forall X, IncidentP X p <-> IncidentP X q.

Infix "=p=" := EqP (at level 70):type_scope.

Lemma incidentp_eqp : forall A B C p, forall H : ~ Col_H A B C,
 IncidentP A p -> IncidentP B p -> IncidentP C p ->
 (Plan A B C H) =p= p.
Proof.
intros A B C p HNCol HA HB HC X.
unfold IncidentP in *; simpl.
assert (Hp := NCol p).
apply ncols_coincide in Hp.
apply ncols_coincide in HNCol.
split; intro; [apply coplanar_pseudo_trans with A B C; trivial|];
apply coplanar_pseudo_trans with (M1 p) (M2 p) (M3 p); Cop.
Qed.

(** Our equality is an equivalence relation. *)

Lemma eqp_transitivity : forall p q r, p =p= q -> q =p= r -> p =p= r.
Proof.
intros p q r H1 H2 X.
rewrite (H1 X); apply H2.
Qed.

Lemma eqp_reflexivity : forall p, p =p= p.
Proof.
intros.
unfold EqP.
intuition.
Qed.

Lemma eqp_symmetry : forall p q, p =p= q -> q =p= p.
Proof.
unfold EqP.
intros p q H X.
assert (T := H X).
intuition.
Qed.

(** * Group II Order *)
Instance EqP_Equiv : Equivalence EqP.
Proof.
split.
unfold Reflexive.
apply eqp_reflexivity.
unfold Symmetric.
apply eqp_symmetry.
unfold Transitive.
apply eqp_transitivity.
Defined.

(** The equality is compatible with IncidentL *)

Lemma eqp_incidentp : forall A p q, p =p= q ->
 (IncidentP A p <-> IncidentP A q).
Proof.
intros A p q H.
exact (H A).
Qed.

Instance incidentp_Proper (A:Tpoint) :
Proper (EqP ==>iff) (IncidentP A).
Proof.
intros a b H.
apply eqp_incidentp.
assumption.
Defined.

Lemma axiom_Incidp_morphism :
 forall M p q, IncidentP M p -> EqP p q -> IncidentP M q.
Proof.
intros M p q Hp H.
destruct (eqp_incidentp M p q H).
intuition.
Qed.

Lemma axiom_Incidp_dec : forall M p, IncidentP M p \/ ~ IncidentP M p.
Proof.
intros.
apply cop_dec.
Qed.

(** There is only one plane going through three non collinear points. *)

Lemma axiom_plane_uniqueness : forall A B C p q, ~ Col_H A B C ->
 IncidentP A p -> IncidentP B p -> IncidentP C p ->
 IncidentP A q -> IncidentP B q -> IncidentP C q ->
 p =p= q.
Proof.
intros A B C p q H; intros.
assert (Heq : (Plan A B C H) =p= p).
apply incidentp_eqp;assumption.
assert ((Plan A B C H) =p= q).
apply incidentp_eqp;assumption.
rewrite <- Heq.
assumption.
Qed.

(** Every plane contains at least one point. *)

Lemma axiom_one_point_on_plane : forall p,
  { A | IncidentP A p }.
Proof.
intro p.
exists (M1 p).
unfold IncidentP; Cop.
Qed.

(** Definition of a line belonging to a plane.
  We say that a line belongs to a plane if every point of the line belongs to the plane. *)

Definition  IncidentLP := fun l p => forall A, IncidentL A l -> IncidentP A p.

(** If two distinct points of a line belong to a plane, then the line belongs to the plane. *)

Lemma axiom_line_on_plane : forall A B l p, A <> B ->
 IncidentL A l -> IncidentL B l -> IncidentP A p -> IncidentP B p ->
 IncidentLP l p.
Proof.
intros A B l p HAB HAl HBl HAp HBp X HXl.
destruct (ex_ncol_cop (M1 p) (M2 p) (M3 p) A B HAB) as [C [HCp HNCol]].
apply ncols_coincide in HNCol.
assert (Heq : (Plan A B C HNCol) =p= p).
apply incidentp_eqp; auto.
rewrite <- Heq.
unfold IncidentP; simpl.
exists X; left; split.
apply cols_coincide_1; exists l; repeat split; assumption.
Col.
Qed.

(** * Group II Order *)

(** Definition of the Between predicate of Hilbert.
    Note that it is different from the Between of Tarski.
    The Between of Hilbert is strict. *)

Definition Between_H := fun A B C =>
  Bet A B C /\ A <> B /\ B <> C /\ A <> C.

Lemma axiom_between_col :
 forall A B C, Between_H A B C -> Col_H A B C.
Proof.
intros.
unfold Col_H, Between_H in *.
DecompAndAll.
exists (Lin A B H2).
unfold IncidentL.
intuition.
Qed.

Lemma axiom_between_diff :
 forall A B C, Between_H A B C -> A<>C.
Proof.
intros.
unfold Between_H in *.
intuition.
Qed.

(** If B is between A and C, it is also between C and A. *)

Lemma axiom_between_comm : forall A B C, Between_H A B C -> Between_H C B A.
Proof.
unfold Between_H in |- *.
intros.
intuition.
Qed.

Lemma axiom_between_out :
 forall A B, A <> B -> exists C, Between_H A B C.
Proof.
intros.
prolong A B C A B.
exists C.
unfold Between_H.
repeat split;
auto;
intro;
treat_equalities;
tauto.
Qed.

Lemma axiom_between_only_one :
 forall A B C,
 Between_H A B C -> ~ Between_H B C A.
Proof.
unfold Between_H in |- *.
intros.
intro;
spliter.
assert (B=C) by
 (apply (between_equality B C A);Between).
solve [intuition].
Qed.

Lemma between_one : forall A B C,
 A<>B -> A<>C -> B<>C -> Col A B C ->
 Between_H A B C \/ Between_H B C A \/ Between_H B A C.
Proof.
intros.
unfold Col, Between_H in *.
destruct H2 as [|[|]]; [left|right..]; Between.
Qed.

Lemma axiom_between_one : forall A B C,
 A<>B -> A<>C -> B<>C -> Col_H A B C ->
 Between_H A B C \/ Between_H B C A \/ Between_H B A C.
Proof.
intros.
apply between_one;try assumption.
apply cols_coincide_1.
assumption.
Qed.

(** Axiom of Pasch, (Hilbert version). *)

(** First we define a predicate which means that the line l intersects the segment AB. *)

Definition cut := fun l A B =>
  ~ IncidentL A l /\ ~ IncidentL B l /\ exists I, IncidentL I l /\ Between_H A I B.

(** We show that this definition is equivalent to the predicate TS of Tarski. *)

Lemma cut_two_sides : forall l A B, cut l A B <-> TS (P1 l) (P2 l) A B.
Proof.
intros.
unfold cut.
unfold TS.
split.
intros.
spliter.
repeat split; intuition.
ex_and H1 T.
exists T.
unfold IncidentL in H1.
unfold Between_H in *.
intuition.

intros.
spliter.
ex_and H1 T.
unfold IncidentL.
repeat split; try assumption.
exists T.
split.
assumption.
unfold Between_H.
repeat split.
assumption.
intro.
subst.
contradiction.
intro.
subst.
contradiction.
intro.
treat_equalities.
contradiction.
Qed.

Lemma cop_plane_aux : forall A B C D, Coplanar A B C D -> A <> B ->
  exists p, IncidentP A p /\ IncidentP B p /\ IncidentP C p /\ IncidentP D p.
Proof.
  intros A B C D HCop HAB.
  destruct (col_dec A B C) as [|HNCol]; [destruct (col_dec A B D) as [|HNCol]|].
  - destruct (not_col_exists A B HAB) as [E HNCol].
    apply ncols_coincide in HNCol.
    exists (Plan A B E HNCol).
    unfold IncidentP; simpl; repeat split; Cop.
  - apply ncols_coincide in HNCol.
    exists (Plan A B D HNCol).
    unfold IncidentP; simpl; repeat split; Cop.
  - apply ncols_coincide in HNCol.
    exists (Plan A B C HNCol).
    unfold IncidentP; simpl; repeat split; Cop.
Qed.

Lemma cop_plane : forall A B C D, Coplanar A B C D ->
  exists p, IncidentP A p /\ IncidentP B p /\ IncidentP C p /\ IncidentP D p.
Proof.
  intros A B C D HCop.
  destruct (eq_dec_points A B) as [|HAB]; [destruct (eq_dec_points A C);
    [destruct (eq_dec_points A D)|]|].
  - destruct (another_point D) as [E].
    destruct (cop_plane_aux D E E E) as [p []]; Cop.
    subst; exists p; repeat split; assumption.
  - destruct (cop_plane_aux A D B C) as [p]; Cop.
    spliter; exists p; repeat split; assumption.
  - destruct (cop_plane_aux A C B D) as [p]; Cop.
    spliter; exists p; repeat split; assumption.
  - apply (cop_plane_aux A B C D HCop HAB).
Qed.

Lemma plane_cop: forall A B C D p,
  IncidentP A p -> IncidentP B p -> IncidentP C p -> IncidentP D p -> Coplanar A B C D.
Proof.
  unfold IncidentP.
  intros A B C D p HA HB HC HD.
  assert (HNCol := NCol p).
  apply ncols_coincide in HNCol.
  apply coplanar_pseudo_trans with (M1 p) (M2 p) (M3 p); assumption.
Qed.

Lemma axiom_pasch : forall A B C l p, ~ Col_H A B C ->
 IncidentP A p -> IncidentP B p -> IncidentP C p -> IncidentLP l p -> ~ IncidentL C l ->
 cut l A B -> cut l A C \/ cut l B C.
Proof.
intros.
apply cut_two_sides in H5.
assert(~Col A B C).
apply ncols_coincide.
assumption.

assert(HH:=H5).
unfold TS in HH.
spliter.

unfold IncidentL in H4.
assert (HCop : Coplanar (P1 l) (P2 l) A C).
apply plane_cop with p; trivial; apply H3; unfold IncidentL; simpl; Col.

assert(HH:= cop__one_or_two_sides (P1 l)(P2 l) A C HCop H7 H4).

induction HH.
left.
apply <-cut_two_sides.
assumption.
right.
apply <-cut_two_sides.
apply l9_2.
eapply l9_8_2.
apply H5.
assumption.
Qed.

Lemma Incid_line :
 forall P A B l, A<>B ->
 IncidentL A l -> IncidentL B l -> Col P A B -> IncidentL P l.
Proof.
intros.
unfold IncidentL in *.
destruct l as [C D HCD].
simpl in *.
ColR.
Qed.

(** * Group IV Congruence *)

(** The cong predicate of Hilbert is the same as the one of Tarski: *)

Definition outH := fun P A B => Between_H P A B \/ Between_H P B A \/ (P <> A /\ A = B).

Lemma out_outH : forall P A B, Out P A B -> outH P A B.
unfold Out.
unfold outH.
intros.
spliter.
induction H1.

induction (eq_dec_points A B).
right; right.
split; auto.
left.
unfold Between_H.
repeat split; auto.

induction (eq_dec_points A B).
right; right.
split; auto.
right; left.
unfold Between_H.
repeat split; auto.
Qed.

Lemma axiom_hcong_1_existence : forall A B A' P l,
  A <> B -> A' <> P ->
  IncidentL A' l -> IncidentL P l ->
  exists B', IncidentL B' l /\ outH A' P B' /\ Cong A' B' A B.
Proof.
intros; destruct (l6_11_existence A' A B P) as [B' [HOut HCong]]; auto.
exists B'; repeat split; try apply out_outH, l6_6; auto; unfold IncidentL in *.
destruct l; simpl in *; ColR.
Qed.

Lemma axiom_hcong_1_uniqueness :
 forall A B l M A' B' A'' B'', A <> B -> IncidentL M l ->
  IncidentL A' l -> IncidentL B' l ->
  IncidentL A'' l -> IncidentL B'' l ->
  Between_H A' M B' -> Cong M A' A B ->
  Cong M B' A B -> Between_H A'' M B'' ->
  Cong M A'' A B -> Cong M B'' A B ->
  (A' = A'' /\ B' = B'') \/ (A' = B'' /\ B' = A'').
Proof.
unfold Between_H.
unfold IncidentL.
intros.
spliter.

assert(A' <> M /\ A'' <> M /\ B' <> M /\ B'' <> M /\ A' <> B' /\ A'' <> B'').
repeat split; intro; treat_equalities; tauto.
spliter.

induction(out_dec M A' A'').
left.
assert(A' = A'').
eapply (l6_11_uniqueness M A B A''); try assumption.
apply out_trivial.
assumption.

split.
assumption.
subst A''.

eapply (l6_11_uniqueness M A B B''); try assumption.

unfold Out.
repeat split; try assumption.
eapply l5_2.
apply H18.
assumption.
assumption.
apply out_trivial.
assumption.

right.
apply not_out_bet in H23.

assert(A' = B'').
eapply (l6_11_uniqueness M A B A'); try assumption.
apply out_trivial.
assumption.

unfold Out.
repeat split; try assumption.

eapply l5_2.
apply H18.
assumption.
apply between_symmetry.
assumption.

split.
assumption.

subst B''.
eapply (l6_11_uniqueness M A B B'); try assumption.
apply out_trivial.
assumption.
unfold Out.
repeat split; try assumption.
eapply l5_2.
apply H20.
apply between_symmetry.
assumption.
assumption.
eapply col3.
apply (Cond l).
Col.
Col.
Col.
Qed.

(** As a remark we also prove another version of this axiom as formalized in Isabelle by
Phil Scott. *)

Definition same_side_scott := fun E A B => E <> A /\ E <> B /\ Col_H E A B /\ ~ Between_H A E B.

Remark axiom_hcong_scott:
 forall P Q A C, A <> C -> P <> Q ->
  exists B, same_side_scott A B C  /\ Cong P Q A B.
Proof.
intros.
unfold same_side_scott.
assert (exists X : Tpoint, Out A X C /\ Cong A X P Q).
apply l6_11_existence;auto.
decompose [ex and] H1;clear H1.
exists x.
repeat split.
unfold Out in H3.
intuition.
unfold Out in H3.
intuition.
apply cols_coincide_2.
apply out_col;assumption.

unfold Out in H3.
unfold Between_H.
intro.
decompose [and] H3;clear H3.
decompose [and] H1;clear H1.
clear H8.
destruct H7.
assert (A = x).
eapply between_equality;eauto.
intuition.
assert (A = C).
eapply between_equality;eauto.
apply between_symmetry.
auto.
intuition.
Cong.
Qed.

(** We define when two segments do not intersect. *)

Definition disjoint := fun A B C D => ~ exists P, Between_H A P B /\ Between_H C P D.

(** Note that two disjoint segments may share one of their extremities. *)

Lemma col_disjoint_bet : forall A B C, Col_H A B C -> disjoint A B B C -> Bet A B C.
Proof.
intros.
apply cols_coincide_1 in H.
unfold disjoint in H0.

induction (eq_dec_points A B).
subst  B.
apply between_trivial2.
induction (eq_dec_points B C).
subst  C.
apply between_trivial.

unfold Col in H.
induction H.
assumption.

induction H.
apply False_ind.
apply H0.
assert(exists M, Midpoint M B C) by(apply midpoint_existence).
ex_and H3 M.
exists M.
unfold Midpoint in H4.
spliter.
split.
unfold Between_H.
repeat split.
apply between_symmetry.
eapply between_exchange4.
apply H3.
assumption.
intro.
treat_equalities.
(*
apply between_symmetry in H.
apply between_equality in H.
treat_equalities.
*)
tauto.
(*
apply between_symmetry.
assumption.
*)
intro.
treat_equalities.
tauto.
assumption.
unfold Between_H.
repeat split.
assumption.
intro.
treat_equalities.
tauto.
intro.
treat_equalities.
tauto.
assumption.

apply False_ind.
apply H0.
assert(exists M, Midpoint M A B) by(apply midpoint_existence).
ex_and H3 M.
exists M.
unfold Midpoint in H4.
spliter.
split.
unfold Between_H.
repeat split.
assumption.
intro.
treat_equalities.
tauto.
intro.
treat_equalities.
tauto.
assumption.

unfold Between_H.
repeat split.

eapply between_exchange4.
apply between_symmetry.
apply H3.
apply between_symmetry.
assumption.
intro.
treat_equalities.
tauto.
intro.
treat_equalities.
intuition.
assumption.
Qed.

Lemma axiom_hcong_3 : forall A B C A' B' C',
   Col_H A B C -> Col_H A' B' C' ->
  disjoint A B B C -> disjoint A' B' B' C' ->
  Cong A B A' B' -> Cong B C B' C' -> Cong A C A' C'.
Proof.
intros.
assert(Bet A B C).
eapply col_disjoint_bet.
assumption.
assumption.

assert(Bet A' B' C').
eapply col_disjoint_bet.
assumption.
assumption.
eapply l2_11;eauto.
Qed.

Lemma exists_not_incident : forall A B : Tpoint, forall  HH : A <> B , exists C, ~ IncidentL C (Lin A B HH).
Proof.
intros.
unfold IncidentL.
assert(HC:=not_col_exists A B HH).
ex_and HC C.
exists C.
intro.
apply H.
simpl in H0.
Col.
Qed.

Definition same_side := fun A B l => exists P, cut l A P /\ cut l B P.

(** Same side predicate corresponds to OS of Tarski. *)

Lemma same_side_one_side : forall A B l, same_side A B l -> OS (P1 l) (P2 l) A B.
Proof.
unfold same_side.
intros.
destruct H as [P []].
apply cut_two_sides in H.
apply cut_two_sides in H0.
eapply l9_8_1.
apply H.
apply H0.
Qed.

Lemma one_side_same_side : forall A B l, OS (P1 l) (P2 l) A B -> same_side A B l.
Proof.
intros.
unfold same_side.
unfold OS in H.
destruct H as [P []].
exists P.
unfold cut.
unfold IncidentL.
unfold TS in H.
unfold TS in H0.
spliter.
repeat split; auto.
ex_and H4 T.
exists T.
unfold Between_H.
repeat split; auto.
intro.
subst T.
contradiction.
intro.
subst T.
contradiction.
intro.
subst P.
apply between_identity in H5.
subst T.
contradiction.
ex_and H2 T.
exists T.
unfold Between_H.
repeat split; auto.
intro.
subst T.
contradiction.
intro.
subst T.
contradiction.
intro.
subst P.
apply between_identity in H5.
subst T.
contradiction.
Qed.

Definition same_side' := fun A B X Y =>
  X <> Y /\ forall l, IncidentL X l -> IncidentL Y l -> same_side A B l.

Lemma OS_distinct : forall P Q A B,
  OS P Q A B -> P<>Q.
Proof.
intros.
apply one_side_not_col123 in H.
assert_diffs;assumption.
Qed.

Lemma OS_same_side' :
 forall P Q A B, OS P Q A B -> same_side' A B P Q.
Proof.
intros.
unfold same_side'.
intros.
split.
apply OS_distinct with A B;assumption.
intros.

apply  one_side_same_side.
destruct l.
unfold IncidentL in *.
simpl in *.
apply col2_os__os with P Q; try assumption; ColR.
Qed.

Lemma same_side_OS :
 forall P Q A B, same_side' P Q A B -> OS A B P Q.
Proof.
intros.
unfold same_side' in *.
destruct H.
destruct (axiom_line_existence A B H).
destruct H1.
assert (T:=H0 x H1 H2).
assert (U:=same_side_one_side P Q x T).
destruct x.
unfold IncidentL in *.
simpl in *.
apply col2_os__os with P1 P2;Col.
Qed.

(** This is equivalent to the out predicate of Tarski. *)

Lemma outH_out : forall P A B, outH P A B -> Out P A B.
Proof.
unfold outH.
unfold Out.
intros.
induction H.
unfold Between_H in H.
spliter.
repeat split; auto.
induction H.
unfold Between_H in H.
spliter.
repeat split; auto.
spliter.
repeat split.
auto.
subst B.
auto.
subst B.
left.
apply between_trivial.
Qed.

(** The 2D version of the fourth congruence axiom **)

Lemma incident_col : forall M l, IncidentL M l -> Col M (P1 l)(P2 l).
Proof.
unfold IncidentL.
intros.
assumption.
Qed.

Lemma col_incident : forall M l, Col M (P1 l)(P2 l) -> IncidentL M l.
Proof.
unfold IncidentL.
intros.
assumption.
Qed.

Lemma Bet_Between_H : forall A B C,
 Bet A B C -> A<>B -> B<>C -> Between_H A B C.
Proof.
intros.
unfold Between_H.
repeat split;try assumption.
intro.
subst.
treat_equalities.
intuition.
Qed.

Lemma axiom_cong_5' : forall A B C A' B' C', ~ Col_H A B C -> ~ Col_H A' B' C' ->
           Cong A B A' B' -> Cong A C A' C' -> CongA B A C B' A' C' -> CongA A B C A' B' C'.
Proof.
intros A B C A' B' C'.
intros.
assert (T:=l11_49 B A C B' A' C').
assert (~ Col A B C).
intro.
apply cols_coincide_2 in H4.
intuition.
assert_diffs.
intuition.
Qed.

Lemma axiom_hcong_4_existence :  forall A B C O X P,
   ~ Col_H P O X -> ~ Col_H A B C ->
  exists Y, CongA A B C X O Y  (* /\ ~Col O X Y *) /\ same_side' P Y O X.
Proof.
intros.
rewrite <- cols_coincide in H.
rewrite <- cols_coincide in H0.

assert(~Col X O P).
intro.
apply H.
Col.
assert(HH:=angle_construction_1 A B C X O P H0 H1).

ex_and HH Y.

exists Y.
split.
assumption.
apply OS_same_side'.
apply invert_one_side.
apply one_side_symmetry.
assumption.
Qed.

Lemma same_side_trans :
 forall A B C l,
  same_side A B l -> same_side B C l -> same_side A C l.
Proof.
intros.
apply one_side_same_side.
apply same_side_one_side in H.
apply same_side_one_side in H0.
eapply one_side_transitivity.
apply H.
assumption.
Qed.

Lemma same_side_sym :
 forall A B l,
  same_side A B l -> same_side B A l.
Proof.
intros.
apply one_side_same_side.
apply same_side_one_side in H.
apply one_side_symmetry.
assumption.
Qed.

Lemma axiom_hcong_4_uniqueness :
  forall A B C O P X Y Y', ~ Col_H P O X  -> ~ Col_H A B C -> CongA A B C X O Y -> CongA A B C X O Y' ->
  same_side' P Y O X -> same_side' P Y' O X -> outH O Y Y'.
Proof.
intros.
rewrite <- cols_coincide in H.
rewrite <- cols_coincide in H0.
assert (T:CongA X O Y X O Y').
eapply conga_trans.
apply conga_sym.
apply H1.
assumption.

apply conga_cop__or_out_ts in T.
induction T.
apply out_outH.
assumption.

apply same_side_OS in H3.
apply same_side_OS in H4.
exfalso.
assert (OS O X Y Y').
apply one_side_transitivity with P.
apply one_side_symmetry.
assumption.
assumption.
apply invert_one_side in H6.
apply l9_9 in H5.
intuition.

apply same_side_OS in H3.
apply same_side_OS in H4.
apply coplanar_trans_1 with P; Col; Cop.
Qed.

Lemma axiom_conga_comm : forall A B C,
 ~ Col_H A B C -> CongA A B C C B A.
Proof.
intros.
rewrite <- cols_coincide in H.
assert_diffs.
apply conga_pseudo_refl;auto.
Qed.

Lemma axiom_congaH_outH_congaH :
 forall A B C D E F A' C' D' F' : Tpoint,
  CongA A B C D E F ->
  Between_H B A A' \/ Between_H B A' A \/ B <> A /\ A = A' ->
  Between_H B C C' \/ Between_H B C' C \/ B <> C /\ C = C' ->
  Between_H E D D' \/ Between_H E D' D \/ E <> D /\ D = D' ->
  Between_H E F F' \/ Between_H E F' F \/ E <> F /\ F = F' ->
  CongA A' B C' D' E F'.
Proof.
intros.
apply out_conga with A C D F;auto using outH_out.
Qed.

Lemma axiom_conga_permlr:
forall A B C D E F : Tpoint, CongA A B C D E F -> CongA C B A F E D.
Proof.
apply Ch11_angles.conga_comm.
Qed.

(*
Lemma axiom_inter_dec : forall l m,
  (exists P, IncidentL P l /\ IncidentL P m) \/ ~ (exists P, IncidentL P l /\ IncidentL P m).
Proof.
intros l m;
elim (inter_dec (P1 l) (P2 l) (P1 m) (P2 m));
intro; [left|right]; auto.
Qed.
*)

Lemma axiom_conga_refl : forall A B C, ~ Col_H A B C -> CongA A B C A B C.
Proof.
intros A B C H.
apply Ch11_angles.conga_refl; intro; subst; apply H; apply cols_coincide; Col.
Qed.

End T.

Section Tarski_neutral_to_Hilbert_neutral.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Instance Hilbert_neutral_follows_from_Tarski_neutral : Hilbert_neutral_dimensionless.
Proof.
exact (Build_Hilbert_neutral_dimensionless Tpoint Line Plane EqL EqL_Equiv EqP EqP_Equiv IncidentL
       IncidentP axiom_Incid_morphism axiom_Incid_dec axiom_Incidp_morphism axiom_Incidp_dec
       eq_dec_points axiom_line_existence axiom_line_uniqueness axiom_two_points_on_line PA
       PB PC lower_dim' axiom_plane_existence axiom_one_point_on_plane axiom_plane_uniqueness
       axiom_line_on_plane Between_H axiom_between_diff axiom_between_col axiom_between_comm
       axiom_between_out axiom_between_only_one axiom_pasch Cong cong_right_commutativity
       axiom_hcong_1_existence cong_inner_transitivity
        axiom_hcong_3 CongA axiom_conga_refl axiom_conga_comm
       axiom_conga_permlr axiom_congaH_outH_congaH axiom_hcong_4_existence
       axiom_hcong_4_uniqueness axiom_cong_5').
Defined.

End Tarski_neutral_to_Hilbert_neutral.

Section Tarski_neutral_2D_to_Hilbert_neutral_2D.

Context `{T2D:Tarski_2D}.

Instance Hilbert_2D_follows_from_Tarski_2D : Hilbert_neutral_2D Hilbert_neutral_follows_from_Tarski_neutral.
Proof.
split.
intros A B C l HNCol HNCl Hcut.
apply axiom_pasch with (Plan A B C HNCol); trivial;
  unfold IncidentLP, IncidentP; intros; try (apply all_coplanar).
Defined.

End Tarski_neutral_2D_to_Hilbert_neutral_2D.

Section Tarski_neutral_3D_to_Hilbert_neutral_3D.

Context `{T3D:Tarski_3D}.

Lemma lower_dim_3' : {A : Tpoint & {B : Tpoint & {C : Tpoint & {D |
  ~ exists p, IncidentP A p /\ IncidentP B p /\ IncidentP C p /\ IncidentP D p}}}}.
Proof.
exists S1, S2, S3, S4.
intros [p]; spliter.
apply tarski_axioms.lower_dim_3, plane_cop with p; assumption.
Qed.

Instance Hilbert_3D_follows_from_Tarski_3D : Hilbert_neutral_3D Hilbert_neutral_follows_from_Tarski_neutral.
Proof.
destruct lower_dim_3' as [A [B [C [D n]]]].
exists A B C D; [|assumption].
clear A B C D n.
intros A p q HAp HAq.
destruct p as [P1 P2 P3 HP].
destruct q as [Q1 Q2 Q3 HQ].
unfold IncidP in *; simpl in *; unfold IncidentP in *; simpl in *.
assert (pi : plane_intersection_axiom).
cut upper_dim_3_axiom.
apply upper_dim_3_equivalent_axioms; simpl; tauto.
unfold upper_dim_3_axiom.
apply upper_dim_3.
apply pi; assumption.
Defined.

End Tarski_neutral_3D_to_Hilbert_neutral_3D.

Section Tarski_Euclidean_to_Hilbert_Euclidean.

Context `{TE:Tarski_euclidean}.

(** * Group Parallels *)

Definition Para := fun l m =>
  (~ exists X, IncidentL X l /\ IncidentL X m) /\ exists p, IncidentLP l p /\ IncidentLP m p.

Lemma Para_Par : forall A B C D (HAB : A<>B) (HCD: C<>D),
 Para (Lin A B HAB) (Lin C D HCD) -> Par A B C D.
Proof.
unfold Para, IncidentL, Par, Par_strict; simpl.
intros.
destruct H as [HNI [p []]].
left.
repeat split;auto.
apply plane_cop with p; [apply H|apply H|apply H0..]; unfold IncidentL; simpl; Col.
Qed.

Lemma axiom_euclid_uniqueness :
  forall l P m1 m2,
  ~ IncidentL P l ->
   Para l m1 -> IncidentL P m1 ->
   Para l m2 -> IncidentL P m2 ->
   EqL m1 m2.
Proof.
intros.
destruct l as [A B HAB].
destruct m1 as [C D HCD].
destruct m2 as [C' D' HCD'].
unfold IncidentL in *;simpl in *.
apply Para_Par in H0.
apply Para_Par in H2.
elim (tarski_s_euclid_implies_playfair euclid A B C D C' D' P H0 H1 H2 H3);intros.
apply axiom_line_uniqueness with C' D';
unfold IncidentL;simpl;Col.
Qed.

Instance Hilbert_euclidean_follows_from_Tarski_euclidean :
  Hilbert_euclidean Hilbert_neutral_follows_from_Tarski_neutral.
Proof.
split.
apply axiom_euclid_uniqueness.
Defined.

Instance Hilbert_euclidean_ID_follows_from_Tarski_euclidean :
  Hilbert_euclidean_ID Hilbert_euclidean_follows_from_Tarski_euclidean.
Proof.
split.
intros l m.
assert (ID : decidability_of_intersection).
apply strong_parallel_postulate_implies_inter_dec.
cut tarski_s_parallel_postulate.
apply equivalent_postulates_without_decidability_of_intersection_of_lines_bis; simpl; tauto.
unfold tarski_s_parallel_postulate.
apply euclid.
destruct l as [L1 L2 HL].
destruct m as [M1 M2 HM].
simpl; unfold IncidentL; simpl.
apply ID.
Defined.

End Tarski_Euclidean_to_Hilbert_Euclidean.


(** This file provides a direct formalizatoin of Girard's paradox, as explained in Martin-Lof's 1972
"An intuitionistic theory of types". It can serve as a test as to whether the version of Coq being
used is (in the most obvious way) inconsistent. **)

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

(* This section has an arbitrary type instead of False *)
Section girard.

Variable Flse : Type.

(* an "ordering without infinite descending chains" (wf is for "well-founded") *)
Definition wf (T : Type) : Type
  := ∑ lt : T -> T -> Type,
            (∏ x y z: T, lt x y -> lt y z -> lt x z) ×
            (∏ h : (nat -> T), (∏ n : nat, lt (h (S n)) (h n)) -> Flse).

(* the type of such orderings *)
Definition wfs : Type := total2 wf.

(* the underyling set *)
Definition uset (w : wfs) : Type := pr1 w.
(* the underlying order *)
Definition uord (w : wfs) : uset w -> uset w -> Type := pr1 (pr2 w).
(* the transitivity property *)
Definition trans (w : wfs) {x y z : uset w}
  : pr1 (pr2 w) x y → pr1 (pr2 w) y z → pr1 (pr2 w) x z
  := pr1 (pr2 (pr2 w)) x y z.
(* the well-foundedness property *)
Definition wfp (w : wfs) :
  (λ _ : ∏ x y z : pr1 w, pr1 (pr2 w) x y → pr1 (pr2 w) y z → pr1 (pr2 w) x z,
                   ∏ h : nat → pr1 w, (∏ n : nat, pr1 (pr2 w) (h (S n)) (h n)) → Flse) (pr1 (pr2 (pr2 w)))
  := pr2 (pr2 (pr2 w)).

(* the order on wfs: an order-preserving function on underlying sets and an
   element of the second set which dominates the image *)
Definition wfs_wf_uord (v : wfs) (w : wfs) : Type
  := ∑ f : uset v -> uset w,
           (∏ x y : uset v, (uord v) x y -> (uord w) (f x) (f y)) ×
           (∑ y : uset w, ∏ (x: uset v), (uord w) (f x) y).

(* the underlying function *)
Definition ufun {v : wfs} {w : wfs} (a : wfs_wf_uord v w) : uset v → uset w := pr1 a.
(* the homomorpshim property *)
Definition homo {v : wfs} {w : wfs} (a : wfs_wf_uord v w)
  : ∏ (x y : uset v), uord v x y → uord w (pr1 a x) (pr1 a y)
  := pr1 (pr2 a).
(* the dominating element *)
Definition domi {v : wfs} {w : wfs} (a : wfs_wf_uord v w) : uset w := pr1 (pr2 (pr2 a)).
(* the relation comparing the dominating element to the various images *)
Definition domicom {v : wfs} {w : wfs} (a : wfs_wf_uord v w)
  : (λ y : uset w, ∏ x : uset v, uord w (pr1 a x) y) (pr1 (pr2 (pr2 a)))
  := pr2 (pr2 (pr2 a)).

(* transitivty of the ordering on wfs *)
Definition wfs_wf_trans : forall x y z : wfs, wfs_wf_uord x y -> wfs_wf_uord y z -> wfs_wf_uord x z.
Proof.
  intros x y z.
  intros f g.
  exists (fun a : uset x => (ufun g) ((ufun f) a)).
  split.
  + intros x0 y0.
    intro x0y0.
    exact (homo g _ _ (homo f _ _ x0y0)).
  + exists (domi g).
    intro x0.
    set (y0 := ufun f x0).
    set (ydom := domi f).
    set (co := domicom f x0).
    exact (trans z (homo g _ _ co) (domicom g (domi f))).
Defined.

(* the following three definitions and lemmas are for showing that wfs_wf_uord is well founded *)

(* given a descending sequence f : nat -> wfs, map each f(n) to f(0) by composing all the maps *)

Definition wfs_wf_wfp_shift (f : nat -> wfs) (b : ∏ n : nat, wfs_wf_uord (f (S n)) (f n)) :
  ∏ (n : nat), (uset (f n) -> uset (f 0)).
Proof.
  intro n.
  induction n.
  - intro a; exact a.
  - intro x.
    exact (IHn (ufun (b n) x)).
Defined.

(* thus obtain a sequence in (f 0) *)
Definition wfs_wf_wfp_seq (f : nat -> wfs) (b : ∏ n : nat, wfs_wf_uord (f (S n)) (f n)) :
  nat -> uset (f 0).
Proof.
  intro n.
  exact (wfs_wf_wfp_shift f b n (domi (b n))).
Defined.

(* obtain comparisons between the shifted elements *)
Definition wfs_wf_wfp_compshift (f : nat -> wfs) (b : ∏ n : nat, wfs_wf_uord (f (S n)) (f n)) :
  ∏ (n : nat) {x y : uset (f n)},
    uord (f n) x y -> uord (f 0) (wfs_wf_wfp_shift f b n x) (wfs_wf_wfp_shift f b n y).
Proof.
  intros n.
  induction n.
  - intros x y p.
    exact p.
  - intros x y p.
    exact (IHn _ _ (homo (b n) x y p)).
Qed.

(* show that the resulting sequence on (f 0) is descending *)
Lemma wfs_wf_wfp_desc (f : nat -> wfs) (b : forall n : nat, wfs_wf_uord (f (S n)) (f n)) :
  ∏ n : nat, uord (f 0) (wfs_wf_wfp_seq f b (S n)) (wfs_wf_wfp_seq f b n).
Proof.
  intro n.
  exact (wfs_wf_wfp_compshift f b n (domicom (b n) (domi (b (S n))))).
Defined.

(* the wf on wfs *)
Definition wfs_wf : wf wfs.
Proof.
  exists wfs_wf_uord.
  split.
  - exact wfs_wf_trans.
  - intro h.
    intro b.
    exact (wfp _ (wfs_wf_wfp_seq h b) (wfs_wf_wfp_desc  h b)).
Defined.

(* the wf on wfs as an element of wfs *)
Definition wfs_wf_t : wfs := tpair (fun T => wf T) wfs (wfs_wf).

(* this definition and the following three lemmas show that wfs_wf has a maximal element *)

(* function mapping each wf to the set of wfs (by taking inital segments) *)
Definition maxi_fun (w : wfs) : uset w -> wfs.
Proof.
  intro x.
  exists (∑ y : uset w, uord w y x).
  exists (fun a b => uord w (pr1 a) (pr1 b)).
  split.
  - intros x0 y z p q.
    exact (trans w p q).
  - intro h.
    intro b.
    exact (wfp w (fun n => pr1 (h n)) b).
Defined.

(* maxi_fun preserves the order *)
Lemma maxi_homo (w : wfs) : ∏ (x y : uset w),
    uord w x y -> wfs_wf_uord (maxi_fun w x) (maxi_fun w y).
Proof.
  intros x y p.
  exists (fun (z : uset (maxi_fun w x)) => tpair _ (pr1 z) (trans w (pr2 z) p)).
  split.
  - intros x0 y0 q.
    exact q.
  - exists (tpair _ x p).
    intro x0.
    exact (pr2 x0).
Defined.

(* w itself dominates the image of w under maxi_fun *)
Lemma maxidom (w : wfs) : ∏ (x : uset w), wfs_wf_uord (maxi_fun w x) w.
Proof.
  intro x.
  exists (fun (z : uset (maxi_fun w x)) => pr1 z).
  split.
  - intros x0 y p.
    exact p.
  - exists x.
    intro x0.
    exact (pr2 x0).
Defined.

(* wfs_wf_t is maximal with respect to wfs_wf *)
Lemma maxi (w : wfs) : wfs_wf_uord w wfs_wf_t.
Proof.
  exists (maxi_fun w).
  split.
  - exact (maxi_homo w).
  - exact (tpair _ _ (maxidom w)).
Defined.

(* in particular wfs_wf_t is greather than itself *)
Proposition whoa : uord wfs_wf_t wfs_wf_t wfs_wf_t.
Proof.
  apply maxi.
Defined.

(* but wfs are irreflexive *)
Proposition irref (w : wfs) : ∏ (x : uset w), (uord w) x x -> Flse.
Proof.
  intro x.
  intro p.
  exact (wfp w (fun n => x) (fun n => p)).
Defined.

(* therefore the world explodes *)
Proposition the_world_explodes : Flse.
Proof.
  exact (irref wfs_wf_t wfs_wf_t whoa).
Defined.

End girard.

(* especially if Flse=False *)
Proposition but_seriously_the_world_explodes : empty.
  exact (the_world_explodes empty).
Defined.


From mathcomp Require Import all_ssreflect all_algebra.
Require Import extra_mathcomp.

Import Order.TTheory GRing.Theory Num.Theory.

Local Notation "s `_ i" := (nth 0 s i) : nat_scope.

(* For n_1, ..., n_k, and n := n_1 + ... + n_k, the multinomial (n | n_1, ... n_k) is
the coefficient of the monomial x_1 ^ n_1 ... x_k ^n_k in the expansion of
(x_1 + ... + x_k)^n. It can also be defined as n! /(n_1!... n_k!) or as the product
(bin n_1 n_2) (bin (n_1 + n_2) n_2)... (bin n n_k) *)

(* Shall we obtain this from a more computational friendly
  definition? One day, may be, if needed. *)
Definition multinomial (l : seq nat) : nat :=
 \prod_(0 <= i < size l) (binomial (\sum_(0 <= j < i.+1) l`_j) l`_i).

Arguments multinomial l : simpl never.

(* Notation under evaluation ... *)
Notation "''C' [ l ]" := (multinomial l)
  (at level 8, format "''C' [ l ]") : nat_scope.

(* For instance I would like to avoid double brackets, like in: *)
Check 'C[[::]].
Check 'C[[:: 8]].

(* Unlocking is needed for computation and for convertibility. *)
Example foo : multinomial [::1;2] = 3.
by rewrite /multinomial /binomial unlock.
Qed.

Lemma multi_nil : 'C[[::]] = 1.
Proof. by rewrite /multinomial big_nil. Qed.

Lemma multi_singl n : 'C[[:: n]] = 1.
Proof.
by rewrite /multinomial; do 2! (rewrite !big_mkord /= big_ord1 /=); rewrite binn.
Qed.

Lemma multi_gt0 l : 'C[l] > 0.
Proof. by apply: prodn_gt0 => i; rewrite bin_gt0 big_nat_recr //= leq_addl. Qed.

Lemma multi_rcons n l :
'C[rcons l n] = 'C[l] * 'C(\sum_(j <- l) j + n, n).
Proof.
rewrite [in LHS]/multinomial [in RHS](big_nth 0) size_rcons !big_nat_recr //=.
have -> : (rcons l n)`_(size l) = n by rewrite nth_rcons ltnn eqxx.
have aux k : 0 <= k < size l -> (rcons l n)`_k = l`_k.
  by rewrite nth_rcons; case/andP=> _ ->.
rewrite !big_nat (eq_bigr _ aux) -big_nat; congr (_ * _); rewrite /multinomial.
rewrite !big_nat; apply: eq_bigr => i ?; rewrite aux // !big_nat; congr 'C(_, _).
by apply: eq_bigr=> j /andP[le0j leji]; rewrite aux // le0j (leq_trans leji).
Qed.

Lemma multi_prod_fact l : 'C[l] * \prod_(j <- l) j`! = (\sum_(j <- l) j)`!.
Proof.
elim/last_ind: l => [| l n ihl]; first by rewrite multi_nil !big_nil.
set p := \prod_(_ <- _) _; set s := \sum_(_ <- _) _.
rewrite multi_rcons mulnAC.
have aux : (rcons l n)`_(size l) = n by rewrite nth_rcons ltnn eqxx.
have -> : p = \prod_(j <- l) j`! * n`! by rewrite /p -cats1 big_cat /= big_seq1.
rewrite mulnA ihl.
have es : s = \sum_(j <- l) j + n by rewrite /s -cats1 big_cat /= big_seq1.
rewrite -es mulnC [X in _ * X = _]mulnC.
have -> : \sum_(j <- l) j = s - n by rewrite es addnK.
by rewrite bin_fact // es leq_addl.
Qed.

Notation "'BIG_op_F' op" :=
  (F in  \big[op/_]_(i <- _ | _) F i)%pattern (at level 36).

Notation "'BIG_op_P' op" :=
  (P in  \big[op/_]_(i <- _ | P i) _)%pattern (at level 36).

(* For the sake of compatibility with hanson.
Note that the sum and prod should be moved to a \sum_(j <- l)_ shape. *)
Lemma eq_def_multiQ l :
  ('C[l]%:Q =
   (\sum_(0 <= i < size l) l`_i)`!%:Q /
   (\prod_(0 <= i < size l) (l`_i)`!)%N%:Q)%R.
Proof.
have dn0 : ((\prod_(i <- l) i `!)%N%:Q != 0)%R.
  rewrite pnatr_eq0 -lt0n prodn_gt0 // => i; exact: fact_gt0.
rewrite -(big_nth 0 xpredT) -(big_nth 0 xpredT id). (* booh *)
by rewrite -multi_prod_fact !PoszM !rmorphM /= mulfK.
Qed.

(* Because it is basically mulnK *)
Lemma whyIsThisNotProved (m d n : nat) : 0 < d -> m * d = n -> m = n %/ d.
Proof. by move=> d_gt0 <-; rewrite mulnK. Qed.

(* Compatiblity again. *)
Lemma eq_def_multi1 (l : list nat) :
'C[l] * \prod_(0 <= i < size l) (l`_i)`! = (\sum_(0 <= i < size l) l`_i)`!.
Proof.
rewrite -(big_nth 0 xpredT) -(big_nth 0 xpredT id). (* booh *)
exact: multi_prod_fact.
Qed.

Local Open Scope ring_scope.

Section Monomials.

Context  {R : unitRingType}.

Definition monomial (x : seq R) (e : seq nat) :=
  \prod_(xi <- zip x e) xi.1 ^ xi.2.

(* Definition monomial {n : nat} (x : seq R) (e : seq 'I_n) := *)
(*   \prod_(xi <- zip x e) xi.1 ^ xi.2. *)

(* Definition monomial {R : unitRingType} {n : nat} (x : seq R) (e : seq 'I_n) := *)
(*   \prod_(0 <= i < size x) (nth 0 x i) ^ (nth 0%N (map (@nat_of_ord n) e) i). *)

Lemma monom_nill e : monomial [::] e = 1.
Proof. by rewrite /monomial zip_nil_l big_nil. Qed.

Lemma monom_nilr (x : seq R) : monomial x [::] = 1.
Proof. by rewrite /monomial zip_nil_r big_nil. Qed.

Lemma monom_rcons (a : R) (x : seq R) i e :
  size x = size e -> monomial (rcons x a) (rcons e i) = (monomial x e) * a ^ i.
Proof. by move => Hxe; rewrite /monomial !zip_rcons // big_rcons. Qed.

End Monomials.

Definition tmap_val {n m} (t : n.-tuple 'I_m) : seq nat :=
  [seq val j | j <- t].

Lemma tmap_val_rcons  {n m} (t : n.-tuple 'I_m) i :
  tmap_val [tuple of rcons t i] = rcons (tmap_val t) i.
Proof. by rewrite /tmap_val map_rcons. Qed.

Section GNewton.

Context  {R : comUnitRingType}.

Lemma generalizedNewton (l : seq R) (n m : nat) (s := size l) :
  (n <= m)%N ->
  (\sum_(x <- l) x) ^+ n =
  \sum_(t : s.-tuple 'I_m.+1 | (\sum_(i <- t) i)%N == n)
   ('C[tmap_val t])%:R * monomial l (tmap_val t).
Proof.
rewrite {}/s; elim/last_ind: l n m => [|l a ihl] n m /=.
- rewrite big_tuple0 big_nil big_tuple big_ord0 /= monom_nill mulr1 /= expr0n.
  by rewrite multi_nil; case: n.
- move=> leqnm; rewrite size_rcons big_rcons /= exprDn.
  set s := size l.
  pose tlast s (t : s.-tuple 'I_m.+1) := last ord0 t.
  have -> P F :
   \sum_(t : s.+1.-tuple 'I_m.+1 | P t) F t =
   \sum_(j < m.+1) \sum_(t | P t && (tlast _ t == j)) F t.
     exact: partition_big.
  pose F (i : nat) := (\sum_(j <- l) j) ^+ (n - i) * a ^+ i *+ 'C(n, i).
  have -> : \sum_(i < n.+1) F i = \sum_(i < m.+1 | (i < n.+1)%N) F i.
    by apply: big_ord_widen; rewrite ltnS.
  rewrite big_mkcond /=; apply: eq_bigr => i _; case: ltnP=> hni; last first.
    rewrite /tlast big_pred0 // => [[]]; case/lastP => // t u stu /=.
    rewrite last_rcons big_rcons /=.
    by apply: contraTF hni; case/andP=> /eqP<- /eqP<-; rewrite -leqNgt leq_addl.
  rewrite {}/F.
  have /ihl -> : (n - i <= m)%N.
    by apply: (leq_trans (leq_subr _ _)); apply: (leq_trans leqnm).
  rewrite mulr_suml -sumrMnl.
  pose tsum a (t : a.-tuple 'I_m.+1) b := ((\sum_(j <- t) j) == b)%N.
  have -> F :
  \sum_(t : s.+1.-tuple 'I_m.+1 | tsum _ t n && (tlast _ t == i)) F t =
  \sum_(t : s.-tuple 'I_m.+1    | tsum _ t (n - i)%N) F [tuple of (rcons t i)].
    pose indx (t : s.-tuple 'I_m.+1) := [tuple of rcons t i].
    pose indxV (t : s.+1.-tuple 'I_m.+1) := [tuple of rev (behead (rev t))].
    rewrite [LHS](reindex indx) /= /tlast /tsum.
       apply: eq_bigl => t; rewrite last_rcons eqxx andbT big_rcons /=.
       apply/eqP/eqP=> [|->]; first exact: (canRL (addnK i)).
       by rewrite subnK.
    exists indxV => t ht; rewrite /indx /indxV /=; apply: val_inj => /=.
      by rewrite rev_rcons revK.
    move: ht; rewrite inE; case/andP=> _; case: t; case/lastP => //= ? j _.
    by rewrite last_rcons => /eqP->; rewrite rev_rcons /= revK.
  symmetry; apply: congr_big => //= u /eqP es /=.
  rewrite tmap_val_rcons multi_rcons natrM mulrAC monom_rcons; last first.
    by rewrite size_map size_tuple.
  by rewrite /tmap_val big_map es exprnP mulr_natr -mulrA subnK.
Qed.

End GNewton.

Section MultinomialIneq.

Context  {R : comUnitRingType}.

Local Open Scope nat_scope.

Lemma multinomial_ineq (l : seq nat) (p :=  \prod_(j <- l) j ^ j) (s := \sum_(j <- l) j) :
  'C[l] * p <= s ^ s.
Proof.
  rewrite -lez_nat -!natz natrX natrM natr_sum.
  pose lz : seq int := [seq i%:R | i <- l].
  have -> : (\sum_(i <- l) i%:R = \sum_(i <- lz) i)%R by rewrite big_map.
  pose m := s; pose n := s.
  have /generalizedNewton -> : n <= m by [].
  have paux (i : 'I_(size l)) : nth 0 l i < m.+1.
    rewrite ltnS /m /s.
    have /(big_rem _) -> /= : (nth 0 l i) \in l by rewrite mem_nth.
    exact: leq_addr.
  pose aux (i : 'I_(size l)) := Ordinal (paux i).
  pose tl := mktuple aux.
  have Heq : tmap_val tl = l.
    suff Heq1 (i : 'I_(size l)) : nth 0 (tmap_val tl) i = nth 0 l i.
      apply: (@eq_from_nth nat 0 _ _); rewrite size_map size_tuple // .
      move => i Hisize.
      suff -> : nth 0 (tmap_val tl) (Ordinal Hisize) = nth 0 l (Ordinal Hisize) by [].
      exact: Heq1.
    by rewrite (nth_map ord0 0) /tl ?size_tuple ?(nth_mktuple aux ord0 i).
  rewrite /lz size_map; set P := BIG_P.
  have /(bigD1 _) -> /= : P tl.
    rewrite /P /n /s big_tuple big_tnth /=; apply/eqP/eq_bigr => i _.
    by rewrite tnth_mktuple /aux /= (tnth_nth 0) in_tupleE.
  suff {P} -> : (('C[l])%:R * p%:R =
     ('C[tmap_val tl])%:R * monomial [seq i%:R | i <- l] (tmap_val tl) :> int)%R.
  rewrite cpr_add; apply: sumr_ge0 => i _; apply: mulr_ge0.
  - by rewrite ler0n.
  - rewrite /monomial big_seq_cond.
    apply: prodr_ge0 => j; rewrite andbT => /nth_index hj.
    rewrite -(hj (1 : int, 0%N)) nth_zip /=; last first.
      by rewrite !size_map size_tuple.
    rewrite exprn_ge0 //.
    set ll := (X in (0 <= nth _ X _)%R); set k := index _ _.
    case: (ltnP k (size ll)) => [/mem_nth |] hk.
      suff ll_pos x : x \in ll -> (0 <= x)%R by apply: ll_pos.
      rewrite /ll; case/mapP => u _ ->; exact: ler0n.
    by rewrite nth_default.
  congr (_ * _)%R.
  - apply/eqP; rewrite eqr_nat.
    by rewrite Heq.
  - rewrite /monomial /p Heq natr_prod.
    suff -> : zip [seq i%:R | i <- l] l = map (fun i => (Posz i,i)) l.
      rewrite big_map.
      by apply: eq_bigr => i _ /=; first by rewrite natrX -exprnP -natz.
    apply: (@eq_from_nth _ (0%:R,0));rewrite size_zip !size_map minnn// => i Hi.
    rewrite nth_zip ?size_map // ; rewrite (nth_map 0 (Posz 0)) // .
    by rewrite (nth_map 0 (Posz 0,0)) // natz.
Qed.

End MultinomialIneq.


Require Import Coq.Init.Prelude.

Fixpoint fnd (n : nat) : Prop :=
  match n with
  | O => True
  | S n => True /\ fnd n
  end.

Fixpoint big_and (xs : list Prop) : Prop :=
  match xs with
  | nil => True
  | cons x xs => and x (big_and xs)
  end.
Fixpoint typeof_big_conj (xs : list Prop) (P : Prop) : Prop :=
  match xs with
  | nil => P
  | cons x xs => x -> typeof_big_conj xs P
  end.
Lemma apply_rconj_and xs (P Q : Prop) : P -> typeof_big_conj xs Q -> typeof_big_conj xs (P /\ Q).
Proof. revert Q; revert P; induction xs; intros; cbn in *; eauto. Qed.
Lemma big_conj xs : typeof_big_conj xs (big_and xs).
Proof. induction xs. exact I. cbn. intros. apply apply_rconj_and; eauto. Qed.

Require Import Coq.Lists.List.

Goal fnd 10000.
  Time
  let n := match goal with |- fnd ?n => n end in
  let ls := eval cbv in (repeat True n) in
  let pf := constr:(big_conj ls) in
  let T := type of pf in
  let T := eval cbv [typeof_big_conj big_and] in T in
  refine (let H : T := pf in _).
  Time clearbody H.
  Time apply H; exact I.
Time Qed.
(*
Finished transaction in 3.028 secs (2.946u,0.067s) (successful)
Finished transaction in 0.001 secs (0.001u,0.s) (successful)
Finished transaction in 21.168 secs (21.078u,0.017s) (successful)
Finished transaction in 3.405 secs (3.397u,0.s) (successful)
*)


Require Export Coq.Unicode.Utf8.
Require Export FSubProd.

(******************************************************************************)
(* Subtyping relation                                                         *)
(******************************************************************************)

Inductive Sub (Γ: Env) : Ty → Ty → Prop :=
  | SA_Top {S} (wf_S: wfTy (domainEnv Γ) S) :
      Sub Γ S top
  | SA_Refl_TVar {X} :
      wfindex (domainEnv Γ) X → Sub Γ (tvar X) (tvar X)
  | SA_Trans_TVar {X T U} :
      lookup_etvar Γ X U → Sub Γ U T → Sub Γ (tvar X) T
  | SA_Arrow {T1 T2 S1 S2} :
      Sub Γ T1 S1 → Sub Γ S2 T2 → Sub Γ (tarr S1 S2) (tarr T1 T2)
  | SA_All {T1 T2 S1 S2} :
      Sub Γ T1 S1 → Sub (etvar Γ T1) S2 T2 → Sub Γ (tall S1 S2) (tall T1 T2)
  | SA_Prod {T1 T2 S1 S2} :
      Sub Γ S1 T1 → Sub Γ S2 T2 →
      Sub Γ (tprod S1 S2) (tprod T1 T2).

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

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

Inductive Typing (Γ: Env) : Tm → Ty → Prop :=
  | T_Var {y T} :
      lookup_evar Γ y T → Typing Γ (var y) T
  | T_Abs {t T1 T2} (wf_T1: wfTy (domainEnv Γ) T1) :
      Typing (evar Γ T1) t T2 →
      Typing Γ (abs T1 t) (tarr T1 T2)
  | T_App {t1 t2 T11 T12} :
      Typing Γ t1 (tarr T11 T12) → Typing Γ t2 T11 →
      Typing Γ (app t1 t2) T12
  | T_Tabs {t T1 T2} (wf_T1: wfTy (domainEnv Γ) T1) :
      Typing (etvar Γ T1) t T2 →
      Typing Γ (tabs T1 t) (tall T1 T2)
  | T_Tapp {t1 T11 T12 T2} :
      Typing Γ t1 (tall T11 T12) → Sub Γ T2 T11 →
      Typing Γ (tapp t1 T2) (tsubstTy X0 T2 T12)
  | T_Prod {t1 T1 t2 T2} :
      Typing Γ t1 T1 → Typing Γ t2 T2 →
      Typing Γ (prod t1 t2) (tprod T1 T2)
  | T_Let {p t1 t2 T1 T2 Δ} :
      Typing Γ t1 T1 → PTyping Γ p T1 Δ →
      Typing (appendEnv Γ Δ) t2 (weakenTy T2 (domainEnv Δ)) →
      Typing Γ (lett p t1 t2) T2
  | T_Sub {t T1 T2} :
      Typing Γ t T1 → Sub Γ T1 T2 →
      Typing Γ t T2.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                            Lib_Div_Even_Odd.v                            *)
(****************************************************************************)

Require Export Lib_Mult.

(****************************** even/odd *********************************)

Inductive even (n : nat) : Prop :=
    even_intro : forall q : nat, n = 2 * q -> even n.

Inductive odd (n : nat) : Prop :=
    odd_intro : forall q : nat, n = 2 * q + 1 -> odd n.

(************************* quotients and divisors ***********************)

Lemma no_zero_div :
 forall n m : nat, 0 < n -> forall q : nat, n = m * q -> 0 < q.
simple induction q.
intro.
absurd (0 = n).
apply lt_O_neq; auto with arith.
rewrite (mult_n_O m); auto with arith.
auto with arith.
Qed.

Lemma lt_quotient2_n :
 forall n : nat, 0 < n -> forall q : nat, n = 2 * q -> q < n.
intros.
rewrite (plus_n_O q).
rewrite H0.
elim plus_mult.
apply plus_lt_compat_l.
apply (no_zero_div n 2 H q H0).
Qed.
Hint Immediate lt_quotient2_n.

Lemma less_div : forall n a b : nat, 0 < n -> n = a * b -> b <= n.
intros.
rewrite H0.
elim (mult_O_le b a); auto with arith.
intro.
absurd (n = 0).
unfold not in |- *; intro.
elim (lt_irrefl n).
pattern n at 1 in |- *.
rewrite H2; auto with arith.
rewrite H0.
rewrite H1; auto with arith.
Qed.

Lemma even_or_odd : forall n : nat, {even n} + {odd n}.
simple induction n.
left; apply (even_intro 0 0); auto with arith.
intros y hrec.
elim hrec.
intro eveny.
right; elim eveny.
intros q hy; apply (odd_intro (S y) q).
elim hy.
elim plus_n_Sm.
auto.
intro oddy; left.
elim oddy.
intros q hy; apply (even_intro (S y) (S q)).
rewrite hy.
rewrite plus_n_Sm.
elim (mult_comm (S q) 2).
elim (mult_comm q 2).
elim plus_comm.
auto.
Qed.

Lemma even_odd : forall a : nat, even a -> ~ odd a.
unfold not in |- *; intros.
elim H0; elim H.
intros k1 evena k2 odda.
apply (le_Sn_n 1).
apply (less_div 1 (k1 - k2) 2); auto with arith.
rewrite mult_comm.
replace (2 * (k1 - k2)) with (2 * k1 - 2 * k2).
elim evena.
rewrite odda.
auto with arith.
elim mult_comm.
replace (2 * k1) with (k1 * 2).
2: apply mult_comm.
replace (2 * k2) with (k2 * 2).
2: apply mult_comm.
(*Rewrite (mult_minus_distr k1 k2 (S(S O))).*)
elim (mult_comm 2 k1); elim (mult_comm 2 k2).
apply sym_equal; auto with arith.
Qed.

Lemma odd_even : forall a : nat, odd a -> ~ even a.
unfold not in |- *; intros.
apply (even_odd a H0).
auto with arith.
Qed.

(********************** S,pred,plus,odd and even ************************)

Lemma plus_even_even : forall a b : nat, even a -> even b -> even (a + b).
intros.
elim H0; elim H.
intros.
rewrite H2; rewrite H1.
elim (mult_plus_distr_left q q0 2).
apply (even_intro (2 * (q + q0)) (q + q0)).
auto with arith.
Qed.

Lemma S_odd_even : forall a : nat, odd a -> even (S a).
intros.
elim H; intros.
rewrite H0.
rewrite (plus_n_Sm (2 * q) 1).
apply (plus_even_even (2 * q) 2).
apply (even_intro (2 * q) q); auto.
apply (even_intro 2 1).
auto with arith.
Qed.

Lemma pred_odd_even : forall a : nat, odd a -> even (pred a).
intros.
elim H; intros.
rewrite H0.
elim (plus_n_Sm (2 * q) 0).
elim (pred_Sn (2 * q + 0)).
elim (plus_n_O (2 * q)).
apply (even_intro (2 * q) q); auto with arith.
Qed.

Lemma plus_even_odd : forall a b : nat, even a -> odd b -> odd (a + b).
intros.
elim H0; elim H; intros.
rewrite H2; rewrite H1.
rewrite (plus_assoc (2 * q) (2 * q0) 1).
elim (mult_plus_distr_left q q0 2).
apply (odd_intro (2 * (q + q0) + 1) (q + q0)).
auto with arith.
Qed.
Hint Immediate plus_even_odd.

Lemma plus_odd_even : forall a b : nat, odd a -> even b -> odd (a + b).
intros.
rewrite plus_comm.
auto with arith.
Qed.

Lemma S_even_odd : forall a : nat, even a -> odd (S a).
intros.
elim H; intros.
rewrite H0.
apply (odd_intro (S (2 * q)) q).
elim (plus_n_Sm (2 * q) 0).
auto with arith.
Qed.

Lemma plus_odd_odd : forall a b : nat, odd a -> odd b -> even (a + b).
intros.
elim H0; elim H; intros.
rewrite H2; rewrite H1; intros.
rewrite (plus_comm (2 * q0) 1).
rewrite (plus_assoc (2 * q + 1) 1 (2 * q0)).
rewrite (plus_assoc_reverse (2 * q) 1 1).
apply (plus_even_even (2 * q + (1 + 1)) (2 * q0)).
apply (plus_even_even (2 * q) (1 + 1)).
apply (even_intro (2 * q) q); auto with arith.
apply (even_intro (1 + 1) 1); auto with arith.
apply (even_intro (2 * q0) q0); auto.
Qed.

(************************** mult, even and odd ***************************)

Lemma mult_even : forall a b : nat, even a -> even (a * b).
intros.
elim H.
intros.
apply (even_intro (a * b) (q * b)).
rewrite H0.
auto with arith.
Qed.

Lemma mult_odd_odd : forall a b : nat, odd a -> odd b -> odd (a * b).
intros.
elim H0; intros.
elim H; intros.
clear H0; clear H.
rewrite H2; rewrite H1.
rewrite (mult_plus_distr_r (2 * q0) 1 (2 * q + 1)).
apply (plus_even_odd (2 * q0 * (2 * q + 1)) (1 * (2 * q + 1))).
apply (mult_even (2 * q0) (2 * q + 1)).
apply (even_intro (2 * q0) q0); auto.
apply (odd_intro (1 * (2 * q + 1)) q); auto with arith.
Qed.

(************************** div, even and odd ****************************)

Definition div (d a : nat) := exists k : nat, a = d * k.

Lemma div_odd_even : forall n d : nat, div d (2 * n) -> odd d -> div d n.
intros.
elim H.
intros.
cut (even x).
intro.
elim H2.
intros q evenx.
unfold div in |- *.
exists q.
apply (mult_reg_l_bis n (d * q) 2).
auto with arith.
rewrite H1.
rewrite evenx.
elim (mult_assoc_reverse 2 d q).
rewrite (mult_comm 2 d).
auto with arith.
elim (even_or_odd x).
auto with arith.
intros.
absurd (even (d * x)).
apply odd_even.
apply mult_odd_odd; auto.
cut (d * x = 2 * n); auto with arith.
intro.
apply (even_intro (d * x) n).
auto with arith.
Qed.

Lemma div_odd_odd : forall n : nat, odd n -> forall d : nat, div d n -> odd d.
intros n oddn d divdn.
elim divdn.
intros.
 elim (even_or_odd d); auto.
intros evend.
absurd (even n).
apply odd_even; auto with arith.
rewrite H.
apply mult_even; auto with arith.
Qed.

Lemma div_plus : forall n m d : nat, div d n -> div d m -> div d (n + m).
intros n m d divdn divdm.
elim divdm; intros; elim divdn; intros.
rewrite H0; rewrite H.
elim mult_plus_distr_left.
unfold div in |- *.
exists (x0 + x); auto with arith.
Qed.
Hint Immediate div_plus.

Lemma div_minus : forall n m d : nat, div d n -> div d m -> div d (n - m).
intros n m d divdn divdm.
elim divdm; intros; elim divdn; intros.
rewrite H0; rewrite H.
elim (mult_minus_distr_left x0 x d).
unfold div in |- *.
exists (x0 - x); auto with arith.
Qed.
Hint Immediate div_minus.

(************* Informative definitions of Even and Or ********************)

Inductive Even (n : nat) : Set :=
    Even_intro : forall q : nat, n = 2 * q -> Even n.

Inductive Odd (n : nat) : Set :=
    Odd_intro : forall q : nat, n = 2 * q + 1 -> Odd n.

Lemma Even_or_Odd : forall n : nat, Even n + Odd n.
simple induction n.
left; apply (Even_intro 0 0); auto with arith.
intros y hrec.
elim hrec.
intro eveny.
right; elim eveny.
intros q hy; apply (Odd_intro (S y) q).
elim hy.
elim plus_n_Sm.
auto with arith.
intro oddy; left.
elim oddy.
intros q hy; apply (Even_intro (S y) (S q)).
rewrite hy.
rewrite plus_n_Sm.
elim (mult_comm (S q) 2).
elim (mult_comm q 2).
elim plus_comm.
auto with arith.
Qed.

Lemma Odd_odd : forall n : nat, Odd n -> odd n.
intros.
elim H.
intros.
apply (odd_intro n q e).
Qed.
Hint Immediate Odd_odd.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Implementation with Dependent Pair
  author    : ZhengPu Shi
  date      : 2021.12
 *)

Require Export MatrixTheory.
Require Import DepPair.Matrix.

(* ######################################################################### *)
(** * Basic matrix theory implemented with Dependent Pair *)

Module BasicMatrixTheoryDP (E : ElementType) <: BasicMatrixTheory E.

  (** Basic library *)
  Export BasicConfig TupleExt SetoidListListExt HierarchySetoid.

  (* ==================================== *)
  (** ** Matrix element type *)
  Export E.

  Infix "==" := (eqlistA Aeq) : list_scope.
  Infix "==" := (eqlistA (eqlistA Aeq)) : dlist_scope.
  Infix "==" := (veq (Aeq:=Aeq)) : vec_scope.

  Open Scope nat_scope.
  Open Scope A_scope.
  Open Scope vector_scope.
  Open Scope mat_scope.

  (* ==================================== *)
  (** ** Matrix type and basic operations *)

  Definition mat r c := @mat A r c.

  (** matrix equality *)
  Definition meq {r c : nat} := @meq A Aeq r c.
  Infix "==" := meq : mat_scope.

  Lemma meq_equiv r c : Equivalence (@meq r c).
  Proof.
    apply meq_equiv.
  Qed.

  Global Existing Instance meq_equiv.

  (** Get n-th element of a matrix *)
  Definition mnth {r c} (m : mat r c) (ri ci : nat) :=
    @mnth A A0 r c m ri ci.

  (** meq and mnth should satisfy this constraint *)
  Lemma meq_iff_mnth : forall {r c : nat} (m1 m2 : mat r c),
      m1 == m2 <-> (forall ri ci, ri < r -> ci < c -> (mnth m1 ri ci == mnth m2 ri ci)%A).
  Proof.
    intros. apply meq_iff_mnth.
  Qed.

  (** linear matrix arithmetic tactic for equation: split goal to every element *)
  Ltac lma :=
    cbv; repeat constructor;
    try ring; try easy.

  (* ==================================== *)
  (** ** Convert between list list and matrix *)

  (** *** list list to mat *)

  Definition l2m {r c} (dl : list (list A)) : mat r c :=
    l2m A0 dl r c.

  (** l2m is a proper morphism *)
  Lemma l2m_aeq_mor : forall r c, Proper (eqlistA (eqlistA Aeq) ==> meq) (@l2m r c).
  Proof.
    Admitted.

  Global Existing Instance l2m_aeq_mor.

  (* Another definition *)
  Definition l2m_old {r c} (dl : list (list A)) : mat r c :=
    mmake r c (fun x y => nth y (nth x dl []) A0).

  Lemma l2m_inj : forall {r c} (d1 d2 : list (list A)),
      length d1 = r -> width d1 c ->
      length d2 = r -> width d2 c ->
      ~(d1 == d2)%dlist -> ~(@l2m r c d1 == l2m d2).
  Proof.
  Admitted.

  Lemma l2m_surj : forall {r c} (m : mat r c),
      (exists d, l2m d == m).
  Proof.
  Admitted.

  (** *** mat to list list *)

  Definition m2l {r c} (m : mat r c) : list (list A) :=
    m2l m.

  (** m2l is a proper morphism *)
  Lemma m2l_aeq_mor : forall r c, Proper (meq ==> eqlistA (eqlistA Aeq)) (@m2l r c).
  Proof.
    Admitted.

  Global Existing Instance m2l_aeq_mor.

  Lemma m2l_length : forall {r c} (m : mat r c), length (m2l m) = r.
  Proof.
    unfold m2l. induction r; intros; destruct m; simpl; auto.
  Qed.

  Global Hint Resolve m2l_length : mat.

  Lemma m2l_width : forall {r c} (m : mat r c), width (m2l m) c.
  Proof.
    unfold width, m2l.
    induction r; intros; destruct m; simpl; auto; constructor; auto.
    apply v2l_length.
  Qed.

  Global Hint Resolve m2l_width : mat.

  Lemma m2l_l2m_id : forall {r c} (dl : list (list A)) (H1 : length dl = r)
                       (H2 : width dl c), (@m2l r c (l2m dl) == dl)%dlist.
  Proof.
    intros. apply m2l_l2m_id; auto.
  Qed.

  Lemma l2m_m2l_id : forall {r c} (m : mat r c), l2m (m2l m) == m.
  Proof.
    intros. apply l2m_m2l_id; auto.
  Qed.

  Lemma m2l_inj : forall {r c} (m1 m2 : mat r c),
      ~(m1 == m2) -> ~(m2l m1 == m2l m2)%dlist.
  Proof.
  Admitted.

  Lemma m2l_surj : forall {r c} (d : list (list A)),
      length d = r -> width d c ->
      (exists m, @m2l r c m == d)%dlist.
  Proof.
  Admitted.

  (* ==================================== *)
  (** ** Specific matrix *)

  Definition mk_mat_1_1 (a11 : A) : mat 1 1 := [[a11]].

  Definition mk_mat_3_1 (a1 a2 a3 : A) : mat 3 1 := [[a1];[a2];[a3]].

  Definition mk_mat_3_3 (a11 a12 a13 a21 a22 a23 a31 a32 a33 : A) : mat 3 3
    := [[a11;a12;a13];[a21;a22;a23];[a31;a32;a33]].

  (* ==================================== *)
  (** ** Convert between tuples and matrix *)

  (** tuple_3x3 -> mat_3x3 *)
  Definition t2m_3x3 (t : @T_3x3 A) : mat 3 3.
  Proof.
    destruct t as ((t1,t2),t3).
    destruct t1 as ((a11,a12),a13).
    destruct t2 as ((a21,a22),a23).
    destruct t3 as ((a31,a32),a33).
    exact (mk_mat_3_3 a11 a12 a13 a21 a22 a23 a31 a32 a33).
  Defined.

  (** mat_3x3 -> tuple_3x3, thatt is ((a11,a12,a13),(a21,a22,a23),(a31,a32,a33)) *)
  Definition m2t_3x3 (m : mat 3 3) : @T_3x3 A.
    set (dl := m2l m).
    remember (hd [] dl) as l1.
    remember (hd [] (tl dl)) as l2.
    remember (hd [] (tl (tl dl))) as l3.
    remember (hd A0 l1, hd A0 (tl l1), hd A0 (tl (tl l1))) as t1.
    remember (hd A0 l2, hd A0 (tl l2), hd A0 (tl (tl l2))) as t2.
    remember (hd A0 l3, hd A0 (tl l3), hd A0 (tl (tl l3))) as t3.
    exact (t1, t2, t3).
  Defined.

  (** m[0,0] : mat_1x1 -> A *)
  Definition scalar_of_mat (m : mat 1 1) := mnth m 0 0.

  (* ==================================== *)
  (** ** Matrix transposition *)

  Definition mtrans {r c} (m : mat r c): mat c r :=
    @mtrans A r c m.

  Global Notation "m \T" := (mtrans m) : mat_scope.

  Lemma mtrans_trans : forall {r c} (m : mat r c), mtrans (mtrans m) == m.
  Proof.
    apply @mtrans_trans. apply Equiv_Aeq.
  Qed.

  (* ==================================== *)
  (** ** Mapping of matrix *)

  (** Mapping of a matrix *)
  Definition mmap {r c} (f : A -> A) (m : mat r c) : mat r c := mmap f m.

  Definition mmap2 {r c} (f: A -> A -> A) (m1 m2: mat r c) : mat r c := mmap2 f m1 m2.

  Lemma mmap2_comm : forall {r c} (f : A -> A -> A)
                       (f_comm : forall a b : A, (f a b == f b a)%A)
                       (m1 m2 : mat r c),
      mmap2 f m1 m2 == mmap2 f m2 m1.
  Proof.
    intros. apply mmap2_comm. auto.
  Qed.

  Lemma mmap2_assoc : forall {r c} (f : A -> A -> A)
                        (f_assoc : forall a b c, (f (f a b) c == f a (f b c))%A)
                        (m1 m2 m3 : mat r c),
      mmap2 f (mmap2 f m1 m2) m3 == mmap2 f m1 (mmap2 f m2 m3).
  Proof.
    intros. apply mmap2_assoc. auto.
  Qed.

End BasicMatrixTheoryDP.

(* ######################################################################### *)
(** * Decidable matrix theory implemented with Dependent Pair *)

Module DecidableMatrixTheoryDP (E : DecidableElementType) <: DecidableMatrixTheory E.

  (* Export E. *)
  Include BasicMatrixTheoryDP E.

  (** meq is decidable *)
  Lemma meq_dec : forall {r c}, Decidable (meq (r:=r)(c:=c)).
  Proof.
    intros. apply veq_dec. apply veq_dec. apply Dec_Aeq.
  Qed.

End DecidableMatrixTheoryDP.

(* ######################################################################### *)
(** * Ring matrix theory implemented with Dependent Pair *)

Module RingMatrixTheoryDP (E : RingElementType) <: RingMatrixTheory E.

  (* Export E. *)
  Include BasicMatrixTheoryDP E.

  Add Ring ring_thy_inst : Ring_thy.

  (** Zero matrix *)
  Definition mat0 r c : mat r c := @mat0 A A0 r c.

  (** Unit matrix *)
  Definition mat1 n : mat n n := @mat1 A A0 A1 n.

  (** *** Addition of matrix *)

  Definition madd {r c} := @madd A Aadd r c.
  Global Notation "m1 + m2" := (madd m1 m2) : mat_scope.

  (** m1 + m2 = m2 + m1 *)
  Lemma madd_comm : forall {r c} (m1 m2 : mat r c), m1 + m2 == m2 + m1.
  Proof.
    intros. apply madd_comm.
  Qed.

  (** (m1 + m2) + m3 = m1 + (m2 + m3) *)
  Lemma madd_assoc : forall {r c} (m1 m2 m3 : mat r c), (m1 + m2) + m3 == m1 + (m2 + m3).
  Proof.
    intros. apply madd_assoc.
  Qed.

  (** 0 + m = m *)
  Lemma madd_0_l : forall {r c} (m : mat r c), (mat0 r c) + m == m.
  Proof.
    intros. apply madd_0_l.
  Qed.

  (** m + 0 = m *)
  Lemma madd_0_r : forall {r c} (m : mat r c), m + (mat0 r c) == m.
  Proof.
    intros. apply madd_0_r.
  Qed.

  (** l2v is a homomorphic mapping with respect to vadd *)
  Notation l2v := (l2v (A0:=A0)).
  Notation vadd := (vadd (Aadd:=Aadd)).

  Lemma l2v_vadd_homo : forall (n : nat) (l1 l2 : list A)
    (H1 : length l1 = n) (H2 : length l2 = n),
      (l2v (map2 Aadd l1 l2) n == vadd (l2v l1 n) (l2v l2 n))%vec.
  Proof.
    induction n; intros.
    - rewrite length_zero_iff_nil in H1,H2. subst; simpl; auto.
    - destruct l1,l2; try easy.
      inversion H1. inversion H2. simpl. split; try easy.
      rewrite H0. apply IHn; auto.
  Qed.

  (** v2l is a homomorphic mapping with respect to vadd *)
  (* Lemma v2l_vadd_homo : forall (n : nat) (v1 v2 : vec n), *)
  (*   v2l (vadd Aadd v1 v2) = map2 Aadd (v2l v1) (v2l v2). *)
  (* Proof. *)
  (*   induction n; intros; destruct v1,v2; simpl; auto. f_equal; auto. *)
  (* Qed. *)

  (** l2m is a homomorphic mapping with respect to madd *)
  Lemma l2m_madd_homo : forall (r c : nat) (dl1 dl2 : list (list A))
    (H1 : length dl1 = r) (W1 : width dl1 c)
    (H2 : length dl2 = r) (W2 : width dl2 c),
    @l2m r c (dmap2 Aadd dl1 dl2) == (l2m dl1) + (l2m dl2).
  Proof.
    induction r; intros.
    - rewrite length_zero_iff_nil in *. subst. simpl. auto.
    - destruct dl1,dl2; simpl in *; try easy.
      inv H1. inv H2. inv W1. inv W2. split.
      + apply l2v_vadd_homo; auto.
      + rewrite H0. apply IHr; auto.
  Qed.

  (** m2l is a homomorphic mapping with respect to madd *)
  (* Lemma m2l_madd_homo : forall (r c : nat) (m1 m2 : mat r c), *)
  (*   m2l (madd m1 m2) = dmap2 Aadd (m2l m1) (m2l m2). *)
  (* Proof. *)
  (*   induction r; intros; destruct m1,m2; simpl; auto. f_equal; auto. *)
  (*   apply v2l_vadd_homo. *)
  (* Qed. *)

  (** *** Opposite of matrix *)

  Definition mopp {r c} (m : mat r c) : mat r c := @mopp A Aopp r c m.
  Global Notation "- m" := (mopp m) : mat_scope.

  (** - - m = m *)
  Lemma mopp_opp : forall {r c} (m : mat r c), - - m == m.
  Proof.
    intros. apply mopp_mopp.
  Qed.

  (** m + (-m) = 0 *)
  Lemma madd_opp : forall {r c} (m : mat r c), m + (-m) == mat0 r c.
  Proof.
    intros. apply msub_self.
  Qed.

  (** *** Subtraction of matrix *)

  Definition msub {r c} (m1 m2 : mat r c) : mat r c := @msub A Aadd Aopp r c m1 m2.
  Global Notation "m1 - m2" := (msub m1 m2) : mat_scope.

  (** m1 - m2 = - (m2 - m1) *)
  Lemma msub_comm : forall {r c} (m1 m2 : mat r c), m1 - m2 == - (m2 - m1).
  Proof.
    intros. apply msub_comm.
  Qed.
  (** (m1 - m2) - m3 = m1 - (m2 + m3) *)
  Lemma msub_assoc : forall {r c} (m1 m2 m3 : mat r c), (m1 - m2) - m3 == m1 - (m2 + m3).
  Proof.
    intros. apply msub_assoc.
  Qed.

  (** 0 - m = - m *)
  Lemma msub_0_l : forall {r c} (m : mat r c), (mat0 r c) - m == - m.
  Proof.
    intros. apply msub_0_l.
  Qed.

  (** m - 0 = m *)
  Lemma msub_0_r : forall {r c} (m : mat r c), m - (mat0 r c) == m.
  Proof.
    intros. apply msub_0_r.
  Qed.

  (** m - m = 0 *)
  Lemma msub_self : forall {r c} (m : mat r c), m - m == (mat0 r c).
  Proof.
    intros. apply msub_self.
  Qed.

  (** *** Scalar multiplication of matrix *)

  (** Left scalar multiplication of matrix *)
  Definition mcmul {r c} (a : A) (m : mat r c) : mat r c :=
    @mcmul A Amul r c a m.
  Global Notation "a c* m" := (mcmul a m) : mat_scope.

  (** Right scalar multiplication of matrix *)
  Definition mmulc {r c} (m : mat r c) (a : A) : mat r c :=
    @mmulc A Amul r c m a.
  Global Notation "m *c a" := (mmulc m a) : mat_scope.

  (** m * a = a * m *)
  Lemma mmulc_eq_mcmul : forall {r c} (a : A) (m : mat r c), m *c a == a c* m.
  Proof.
    intros. apply mmulc_eq_mcmul.
  Qed.

  (** a * (b * m) = (a * b) * m *)
  Lemma mcmul_assoc : forall {r c} (a b : A) (m : mat r c), a c* (b c* m) == (a * b)%A c* m.
  Proof.
    intros. apply mcmul_assoc.
  Qed.

  (** a * (b * m) = b * (a * m) *)
  Lemma mcmul_perm : forall {r c} (a b : A) (m : mat r c), a c* (b c* m) == b c* (a c* m).
  Proof.
    intros. apply mcmul_perm.
  Qed.

  (** a * (m1 + m2) = (a * m1) + (a * m2) *)
  Lemma mcmul_add_distr_l : forall {r c} (a : A) (m1 m2 : mat r c),
      a c* (m1 + m2) == (a c* m1) + (a c* m2).
  Proof.
    intros. apply mcmul_add_distr_l.
  Qed.

  (** (a + b) * m = (a * m) + (b * m) *)
  Lemma mcmul_add_distr_r : forall {r c} (a b : A) (m : mat r c),
      (a + b)%A c* m == (a c* m) + (b c* m).
  Proof.
    intros. apply mcmul_add_distr_r.
  Qed.

  (** 0 * m = 0 *)
  Lemma mcmul_0_l : forall {r c} (m : mat r c), A0 c* m == mat0 r c.
  Proof.
    intros. apply mcmul_0_l.
  Qed.

  (** 1 * m = m *)
  Lemma mcmul_1_l : forall {r c} (m : mat r c), A1 c* m == m.
  Proof.
    intros. apply mcmul_1_l.
  Qed.

  (** *** Multiplication of matrix *)
  Definition mmul {r c s} (m1 : mat r c) (m2 : mat c s) : mat r s :=
    @mmul A Aadd A0 Amul r c s m1 m2.
  Global Infix "*" := mmul : mat_scope.

  (** m1 * (m2 + m3) = (m1 * m2) + (m1 * m3) *)
  Lemma mmul_add_distr_l : forall {r c A} (m1 : mat r c) (m2 m3 : mat c A),
      m1 * (m2 + m3) == m1 * m2 + m1 * m3.
  Proof.
    intros. apply mmul_add_distr_l.
  Qed.

  (** (m1 + m2) * m3 = (m1 * m3) + (m2 * m3) *)
  Lemma mmul_add_distr_r : forall {r c s} (m1 m2 : mat r c) (m3 : mat c s),
      (m1 + m2) * m3 == (m1 * m3) + (m2 * m3).
  Proof.
    intros. apply mmul_add_distr_r.
  Qed.

  (** (m1 * m2) * m3 = m1 * (m2 * m3) *)
  Lemma mmul_assoc : forall {r c s A} (m1 : mat r c) (m2 : mat c s) (m3 : mat s A),
      (m1 * m2) * m3 == m1 * (m2 * m3).
  Proof.
    intros. apply mmul_assoc.
  Qed.

  (** mat0 * m = mat0 *)
  Lemma mmul_0_l : forall {r c A} (m : mat c A), (mat0 r c) * m == mat0 r A.
  Proof.
    intros. apply mmul_0_l.
  Qed.

  (** m * mat0 = mat0 *)
  Lemma mmul_0_r : forall {r c A} (m : mat r c), m * (mat0 c A) == mat0 r A.
  Proof.
    intros. apply mmul_0_r.
  Qed.

  (** mat1 * m = m *)
  Lemma mmul_1_l : forall {r c} (m : mat r c), (mat1 r) * m == m.
  Proof.
    intros. apply mmul_1_l.
  Qed.

  (** m * mat1 = m *)
  Lemma mmul_1_r : forall {r c} (m : mat r c), m * (mat1 c) == m.
  Proof.
    intros. apply mmul_1_r.
  Qed.

End RingMatrixTheoryDP.

(* ######################################################################### *)
(** * Decidable Field matrix theory implemented with Dependent Pair *)

Module DecidableFieldMatrixTheoryDP (E : DecidableFieldElementType)
<: DecidableFieldMatrixTheory E.

  (* Export E. *)
  Include RingMatrixTheoryDP E.
  Module Export DecMT := DecidableMatrixTheoryDP E.

  (** meq is decidable *)
  Lemma meq_dec : forall (r c : nat), Decidable (meq (r:=r) (c:=c)).
  Proof.
    intros. apply meq_dec.
  Qed.

  (** ** matrix theory *)

End DecidableFieldMatrixTheoryDP.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

Theorem append_assoc:
   forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
   induction l1; induction l2; induction l3; try (simpl; reflexivity).
   { simpl. rewrite <- IHl1. f_equal. }
   { simpl. rewrite 2 append_nil. reflexivity. }
   { simpl. rewrite append_nil.  reflexivity. }
   { simpl. rewrite 2 append_nil. reflexivity. }
Qed.

Theorem append_rev_cons:
   forall (l1 l2: lst) (x: natural),
   rev (append l1 (Cons x l2)) = append (rev l2) (Cons x (rev l1)).
Proof.
   induction l1; induction l2; try (simpl; reflexivity).
   { intro.  simpl.  rewrite IHl1.  simpl. lfind.
Admitted.

Theorem rev_append: forall (l1 l2: lst), rev (append l1 l2) = append (rev l2) (rev l1).
Proof.
   induction l1.
   { induction l2.
   { simpl. rewrite append_rev_cons.
      rewrite <- 2 append_assoc.
      f_equal. }
   { simpl. rewrite append_nil. reflexivity. }
   }
   { intro. simpl. rewrite append_nil. reflexivity. }
Qed.

Theorem rev_involutive : forall (x : lst), eq (rev (rev x)) x.
Proof.
   induction x.
   { simpl. rewrite rev_append. simpl. f_equal.
   assumption. }
   { simpl. reflexivity. }
Qed.

Theorem theorem0 : forall (x : lst), eq (rev (append (rev x) Nil)) x.
Proof.
   intro.
   rewrite append_nil.
   apply rev_involutive.
Qed.


(** Finite Multiset over Lists

We define an axiomatization of finite multiset through their relation with lists.
Equality is an equivalence relation.
An implementation of the axioms is provided for every type
by lists up to permutation. *)

From Coq Require Import Relation_Definitions Morphisms List Permutation.

Set Implicit Arguments.
Set Default Proof Using "Type".

(** * Axiomatization *)

(** A finite multiset with elements in [A] is a type [M]
    related with [list A] as follows: *)
Class FinMultisetoid M A := {
  meq : relation M;
  mequiv : Equivalence meq;
  empty : M;
  add : A -> M -> M;
  add_meq : Proper (eq ==> meq ==> meq) add;
  elts : M -> list A;
  elts_empty : elts empty = @nil A;
  elts_add : forall a m, Permutation (elts (add a m)) (a :: elts m);
  perm_meq : forall l1 l2, Permutation l1 l2 ->
               meq (fold_right add empty l1) (fold_right add empty l2);
  meq_perm : forall m1 m2, meq m1 m2 -> Permutation (elts m1) (elts m2);
  retract_meq : forall m, meq (fold_right add empty (elts m)) m
}.

(** [Mst] and [Elt] define a finite multiset construction over a type [K]
    if for any [A] in [K], [Mst A] is a finite multiset with elements [Elt A]. *)
Definition FMoidConstructor K Mst Elt :=
  forall A : K, FinMultisetoid (Mst A) (Elt A).

(** * Constructions and properties over finite multisets *)

Section FMSet2List.

  Variable M A : Type.
  Variable fm : FinMultisetoid M A.

  #[export] Instance mequivalence : Equivalence meq := mequiv.

  Definition list2fm l := fold_right add empty l.

  #[export] Instance list2fm_perm : Proper (@Permutation A ==> meq) list2fm := perm_meq.

  #[export] Instance elts_perm' : Proper (meq ==> @Permutation A) elts := meq_perm.

  Lemma list2fm_retract m : meq (list2fm (elts m)) m.
  Proof. apply retract_meq. Qed.

  Lemma list2fm_nil : list2fm nil = empty.
  Proof. reflexivity. Qed.

  Lemma list2fm_elt l1 l2 a :
    meq (list2fm (l1 ++ a :: l2)) (add a (list2fm (l1 ++ l2))).
  Proof.
  symmetry.
  change (add a (list2fm (l1 ++ l2)))
    with (list2fm (a :: l1 ++ l2)).
  apply perm_meq, Permutation_middle.
  Qed.

  Lemma list2fm_cons l a : meq (list2fm (a :: l)) (add a (list2fm l)).
  Proof. now rewrite <- (app_nil_l (a :: l)), list2fm_elt. Qed.

  Lemma elts_perm l : Permutation (elts (list2fm l)) l.
  Proof.
  induction l as [|a l IHl].
  - now simpl; rewrite elts_empty.
  - now simpl; rewrite elts_add, IHl.
  Qed.

  Lemma elts_eq_nil m : elts m = nil -> meq m empty.
  Proof.
  intros Heq.
  now assert (Hr := retract_meq m); rewrite Heq in Hr; simpl in Hr; rewrite Hr.
  Qed.

  Lemma add_swap m a b : meq (add a (add b m)) (add b (add a m)).
  Proof.
  now rewrite <- list2fm_retract, ? elts_add, perm_swap,
              <- 2 elts_add, list2fm_retract.
  Qed.

  Definition sum m1 m2 := list2fm (elts m1 ++ elts m2).

  Lemma elts_sum m1 m2 : Permutation (elts (sum m1 m2)) (elts m1 ++ elts m2).
  Proof. apply elts_perm. Qed.

  Lemma sum_empty_left m : meq (sum empty m) m.
  Proof. unfold sum; rewrite elts_empty; apply retract_meq. Qed.

  Lemma sum_empty_right m : meq (sum m empty) m.
  Proof. unfold sum; rewrite elts_empty, app_nil_r; apply retract_meq. Qed.

  Lemma sum_comm m1 m2 : meq (sum m1 m2) (sum m2 m1).
  Proof. now unfold sum; rewrite Permutation_app_comm. Qed.

  Lemma sum_ass m1 m2 m3 : meq (sum (sum m1 m2) m3) (sum m1 (sum m2 m3)).
  Proof.
  unfold sum; apply perm_meq.
  transitivity ((elts m1 ++ elts m2) ++ elts m3).
  - apply Permutation_app_tail, elts_perm.
  - rewrite <- app_assoc; symmetry.
    apply Permutation_app_head, elts_perm.
  Qed.

  Lemma list2fm_app l1 l2 : meq (list2fm (l1 ++ l2)) (sum (list2fm l1) (list2fm l2)).
  Proof.
  unfold sum; apply perm_meq.
  transitivity (elts (list2fm l1) ++ l2); symmetry.
  - apply Permutation_app_tail, elts_perm.
  - apply Permutation_app_head, elts_perm.
  Qed.

  #[export] Instance sum_meq : Proper (meq ==> meq ==> meq) sum.
  Proof.
  intros m1 m2 Heq m1' m2' Heq'; unfold sum.
  apply meq_perm in Heq.
  apply meq_perm in Heq'.
  now apply perm_meq, Permutation_app.
  Qed.

End FMSet2List.

Arguments list2fm {_ _ _}  _.
Arguments list2fm_retract {_ _ _} _.
Arguments sum {_ _ _} _ _.

Section Fmmap.

  Variable M A N B: Type.
  Variable fm : FinMultisetoid M A.
  Variable fm' : FinMultisetoid N B.
  Variable f : A -> B.

  Definition fmmap (m : M) := list2fm (map f (elts m)).

  #[export] Instance fmmap_meq : Proper (meq ==> meq) fmmap.
  Proof.
  intros l1 l2 Heq.
  now apply perm_meq, Permutation_map, meq_perm.
  Qed.

  Lemma list2fm_map l : meq (list2fm (map f l)) (fmmap (list2fm l)).
  Proof. symmetry; apply perm_meq, Permutation_map, elts_perm. Qed.

  Lemma elts_fmmap m : Permutation (elts (fmmap m)) (map f (elts m)).
  Proof.
  rewrite <- (list2fm_retract m) at 1.
  remember (elts m) as l eqn:Heql; clear m Heql; induction l as [|a l IHl].
  - simpl; unfold fmmap; rewrite elts_empty; simpl.
    now rewrite elts_empty.
  - transitivity (map f (elts (list2fm (a :: l)))).
    + apply elts_perm.
    + apply Permutation_map, elts_perm.
  Qed.

End Fmmap.

Arguments fmmap {_ _ _ _ _ _} _ _.

(** * Lists up to permutation as finite multisets *)

Lemma fold_id A l : fold_right (@cons A) nil l = l.
Proof. now induction l; simpl; auto; f_equal. Qed.

Fact FMoidConstr_list : FMoidConstructor list id.
Proof.
intros A.
split with (@Permutation A) (@nil A) (@cons A) id; auto.
- apply Permutation_Equivalence.
- intros a1 a2 Heq l1 l2 HP; subst.
  now apply Permutation_cons.
- now intros l1 l2 HP; rewrite 2 fold_id.
- now intros m; rewrite fold_id.
Defined.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Homomorphism theory on matrix.
  author    : ZhengPu Shi
  date      : 2021.12
*)

Require Export MatrixAll.
Require Export HomomorphismThy.

Require Import Lia.
Require Import List.

(** * DR and DP is homomorphism *)
Module Homo_DR_DP (E : RingElementType).

  (** Instantialize the functor to module *)
  Module Import MatrixAllInst := MatrixAll.RingMatrixTheory E.

  (* ====================================================== *)
  (** ** DR and DP is homomorphism with respect to madd *)

  (** Examples: prove properties of madd in DP with the help of DR *)

  Example mdp_madd_comm : forall r c,
    Commutative (@DR.madd r c) DR.meq -> Commutative (@DP.madd r c) DP.meq.
  Proof.
    intros r c H.
    apply (homo_keep_comm (fa := @DR.madd r c) (Aeq:=DR.meq)); auto.
    constructor.
    exists dr2dp. split.
    - apply hom_madd_dr2dp.
    - split.
      + apply dr2dp_surj.
      + apply dr2dp_aeq_mor.
  Qed.

  Example mdp_madd_assoc : forall r c,
    Associative (@DR.madd r c) DR.meq -> Associative (@DP.madd r c) DP.meq.
  Proof.
    intros r c H.
    apply (homo_keep_assoc (fa := @DR.madd r c) (Aeq:=DR.meq)); auto.
    constructor.
    exists dr2dp. split.
    - apply hom_madd_dr2dp.
    - split.
      + apply dr2dp_surj.
      + apply dr2dp_aeq_mor.
  Qed.

  (** Examples: prove properties of madd in DR with the help of DP *)

  Example mdr_madd_comm : forall r c,
    Commutative (@DP.madd r c) DP.meq -> Commutative (@DR.madd r c) DR.meq.
  Proof.
    intros r c H.
    apply (homo_keep_comm (fa := @DP.madd r c) (Aeq:=DP.meq)); auto.
    constructor.
    exists dp2dr. split.
    - apply hom_madd_dp2dr.
    - split.
      + apply dp2dr_surj.
      + apply dp2dr_aeq_mor.
  Qed.

End Homo_DR_DP.


(** * INITIATION A COQ *)

(**
Le début de ce fichier a été présenté en cours.
Il est demandé de le réviser à la maison et de le terminer
en préparation du TD suivant.
- Lire attentivement les commentaires explicatifs
- sous emacs/Proof-general,
  - pour avancer d'une étape, faire C-c C-n
  - pour reculer, C-c C-p
  - pour aller d'un coup à la position du curseur, C-c RET.
  D'autres raccourcis sont disponibles, regarder les menus Proof-General et Coq.
*)

(** ** Généralités *)

(** Coq est primitivement un langage de programmation particulier.
    Comme OCaml, c'est un langage fonctionnel typé.
    Son système de types est beaucoup plus riche que celui de OCaml,
    ce qui permet en particulier d'énoncer des formules logiques,
    et éventuellement de les démontrer.

    Dans un premier temps, on se focalise sur l'aspect programmation,
    et les formules logiques considérées sont de simples égalités.
 *)

(** Un script Coq est une suite de déclarations de types, de valeurs,
    (très souvent : des fonctions), d'énoncés de théorèmes suivis
    de leur preuve.

    On a également des requêtes pour obtenir des informations,
    calculer des expressions.
*)

(** À RETENIR : EN COQ, TOUT FINIT PAR UN POINT '.' *)

(** ** Types énumérés *)

(** Le type qui s'écrirait en OCaml
type coulfeu =
  | Vert
  | Orange
  | Rouge

se définit en Coq presque de la même façon.
*)

Inductive coulfeu : Set :=
  | Vert : coulfeu
  | Orange : coulfeu
  | Rouge : coulfeu
.

(** Comme en OCaml, [blabla : machin] se lit "[blabla] a pour type [machin]".
    Ainsi la déclaration précédente indique que [Vert], [Orange] et [Rouge]
    sont de type coulfeu.
    Par ailleurs, en Coq tout a un type ; la déclaration ci-dessus indique que
    le type de [coulfeu] est [Set], cf. notes de cours.
*)

(** ** Définition d'une valeur fonctionnelle *)

Definition coul_suiv : coulfeu -> coulfeu :=
  fun c =>
    match c with
    | Vert => Orange
    | Orange => Rouge
    | Rouge => Vert
    end.

(** La commande Check permet d'obtenir le type d'une expression.
    Elle vérifie que l'expression est bien typée. *)

Check coul_suiv.
Check (coul_suiv Vert).

(** La commande Eval permet de calculer une expression. *)

Eval compute in (coul_suiv Vert).

(** Raccourci *)
Compute (coul_suiv Vert).

(** ** Premier théorème, tactiques cbn et reflexivity *)

Theorem ex1_coul_suiv : coul_suiv (coul_suiv Vert) = Rouge.
Proof. cbn [coul_suiv]. reflexivity. Qed.

(** Remarque : on peut énoncer une théorème à prouver au moyen d'autres
mots-clé, notamment Lemma (pour un résultat auxiliaure) ou Example
(pour un théorème très simple servant à tester le résultat d'une fonction
sur une entrée particulière.
Ces mots-clé sont équivalents, le choix de l'un ou l'autre est affaire de
convention ou d'usage.
Ici on aurait donc plutôt utilisé  Example.
Example ex1_coul_suiv : coul_suiv (coul_suiv Vert) = Rouge.
*)

(** Une *tactique* est une commande permettant de faire progresser une preuve *)

(** On a utilisé ci-dessus les tactiques suivantes :
    - cbn [nom_de_fonction] : évaluation (partielle) de [nom_de_fonction]
    - reflexivity : reconnaissance que les deux membres de l'égalité
                    à prouver sont identiques (preuve de x = x).
 *)

(** ATTENTION À BIEN TERMINER PAR "Qed." *)

(** ** Variables *)

(** Les preuves par réflexivité fonctionnent non seulement
    entre des expressions constantes identiques, mais aussi
    entre des expressions comportant des variables. *)

(** On a la possibilité en Coq (mais pas en OCaml) de déclarer
    des variables :
    ce sont des noms dont on connaît simplement le type.
    Il faut que ces noms soient déclarés dans une portée
    (domaine de visibilité) définie par une section.
*)

(** Ouverture d'une section dans laquelle on va faire quelques
    preuves par réflexivité. *)

Section sec_refl.
  Variable c : coulfeu.
  (** Signification intuitive : "soit [c] une [coulfeu] inconnue". *)

  Theorem th1_refl_simple : c = c.
  (** Remarquer que le but contient un environnement comportant
      l'hypothèse [c : coulfeu]. *)
  Proof. reflexivity. Qed.

  Check c.

(** Fermeture de la section,
    ce qui clôt la portée des variables, ici [c : coulfeu]. *)
End sec_refl.

Fail Check c.
Fail Definition x := Vert + 2.

(* -------------------------------------------------------------------  *)
(** Vu jusqu'ici dans ls CM1 2020, en fait juste avant le End sec_refl. *)
(* -------------------------------------------------------------------  *)

(** ** Principe de Leibniz : tactique rewrite *)

Section sec_reec.
  Variable c : coulfeu.
  Hypothesis crou : c = Rouge.
  (** Signification intuitive, par analogie avec la ligne d'avant :
      "soit [crou] une preuve inconnue de [c = Rouge]". *)

  Theorem coul_suiv_Rouge : coul_suiv c = Vert.
  Proof.
    rewrite crou.
    cbn [coul_suiv].
    reflexivity.
  Qed.

End sec_reec.

(** ** Raisonnement par cas : tactique destruct *)

Section sec_cas.
  Variable c : coulfeu.

  Theorem th3_coul_suiv : coul_suiv (coul_suiv (coul_suiv c)) = c.
  Proof.
    (** reflexivity ne fonctionne pas. *)
    Fail reflexivity.
    (** Il faut raisonner par cas sur les trois valeurs de [c] possibles *)
    (** Cela va donner lieu à trois sous-buts, un pour chaque cas. *)
    destruct c as [ (*Vert*) | (*Orange*) | (*Rouge*) ].
    - cbn [coul_suiv]. reflexivity.
    - cbn [coul_suiv]. reflexivity.
    - cbn [coul_suiv]. reflexivity.
  Qed.

End sec_cas.

(** ** Raisonnement universel : tactique intro *)

(** Il est possible d'énoncer des formules quantifiées universellement.
    Par exemple : [forall c : coulfeu, c = c].
 *)

Theorem th_refl_gen : forall c : coulfeu, c = c.
Proof.
  (** Pour la démontrer, la première étape consiste à dire
      "soit [c0] une couleur arbitraire, démontrons [c0 = c0]." *)
  intro c0.
  (** Remarquer que intro a introduit l'hypothèse [c0 : coulfeu]. *)
  (** On a déjà vu que reflexivity fonctionne dans cette situation. *)
  reflexivity.
Qed.

(** La tactique intro sert également à démontrer une implication. *)
Theorem th_crou_gen : forall c : coulfeu, c = Rouge -> coul_suiv c = Vert.
Proof.
  intro c0.
  (** Pour démontrer [c0 = Rouge -> coul_suiv c0 = Vert],
      on suppose [c0 = Rouge]
      et on doit alors prouver [coul_suiv c0 = Vert]
      sous cette hypothèse supplémentaire ;
      lorsque l'on introduit une hypothèse, on lui donne un nom. *)
  intro c0rou.
  (** Le raisonnement sous-jacent est :
      soit c0rou une preuve arbitraire (inconnue) de [c0 = Rouge],
      on peut s'en servir pour démontrer coul_suiv [c0 = Vert]. *)
  rewrite c0rou. cbn [coul_suiv]. reflexivity.
Qed.

(** Remarque : on est souvent amené à effectuer plusieurs introductions
    successives. On emploie alors le raccourci intros (au pluriel).
    Sur l'exemple précédent cela donne ceci : *)
Theorem th_crou_gen_bis : forall c : coulfeu, c = Rouge -> coul_suiv c = Vert.
Proof.
  intros c0 c0rou.
  rewrite c0rou. cbn [coul_suiv]. reflexivity.
Qed.

(** * Début du travail à faire à la maison *)

(** *** Exercice: Variante du précédent avec section *)

Section sec_variante_th_crou_gen.
  Variable c : coulfeu.
  Theorem th_crou_demi_gen : c = Rouge -> coul_suiv c = Vert.
  Proof.
    (** à compléter *)
    intros.
    rewrite H.
    cbn [coul_suiv].
    reflexivity.
Qed.

End sec_variante_th_crou_gen.

(** *** Exercice: Preuve par cas d'un théorème avec forall *)

Lemma suivsuivsuiv_id : forall c:coulfeu, coul_suiv (coul_suiv (coul_suiv c))=c.
Proof.
    intros.
    destruct c.
    - cbn [coul_suiv]. reflexivity.
    - cbn [coul_suiv]. reflexivity.
    - cbn [coul_suiv]. reflexivity.
Qed.

(** ** Type inductif et récurrence structurelle : arbres binaires tricolores *)

Inductive arbin : Set :=
  | F : coulfeu -> arbin
  | N : arbin -> arbin -> arbin.

(**
Pour définir une fonction récursive (l'équivalent de let rec
en OCaml) on utilise le mot clé [Fixpoint].
 *)

Fixpoint renva a : arbin :=
  match a with
  | F c => F c
  | N g d => N (renva d) (renva g)
  end.

(** *** Exercice: prouver que renverser deux fois un arbre rend le même arbre *)
Theorem renva_renva : forall a, renva (renva a) = a.
Proof.
  intro a.
  (** Tentative de raisonnement par cas sur a *)
  (** Les noms mis dans chaque cas (c pour le premier, a2 a2 pour le second)
      désignent les composantes des constructeurs respectivement F puis N *)
  destruct a as [ (* F *) c
                | (* N *) a1 a2 ].
  - cbn [renva]. reflexivity.
  - cbn [renva].
    (** Il apparaît qu'un simple raisonnement par cas est insuffisant, *)
    (** donc on arrete tout... *)
 Abort.

(** ... et on recommence en raisonnant par récurrence structurelle *)
Theorem renva_renva : forall a, renva (renva a) = a.
Proof.
  intro a.
  (** récurrence structurelle sur le type inductif arbin *)
  (** Remarquer l'analogie avec l'utilisation de la tactique destruct :
      les noms mis dans chaque cas (c pour le premier, a2 a2 pour le second)
      désignent les composantes des constructeurs respectivement F puis N
      mais en complément, on ajoute deux noms pour les hypothèses de récurrence,
       Hrec_a1 pour celle sur a1 et Hrec_a2 pour celle sur a2 *)
  induction a as [ (* F *) c
                 | (* N *) a1 Hrec_a1 a2 Hrec_a2 ].
  - cbn [renva]. reflexivity.
  - cbn [renva]. rewrite Hrec_a1. rewrite Hrec_a2. reflexivity.
Qed.
(** Fin du travail à faire à la maison. *)


Require Import Notation.
Require Import GeneralTactics.
Require Import Axioms.

Create HintDb prop_simpl.

Theorem and_idempotent : forall P: Prop,
  (P /\ P) = P.
Proof using.
  intros *.
  follows extensionality.
Qed.
Hint Rewrite and_idempotent : prop_simpl.

Theorem or_idempotent : forall P: Prop,
  (P \/ P) = P.
Proof using.
  intros *.
  follows extensionality.
Qed.
Hint Rewrite or_idempotent : prop_simpl.

Theorem and_inv : forall P: Prop,
  (P /\ ~P) = False.
Proof using.
  intros *.
  follows extensionality.
Qed.
Hint Rewrite and_inv : prop_simpl.

Theorem or_inv : forall P: Prop,
  (P \/ ~P) = True.
Proof using.
  intros *.
  extensionality.
  after split.
  intro.
  apply classic.
Qed.
Hint Rewrite or_inv : prop_simpl.

Theorem and_id_left : forall P: Prop,
  (True /\ P) = P.
Proof using.
  intros *.
  follows extensionality.
Qed.
Hint Rewrite and_id_left : prop_simpl.

Theorem and_id_right : forall P: Prop,
  (P /\ True) = P.
Proof using.
  intros *.
  follows extensionality.
Qed.
Hint Rewrite and_id_right : prop_simpl.

Theorem or_id_left : forall P: Prop,
  (False \/ P) = P.
Proof using.
  intros *.
  follows extensionality.
Qed.
Hint Rewrite or_id_left : prop_simpl.

Theorem or_id_right : forall P: Prop,
  (P \/ False) = P.
Proof using.
  intros *.
  follows extensionality.
Qed.
Hint Rewrite or_id_right : prop_simpl.

Theorem or_true_left : forall P: Prop,
  (True \/ P) = True.
Proof using.
  intros *.
  follows extensionality.
Qed.
Hint Rewrite or_true_left : prop_simpl.

Theorem or_true_right : forall P: Prop,
  (P \/ True) = True.
Proof using.
  intros *.
  follows extensionality.
Qed.
Hint Rewrite or_true_right : prop_simpl.

Theorem and_false_left : forall P: Prop,
  (False /\ P) = False.
Proof using.
  intros *.
  follows extensionality.
Qed.
Hint Rewrite and_false_left : prop_simpl.

Theorem and_false_right : forall P: Prop,
  (P /\ False) = False.
Proof using.
  intros *.
  follows extensionality.
Qed.
Hint Rewrite and_false_right : prop_simpl.

Theorem impl_refl : forall P: Prop,
  (P -> P) = True.
Proof using.
  intros *.
  follows extensionality.
Qed.
Hint Rewrite impl_refl : prop_simpl.

Theorem impl_true_left : forall P: Prop,
  (True -> P) = P.
Proof using.
  intros *.
  follows extensionality.
Qed.
Hint Rewrite impl_true_left : prop_simpl.

Theorem impl_true_right : forall P: Prop,
  (P -> True) = True.
Proof using.
  intros *.
  follows extensionality.
Qed.
Hint Rewrite impl_true_right : prop_simpl.

Theorem impl_false_left : forall P: Prop,
  (False -> P) = True.
Proof using.
  intros *.
  follows extensionality.
Qed.
Hint Rewrite impl_false_left : prop_simpl.

(* Positivity rewrites *)
Hint Rewrite rew_not_not   : prop_simpl.
Hint Rewrite rew_not_and   : prop_simpl.
Hint Rewrite rew_not_or    : prop_simpl.
Hint Rewrite rew_not_all   : prop_simpl.
Hint Rewrite rew_not_ex    : prop_simpl.
Hint Rewrite rew_not_imply : prop_simpl.

(* Agressive rewriting with UIP and propositional extensionality
   Note, this is *very* experimental. In particular, `crush_eqs`
   currently erases too much information at times
*)

Tactic Notation "simpl!" :=
  cbn;
  repeat (progress crush_eqs; cbn);
  autorewrite with prop_simpl.

Tactic Notation "simpl!" "in" hyp(H) :=
  cbn in H;
  repeat (progress crush_eqs; cbn in H);
  autorewrite with prop_simpl in H.

Tactic Notation "simpl!" "in" "*" :=
  cbn in *;
  repeat (progress crush_eqs; cbn in *);
  autorewrite with prop_simpl in *.

(* `with` adds rewriting rule *)

Tactic Notation "simpl!" "with" uconstr(rew) :=
  simpl!;
  repeat (progress rewrite rew; progress simpl!).

Tactic Notation "simpl!" "in" hyp(H) "with" uconstr(rew) :=
  simpl! in H;
  repeat (progress rewrite rew in H; progress simpl! in H).

Tactic Notation "simpl!" "in" "*" "with" uconstr(rew) :=
  simpl! in *;
  repeat (progress rewrite rew in *; progress simpl! in *).


(* Exercise 47 *)

Require Import BenB.

Variables A B C D : Prop.

Theorem exercise_047 : A -> (A -> (B -> A)).
Proof.
imp_i a1.
imp_i a2.
imp_i a3.
hyp a1.
Qed.