(* Gabriel Braun February 2013 *)

Require Export GeoCoq.Tarski_dev.Annexes.quadrilaterals_inter_dec.

Section Vectors.

Context `{TE:Tarski_euclidean}.

Lemma eqv_refl : forall A B, EqV A B A B.
Proof.
intros.
unfold EqV.
induction (eq_dec_points A B).
right.
split; auto.
left.
right.
apply plgf_trivial.
assumption.
Qed.

Lemma eqv_sym : forall A B C D, EqV A B C D -> EqV C D A B.
Proof.
intros.
unfold EqV in *.
induction H.
left.
apply plg_sym.
apply plg_comm2.
assumption.
right.
tauto.
Qed.

Lemma eqv_trans : forall A B C D E F, EqV A B C D -> EqV C D E F -> EqV A B E F.
Proof.
intros.
unfold EqV in *.

induction H; induction H0.
assert(Parallelogram A B F E \/ A = B /\ D = C /\ E = F /\ A = E).
apply (plg_pseudo_trans A B D C E F); auto.
apply plg_comm2.
assumption.
induction H1.
left.
auto.
right.
tauto.
spliter.
subst D.
subst F.
induction (eq_dec_points A B).
right.
tauto.
left.
induction H.
induction H.
unfold TS in H.
spliter.
apply False_ind.
apply H3.
Col.
apply plgf_sym in H.
apply plgf_trivial_neq in H.
tauto.
spliter.
subst B.
subst D.
induction H0.
induction H.
unfold TS in H.
spliter.
apply False_ind.
apply H.
Col.
apply plgf_trivial_neq in H.
right.
spliter.
subst F.
tauto.
right.
tauto.
Qed.

Lemma eqv_comm : forall A B C D, EqV A B C D -> EqV B A D C.
Proof.
intros.
unfold EqV in *.
induction H.
left.
apply plg_comm2.
assumption.
right.
spliter.
subst B.
subst D.
tauto.
Qed.

Lemma vector_construction : forall A B C, exists D, EqV A B C D.
Proof.
intros.
induction (eq_dec_points A B).
exists C.
right.
tauto.
assert(HH:= midpoint_existence B C).
ex_and HH M.
prolong A M D A M.
exists D.
left.
apply (mid_plg _ _ _ _ M).

induction(eq_dec_points A D).
subst D.
right.
intro.
subst C.
apply l7_3 in H0.
apply between_identity in H1.
subst M.
contradiction.
left.
assumption.
split; Cong.
assumption.
Qed.

Lemma vector_construction_uniqueness :
 forall A B C D D',
 EqV A B C D ->
 EqV A B C D' ->
 D = D'.
Proof.
intros.
unfold EqV in *.
induction H; induction H0.
apply plg_comm2 in H.
apply plg_comm2 in H0.
apply (plg_uniqueness B A C); auto.
spliter.
subst B.
subst D'.
induction H.
induction H.
unfold TS in H.
spliter.
apply False_ind.
apply H.
Col.
apply (plgf_trivial_neq A D C ).
assumption.
spliter.
subst B.
subst D.
induction H0.
induction H.
unfold TS in H.
spliter.
apply False_ind.
apply H.
Col.
apply plgf_comm2 in H.
apply (plgf_trivial_neq A C D').
assumption.
spliter.
subst C.
auto.
Qed.

Lemma null_vector : forall A B C, EqV A A B C -> B = C.
Proof.
intros.
unfold EqV in H.
induction H.
induction H.
induction H.
unfold TS in H.
spliter.
apply False_ind.
apply H.
Col.
apply plgf_trivial_neq in H.
spliter.
subst C.
tauto.
tauto.
Qed.

Lemma vector_uniqueness : forall A B C, EqV A B A C -> B = C.
Proof.
intros.
unfold EqV in H.
induction H.
induction H.
induction H.
unfold TS in H.
spliter.
apply False_ind.
apply H2.
Col.
apply plgf_permut in H.
apply plgf_sym in H.
apply (plgf_trivial_neq A B C ).
assumption.
spliter.
subst A.
auto.
Qed.

Lemma eqv_trivial : forall A B , EqV A A B B.
Proof.
intros.
unfold EqV.
right.
tauto.
Qed.

Lemma eqv_permut :
  forall A B C D,
  EqV A B C D ->
  EqV A C B D.
Proof.
intros.
induction (eq_dec_points A C).
subst C.
assert(B = D).
apply (vector_uniqueness A).
assumption.
subst D.
apply eqv_trivial.

unfold EqV in *.
induction H.
left.
apply plg_permut.
apply plg_comm2.
assumption.
left.
spliter.
subst B.
subst D.
apply plg_trivial.
assumption.
Qed.

Lemma eqv_par :
 forall A B C D,
  A <> B ->
  EqV A B C D ->
  Par A B C D.
Proof.
intros.
unfold EqV in H0.
induction H0.
unfold Parallelogram in H0.
induction H0.
unfold Parallelogram_strict in H0.
spliter.
apply par_right_comm.
assumption.
unfold Parallelogram_flat in H0.
spliter.
right.
spliter.
repeat split; Col.
intro.
subst D.
apply cong_identity in H2.
contradiction.
ColR.
ColR.

spliter.
contradiction.
Qed.

Lemma eqv_opp_null :
  forall A B,
  EqV A B B A ->
  A = B.
Proof.
intros.
unfold EqV in H.
induction H.
apply plg_irreflexive in H.
tauto.
tauto.
Qed.

Lemma eqv_sum :
  forall A B C A' B' C',
  EqV A B A' B' ->
  EqV B C B' C' ->
  EqV A C A' C'.
Proof.
intros.

unfold EqV in *.
induction H.
induction H0.
apply plg_comm2 in H.
apply plg_permut in H.
apply plg_permut in H0.
apply plg_sym in H0.
assert(HH:= plg_pseudo_trans A A' B' B C C' H H0).
induction HH.
left.
apply plg_permut.
apply plg_comm2.
assumption.
spliter.
right.
subst A'.
subst C'.
tauto.
spliter.
subst C.
subst C'.
left.
assumption.
spliter.
subst B.
subst B'.
assumption.
Qed.

Lemma null_sum :
 forall A B C,
  SumV A B B A C C.
Proof.
intros.
unfold SumV.
intros D H.
assert(A = D).
apply (vector_uniqueness B).
apply H.
subst D.
apply eqv_trivial.
Qed.

Lemma chasles :
 forall A B C,
  SumV A B B C A C.
Proof.
intros.
unfold SumV.
intros D H.
assert(C = D).
apply (vector_uniqueness B).
assumption.
subst D.
apply eqv_refl.
Qed.

Lemma eqv_mid :
 forall A B C,
  EqV A B B C ->
  Midpoint B A C.
Proof.
intros.
unfold EqV in H.
induction H.
apply plg_mid in H.
ex_and H M.
apply l7_3 in H0.
subst M.
assumption.
spliter.
subst C.
subst B.
apply l7_3_2.
Qed.

Lemma mid_eqv :
  forall A B C, Midpoint A B C ->
  EqV B A A C.
Proof.
intros.
unfold EqV.
induction(eq_dec_points A B).
subst B.
apply is_midpoint_id in H.
subst C.
right.
tauto.
left.

apply (mid_plg _ _ _ _ A).
left.
intro.
subst C.
apply l7_3 in H.
contradiction.
assumption.
Midpoint.
Qed.

Lemma sum_sym :
  forall A B C D E F,
  SumV A B C D E F ->
  SumV C D A B E F.
Proof.
intros.
unfold SumV in *.
assert(HH:=vector_construction C D B).
ex_and HH D'.

assert(HH:= (H D' H0)).
clear H.

assert(EqV C B D D').
apply eqv_permut.
assumption.

assert(EqV A D B D'0).
apply eqv_permut.
assumption.

induction (eq_dec_points A D'0).
subst D'0.

apply eqv_comm in H1.
assert(HP:= (eqv_mid B A D H1)).

unfold EqV in H0.
induction H0.
apply plg_mid in H0.
ex_and H0 M.
assert( A = M).
apply (l7_17 B D).
apply HP.
Midpoint.
subst M.

apply mid_eqv in H0.
apply (eqv_trans _ _ A D').
apply H0.
assumption.

spliter.
subst D.
subst D'.
apply (eqv_trans _ _ A B).
apply eqv_sym.
apply eqv_comm.
apply H1.
assumption.

induction H0; induction H1.
apply plg_mid in H0.
apply plg_mid in H1.
ex_and H0 M0.
ex_and H1 M1.

assert(M1 = M0).
apply (l7_17 B D).
apply H5.
Midpoint.
subst M1.
assert(Parallelogram A D' D'0 C).
apply (mid_plg _ _ _ _ M0).
left.
assumption.
assumption.
Midpoint.
assert(EqV C D'0 A D').
unfold EqV.
left.
apply plg_comm2.
apply plg_sym.
assumption.
apply (eqv_trans _ _ A D').
apply H7.
assumption.
spliter.
subst B.
subst D'0.
assert(EqV C D A D').
apply eqv_permut.
assumption.
apply (eqv_trans _ _ A D').
apply H1.
assumption.
spliter.
subst D.
subst D'.

assert(EqV A B C D'0).
apply eqv_permut.
assumption.
apply (eqv_trans _ _ A B).
apply eqv_sym.
apply H0.
assumption.
spliter.
subst D.
subst D'.
subst B.
subst D'0.
apply null_vector in HH.
subst F.
apply eqv_trivial.
Qed.

Lemma opposite_sum :
  forall A B C D E F,
  SumV A B C D E F ->
  SumV B A D C F E.
Proof.
intros.
unfold SumV in *.
intros D0 H0.
assert(HH:=vector_construction C D B).
ex_and HH D'.
assert(HH:= (H D' H1)).
clear H.

assert(EqV D' B A D0).
apply (eqv_trans _ _ D C).
apply eqv_sym.
apply eqv_comm.
apply H1.
assumption.
apply eqv_permut in H.
eapply (eqv_trans _ _ D' A).
apply eqv_sym.
apply H.
apply eqv_comm.
assumption.
Qed.

Lemma null_sum_eq :
  forall A B C D,
  SumV A B B C D D ->
  A = C.
Proof.
intros.
unfold SumV in H.
assert(HH:= vector_construction B C B).
ex_and HH D'.
assert(HH:= (H D' H0)).
assert(A = D').
apply (null_vector D).
apply eqv_sym.
apply HH.
subst D'.
apply vector_uniqueness in H0.
auto.
Qed.

Lemma is_to_ise :
  forall A B C D E F,
  SumV A B C D E F ->
  SumV_exists A B C D E F.
Proof.
intros.
unfold SumV in H.
unfold SumV_exists.
assert(HH:= (vector_construction C D B)).
ex_and HH D'.
assert(HH:=(H D' H0)).
exists D'.
split.

apply eqv_sym.
assumption.
assumption.
Qed.

Lemma ise_to_is :
 forall A B C D E F,
  SumV_exists A B C D E F ->
  SumV A B C D E F.
Proof.
intros.
ex_and H D'.
unfold SumV.
intros.
assert(D'= D'0).
apply (vector_construction_uniqueness C D B).
apply eqv_sym.
apply H.
assumption.
subst D'0.
assumption.
Qed.

Lemma sum_exists :
 forall A B C D, exists E, exists F, SumV A B C D E F.
intros.
assert(HH:= vector_construction C D B).
ex_and HH F.
exists A.
exists F.
unfold SumV.
intros.
assert(D' = F).
apply (vector_construction_uniqueness C D B); auto.
subst D'.
apply eqv_refl.
Qed.

Lemma sum_uniqueness :
 forall A B C D E F E' F',
 SumV A B C D E F ->
 SumV A B C D E' F' ->
 EqV E F E' F'.
Proof.
intros.
unfold SumV in *.
assert(HH:= vector_construction C D B).
ex_and HH D'.
assert(HH:= (H D' H1)).
assert(HP := (H0 D' H1)).
apply (eqv_trans _ _ A D').
apply eqv_sym.
auto.
auto.
Qed.

Lemma same_dir_refl : forall A B, Same_dir A B A B.
intros.
unfold Same_dir.
induction (eq_dec_points A B).
left.
tauto.
right.
exists B.
split.
apply out_trivial.
auto.
apply eqv_refl.
Qed.

Lemma same_dir_ts :
  forall A B C D,
  Same_dir A B C D ->
  exists M, Bet A M D /\ Bet B M C.
Proof.
intros.
induction H.
spliter.
subst B.
subst D.
exists A.
split; Between.

ex_and H D'.
induction H0.

assert(exists M : Tpoint, Midpoint M A D' /\ Midpoint M B C).
apply plg_mid.
assumption.
ex_and H1 M.
unfold Midpoint in *.
spliter.

induction H0.
assert(HH:=plgs_two_sides A B D' C H0).
spliter.

assert(B <> C).
intro.
subst C.
unfold TS in H6.
spliter.
Col.
assert(~ Col B C D').
intro.
unfold TS in H6.
spliter.
apply H9.
Col.

assert(OS B C D' D).
apply l6_6 in H.
apply (out_one_side_1 _ _ _ _ C); Col.

assert(TS B C A D).
apply l9_2.
apply (l9_8_2 _ _ D').
apply l9_2.
apply H6.
auto.

assert(~ Col A B C).
induction H10.
assumption.
induction H10.
spliter.
ex_and H13 T.

assert(OS A B D' C /\ OS D' C A B).
apply(plgs_one_side A B D' C).
assumption.
spliter.

assert(~Col A B C).
assumption.

assert(Par_strict A B D' C /\ Par_strict A C B D').

apply(plgs_par_strict A B D' C).
assumption.
spliter.

assert(A <> B).
intro.
subst B.
apply H18.
exists C.
split; Col.

assert(Par C D A B).
apply (par_col_par_2 _ D').
unfold Out in H.
spliter.
auto.
apply out_col in H.
Col.
apply par_symmetry.
apply par_right_comm.
left.
assumption.

assert(Par_strict A B C D).
apply par_strict_symmetry.
induction H21.
auto.
spliter.
apply False_ind.
apply H17.
Col.

induction(col_dec A B T).
apply False_ind.
assert(B = T).
apply (l6_21 A B C B); Col.
subst T.
apply H22.
exists D.
apply bet_col in H14.
split; Col.

induction(col_dec C D T).
apply False_ind.
assert(C = T).
apply (l6_21 C D B C); Col.
subst T.
apply H22.
exists A.
apply bet_col in H14.
split; Col.

induction H13.

assert(OS B A T D).
apply (out_one_side_1 _ _ _ _ A); Col.

unfold Out.
repeat split.
intro.
subst T.
apply H23.
Col.
intro.
subst D.
apply H22.
exists A.
split; Col.
left.
auto.

assert(OS B A T C).
apply (one_side_transitivity _ _ _ D).
apply H25.
apply (par_strict_one_side _ _ _ C).
apply par_strict_comm.
apply H22.
Col.

assert(TS B A T C).
unfold TS.
repeat split; Col.
exists B.
split; Col.
apply l9_9 in H26.
contradiction.
assumption.

induction H13.

assert(OS C D T A).
apply (out_one_side_1 _ _ _ _ D).
auto.
Col.
unfold Out.
repeat split.
intro.
subst T.
apply H24.
Col.
intro.
subst D.
apply H22.
exists A.
split; Col.
left.
Between.
assert(OS C D T B).
apply (one_side_transitivity _ _ _ A).
apply H25.
apply (par_strict_one_side _ _ _ B).
apply par_strict_symmetry.
apply H22.
Col.

assert(TS C D T B).
unfold TS.
repeat split.
unfold Out in H.
spliter.
auto.

intro.
apply H24.
Col.
intro.
apply H22.
exists B.
split; Col.
exists C.
split.
Col.
Between.
apply l9_9 in H27.
contradiction.
exists T.
split; Between.

assert(HH:= plgf_bet A B C D' H0).

induction (eq_dec_points A D').
subst D'.
unfold Parallelogram_flat in H0.
spliter.
assert(B = C \/ Midpoint A B C).
apply l7_20.
Col.
Cong.
induction H9.
subst C.
tauto.
exists A.
split.
Between.
apply midpoint_bet.
assumption.

induction (eq_dec_points B C).
subst C.
unfold Parallelogram_flat in H0.
spliter.
assert(A = D' \/ Midpoint B A D').
apply l7_20.
Col.
Cong.
induction H10.
subst D'.
tauto.
exists B.
split.
induction H10.
unfold Out in H.
spliter.
induction H13.
apply (between_inner_transitivity _ _ _ D').
apply H10.
auto.
apply (outer_transitivity_between _ _ D').
apply H10.
auto.
auto.
Between.

induction HH.
spliter.
exists A.
split.
Between.
apply (outer_transitivity_between _ _ D'); Between.

induction H7.
spliter.
exists A.
split.
Between.
apply between_symmetry.
apply (outer_transitivity_between _ _ D'); Between.

induction H7.
spliter.
exists C.
split.
induction H.
spliter.
induction H10.
assert(Bet C B D \/ Bet C D B).
apply (l5_3 _ _ _ D'); auto.
induction H11.
apply (outer_transitivity_between _ _ B); Between.
apply (between_inner_transitivity _ _ _ B).
apply H7.
auto.
apply (outer_transitivity_between _ _ B); Between.
apply (between_exchange4 _ _ D').
apply H8.
auto.
Between.
spliter.

exists B.
split.
unfold Out in H.
spliter.
induction H10.
assert(Bet B C D).
apply (between_inner_transitivity _ _ _ D').
apply H8.
assumption.
eBetween.

apply (outer_transitivity_between _ _ C).
apply H7.
apply (outer_transitivity_between _ _ D' ).
apply H8.
auto.
auto.
auto.
Between.
spliter.
subst B.
subst D'.
exists A.
split; Between.
Qed.

Lemma one_side_col_out :
 forall A B X Y,
  Col A X Y ->
  OS A B X Y ->
  Out A X Y.
Proof.
intros.
assert(A <> B /\ ~ Col X A B /\ ~ Col Y A B /\ X <> A /\ Y <> A).
unfold OS in H0.
ex_and H0 T.
unfold TS in *.
spliter.
repeat split; auto.
intro.
subst B.
Col.
intro.
subst X.
apply H0.
Col.
intro;
spliter.
subst Y.
apply H1.
Col.
spliter.

induction H.
repeat split; auto.
induction H.
repeat split; auto.
right.
Between.

assert(TS A B X Y).
unfold TS.
repeat split; auto.
exists A.
split.
Col.
Between.
apply l9_9 in H6.
contradiction.
Qed.

Lemma par_ts_same_dir :
 forall A B C D, Par_strict A B C D ->
 (exists M, Bet A M D /\ Bet B M C) ->
 Same_dir A B C D.
Proof.
intros.
ex_and H0 M.
unfold Same_dir.
right.

assert(HH:=vector_construction A B C).
ex_and HH D'.
exists D'.
split; trivial.

assert(A <> B /\ C <> D).
apply par_strict_distinct in H.
spliter.
split; auto.
spliter.

assert(A <> M).
intro.
subst M.
apply False_ind.
apply H.
exists C.
apply bet_col in H1.
split; Col.

induction (eq_dec_points B D').
subst D'.
assert( A = C).
apply (vector_uniqueness B).
apply eqv_comm.
apply H2.
subst C.

assert(Bet A D B \/ Bet A B D).
apply (l5_1 _ M).
apply H5.
auto.
Between.
unfold Out.
repeat split; auto.
induction H2.

assert(Par A B D' C).
apply plg_par in H2; auto.
spliter.
auto.

assert(Col C D D').
apply col_permutation_1.
apply (parallel_uniqueness A B _ _ C _ C).
left.
apply H.
Col.
apply par_right_comm.
apply H7.
Col.

induction H2.

assert(HH := (plgs_two_sides A B D' C H2)).
spliter.

assert(TS B C A D).
unfold TS.
unfold TS in H10.
spliter.
repeat split;
auto.
intro.
apply H11.
ColR.
exists M.
split.
apply bet_col in H1.
Col.
auto.

assert(OS B C D D').
apply (l9_8_1 _ _ _ _ A).
apply l9_2.
apply H11.
apply l9_2.
auto.

apply (one_side_col_out _ B).
Col.
apply invert_one_side.
apply H12.

apply False_ind.
unfold Parallelogram_flat in H2.
spliter.
apply H.
exists C.
split; Col.

spliter.
subst D'.
subst B.
tauto.
Qed.

Lemma same_dir_out : forall A B C, Same_dir A B A C -> Out A B C \/ A = B /\ A = C.
intros.
unfold Same_dir in H.
induction H.
right.
auto.
ex_and H D'.
unfold EqV in H0.
induction H0.
induction H0.
apply plgs_par_strict in H0.
spliter.
apply False_ind.
apply H1.
exists B.
split; Col.
apply plgf_permut in H0.
apply plgf_sym in H0.
apply plgf_trivial_neq in H0.
spliter.
subst D'.
left.
apply l6_6.
assumption.
spliter.
subst D'.
subst B.
unfold Out in H.
tauto.
Qed.

Lemma same_dir_out1 : forall A B C, Same_dir A B B C -> Out A B C \/ A = B /\ A = C.
intros.
unfold Same_dir in H.
induction H.
right.
spliter.
subst B.
tauto.
ex_and H D'.
unfold EqV in H0.

induction H0.
induction H0.
apply plgs_par_strict in H0.
spliter.
apply False_ind.
apply H1.
exists B.
split; Col.
unfold Parallelogram_flat in H0.
spliter.
assert(A = D' \/ Midpoint B A D').
apply l7_20.
Col.
Cong.
induction H5.
subst D'.
tauto.
left.
unfold Midpoint in H5.
spliter.
unfold Out.
repeat split.
intro.
subst B.
apply cong_symmetry in H6.
apply cong_identity in H6.
induction H4; tauto.
intro.
subst C.
unfold Out in H.
spliter.
induction H8.
apply H.
apply (between_equality _ _ D');
Between.
apply H7.
apply (between_equality _ _ A);
Between.
induction H.
spliter.
induction H8.
left.
apply (between_inner_transitivity _ _ _ D').
apply H5.
apply H8.
left.
apply (outer_transitivity_between _ _  D').
apply H5.
auto.
auto.
spliter.
subst B.
subst D'.
unfold Out in H.
tauto.
Qed.

Lemma same_dir_null : forall A B C, Same_dir A A B C -> B = C.
intros.
unfold Same_dir in H.
induction H.
tauto.
ex_and H D.
apply null_vector in H0.
subst D.
unfold Out in H.
tauto.
Qed.

Lemma plgs_out_plgs :
 forall A B C D B' C',
 Parallelogram_strict A B C D ->
 Out A B B' ->
 Out D C C' ->
 Cong A B' D C' ->
 Parallelogram_strict A B' C' D.
Proof.
intros.
assert(OS A D C B /\ OS C B A D).
apply plgs_one_side.
apply plgs_permut.
apply plgs_comm2.
assumption.

assert( A <> B /\ A <> B' /\ D <> C /\ D <> C').
unfold Out in *.
spliter.
repeat split; auto.
spliter.

assert(Par_strict A B C D).
apply plgs_par_strict in H.
spliter.
auto.

assert(Par_strict A B' D C').
assert(Par A B' D C').
apply (par_col_par_2 _ B).
auto.
apply out_col.
auto.
apply par_symmetry.
apply (par_col_par_2 _ C).
auto.
apply out_col.
auto.
apply par_symmetry.
apply par_right_comm.
left.
auto.
induction H10.
auto.
spliter.
apply False_ind.
apply out_col in H0.
apply out_col in H1.

assert(~Col A C D).
intro.
apply H9.
exists A.
split; Col.
apply H14.
ColR.

assert(OS A D B B').
apply (out_one_side_1 A _ _ _ A).
intro.
apply H9.
exists D.
split; Col.
Col.
auto.

assert(OS A D C C').
apply (out_one_side_1 _ D _ _ D).
intro.
apply H9.
exists A.
split; Col.
Col.
auto.

assert(OS A D B' C').
apply (one_side_transitivity _ _ _ B).
apply one_side_symmetry.
apply H11.
apply (one_side_transitivity _ _ _ C).
apply one_side_symmetry.
apply H3.
assumption.

assert(HH:=par_cong_mid_os  A B' D C' H10 H2 H13).
ex_and HH M.

apply (mid_plgs _ _ _ _ M).
intro.
apply H10.
exists C'.
split; Col.
assumption.
assumption.
Qed.

Lemma plgs_plgs_bet :
 forall A B C D B' C',
 Parallelogram_strict A B C D ->
 Bet A B B' ->
 Parallelogram_strict A B' C' D ->
 Bet D C C'.
Proof.
intros.
assert(Col C' C D /\ Col D C D).
apply (parallel_uniqueness A B C D C' D D); Col.
left.
apply plgs_par_strict in H.
spliter.
assumption.
apply (par_col_par_2 _ B').
intro.
subst B.
apply plgs_par_strict in H.
spliter.
apply H.
exists C.
split; Col.
apply bet_col in H0.
Col.
apply plgs_par_strict in H1.
spliter.
left.
assumption.
spliter.
clear H3.
induction H2.
Between.
induction H2.
apply False_ind.

apply plgs_permut in H.
apply plgs_permut in H1.

assert(HH1:=plgs_one_side B C D A H).
assert(HH2:=plgs_one_side B' C' D A H1).
spliter.
assert(OS D A C C').
apply (one_side_transitivity _ _ _ B).
apply one_side_symmetry.
apply H6.
apply one_side_symmetry.
apply (one_side_transitivity _ _ _ B').
apply one_side_symmetry.
apply H4.
apply (out_one_side_1 _ _ _ _ A).
intro.
apply plgs_par_strict in H1.
spliter.
apply H1.
exists B'.
split; Col.
Col.
repeat split.
intro.
subst B'.
apply H1.
Col.
intro.
subst B.
apply H.
Col.
right.
assumption.
assert(TS D A C C').
repeat split.
intro.
apply plgs_par_strict in H.
spliter.
apply H.
exists C.
split; Col.
intro.
apply plgs_par_strict in H1.
spliter.
apply H1.
exists C'.
split; Col.
exists D.
split.
Col.
assumption.
apply l9_9 in H8.
contradiction.

assert(Parallelogram_strict B C D A).
apply plgs_permut.
assumption.
assert(Parallelogram_strict D A B' C').
apply plgs_permut.
apply plgs_sym.
assumption.

induction (eq_dec_points C C').
subst C'.
Between.

assert(HH:= plgs_pseudo_trans B C D A B' C' H3 H4).
assert(Parallelogram_strict B C C' B').
induction HH.
assumption.
unfold Parallelogram_flat in H6.
spliter.
apply False_ind.

apply plgs_par_strict in H.
apply plgs_par_strict in H1.
spliter.
apply H.
exists B.
split.
Col.
apply bet_col in H2.
ColR.

assert(HH1:=plgs_one_side B C C' B' H6).
assert(HH2:=plgs_one_side B C D A H3).
spliter.

(*******************************)

assert(TS B C A B').
unfold TS.
repeat split.
intro.
apply plgs_par_strict in H.
spliter.
apply H.
exists C.
split; Col.
intro.
apply plgs_par_strict in H6.
spliter.
apply H6.
exists B'.
split; Col.
exists B.
split.
Col.
assumption.

assert(OS B C C' D).
apply (out_one_side_1 _ _ _ _ C).
intro.
apply plgs_par_strict in H6.
spliter.
apply H6.
exists C'.
split; Col.
apply col_trivial_2.
repeat split.
auto.
intro.
subst D.
apply plgs_par_strict in H3.
spliter.
apply H3.
exists C.
split; Col.
left.
Between.

assert(OS B C A B').
apply (one_side_transitivity _ _ _ D).
apply one_side_symmetry.
apply H7.
apply (one_side_transitivity _ _ _ C').
apply one_side_symmetry.
apply H12.
assumption.
apply l9_9 in H11.
contradiction.
Qed.

Lemma plgf_plgf_bet :
 forall A B C D B' C',
 Parallelogram_flat A B C D ->
 Bet A B B' ->
 Parallelogram_flat A B' C' D ->
 Bet D C C'.
Proof.
intros.
induction (eq_dec_points A B).
subst B.
assert(C = D /\ A <> C).
apply plgf_trivial_neq.
auto.
spliter.
subst D.
Between.

assert(HH:=not_col_exists A B H2).
ex_and HH P.
assert(HH:=plg_existence A B P H2).
ex_and HH Q.

assert(Parallelogram_strict A B P Q).
induction H4.
assumption.
unfold Parallelogram_flat in H4.
spliter.
contradiction.

assert(Parallelogram_strict C D Q P).

apply(plgf_plgs_trans C D A B P Q).
intro.
subst D.
assert(A = B /\ C <> A).
apply plgf_trivial_neq.
apply plgf_sym.
assumption.
tauto.
apply plgf_sym.
assumption.
assumption.

assert(A <> B').
intro.
subst B'.
apply between_identity in H0.
contradiction.

assert(HH:=vector_construction A B' Q).
ex_and HH P'.

induction H8; [|tauto].

assert(B <> P).
intro.
subst P.
apply H3.
Col.

assert(B' <> P').
intro.
subst P'.

induction H8.
apply plgs_par_strict in H8.
spliter.
apply H10.
apply plgs_par_strict in H5.
exists A.
split; Col.
apply plgf_permut in H8.
assert(Q = A /\ B' <> Q).
apply plgf_trivial_neq.
auto.
spliter.
subst Q.
apply H5.
Col.

assert(Par A B' P Q).
apply plg_par in H8; auto.
spliter.
apply bet_col in H0.

apply (par_col_par_2 _ B); auto.
apply plg_par in H4; auto.
spliter.
assumption.

assert(Col P' P Q /\ Col Q P Q).
apply(parallel_uniqueness A B' P Q P' Q Q ); Col.
apply plg_par in H8; auto.
spliter.
auto.
spliter.
clear H13.

assert(Parallelogram_strict A B' P' Q).
induction H8.
auto.
unfold Parallelogram_flat in H8.
spliter.
apply False_ind.
unfold Parallelogram_flat in *.
spliter.
apply bet_col in H0.
assert(Col B' P' Q).
ColR.

apply plgs_par_strict in H5.
spliter.
apply H5.
exists Q.
split.
ColR.
Col.

assert(Parallelogram_strict D C' P' Q).
apply (plgf_plgs_trans _ _ B' A).
intro.
subst C'.
apply plgf_sym in H1.
apply plgf_trivial_neq in H1.
tauto.
apply plgf_comm2.
apply plgf_sym.
apply H1.
apply plgs_comm2.
assumption.

assert(Bet Q P P').
apply(plgs_plgs_bet A B P Q B' P'); auto.
apply(plgs_plgs_bet Q P C D P' C').
apply plgs_sym.
auto.
auto.
apply plgs_comm2.
apply plgs_sym.
auto.
Qed.

Lemma plg_plg_bet :
 forall A B C D B' C',
 Parallelogram A B C D ->
 Bet A B B' ->
 Parallelogram A B' C' D ->
 Bet D C C'.
Proof.
intros.

induction(eq_dec_points A B).
subst B.
induction H.
apply False_ind.
apply H.
apply plgs_sym in H.
apply False_ind.
apply H.
Col.
apply plgf_trivial_neq in H.
spliter.
subst D.
Between.

induction (eq_dec_points B C).
subst C.
induction H.
apply False_ind.
apply plgs_sym in H.
apply H.
Col.
apply plgf_permut in H.
apply plgf_trivial_neq in H.
spliter.
subst D.
induction H1.
apply False_ind.
apply H.
Col.
apply plgf_permut in H.
apply plgf_sym in H.
apply plgf_trivial_neq in H.
spliter.
subst C'.
Between.

assert(A <> B').
intro.
subst B'.
apply between_identity in H0.
contradiction.

assert(B' <> C').
intro.
subst C'.
apply plg_permut in H1.
induction H1.
apply plgs_par_strict in H1.
spliter.
apply H1.
exists A.
split; Col.
apply plgf_trivial_neq in H1.
spliter.
subst D.
apply plg_permut in H.
induction H.
apply plgs_par_strict in H.
spliter.
apply H1.
exists A.
split; Col.
apply plgf_sym in H.
apply plgf_trivial_neq in H.
tauto.

assert(HH:=H).
assert(HH1:=H1).

apply plg_par in H; auto.
apply plg_par in H1; auto.
spliter.

assert(Par A B C' D).
apply (par_col_par_2 _ B'); auto.
apply bet_col in H0.
Col.

assert(Col C' C D /\ Col D C D).

apply(parallel_uniqueness A B C D C' D D); Col.
spliter.
clear H10.

induction HH; induction HH1.
apply (plgs_plgs_bet A B _ _ B').
apply H10.
apply H0.
auto.

apply False_ind.
unfold Parallelogram_flat in H11.
spliter.
apply plgs_par_strict in H10.
spliter.
apply bet_col in H0.
apply H10.
assert(Col A B C').
ColR.
exists C'.
split; Col.

apply False_ind.
unfold Parallelogram_flat in H10.
spliter.
apply plgs_par_strict in H11.
spliter.
apply bet_col in H0.
apply H11.
assert(Col A B' C).
ColR.
exists C.
split; Col.

apply (plgf_plgf_bet A B _ _ B').
apply H10.
apply H0.
auto.
Qed.

Lemma plgf_out_plgf :
 forall A B C D B' C',
 Parallelogram_flat A B C D ->
 Out A B B' ->
 Out D C C' ->
 Cong A B' D C' ->
 Parallelogram_flat A B' C' D.
Proof.
intros.
assert( A <> B /\ A <> B' /\ D <> C /\ D <> C').
unfold Out in *.
spliter.
repeat split; auto.
spliter.

assert(HH:=not_col_exists A B H3).
ex_and HH P.
assert(HH:=plg_existence A B P H3).
ex_and HH Q.
assert(Parallelogram_strict A B P Q).
induction H8.
assumption.
unfold Parallelogram_flat in H8.
spliter.
contradiction.

assert(Parallelogram_strict C D Q P).

apply(plgf_plgs_trans C D A B P Q).
auto.
apply plgf_sym.
assumption.
assumption.

assert(HH:=vector_construction A B' Q).
ex_and HH P'.
induction H11.

assert(B <> P).
intro.
subst P.
apply plgs_par_strict in H9.
spliter.
apply H9.
exists B.
split; Col.

assert(B' <> P').
intro.
subst P'.
induction H11.
apply plgs_par_strict in H11.
spliter.
apply H11.
exists B'.
split; Col.
unfold Parallelogram_flat in H11.
spliter.
apply cong_identity in H15.
subst Q.
apply H9.
Col.

assert(Col Q P P').
apply plg_par in H8; auto.
apply plg_par in H11; auto.
spliter.

assert(Par A B' P Q).
apply (par_col_par_2 _ B).
auto.
apply out_col.
apply H0.
assumption.

assert(Col P' P Q /\ Col Q P Q).
apply(parallel_uniqueness A B' P Q P' Q Q); Col.
spliter.
Col.

assert(Parallelogram_strict A B' P' Q).
induction H11.
assumption.
unfold Parallelogram_flat in H11.
spliter.
apply False_ind.

apply plgs_par_strict in H9.
spliter.
apply H9.
exists Q.
split.

apply out_col in H0.
ColR.
Col.

assert(P <> Q).
intro.
subst Q.
apply H9.
Col.

assert(P' <> Q).
intro.
subst Q.
apply H15.
Col.

assert(Parallelogram_strict D C' P' Q).
apply (plgs_out_plgs _ C P).
apply plgs_comm2.
apply H10.
auto.
repeat split; auto.

unfold Out in H0.
spliter.
induction H19.
left.

apply (plgs_plgs_bet A B P Q B' P' H9); auto.
right.

apply(plgs_plgs_bet A B' P' Q B P); auto.

apply plg_cong in H11.
spliter.
CongR.

assert(Parallelogram A B' C' D).
apply (plgs_pseudo_trans _ _ P' Q).
apply H15.
apply plgs_sym.
assumption.
induction H19.
apply False_ind.
apply plgs_par_strict in H19.
spliter.
unfold Parallelogram_flat in H.
spliter.
apply out_col in H0.
apply out_col in H1.

apply H19.
exists B.
split.

Col.
assert(Col B C D).
ColR.
ColR.
assumption.
spliter.
subst B'.
tauto.
Qed.

Lemma plg_out_plg :
 forall A B C D B' C',
 Parallelogram A B C D ->
 Out A B B' ->
 Out D C C' ->
 Cong A B' D C' ->
 Parallelogram A B' C' D.
Proof.
intros.
induction H.
left.
apply (plgs_out_plgs _ B C).
apply H.
auto.
auto.
auto.
right.
apply (plgf_out_plgf _ B C).
apply H.
auto.
auto.
auto.
Qed.

Lemma same_dir_sym : forall A B C D, Same_dir A B C D -> Same_dir C D A B.
intros.

induction (eq_dec_points A B).
subst B.
apply same_dir_null in H.
subst D.
left.
tauto.

unfold Same_dir in *.
induction H.
left.
tauto.

ex_and H D'.
right.
assert(HH:=vector_construction C D A).
ex_and HH B'.
exists B'.
split.
unfold EqV in H1.
unfold EqV in H2.
unfold Out in *.
spliter.
induction H1; induction H2.

repeat split.
auto.
intro.
subst B'.
induction H2.
apply H2.
Col.
apply plgf_sym in H2.
apply plgf_trivial_neq in H2.
spliter.
auto.

induction H4.
right.
apply (plg_plg_bet C D _ _ D').
apply H2.
apply H4.
apply plg_sym.
apply plg_comm2.
assumption.

left.
apply (plg_plg_bet C D' _ _ D).
apply plg_sym.
apply plg_comm2.
apply H1.
apply H4.
assumption.

spliter.
subst D.
tauto.
spliter.
subst B.
tauto.
spliter.
subst D.
tauto.
assumption.
Qed.

Lemma same_dir_trans : forall A B C D E F, Same_dir A B C D -> Same_dir C D E F -> Same_dir A B E F.
intros.
unfold Same_dir in *.
induction H; induction H0; spliter.
left.
tauto.
ex_and H0 F'.
subst B.
subst D.
apply null_vector in H2.
subst F'.
unfold Out in H0.
tauto.
ex_and H D'.
subst D.
subst F.
unfold Out in H.
tauto.
ex_and H D'.
ex_and H0 F'.
right.

induction(eq_dec_points A B).
subst B.
apply null_vector in H1.
subst D'.
unfold Out in H.
tauto.

assert(HH:=vector_construction A B E).
ex_and HH F''.
exists F''.
split; trivial.

assert(C <> D /\ C <> D' /\ E <> F /\ E <> F').
unfold Out in *.
spliter.
repeat split;
auto.
spliter.

unfold EqV in *.
induction H1; induction H2; induction H4.
unfold Out in *.
spliter.
induction H10; induction H12.
repeat split.
auto.
intro.
subst F''.

induction H4.
apply H4.
Col.
apply plgf_sym in H4.
apply plgf_trivial_neq in H4.
tauto.

left.
assert(Bet E F' F'').

apply (plg_plg_bet C D _ _ D').
apply H2.
apply H12.

assert(Parallelogram C D' F'' E \/ C = D' /\ B = A /\ E = F'' /\ C = E).

apply(plg_pseudo_trans C D' B A E F'').
apply plg_sym.
apply plg_comm2.
auto.
apply plg_comm2.
auto.
induction H13.
assumption.
tauto.
apply (between_exchange4 _ _ F').
apply H10.
auto.

repeat split.
auto.
intro.
subst F''.
induction H4.
apply H4.
Col.
apply plgf_sym in H4.
apply plgf_trivial_neq in H4.
tauto.

assert(Bet E F'' F').
apply (plg_plg_bet C D' _ _ D); trivial.

assert(Parallelogram C D' F'' E \/ C = D' /\ B = A /\ E = F'' /\ C = E).
apply plg_pseudo_trans.
apply plg_sym.
apply plg_comm2.
auto.
apply plg_comm2.
auto.

induction H13.
assumption.
tauto.
apply (l5_3 _ _ _ F').
apply H10.
assumption.

repeat split.
auto.
intro.
subst F''.
induction H4.
apply H4.
Col.
apply plgf_sym in H4.
apply plgf_trivial_neq in H4.
tauto.

assert(Bet E F' F'').
apply (plg_plg_bet C D _ _ D').
apply H2.
apply H12.
assert(Parallelogram C D' F'' E \/ C = D' /\ B = A /\ E = F'' /\ C = E).
apply plg_pseudo_trans.
apply plg_sym.
apply plg_comm2.
auto.
apply plg_comm2.
auto.

induction H13.
assumption.
tauto.
apply (l5_1 _ F').
apply H8.
auto.
auto.

repeat split.
auto.
intro.
subst F''.
induction H4.
apply H4.
Col.
apply plgf_sym in H4.
apply plgf_trivial_neq in H4.
tauto.

assert(Bet E F'' F').
apply (plg_plg_bet C D' _ _ D); trivial.

assert(Parallelogram C D' F'' E \/ C = D' /\ B = A /\ E = F'' /\ C = E).
apply plg_pseudo_trans.
apply plg_sym.
apply plg_comm2.
auto.
apply plg_comm2.
auto.

induction H13.
auto.
tauto.
right.
apply (between_exchange4 _ _ F').
apply H13.
auto.
tauto.
tauto.
tauto.
tauto.
tauto.
tauto.
tauto.
Qed.

Lemma same_dir_comm : forall A B C D, Same_dir A B C D -> Same_dir B A D C.
intros.

unfold Same_dir in *.
induction H.
left.
auto.
spliter.
split; auto.

right.
ex_and H D'.
assert(A <> B).
intro.
subst B.
apply null_vector in H0.
unfold Out in H.
spliter.
auto.

assert(HH:=vector_construction B A D).
ex_and HH C'.
exists C'.
split; trivial.

unfold Out in *.
spliter.

unfold EqV in *.

induction H4.
repeat split.
auto.
intro.
subst C'.
apply eqv_sym in H2.
apply null_vector in H2.
subst B.
tauto.
left.

induction H0; induction H2;try tauto.

assert(Parallelogram C D' D C' \/ C = D' /\ B = A /\ C' = D /\ C = C').

apply(plg_pseudo_trans C D' B A C' D).
apply plg_sym.
apply plg_comm2.
assumption.
assumption.
induction H5.

assert(Parallelogram_flat C D' D C').
induction H5.
apply False_ind.
apply plgs_par_strict in H5.
spliter.
apply H5.
exists D.
apply bet_col in H4.
split; Col.
assumption.

unfold Parallelogram_flat in H6.
spliter.

apply (col_cong2_bet1 D').
Col.
Between.
Cong.
Cong.
spliter.
subst B.
tauto.
spliter.
subst B.
tauto.

repeat split.
auto.
intro.
subst C'.
induction H2.
induction H2.
apply H2.
Col.
apply plgf_sym in H2.
apply plgf_trivial_neq in H2.
spliter.
auto.
spliter.
auto.

induction H0; induction H2;try tauto.

induction(eq_dec_points C C').
subst C'.
left.
Between.

assert(Parallelogram C D' D C' \/ C = D' /\ B = A /\ C' = D /\ C = C').

apply(plg_pseudo_trans C D' B A C' D).
apply plg_sym.
apply plg_comm2.
assumption.
assumption.
induction H6.

assert(Parallelogram_flat C D' D C').
induction H6.
apply False_ind.
apply plgs_par_strict in H6.
spliter.
apply H6.
exists D.
apply bet_col in H4.
split; Col.
assumption.

right.

assert(HH:= H7).
unfold Parallelogram_flat in H7.
spliter.

apply plgf_bet in HH.
induction HH.
spliter.

apply False_ind.

apply H3.
apply (between_equality _ _ D).
apply between_symmetry.
apply H13.
assumption.
induction H12.
spliter.

assert(D = D').
apply (between_equality _ _ C).
Between.
Between.
subst D'.

apply cong_identity in H10.
contradiction.

induction H12.
spliter.
eBetween.

spliter.
eBetween.
spliter.
subst B.
tauto.
spliter.
subst B.
tauto.
Qed.

Lemma bet_same_dir1 : forall A B C, A <> B -> B <> C -> Bet A B C -> Same_dir A B A C.
intros.
unfold Same_dir.
right.
exists B.
split.
unfold Out.
repeat split.
intro.
subst C.
apply between_identity in H1.
tauto.
auto.
right.
assumption.
apply eqv_refl.
Qed.

Lemma bet_same_dir2 : forall A B C, A <> B -> B <> C -> Bet A B C -> Same_dir A B B C.
intros.
unfold Same_dir.
right.
assert(HH:=vector_construction A B B).
ex_and HH C'.
exists C'.
split; trivial.
unfold EqV in H2.
induction H2; [|tauto].

induction H2.
apply plgs_par_strict in H2.
spliter.
apply False_ind.
apply H3.
exists B.
split; Col.
assert(HH:= H2).
unfold Parallelogram_flat in HH.
apply plgf_bet in H2.
spliter.

unfold Out.
repeat split.
auto.
intro.
subst C'.
apply cong_identity in H5.
contradiction.

induction H2.

assert(Bet B A B).
spliter.
apply (outer_transitivity_between2 _ C').
Between.
auto.
induction H7.
auto.
tauto.
apply between_identity in H8.
subst B.
tauto.
induction H2.

assert(Bet B A B).
spliter.
apply (outer_transitivity_between _ _ C').
apply H2.
auto.
induction H7.
auto.
tauto.
apply between_identity in H8.
subst B.
tauto.

induction H2.

assert( A = C' \/ Midpoint B A C').
apply l7_20.
Col.
Cong.
induction H8.
induction H7.
tauto.
tauto.
unfold Midpoint in H8.
spliter.
apply (l5_2 A); auto.

assert( A = C' \/ Midpoint B A C').
apply l7_20.
Col.
Cong.
induction H8.
induction H7.
tauto.
tauto.
unfold Midpoint in H8.
spliter.
apply (l5_2 A); auto.
Qed.

Lemma plg_opp_dir : forall A B C D, Parallelogram A B C D -> Same_dir A B D C.
intros.

induction(eq_dec_points A B).
subst B.
induction H.
apply False_ind.
apply plgs_sym in H.
apply H.
Col.
apply plgf_trivial_neq in H.
spliter.
subst D.
left.
tauto.

unfold Same_dir.
right.
exists C.
split.
apply out_trivial.
intro.
subst D.
induction H.
apply H.
Col.
apply plgf_sym in H.
apply plgf_trivial_neq in H.
tauto.
unfold EqV.
left.
assumption.
Qed.

Lemma same_dir_dec : forall A B C D,
  Same_dir A B C D \/ ~ Same_dir A B C D.
Proof.
intros.
unfold Same_dir.
unfold EqV.
elim (eq_dec_points A B); intro HAB;
elim (eq_dec_points C D); intro HCD; try tauto.

  right; intro HFalse.
  elim HFalse; clear HFalse; intro HFalse.

    spliter; intuition.

    destruct HFalse as [E [HFalse HElim]].
    elim HElim; clear HElim; intro HElim.

      subst.
      apply plg_cong in HElim.
      destruct HElim as [HCong1 HCong2].
      treat_equalities.
      apply out_diff2 in HFalse; intuition.

      destruct HElim as [Hclear HCE]; clear Hclear; subst.
      apply out_diff2 in HFalse; intuition.

  right; intro HFalse.

  elim HFalse; clear HFalse; intro HFalse.

    spliter; intuition.

    destruct HFalse as [E [HFalse Hclear]]; clear Hclear.
    subst.
    apply out_diff1 in HFalse; intuition.

  assert (H := plg_existence B A C).
  assert (HPar : B <> A) by auto.
  apply H in HPar; clear H.
  destruct HPar as [E HPar].
  elim (out_dec C D E); intro Hout.

    left.
    right.
    exists E.
    split; try assumption.
    left.
    apply plg_comm2 in HPar.
    assumption.

    right.
    intro H.
    elim H; clear H; intro H.

      spliter; subst; intuition.

      destruct H as [F [Hout' HElim]].
      elim HElim; clear HElim; intro HElim.

        apply plg_comm2 in HElim.
        assert (HEF := plg_uniqueness B A C E F HPar HElim).
        subst; intuition.

        spliter; intuition.
Qed.

Lemma same_or_opp_dir : forall A B C D, Par A B C D -> Same_dir A B C D \/ Opp_dir A B C D.
intros.
induction (same_dir_dec A B C D).
left.
assumption.
right.
unfold Opp_dir.

unfold Same_dir.
right.
assert(HH:= vector_construction A B D).
ex_and HH C'.
exists C'.
split; trivial.
unfold EqV in H1.

induction (eq_dec_points B C').
subst C'.
induction H1.

induction H1.
apply False_ind.
apply plgs_permut in H1.
apply plgs_sym in H1.
apply H1.
Col.
apply plgf_permut in H1.
apply plgf_trivial_neq in H1.
spliter.
subst D.
induction H.
apply False_ind.
apply H.
exists A.
split; Col.
spliter.
induction H4.
unfold Out.
repeat split; auto.
left.
Between.
induction H4.
unfold Out.
repeat split; auto.
apply False_ind.
apply H0.
apply same_dir_sym.
apply bet_same_dir2; auto.
unfold Out.
repeat split.
auto.
auto.
right.
assumption.
spliter.
subst A.
subst D.
apply par_distinct in H.
tauto.

induction H1.

assert(Col C' C D /\ Col D C D).
apply plg_par in H1.
spliter.

apply(parallel_uniqueness A B C D C' D D); Col.
apply par_distinct in H.
tauto.
assumption.
spliter.
clear H4.

unfold Out.
repeat split.
apply par_distinct in H.
tauto.
intro.
subst C'.
induction H1.
apply H1.
Col.
apply plgf_sym in H1.
apply plgf_trivial_neq in H1.
spliter.
apply par_distinct in H.
tauto.

induction H3.
left.
Between.
induction H3.
apply False_ind.

assert(Same_dir A B D C').
apply plg_opp_dir.
assumption.

assert(Same_dir C D D C').
apply bet_same_dir2.
apply par_distinct in H.
spliter.
auto.
intro.
subst C'.
induction H1.
apply H1.
Col.
apply plgf_sym in H1.
apply plgf_trivial_neq in H1.
spliter.
apply par_distinct in H.
tauto.
assumption.
apply False_ind.
apply H0.
apply (same_dir_trans _ _ D C').
apply H4.
apply same_dir_sym.
auto.
right.
assumption.
apply par_distinct in H.
tauto.
Qed.

Lemma same_dir_id : forall A B, Same_dir A B B A -> A = B.
intros.
unfold Same_dir in H.
induction H.
tauto.
ex_and H C.
apply eqv_mid in H0.
unfold Midpoint in H0.
unfold Out in H.
spliter.
induction H3.
apply (between_equality _ _ C).
apply H0.
assumption.
apply False_ind.
apply H2.
apply (between_equality _ _ A).
Between.
assumption.
Qed.

Lemma opp_dir_id : forall A B, Opp_dir A B A B -> A = B.
intros.
unfold Opp_dir in H.
apply same_dir_id in H.
auto.
Qed.

Lemma same_dir_to_null : forall A B C D, Same_dir A B C D -> Same_dir A B D C -> A = B /\ C = D.
intros.

assert(Same_dir C D D C).
apply (same_dir_trans _ _ A B).
apply same_dir_sym.
apply H.
assumption.
apply same_dir_id in H1.
subst D.
apply same_dir_sym in H.
apply same_dir_null in H.
subst B.
tauto.
Qed.

Lemma opp_dir_to_null : forall A B C D, Opp_dir A B C D -> Opp_dir A B D C -> A = B /\ C = D.
unfold Opp_dir.
intros.
apply same_dir_to_null; auto.
Qed.

Lemma same_not_opp_dir : forall A B C D, A <> B -> Same_dir A B C D -> ~ Opp_dir A B C D.
intros.
intro.
apply same_dir_to_null in H0.
tauto.
assumption.
Qed.

Lemma opp_not_same_dir : forall A B C D, A <> B -> Opp_dir A B C D -> ~ Same_dir A B C D.
unfold Opp_dir.
intros.
intro.
apply same_dir_to_null in H0.
tauto.
assumption.
Qed.

Lemma vector_same_dir_cong : forall A B C D, A <> B -> C <> D -> exists X, exists Y, Same_dir A B X Y /\ Cong X Y C D.
intros.
exists A.
assert(HH:=segment_construction_3 A B C D H H0).
ex_and HH P.
exists P.
split; auto.
unfold Same_dir.
right.
exists B.
split.
apply l6_6.
assumption.
apply eqv_refl.
Qed.

End Vectors.


Require Import String.
Require Import List.
Require Import Arith.
Require Import Nat.

Module PM.

Example x : string := "12345".

Inductive eProp :=
  | TrueP : eProp
  | FalseP : eProp
  | UnitP : nat -> eProp
  | InjP : eProp -> eProp -> eProp (*OR*)
  | ConjP : eProp -> eProp -> eProp (*AND*)
  | ImpP : eProp -> eProp -> eProp
  | NegP : eProp -> eProp
  | AbsP : eProp -> eProp
  | AppP : eProp -> eProp -> eProp
  .

(* The level is slightly lower than the level for list operator :: . *)
Notation "# x" := (UnitP x) (at level 58, right associativity).
Notation "x \/ y" := (InjP x y).
Notation "x /\ y" := (ConjP x y).
Notation "-- x" := (NegP x) (at level 59, right associativity).
Notation "x =) y" := (ImpP x y) (at level 59, right associativity).

(* Inductive eFunc := (* Only takes one argument *)
  | EFunc : string -> eProp -> eFunc. *)

Example ep1 : eProp := (# 0) \/ (# 1).
Print ep1.
Example ep2 : eProp := -- (#0 /\ #1).
Print ep2.
Example ep3 : eProp := AbsP (#0). (* lambda x.x *)
Print ep3.
Example ep4 := AbsP (#0).
Example ep5 := AppP (AbsP (#2)) (#0).

(* Inductive context :=
  | None : context
  | Some : eProp -> context -> context. *)

(* The context here is for de bruijin interpretaton, or actually the environment.
  How about the context for deduction? *)
Notation context := (list eProp).

Example ctx_two_vars : context := #0 :: #1 :: nil.
Print ctx_two_vars.

(************************************************)
(* De Bruijin Index Interpretation *)

Inductive ePropDB :=
  | TrueDB : ePropDB
  | FalseDB : ePropDB
  | UnitDB : nat -> ePropDB
  | InjDB : ePropDB -> ePropDB -> ePropDB (*OR*)
  | ConjDB : ePropDB -> ePropDB -> ePropDB (*AND*)
  | ImpDB : ePropDB -> ePropDB -> ePropDB
  | NegDB : ePropDB -> ePropDB
  | AbsDB : ePropDB -> ePropDB
  | AppDB : ePropDB -> ePropDB -> ePropDB
  .

(* Notation envDB := (list (nat * string)). *)
Notation envDB := (list nat).

(* Suppose the edge case never happens... *)

Fixpoint lookup (n : nat) (l : envDB) : nat :=
  match l with
  | nil => 0
  | x :: xs => if n =? x then 0 else S (lookup n xs)
  end.

Fixpoint interpX (p : eProp) (env : envDB) : ePropDB :=
  match p with
  | TrueP => TrueDB
  | FalseP => FalseDB
  | UnitP n => UnitDB (lookup n env)
  | InjP n1 n2 => InjDB (interpX n1 env) (interpX n2 env)
  | ConjP n1 n2 => ConjDB (interpX n1 env) (interpX n2 env)
  | ImpP n1 n2 => ImpDB (interpX n1 env) (interpX n2 env)
  | NegP n => NegDB (interpX n env)
  | AbsP p => AbsDB (interpX p (0 :: map S env))
  | AppP p1 p2 => AppDB (interpX p1 env) (interpX p2 env)
  end.

Notation "[[ p ]]" := (interpX p nil).
Notation "[[ p | env ]]" := (interpX p env).

Example interp_1 : ePropDB := [[ AbsP (#0) ]].
Compute interp_1.
Example interp_2 : ePropDB := [[ AbsP (AbsP (#0)) ]].
Compute interp_2.
Example interp_3 : ePropDB := [[ AppP (AbsP (AppP (#0) (#0))) (AbsP (AppP (#0) (#0))) ]].
Compute interp_3.
(* NOTE: if the env is nil, the number being returned will be directly cut down to 0. Hence
the interpreted number appears to be 1.
The thing here could be that, even in the original language the abstraction is still somehow
fuzzy. We don't know what is x, what is y and what does the unit number means. Or maybe it
actually saved some efforts. *)
Example interp_4 : ePropDB := [[ AppP (AbsP (AppP (#10) (#10))) (AbsP (AppP (#10) (#10))) ]].
Compute interp_4.

(* STUB *)
Fixpoint substX (p : ePropDB) (env : list eProp) : ePropDB :=
  match p with
  | _ => UnitDB 100
  end.

(* STUB *)
Fixpoint evalX (p : ePropDB) (env : list eProp) : ePropDB :=
  match p with
  | _ => UnitDB 100
  end.

(* **************************************** *)
(* 1ST ATTEMPT *)

(* Ideal case for deep interpretation:

#"x" /\ #"y" /\ #"z"
== interpret into =>
$0 /\ $1 /\ $2 <= with a "environment" == [($0, "x"), ($1, "y"), ($2, "z")]

TODO:
  if (find var in env)
  => interpret as var
  else => shift all vars and interpret as new var
*)

(* Definition string_eq (s1 s2 : string) : bool :=
  match string_dec s1 s2 with
  | left _ => true
  | right _ => false
  end.

Fixpoint findVar (s : string) (env : envDB) : bool :=
  match env with
  | nil => false
  | (_, s') :: es =>
    if string_eq s s' then true
    else findVar s es
  end.

Fixpoint createVar (s : string) (env : envDB) : envDB. Admitted.

Fixpoint interp (p : eProp) (env : envDB) : (ePropDB, envDB) :=
  match p with
  | TrueP => (TrueDB, env)
  | FalseP => (FalseDB, env)
  (* TODO: change environment *)
  (* TODO: carefully calculate a variable's number? *)
  | UnitP s => if findVar s env then _ else ((UnitDB 0), env)
  | InjP n1 n2 => match interpX n1 ctx xx, interpX n2 ctx xx with
                  | FalseP, FalseP => FalseP
                  | _, _ => TrueP
                  end
  | ConjP n1 n2 => match interpX n1 ctx xx, interpX n2 ctx xx with
                  | TrueP, TrueP => TrueP
                  | _, _ => FalseP
                  end
  | ImpP n1 n2 => match interpX n1 ctx xx, interpX n2 ctx xx with
                  | FalseP, _ => TrueP
                  | TrueP, TrueP => TrueP
                  | _, _ => FalseP
                  end
  | NegP n => match interpX n ctx xx with
                  | TrueP => FalseP
                  | _ => TrueP
                  end *)

(* **************************************** *)
(* 2ND ATTEMPT *)
(* **************************************** *)

(* Fixpoint shift (d : nat) (c : nat) (f : eProp) : eProp :=
  match f with
  | UnitP n =>
      if leb c n then UnitP (d + n) else UnitP n
  | TrueP => TrueP
  | FalseP => FalseP
  | InjP n1 n2 => InjP (shift d c n1) (shift d c n2)
  | ConjP n1 n2 => ConjP (shift d c n1) (shift d c n2)
  | ImpP n1 n2 => ImpP (shift d c n1) (shift d c n2)
  | AbsP n1 =>
      AbsP (shift d (c+1) n1)
  | AppP n1 n2 =>
      AppP (shift d c n1) (shift d c n2)
  | NegP n => NegP (shift d c n)
  end.

Fixpoint countDepth (p : eProp) (n : nat) : nat :=
  match p with
  | UnitP _ => n+1
  | TrueP => n+1
  | FalseP => n+1
  | InjP p1 p2 => max (countDepth p1 n) (countDepth p2 n) + 1
  | ConjP p1 p2 => max (countDepth p1 n) (countDepth p2 n) + 1
  | ImpP p1 p2 => max (countDepth p1 n) (countDepth p2 n) + 1
  | AbsP _ => n+1
  | AppP p1 p2 => max (countDepth p1 n) (countDepth p2 n) + 1
  | NegP _ => n+1
  end.

(* This interp translates and evaluates the proposition to a de bruijin term to the end

   The interpretation is actually a big-step evaluation. Maybe I just need to merely
 interpret it rather than evaluate it... *)
Fixpoint interpX (p : eProp) (ctx : context) (x : nat) {struct x} : eProp :=
  match x with
  | 0 => FalseP
  | S xx => match p with
        | TrueP => TrueP
        | FalseP => FalseP
        | UnitP n => nth n ctx (UnitP n)
        | InjP n1 n2 => match interpX n1 ctx xx, interpX n2 ctx xx with
                        | FalseP, FalseP => FalseP
                        | _, _ => TrueP
                        end
        | ConjP n1 n2 => match interpX n1 ctx xx, interpX n2 ctx xx with
                        | TrueP, TrueP => TrueP
                        | _, _ => FalseP
                        end
        | ImpP n1 n2 => match interpX n1 ctx xx, interpX n2 ctx xx with
                        | FalseP, _ => TrueP
                        | TrueP, TrueP => TrueP
                        | _, _ => FalseP
                        end
        | NegP n => match interpX n ctx xx with
                        | TrueP => FalseP
                        | _ => TrueP
                        end
        (* Append a variable to environment and add 1 index to all other values *)
        | AbsP t1 => AbsP (interpX t1 (UnitP 0 :: map (shift 1 0) ctx) xx)
        | AppP t1 t2 => match interpX t1 ctx xx with
                       | AbsP t3 => interpX t3 ((interpX t2 ctx xx) :: (map (shift 1 0) ctx)) xx
                       | _ => AppP (interpX t1 ctx xx) (interpX t2 ctx xx)
                       end
        end
  end.

Definition interp (p : eProp) (ctx : context) : eProp :=
  interpX p ctx (countDepth p 1). *)

(* **************************************** *)

(* Notation "[[ p ]]" := (interp p nil).
Notation "[[ p | ctx ]]" := (interp p ctx).

Example interp_1 : eProp := [[ ep1 ]].
Example interp_2 : eProp := [[ ep4 | nil ]].
Example interp_3 : eProp := [[ ep5 | (AbsP (#0)) :: (AbsP (#0)) :: nil]].

(* ep5 := AppP (AbsP (#2)) (#0). *)
(* ctx1 :=  (AbsP (#0)) :: (AbsP (#0)) :: nil *)
(* ctx2 :=  (AbsP (#0)) :: (AbsP (#1)) :: nil *)
(* TODO: figure out why the result is different *)

(*
AppP (AbsP (#2)) (#0) | (AbsP (#0)) :: (AbsP (#0)) :: nil
= [(AbsP (#2)) | ctx]

AppP (AbsP (#2)) (#0) | (AbsP (#0)) :: (AbsP (#1)) :: nil

*)

Compute interp_1.
Compute interp_2.
Compute interp_3. *)

(************************************************)

(*
NOTE:
Here I have to use Set for asserted rather than Prop.
The reason is that eventually I have to extract some proof from the prop.
Prop is proof irrevalent while Set allows distinction.

*)

Inductive asserted : ePropDB -> Set :=
  | Asserted : forall (e: ePropDB), asserted e.

Definition extract {e : ePropDB} (p : asserted e) : ePropDB := e.

(* Notation Pp := (asserted). *)

Definition pp1_1 (e : eProp) : Set := asserted [[ e ]].
(*
asserted nil e : Prop :=
Asserted : forall (c : context)

*)

(* Definition pp1_11 := forall (e1 e2: eProp),
  asserted [[ e1 ]]
  -> asserted [[ e1 =) e2 ]]
  -> asserted [[ e2 ]]. *)

Definition pp1_2 (p: eProp) : Set := asserted [[ (p \/ p) =) p ]].

(* Definition pp1_3 := forall p q: eProp, Pp [[ q =) (p \/ q) ]].

Definition pp1_4 := forall p q: eProp, Pp [[ (p \/ q) =) (q \/ p) ]].

Definition pp1_5 := forall p q r: eProp, Pp [[ (p \/ (q \/ r)) =) (q \/ (p \/ r)) ]].

Definition pp1_6 := forall p q r: eProp, Pp [[ (q \/ r) =) (p \/ q) =) (p \/ r) ]]. *)

(* Theorem pp1_7: Pp (If p is a eProp, then --p is a eProp). *)

(* Theorem pp1_71: Pp (If p, q are eProps, then p \/ q is a eProp). *)

(* Theorem pp1_72: Pp (If p, q are elemental functions, then p(x) \/ q(x) is a elemental function). *)

(* Require Import Coq.Program.Equality. *)

Theorem n2_01 : forall p: eProp, asserted [[ (p =) (--p)) =) (--p) ]].
Proof.
  intros.
  pose (pp1_2 (--p)) as pp1_2_r1.
  change (pp1_2 (--p)) with (asserted [[ ((--p) \/ (--p)) =) (--p) ]]) in pp1_2_r1.

(*   pose ((pp1_2 (--p)) : asserted [[ (-- p \/ -- p) =) -- p ]]) as pp1_2_r1. *)
(*   change (pp1_2 (--p)) with (Asserted [[ ((--p) \/ (--p)) =) (--p) ]]) in pp1_2_r1. *)
(*   pose (extract pp1_2_r1) as pp1_2_e. *)

(*   Check pp1_2 (--p).
  Check pp1_2_r1.
  Fail pose (extract pp1_2_r1) as pp1_2_e. *)
(*   change (asserted new_prop_r2) with (asserted [[ --p ]]) in new_prop.
  clear new_prop_r1. clear new_prop_r2. *)

Admitted.

Check n2_01.

End PM.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool eqtype ssrfun ssrnat.
Require Import Reals Fourier.
Require Import ssrR Reals_ext Ranalysis_ext.

(** * log_n x and n ^ x *)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope R_scope.

Section addtional_lemmas_about_ln_exp.

Lemma ln_pos x : 1 < x -> 0 < ln x.
Proof. move=> x0; rewrite -ln_1; exact: ln_increasing. Qed.

Lemma ln2_gt0 : 0 < ln 2. Proof. apply ln_pos; fourier. Qed.
Local Hint Resolve ln2_gt0.

Lemma ln2_neq0 : ln 2 != 0. Proof. exact/eqP/gtR_eqF. Qed.

Lemma ln_increasing_le a b : 0 < a -> a <= b -> ln a <= ln b.
Proof.
move=> Ha.
case/Rle_lt_or_eq_dec; last by move=> ->; exact/leRR.
by move/(ln_increasing _ _ Ha)/ltRW.
Qed.

Lemma exp_le_inv x y : exp x <= exp y -> x <= y.
Proof.
case/Rle_lt_or_eq_dec; [move/exp_lt_inv => ?; exact/ltRW |
  move/exp_inv => ->; exact/leRR].
Qed.

Lemma exp_pow n : forall k, exp (INR k * n) = (exp n) ^ k.
Proof.
elim => [|k IH]; first by rewrite mul0R exp_0.
by rewrite S_INR mulRDl mul1R exp_plus IH mulRC.
Qed.

Lemma leR2e : 2 <= exp 1.
Proof. apply Rlt_le, exp_ineq1; fourier. Qed.

Lemma ltRinve1 : exp (-1) < 1.
Proof. rewrite -[X in _ < X]exp_0. apply exp_increasing. fourier. Qed.

Lemma ltRinve21 : exp (-2) < 1.
Proof. rewrite -[X in _ < X]exp_0. apply exp_increasing. fourier. Qed.

Section exp_lower_bound.

Let exp_dev (n : nat) := fun x => exp x - x ^ n * / INR (n`!).

Let derivable_exp_dev (n : nat) : derivable (exp_dev n).
Proof.
rewrite /exp_dev => x.
apply derivable_pt_minus ; first by apply derivable_pt_exp.
apply derivable_pt_mult ; first by apply derivable_pt_pow.
by apply derivable_pt_const.
Defined.

Let exp_dev_rec n x : derive_pt (exp_dev n.+1) x (derivable_exp_dev n.+1 x) = exp_dev n x.
Proof.
rewrite /exp_dev derive_pt_minus derive_pt_exp; congr (_ - _).
rewrite derive_pt_mult derive_pt_const mulR0 addR0 derive_pt_pow.
rewrite mulRC mulRA mulRC; congr (_ * _).
rewrite factS mult_INR invRM; last 2 first.
  exact/INR_eq0.
  apply/eqP; by rewrite INR_eq0' -lt0n fact_gt0.
by rewrite mulRC mulRA mulRV ?mul1R // INR_eq0'.
Qed.

Let exp_dev_gt0 : forall n r, 0 < r -> 0 < exp_dev n r.
Proof.
elim => [r rpos | n IH r rpos].
- rewrite /exp_dev /= mul1R Rinv_1 -exp_0.
  by apply subR_gt0, exp_increasing.
- apply: (@ltR_trans 1) ; first by fourier.
  rewrite (_ : 1 = exp_dev n.+1 0) ; last first.
    rewrite /exp_dev exp_0 pow_i ?mul0R ?subR0 //; by apply/ltP.
  move: derive_increasing_interv.
  move/(_ 0 r (exp_dev n.+1) (derivable_exp_dev n.+1) rpos).
  have Haux : forall t : R,
     0 < t < r -> 0 < derive_pt (exp_dev n.+1) t (derivable_exp_dev n.+1 t).
    move=>x Hx.
    rewrite exp_dev_rec.
    by apply IH, Hx.
  move/(_ Haux 0 r) => {Haux}.
  apply => //.
  - split; [exact/leRR | exact: ltRW].
  - split; [exact: ltRW | exact/leRR].
Qed.

Lemma exp_strict_lb (n : nat) x : 0 < x -> x ^ n * / INR (n`!) < exp x.
Proof. move=> xpos; by apply Rgt_lt, Rminus_gt, Rlt_gt, exp_dev_gt0. Qed.

Let exp_dev_ge0 n r : 0 <= r -> 0 <= exp_dev n r.
Proof.
move=> Hr.
case/boolP : (r == 0) => [/eqP ->|]; last first.
- move=> Hr2.
  have {Hr Hr2}R_pos : 0 < r by apply/ltRP; rewrite lt0R Hr2 /=; exact/leRP.
  exact/ltRW/exp_dev_gt0.
- case: n.
  + rewrite /exp_dev exp_0 mul1R invR1 subRR; exact/leRR.
  - move=> n.
    rewrite -(_ : 1 = exp_dev n.+1 0) //.
    rewrite /exp_dev exp_0 pow_i ?mul0R ?subR0 //; exact/ltP.
Qed.

Lemma exp_lb x (n : nat) : 0 <= x -> x ^ n / INR (n`!) <= exp x.
Proof. move=> xpos; by apply Rge_le, Rminus_ge, Rle_ge, exp_dev_ge0. Qed.

End exp_lower_bound.

End addtional_lemmas_about_ln_exp.
Hint Resolve ln2_gt0.

(** log_n x *)

Definition Log (n : R) x := ln x / ln n.

Lemma ltR0Log n x : 1 < n -> 1 < x -> 0 < Log n x.
Proof. move=> ? ?; apply mulR_gt0; [exact/ln_pos | exact/invR_gt0/ln_pos]. Qed.

Lemma Log_1 (n : R) : Log n 1 = 0.
Proof. by rewrite /Log ln_1 div0R. Qed.

Lemma Log_n (n : R) : 1 < n -> Log n n = 1.
Proof. move=> n1; rewrite /Log /Rdiv mulRV //; exact/eqP/gtR_eqF/ln_pos. Qed.

Lemma LogV n x : 0 < x -> Log n (/ x) = - Log n x.
Proof.
by move=> x0; rewrite /Log ln_Rinv // -mulNR.
Qed.

Lemma LogM n x y : 0 < x -> 0 < y -> Log n (x * y) = Log n x + Log n y.
Proof. move=> *; by rewrite /Log -mulRDl ln_mult. Qed.

Lemma Log_increasing_le n x y : 1 < n -> 0 < x -> x <= y -> Log n x <= Log n y.
Proof.
move=> n1 x0 xy.
apply leR_wpmul2r; [exact/leRP/ltRW'/ltRP/invR_gt0/ln_pos|].
exact: ln_increasing_le.
Qed.

Lemma Log_increasing n a b : 1 < n -> 0 < a -> a < b -> Log n a < Log n b.
Proof.
move=> n1 Ha a_b.
rewrite /Log.
apply ltR_pmul2r; last exact: ln_increasing.
exact/invR_gt0/ln_pos.
Qed.

Lemma Log_inv n x y : 1 < n -> 0 < x -> 0 < y -> Log n x = Log n y -> x = y.
Proof.
move=> n1 Hx Hy.
rewrite /Log /Rdiv eqR_mul2r; last exact/eqP/invR_neq0/eqP/gtR_eqF/ln_pos.
apply ln_inv => //; exact: H.
Qed.

Lemma Log_lt_inv n x y : 1 < n -> 0 < x -> 0 < y -> Log n x < Log n y -> x < y.
Proof.
move=> n1 Hx Hy.
rewrite /Log /Rdiv.
have H : 0 < / ln n by exact/invR_gt0/ln_pos.
move/(ltR_pmul2r H); exact: ln_lt_inv.
Qed.

Lemma Log_le_inv n x y : 1 < n -> 0 < x -> 0 < y -> Log n x <= Log n y -> x <= y.
Proof.
move=> n1 Hx Hy.
case/Rle_lt_or_eq_dec; first by move/(Log_lt_inv n1 Hx Hy)/ltRW.
move/(Log_inv n1 Hx Hy) => ->; exact/leRR.
Qed.

Lemma derivable_pt_Log n : forall x : R, 0 < x -> derivable_pt (Log n) x.
move=> x Hx.
rewrite /Log /Rdiv.
apply derivable_pt_mult.
  exact: derivable_pt_ln.
apply derivable_pt_const.
Defined.

Lemma derive_pt_Log n : forall (a : R) (Ha : 0 < a),
  derive_pt (Log n) a (derivable_pt_Log n Ha) = / a * / ln n.
move=> a Ha.
rewrite /Log.
rewrite /Rdiv.
rewrite derive_pt_mult.
rewrite derive_pt_const.
rewrite derive_pt_ln.
rewrite mulR0 addR0.
reflexivity.
Defined.

(** Log base 2 *)

(* NB: log is 0 for input < 0 *)
Definition log x := Log 2 x.

Lemma logexp1E : log (exp 1) = / ln 2.
Proof. by rewrite /log /Log ln_exp div1R. Qed.

Lemma log_exp1_Rle_0 : 0 <= log (exp 1).
Proof. rewrite logexp1E; exact/leRP/ltRW'/ltRP/invR_gt0. Qed.

(** n ^ x *)
Definition Exp (n : R) x := exp (x * ln n).

Lemma pow_Exp x n : 0 < x -> x ^ n = Exp x (INR n).
Proof. by move=> x0; rewrite /Exp exp_pow exp_ln. Qed.

Lemma LogK n x : 1 < n -> 0 < x -> Exp n (Log n x) = x.
Proof.
move=> n1 x0.
rewrite /Log /Exp -mulRA mulVR ?mulR1; last first.
  rewrite -ln_1.
  apply/eqP => /ln_inv H.
  have : 0 < n by fourier.
  move/H => /(_ Rlt_0_1) ?; fourier.
by rewrite exp_ln.
Qed.

Lemma ExpK n x : 1 < n -> Log n (Exp n x) = x.
Proof.
move=> n1.
rewrite /Log /Exp ln_exp /Rdiv -mulRA mulRV ?mulR1 //.
rewrite -ln_1; apply/eqP => /ln_inv H.
have : 0 < n by fourier.
move/H => /(_ Rlt_0_1) ?; fourier.
Qed.

Lemma Exp_gt0 n x : 0 < Exp n x. Proof. rewrite /Exp; exact: exp_pos. Qed.
Lemma Exp_ge0 n x : 0 <= Exp n x. Proof. exact/ltRW/Exp_gt0. Qed.
Hint Resolve Exp_gt0.
Hint Resolve Exp_ge0.

Lemma Exp_0 n : Exp n 0 = 1.
Proof. by rewrite /Exp mul0R exp_0. Qed.

Lemma ExpD n x y : Exp n (x + y) = Exp n x * Exp n y.
Proof. by rewrite /Exp mulRDl exp_plus. Qed.

Lemma Exp_INR n : (0 < n)%nat -> forall m, Exp (INR n) (INR m) = INR (expn n m).
Proof.
move=> n0.
elim=> [|m IH]; first by rewrite /Exp mul0R exp_0.
rewrite S_INR ExpD expnS mult_INR IH /Exp mul1R exp_ln;
  [by rewrite mulRC | exact/ltR0n].
Qed.

Lemma Exp_increasing n x y : 1 < n -> x < y -> Exp n x < Exp n y.
Proof. move=> ? ?; apply/exp_increasing/ltR_pmul2r => //; exact/ln_pos. Qed.

Lemma Exp_le_inv n x y : 1 < n -> Exp n x <= Exp n y -> x <= y.
Proof.
rewrite /Exp => n1 /exp_le_inv H.
apply/leRP; rewrite -(leR_pmul2l' (ln n)); last exact/ltRP/ln_pos.
rewrite mulRC -(mulRC y); exact/leRP.
Qed.

Lemma Exp_le_increasing n x y : 1 < n -> x <= y -> Exp n x <= Exp n y.
Proof.
move=> n1; rewrite /Exp; case/Rle_lt_or_eq_dec.
move/Exp_increasing => x_y; exact/ltRW/x_y.
move=> ->; exact/leRR.
Qed.

Lemma Exp_Ropp n x : Exp n (- x) = / Exp n x.
Proof. by rewrite /Exp mulNR exp_Ropp. Qed.

(** 2 ^ x *)

Definition exp2 (x : R) := Exp 2 x.

Lemma exp2_gt0 x : 0 < exp2 x. Proof. exact: Exp_gt0. Qed.
Lemma exp2_ge0 x : 0 <= exp2 x. Proof. exact: Exp_ge0. Qed.
Hint Resolve exp2_gt0.
Hint Resolve exp2_ge0.

Lemma exp2_neq0 l : exp2 l <> 0. Proof. exact/gtR_eqF. Qed.
Hint Resolve exp2_neq0.

Lemma exp2_0 : exp2 0 = 1.
Proof. by rewrite /exp2 -/(Exp 2 0) Exp_0. Qed.

Lemma exp2_INR : forall m, exp2 (INR m) = INR (expn 2 m).
Proof. move=> m; by rewrite -Exp_INR. Qed.

Lemma exp2_pow n k : exp2 (INR k * n) = (exp2 n) ^ k.
Proof. by rewrite /exp2 /Exp -mulRA exp_pow. Qed.

Lemma exp2_Ropp x : exp2 (- x) = / exp2 x.
Proof. by rewrite /exp2 Exp_Ropp. Qed.

Lemma logK x : 0 < x -> exp2 (log x) = x.
Proof. move=> Hx; by rewrite /exp2 -/(Exp 2 (log x)) /log -/(Log 2 _) LogK. Qed.

Lemma exp2K x : log (exp2 x) = x.
Proof. by rewrite /exp2 -/(Exp 2 x) /log -/(Log 2 _) ExpK. Qed.

Lemma Rle_exp2_log1_L a b : 0 < b -> exp2 a <b= b = (a <b= log b).
Proof.
move=> Hb; move H1 : (_ <b= _ ) => [|] /=.
- move/leRP in H1.
  have {H1}H1 : a <= log b.
    rewrite (_ : a = log (exp2 a)); last by rewrite exp2K.
    exact: Log_increasing_le.
  move/leRP in H1; by rewrite H1.
- move H2 : (_ <b= _ ) => [|] //=.
  move/leRP in H2.
  rewrite -(@ExpK 2 a _) // in H2.
  apply Log_le_inv in H2 => //.
  move/leRP in H2.
  by rewrite H2 in H1.
Qed.

Lemma Rle_exp2_log2_R b c : 0 < b -> b <b= exp2 c = (log b <b= c).
Proof.
move=> Hb; move H1 : (_ <b= _ ) => [|] /=.
- move/leRP in H1.
  have {H1}H1 : log b <= c.
    rewrite (_ : c = log (exp2 c)); last by rewrite exp2K.
    apply Log_increasing_le => //; exact: exp2_pos.
  by move/leRP in H1.
- move H2 : (_ <b= _ ) => [|] //=.
  move/leRP in H2.
  rewrite -(exp2K c) in H2.
  apply Log_le_inv in H2 => //.
  move/leRP in H2.
  by rewrite H2 in H1.
Qed.

Lemma Rle2_exp2_log a b c : 0 < b ->
  exp2 a <b= b <b= exp2 c = (a <b= log b <b= c).
Proof.
move=> Hb; move H1 : (_ <b= _ ) => [|] /=.
- rewrite Rle_exp2_log1_L // in H1.
  by rewrite H1 /= Rle_exp2_log2_R.
- move H2 : (_ <b= _ ) => [|] //=.
  rewrite -Rle_exp2_log1_L // in H2.
  by rewrite H2 in H1.
Qed.

Lemma exists_frac_part (P : nat -> Prop) : (exists n, P n) ->
  forall num den, (0 < num)%nat -> (0 < den)%nat ->
  (forall n m, (n <= m)%nat -> P n -> P m) ->
  exists n, P n /\
    frac_part (exp2 (INR n * (log (INR num) / INR den))) = 0.
Proof.
case=> n Pn num den Hden HP.
exists (n * den)%nat.
split.
  apply H with n => //.
  by rewrite -{1}(muln1 n) leq_mul2l HP orbC.
rewrite mult_INR -mulRA (mulRCA (INR den)) mulRV // ?mulR1; last first.
  by rewrite INR_eq0' -lt0n.
rewrite exp2_pow logK; [exact/frac_part_pow/frac_part_INR | exact/ltR0n].
Qed.


Require Export CatSem.CAT.category.

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

Section defs.

Variable obC : Type.
Variable morC : obC -> obC -> Type.
Variable C : Cat_struct morC.

(** definition of
      - monic
      - epi
      - invertible
      - ismorphic objects
*)

Section morphisms.

Variables a b : obC.

Class Monic (f: morC a b) := {
  monic_cond : forall d (g1 g2 : morC d a),
                 g1 ;; f == g2 ;; f -> g1 == g2
}.

Class Epi (f: morC a b) := {
  epi_cond : forall d (g1 g2 : morC b d),
                 f ;; g1 == f ;; g2 -> g1 == g2
}.

Class Invertible (f: morC a b) := {
  inverse : morC b a ;
  inv_prae : inverse ;; f == id _ ;
  inv_post : f ;; inverse == id _
}.

Class isomorphic := {
  inv_morphism : morC a b;
  invertible :> Invertible inv_morphism
}.

End morphisms.

Implicit Arguments inverse [a b Invertible].

Notation "-- f" := (inverse f) (at level 30).

(**   lemmata, such as "composition of monics..." etc bla bla *)

Section lemmata.

Variables a b c : obC.
Variable f : morC a b.
Variable g : morC b c.

Global Instance comp_of_monics
   (Hf : Monic f) (Hg : Monic g) : Monic (f ;; g).
Proof.
  intros Hf Hg.
  constructor.
  intros d g1 g2.
  repeat rewrite <- assoc.
  intro H.
  assert (H': g1 ;; f == g2 ;; f).
  apply Hg; auto.
  apply Hf; auto.
Qed.

Global Instance comp_of_epis (Hf : Epi f) (Hg : Epi g) : Epi (f ;; g).
Proof.
  intros Hf Hg.
  constructor.
  intros d g1 g2.
  repeat rewrite assoc.
  intro H.
  assert (H': g ;; g1 == g ;; g2).
  apply Hf; auto.
  apply Hg; auto.
Qed.

Global Instance comp_monic_fst_monic (H : Monic (f ;; g)) : Monic f.
Proof.
  intro H.
  set (H':= monic_cond (Monic:=H)).
  constructor.
  intros d g1 g2 H2.
  apply (H' _ g1 g2).
  repeat rewrite <- assoc.
  rewrite H2.
  cat.
Qed.

Global Instance comp_epi_snd_epi (H : Epi (f ;; g)) : Epi g.
Proof.
  intro H.
  set (H':= epi_cond (Epi:=H)).
  constructor.
  intros d g1 g2 H2.
  apply (H' _ g1 g2).
  repeat rewrite assoc.
  rewrite H2.
  cat.
Qed.

(** uniqueness of the inverse *)

Lemma inverse_unique (H : Invertible f) h
   (H1 : f ;; h == id _ ) (H2 : h ;; f == id _ ) :
         h == -- f.
Proof.
  intros  H h H1 H2.
  transitivity (h ;; (f ;; --f)).
  rewrite inv_post; cat.
  rewrite <- assoc.
  rewrite H2.
  cat.
Qed.

Program Instance inverse_invertible (H : Invertible f) :
                                 Invertible (--f):= {
  inverse := f;
  inv_prae := inv_post (Invertible := H);
  inv_post := inv_prae (Invertible := H)
}.

End lemmata.

Existing Instance inverse_invertible.

Section more_lemmata.

Variables a b c : obC.
Variable f : morC a b.
Variable g : morC b c.

Lemma inverse_inverse (H : Invertible f) : -- (-- f) == f.
Proof.
  intro H.
  apply hom_sym.
  apply inverse_unique.
  apply inv_prae.
  apply inv_post.
Qed.

Lemma put_inv_to_right (H : Invertible f) h :
        f ;; g == h <-> g == -- f ;; h.
Proof.
  intros H h.
  split; intro H'.
  transitivity (--f ;; f ;; g).
  rewrite inv_prae; cat.
  rewrite <- H'; apply assoc.

  transitivity (f ;; --f ;; h).
  repeat rewrite assoc.
  apply praecomp; auto.
  rewrite inv_post; cat.
Qed.

End more_lemmata.

Section still_more_lemmata.

Variables a b c : obC.
Variable f : morC a b.
Variable g : morC b c.

(** inverse of a composition *)

Program Instance inv_of_comp (Hf : Invertible f) (Hg : Invertible g) :
      Invertible (f ;; g) := {
  inverse := --g ;; --f
}.
Next Obligation.
Proof.
  apply hom_sym.
  rewrite assoc.
  rewrite <- put_inv_to_right.
  rewrite <- assoc.
  rewrite inv_prae.
  cat.
Qed.

End still_more_lemmata.

End defs.

Implicit Arguments Invertible [obC morC C a b].
Implicit Arguments inverse [obC morC C a b Invertible].


Require Import pure_lemmas.
Require Import Coqlib.
Require Import Integers.
(* Require Import HMAC_spec_harvard_concat. *)
Require Import SHA256.
Require Import functional_prog.
Require Import hmac_pure_lemmas.

(* Lemma 1: M = Prefix(Pad(M)) *)

Inductive Prefix {X : Type} : list X -> list X -> Prop :=
  | p_nil : forall (l : list X), Prefix [] l
  | p_self : forall (l : list X), Prefix l l
  | p_cons : forall (l1 l2 : list X) (x : X), Prefix l1 l2 -> Prefix (x :: l1) (x :: l2)
  | p_append : forall (l1 l2 : list X) (l3 : list X), Prefix l1 l2 -> Prefix l1 (l2 ++ l3).
  (* | p_trans : forall (l1 l2 l3 : list X), Prefix l1 l2 -> Prefix l2 l3 -> Prefix l1 l2. *)

(* TODO: replace InWords with InBlocks 4? *)
Inductive InWords : list Z -> Prop :=
  | words_nil : InWords []
  | words_word : forall (a b c d : Z) (msg : list Z),
                   InWords msg -> InWords (a :: b :: c :: d :: msg).

(* *** New definition for this lemma. *)
Definition pad (msg : list Z) : list Z :=
  let n := Zlength msg in
  msg ++ [128%Z]
      ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0
      ++ intlist_to_Zlist ([Int.repr (n * 8 / Int.modulus), Int.repr (n * 8)]).

Definition generate_and_pad' (msg : list Z) : list int :=
  Zlist_to_intlist (pad msg).

(* TODO: total_pad_len_Zlist  *)
Inductive InBlocks {A : Type} (n : nat) : list A -> Prop :=
  | list_nil : InBlocks n []
  | list_block : forall (front back full : list A),
                   length front = n ->
                   full = front ++ back ->
                   InBlocks n back ->
                   InBlocks n full.

(* ----------------- ^ Definitions *)
(*
Check NPeano.divide.
Print NPeano.divide.
Check list_repeat.
Print list_repeat.
*)

Lemma fstpad_len :
  forall (msg : list Z),
    Datatypes.length (msg ++ [128]
                 ++ list_repeat (Z.to_nat (- (Zlength msg + 9) mod 64)) 0)
= (Datatypes.length msg + (S (Z.to_nat (- (Zlength msg + 9) mod 64))))%nat.
Proof.
  intros msg.
  simpl.
  rewrite -> app_length.
  simpl.
  rewrite -> length_list_repeat.
  reflexivity.
Qed.

Lemma InWords_len4 : forall (l : list Z),
                       NPeano.divide (Z.to_nat WORD) (length l) -> InWords l.
Proof.
  intros l [x H].
  revert l H.
  induction x.
  intros l H. simpl in H.
  destruct l.
    apply words_nil.
    simpl in H. inversion H.
  intros l H.
  destruct l as [ | a [ | b [ | c [ | d ? ]]]].
    inversion H.
    inversion H.
    inversion H.
    inversion H.
    specialize (IHx l).
      apply words_word.
      apply IHx.
      simpl in H. inversion H.
      simpl. apply H1.
Qed.

Lemma InBlocks_len : forall {A : Type} (l : list A) (n : nat),
                       NPeano.divide (n) (length l) -> InBlocks n l.
Proof.
  intros A l n div.
  destruct div.
  revert A l n H.
  induction x; intros; simpl in *.
  - destruct l; simpl in *. constructor. inversion H.
  - destruct (list_splitLength _ _ _ H) as [l1 [l2 [L [L1 L2]]]]. clear H; subst.
    apply IHx in L2. clear IHx.
    apply (list_block _ l1 l2); trivial.
Qed.

(* TODO: clear out the SearchAbouts / clean up proof *)
Lemma pad_len_64_mod : forall (msg : list Z),
                           (Zlength (pad msg)) mod 64 = 0.
Proof.
  intros msg.
  unfold pad.
  rewrite -> Zlength_correct.
  repeat rewrite -> app_length.
  simpl.
  assert (succ: forall (n : nat), S n = (n + 1)%nat).
    intros. induction n. reflexivity. omega.
  rewrite -> succ.
  assert ((length msg +
      (length (list_repeat (Z.to_nat (- (Zlength msg + 9) mod 64)) 0%Z) + 8 +
       1))%nat = (length msg +
      (length (list_repeat (Z.to_nat (- (Zlength msg + 9) mod 64)) 0%Z) + 9))%nat) by omega.
  rewrite -> H. clear H.

(*  SearchAbout generate_and_pad.*)
  rewrite -> Zlength_correct.
  rewrite -> length_list_repeat.

  repeat rewrite -> Nat2Z.inj_add.
  rewrite -> Z2Nat.id.

  assert (move : forall (a b c : Z), a + (b + c) = (a + c) + b).
  intros. omega.

  rewrite -> move.
  rewrite -> Zplus_mod_idemp_r.

  assert (Z_9 : 9 = Z.of_nat (9%nat)). reflexivity.
  rewrite -> Z_9.

  repeat rewrite <- Nat2Z.inj_add.

  assert (forall (x : Z), x + (-x) = 0). intros. omega.

  rewrite -> H.
  reflexivity.

  * apply Z.mod_pos_bound.
    omega.
Qed.

(* more usable versions *)
Lemma pad_len_64 : forall (msg : list Z), exists (n : Z),
                           Zlength (pad msg) = 64 * n /\ n >= 0.
Proof.
  intros msg.
  pose proof pad_len_64_mod msg as pad_len_mod.
  rewrite -> Zmod_divides in *. 2: omega.

  destruct pad_len_mod.
  exists x.
  split.
  apply H.
  specialize (Zlength_nonneg (pad msg)); intros. omega.
Qed.

Lemma pad_len_64_nat : forall (msg : list Z), exists (n : nat),
                           (length (pad msg))%nat = (64 * n)%nat.
Proof.
  intros msg.
  pose proof pad_len_64 msg as pad_len_64.

  rewrite -> Zlength_correct in *.
  destruct pad_len_64.
  exists (Z.to_nat x).
  destruct H.

  assert (app_each : Z.to_nat (Z.of_nat (length (pad msg))) = Z.to_nat (64 * x)).
    rewrite -> H. reflexivity.

  rewrite -> Nat2Z.id in app_each.

  rewrite -> app_each.
(*  SearchAbout (Z.to_nat (_ * _)).*)
  rewrite -> Z2Nat.inj_mul.
  assert (n_64 : Z.to_nat 64 = 64%nat). reflexivity.

  rewrite -> n_64.
  reflexivity.

  * omega.
  * omega.
Qed.

Lemma total_pad_len_Zlist : forall (msg : list Z), exists (n : nat),
     length
       (msg ++ [128] ++ list_repeat (Z.to_nat (- (Zlength msg + 9) mod 64)) 0)
     =  (n * Z.to_nat WORD (* 4 *))%nat.
Proof.
  intros msg.
  pose proof pad_len_64_nat msg as pad_len_64_nat.

  unfold pad in *.
  repeat rewrite -> app_length in *.
  destruct pad_len_64_nat.
  assert (sym: (64 * x)%nat = (x * 64)%nat) by omega.
  rewrite -> sym in *. clear sym.

  simpl in *.
  assert (Pos.to_nat 4 = 4%nat) by reflexivity.
  rewrite -> H0. clear H0.

  rewrite -> length_list_repeat in *.

  assert (add_both: (length msg + S (Z.to_nat (- (Zlength msg + 9) mod 64) ))%nat =
      (x * 64 - 8)%nat) by omega. clear H.

  rewrite -> add_both.
  assert ((x * 64 - 8)%nat = (4 * (16 * x - 2))%nat) by omega.

  rewrite -> H.
  exists (16 * x - 2)%nat.
  omega.
Qed.

Lemma pad_inwords :
  forall (msg : list Z),
    InWords (msg ++ [128]
                 ++ list_repeat (Z.to_nat (- (Zlength msg + 9) mod 64)) 0).
Proof.
  intros msg.
  apply InWords_len4.
  pose proof total_pad_len_Zlist.
  specialize (H msg).
  unfold NPeano.divide.
  apply H.
Qed.

Definition fulllen (len : Z) :=
  len + 1%Z + (- (len + 9) mod 64).

Lemma app_left : forall (a b c d : list Z),
   a ++ b ++ c ++ d = (a ++ b ++ c) ++ d.
(* a ++ (b ++ (c ++ d)) = (a ++ (b ++ c)) ++ d *)
Proof.
   intros a b c d.
   assert (b ++ (c ++ d) = (b ++ c) ++ d) as assert1.
     rewrite -> app_assoc. reflexivity.
   rewrite -> assert1.
   rewrite -> app_assoc.
   reflexivity.
Qed.

(* can use extensionality *)
Theorem pad_compose_equal : forall (msg : list Z),
                              generate_and_pad' msg = generate_and_pad msg.
Proof.
  intros msg.
  unfold generate_and_pad'.
  unfold pad.
  unfold generate_and_pad.
  (* need il => ZIL (IZL il), and
     ZIL a ++ Zil b = ZIL (a ++ b) (with length a being a multiple of 4)
   *)
  pose proof pad_inwords as pad_inwords.
  specialize (pad_inwords msg).
  rewrite -> app_left.
  induction pad_inwords.
  (* case none *)
    assert (forall l : list Z, [] ++ l = l) as Happend. reflexivity.
    specialize (Happend (intlist_to_Zlist
        [Int.repr (Zlength msg * 8 / Int.modulus),
        Int.repr (Zlength msg * 8)])).
    rewrite -> Happend.
    rewrite -> intlist_to_Zlist_to_intlist.
    reflexivity.
  (* case a :: b :: c :: d :: msg0 *)
    Opaque intlist_to_Zlist.
    simpl.
    apply f_equal.
    apply IHpad_inwords.
Qed.

(* Proof easy with pad definition *)
Theorem prefix : forall (msg : list Z),
                   Prefix msg (pad msg).
Proof.
  intros msg.
  unfold pad.
  apply p_append.
  apply p_self.
Qed.

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

(* Lemma 2: |M1| = |M2| -> |Pad(M1)| = |Pad(M2)| *)

Theorem length_equal_pad_length : forall (msg1 : list Z) (msg2 : list Z),
     Zlength msg1  = Zlength msg2 ->
     Zlength (generate_and_pad msg1) = Zlength (generate_and_pad msg2).
Proof.
  intros m1 m2 H.
  repeat rewrite -> functional_prog.length_generate_and_pad.
  rewrite -> H.
  reflexivity.
Qed.

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

(* Lemma 3: |M1| =/= |M2| ->
last block of Pad(M1) =/= last block of Pad(M2)

or, if one-to-one property is desired (for HMAC), only need to prove that
the padded messages differ
*)

Definition generate_and_pad_copy msg :=
  let n := Zlength msg in
   Zlist_to_intlist (msg ++ [128%Z]
                ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0)
           ++ [Int.repr (n * 8 / Int.modulus), Int.repr (n * 8)].

(* Probably easier to use the rewritten version; already "proved"
 that that's in blocks of 4 *)

Theorem length_differ_pad_differ : forall (m1 m2 : list Z),
                                     Zlength m1 <> Zlength m2 ->
                                     generate_and_pad m1 <> generate_and_pad m2.
Proof.
  intros m1 m2 len_diff.
  unfold generate_and_pad.

Admitted.

(* TODO prove equivalent to above *)
Theorem contrapositive_gap : forall (m1 m2 : list Z),
                                     generate_and_pad m1 = generate_and_pad m2 ->
                                     Zlength m1 = Zlength m2.

Proof.
  intros m1 m2 gap_eq.
  unfold generate_and_pad in *.

Admitted.

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

(* TODO: Prove that the above three lemmas imply that generate_and_pad is one-to-one
-- actually, that has type list Z -> list int.

Prove first that it implies the pad function is one-to-one (defined above).

Then, lift it to the vector version.

  Variable splitAndPad : Blist -> list (Bvector b).
  Hypothesis splitAndPad_1_1 :
    forall b1 b2,
      splitAndPad b1 = splitAndPad b2 ->
      b1 = b2.
*)

SearchAbout (_ <> _ -> _ <> _).

Require Import Coq.Logic.Decidable.

Lemma f_app_equal : forall {A B : Type} (f : A -> B) (x y : A),
                      x = y -> f x = f y.
Proof. intros. rewrite H. reflexivity. Qed.

Theorem pad_1_1_len : forall (m1 m2 : list Z),
                    pad m1 = pad m2 ->
                    length m1 = length m2.
Proof.
  intros m1 m2.

  (* apply contrapositive. *)
  (* * unfold decidable. *)
  (*   omega. *)
  (* * intros lenfalse. *)
  (*   unfold pad. *)

  intros pad_eq.
  unfold pad in *.

(*
  assert (lp : length (pad m1) = length (pad m2)).
    apply f_app_equal. apply pad_eq.
  unfold pad in lp.
  repeat rewrite app_length in lp.
  simpl in lp.
  rewrite plus_comm in lp.
  symmetry in lp.
  rewrite plus_comm in lp.
  inversion lp.
  clear lp.
  repeat rewrite -> length_list_repeat in *.
  repeat rewrite -> length_intlist_to_Zlist in *.
  simpl in *.
  repeat rewrite -> Zlength_correct in *.
  assert (forall x y z : nat, (x + y + z)%nat = (y + x + z)%nat) as plus_comm_3.
    intros. omega.
  rewrite -> plus_comm_3 in H0. symmetry in H0.
  rewrite -> plus_comm_3 in H0.
  inversion H0. clear H0.
  SearchAbout ((_ + _) mod _).
  SearchAbout (-_ mod _).
  SearchAbout (- (_ + _)).
  rewrite -> Z.opp_add_distr in H1. symmetry in H1. rewrite -> Z.opp_add_distr in H1.

  SearchAbout ((_ + _) mod _).

not true
*)

  (* f(x) + x = f(y) + y. x = y? not necessarily; f(c) = -c for example.
     what if x,y,f(c):nat? then it must be true by inversion? *)

  (* generalize dependent H1. *)
  (* apply contrapositive. *)
  (* * admit. *)
  (* * intros lenfalse. *)
  (*   SearchAbout (_ -> False). *)
  (*   SearchAbout (_ <> _). *)

  assert (forall x y : nat, -(x + y) = -x + -y).

  (* specialize (f_app_equal length). *)
  SearchAbout (_ ++ _ = _ ++ _).
  (* apply app_inv_tail in pad_eq. *)
  (* apply app_inj_tail in pad_eq. *)

Admitted.

Theorem pad_general : forall (m1 m2 l1 l2 : list Z),
                     length l1 = length l2 ->
                     m1 ++ l1 = m2 ++ l2 ->
                     m1 = m2.
Proof.
  intros m1 m2 l1 l2 len_tail_eq concat_eq.
  SearchAbout (_ ++ _ = _ ++ _).
  revert m2 l1 l2 len_tail_eq concat_eq.
  induction m1; intros.
  *
    destruct m2.
    - reflexivity.
    - rewrite -> app_nil_l in concat_eq.
      assert (length l1 = length (z :: m2 ++ l2)) as length_absurd.
      { apply f_app_equal. apply concat_eq. }
      simpl in length_absurd.
      rewrite -> len_tail_eq in length_absurd.
      rewrite -> app_length in length_absurd.
      omega.
  *
    destruct m2.
    -
      rewrite -> app_nil_l in concat_eq.
      assert (length (a :: m1 ++ l1) = length l2) as length_absurd.
      { apply f_app_equal. apply concat_eq. }
      simpl in length_absurd.
      rewrite <- len_tail_eq in length_absurd.
      rewrite -> app_length in length_absurd.
      omega.
    -
      f_equal.
      +
        inversion concat_eq.
        reflexivity.
      +
        apply (IHm1 m2 l1 l2).
        apply len_tail_eq.
        inversion concat_eq.
        reflexivity.
Qed.

Theorem pad_1_1 : forall (m1 m2 : list Z),
                    pad m1 = pad m2 ->
                    m1 = m2.
Proof.
  intros m1 m2 pad_eq.
  unfold pad in *.
  apply pad_general in pad_eq.
  apply pad_eq.
  repeat rewrite -> app_length.
  simpl.
  f_equal.
  f_equal.
  *
    do 6 f_equal.
    (* apply pad_1_1_len. *)
    admit.
Qed.


Require Import List.
Import ListNotations.

Require Import Logic.Class.Eq.

Require Import Logic.STLC.Syntax.

Fixpoint subst_(b v:Type)(eq:Eq v)(f:v -> Exp b v)(xs:list v)(e:Exp b v):Exp b v:=
    match e with
    | Ann e' Ty => Ann (subst_ b v eq f xs e') Ty
    | Var x     =>
        match in_dec eqDec x xs with
        | left _    => Var x    (* x is deemed bound    -> Var x                *)
        | right _   => f x      (* x is deemed free     -> f x                  *)
        end
    | App t1 t2 => App (subst_ b v eq f xs t1) (subst_ b v eq f xs t2)
    | Lam x t1  => Lam x (subst_ b v eq f (x :: xs) t1)  (* x now bound         *)
    end.
Arguments subst_ {b} {v} {eq}.

Definition subst(b v:Type)(eq:Eq v)(f:v -> Exp b v)(e:Exp b v):Exp b v:=
    subst_ f [] e.

Arguments subst {b} {v} {eq}.

Lemma substAnn : forall (b v:Type)(eq:Eq v)(f:v -> Exp b v)(e:Exp b v)(Ty:T b),
    subst f (Ann e Ty) = Ann (subst f e) Ty.
Proof. intros b v eq f e Ty. reflexivity. Qed.

Lemma substVar : forall (b v:Type)(eq:Eq v)(f:v -> Exp b v)(x:v),
    subst f (Var x) = f x.
Proof. intros b v eq f x. reflexivity. Qed.

Lemma substApp : forall (b v:Type)(eq:Eq v)(f:v -> Exp b v)(e1 e2:Exp b v),
    subst f (App e1 e2) = App (subst f e1) (subst f e2).
Proof. intros b v eq f e1 e2. reflexivity. Qed.


Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.

Import ListNotations.

Require Import GHC.Num.
Require Import GHC.List.
Require Import Proofs.GHC.Base.

(* NOTE: both GHC and Coq.Lists modules are in scope. But we import the GHC module
   second to make it the default one. *)

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

(* Haskell-Coq equivalence: we can relate various operation in GHC.List with
   those defined in Coq.Lists.List *)

Lemma hs_coq_lenAcc_add {A} (l : list A) (acc1 acc2 : Z) :
  List.lenAcc l (acc1 + acc2)%Z = (lenAcc l acc1 + acc2)%Z.
Proof.
  generalize dependent acc1; generalize dependent acc2;
    induction l as [|x l IH]; simpl; auto; intros.
  rewrite <-Z.add_assoc, Z.add_comm, <-Z.add_assoc, Z.add_comm, IH; do 2 f_equal;
    apply Z.add_comm.
Qed.

Lemma hs_coq_lenAcc {A} (l : list A) (acc : Z) :
  List.lenAcc l acc = (Zlength l + acc)%Z.
Proof.
  generalize dependent acc; induction l as [|x l IH]; simpl; auto; intros.
  rewrite Zlength_cons, Z.add_succ_l, <-IH, hs_coq_lenAcc_add, Z.add_1_r; reflexivity.
Qed.

Theorem hs_coq_list_length {A} (l : list A) :
  List.length l = Zlength l.
Proof.
  unfold length; rewrite hs_coq_lenAcc, Z.add_0_r; reflexivity.
Qed.

Theorem hs_coq_filter {A} (p : A -> bool) (l : list A) :
  List.filter p l = Coq.Lists.List.filter p l.
Proof.
  induction l; simpl; auto.
  destruct (p _); f_equal; auto.
Qed.

Theorem hs_coq_reverse : forall A (xs : list A),
  List.reverse xs = Coq.Lists.List.rev xs.
Proof.
  intros A.
  unfold List.reverse.
  set (rev := fix rev (arg_0__ arg_1__ : list A) {struct arg_0__} :
   list A :=
     match arg_0__ with
     | nil => arg_1__
     | cons x xs => rev xs (cons x arg_1__)
     end).
  induction xs.
  simpl.
  auto.
  simpl.
  rewrite <- List.rev_append_rev.
  replace (List.rev_append xs (a :: nil)) with
      (List.rev_append (a :: xs) nil); auto.
Qed.

(* ------------------------- length ----------------------------------- *)

Section Length.

Local Parameter A : Type.

Lemma length_nil : List.length (@nil A) = 0%Z.
Proof. reflexivity. Qed.

Lemma length_cons (x:A) xs : List.length (x :: xs) = (List.length xs + 1)%Z.
Proof. rewrite hs_coq_list_length. rewrite Zlength_cons.
       rewrite hs_coq_list_length. reflexivity.
Qed.

Lemma length_app (xs : list A) (ys : list A) : List.length (xs ++ ys) = (List.length xs + List.length ys)%Z.
Proof.
  rewrite !hs_coq_list_length. rewrite !Zlength_correct.
  rewrite app_length. rewrite Nat2Z.inj_add. reflexivity.
Qed.

Hint Rewrite @length_nil @length_cons @length_app : hs_simpl.

End Length.

(* ------------------------- reverse ----------------------------------- *)

Section Reverse.

Lemma reverse_nil : reverse (@nil A) = @nil A.
Proof. rewrite !hs_coq_reverse. reflexivity. Qed.

Lemma reverse_unit : forall (l:list A) (a:A), List.reverse (l ++ [a]) = a :: List.reverse l.
Proof. intros. rewrite !hs_coq_reverse. rewrite rev_unit. reflexivity. Qed.

Lemma reverse_involutive : forall l:list A, List.reverse (List.reverse l) = l.
Proof. intros. rewrite !hs_coq_reverse. rewrite rev_involutive. reflexivity. Qed.

Hint Rewrite @reverse_nil @reverse_unit @reverse_involutive : hs_simpl.

End Reverse.

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

(* Make sure by-hand definitions are suitable for reasoning. *)

Lemma take_drop : forall (a:Set) (xs : list a) n,
    xs = (List.take n xs) ++ (List.drop n xs).
Proof.
  intros a xs.
  induction xs; intro n.
  unfold take. unfold drop.
  destruct (n <=? 0)%Z; auto.
  unfold take. unfold drop.
  destruct (n <=? 0)%Z.
  auto.
  fold (@take a).
  fold (@drop a).
  simpl.
  f_equal.
  auto.
Qed.

Lemma List_foldl_foldr:
  forall {a b} f (x : b) (xs : list a),
    List.fold_left f xs x = Coq.Lists.List.fold_right (fun x g a => g (f a x)) id xs x.
Proof.
  intros. revert x.
  induction xs; intro.
  * reflexivity.
  * simpl. rewrite IHxs. reflexivity.
Qed.

Lemma reverse_append : forall A (vs1:list A) (vs0:list A)  a ,
  (List.reverse (a :: vs0) ++ vs1 = List.reverse vs0 ++ (a :: vs1)).
Proof.
  intros A.
  intros.
  rewrite hs_coq_reverse.
  rewrite hs_coq_reverse.
  rewrite <- List.rev_append_rev.
  rewrite <- List.rev_append_rev.
  simpl.
  auto.
Qed.

Ltac expand_pairs :=
match goal with
  |- context[let (_,_) := ?e in _] =>
  rewrite (surjective_pairing e)
end.

Lemma flat_map_unpack_cons_f:
  forall (A B C : Type) (f : A -> B -> C ) (xs : list (A * B)),
   flat_map (fun '(x,y) => [f x y]) xs = map (fun '(x,y) => f x y) xs.
Proof.
  intros.
  induction xs.
  * reflexivity.
  * simpl. repeat expand_pairs. simpl.
    f_equal. apply IHxs.
Qed.

(* ---------------------------------- zip ----------------------------- *)

(** [zip] and [unzip] *)

Lemma snd_unzip:
  forall a b (xs : list (a * b)),
  snd (List.unzip xs) = map snd xs.
Proof.
  intros.
  induction xs.
  * reflexivity.
  * simpl. repeat expand_pairs. simpl. f_equal. apply IHxs.
Qed.

Lemma snd_unzip_map:
  forall a b c (f : a -> b) (g : a -> c) xs,
  snd (List.unzip (map (fun x => (f x, g x)) xs)) = map g xs.
Proof.
  intros.
  induction xs.
  * reflexivity.
  * simpl. repeat expand_pairs. simpl. f_equal. apply IHxs.
Qed.

Lemma zip_unzip_map:
  forall a b c (f : b -> c) (xs : list (a * b)),
  List.zip (fst (List.unzip xs)) (Base.map f (snd (List.unzip xs)))
  = map (fun '(x,y) => (x, f y)) xs.
Proof.
  intros.
  induction xs.
  * reflexivity.
  * simpl. repeat expand_pairs. simpl. f_equal. apply IHxs.
Qed.

Lemma unzip_zip : forall A B l (la : list A)( lb : list B),
          List.unzip l = (la,lb) ->
          l = List.zip la lb.
Proof.
  induction l; intros; simpl.
  - inversion H; simpl; auto.
  - destruct a as [a b].
    simpl in H.
    destruct (List.unzip l) as [as_ bs].
    inversion H. subst.
    simpl.
    erewrite IHl.
    eauto.
    eauto.
Qed.

Lemma In_zip_swap : forall {A B} {x:A}{y:B} {xs}{ys},
      In (x,y) (List.zip xs ys) -> In (y,x) (List.zip ys xs).
Proof.
  induction xs; intros; destruct ys;
    simpl in *; inversion H; try contradiction.
  - inversion H0; subst. eauto.
  - right. eapply IHxs; eauto.
Qed.

Lemma In_zip_map :
  forall {A B : Type} {f : A -> B} {x:A}{y:B}{xs},
       In (x,y) (List.zip xs (map f xs)) -> y = f x.
Proof.
  induction xs; intros;
    simpl in *; inversion H; try contradiction.
  - inversion H0; subst. eauto.
  - eapply IHxs; eauto.
Qed.

Lemma In_zip : forall {a} {b} (x:a) (y:b) xs ys,
    In (x,y) (List.zip xs ys) -> In x xs /\ In y ys.
Proof.
  induction xs;
  intros; destruct ys; simpl in H; try contradiction.
  destruct H as [h0 | h1].
  - inversion h0; subst.
    split; econstructor; eauto.
  - simpl. edestruct IHxs; eauto.
Qed.

Lemma unzip_equal_length :
  forall A B l (al:list A) (bl:list B),
    List.unzip l = (al,bl) -> Datatypes.length al = Datatypes.length bl.
Proof.
  induction l. intros; simpl in *. inversion H. auto.
  intros; simpl in *.
  destruct a as [a b].
  destruct (List.unzip l) eqn:UL.
  inversion H.
  simpl.
  f_equal.
  eauto.
Qed.

Lemma length_zip : forall {a}{b} (xs : list a) (ys :list b),
             Datatypes.length xs = Datatypes.length ys ->
             Datatypes.length xs = Datatypes.length (List.zip xs ys).
Proof.
  induction xs; intros; destruct ys; simpl in *; try discriminate.
  auto.
  inversion H.
  erewrite IHxs; eauto.
Qed.

Lemma map_fst_zip : forall A B  (l2:list B) (l1 : list A),
    Datatypes.length l2 = Datatypes.length l1 -> List.map fst (List.zip l2 l1) = l2.
  intros A B l2.
  induction l2; intros; simpl in *. auto.
  destruct l1; simpl in *.
  inversion H.
  f_equal.
  apply IHl2.
  inversion H.
  auto.
Qed.

Lemma map_snd_zip : forall A B  (l1:list B) (l2 : list A),
    Datatypes.length l1 = Datatypes.length l2 -> List.map snd (List.zip l1 l2) = l2.
Proof.
  intros A B l1.
  induction l1; intros; destruct l2; simpl in *; auto.
  inversion H.
  f_equal.
  apply IHl1.
  inversion H.
  auto.
Qed.

Lemma In_zip_fst : forall {A B} {x:A}{y:B} {xs}{ys}{C}(zs: list C),
             In (x,y) (List.zip xs ys) ->
             Datatypes.length ys = Datatypes.length zs ->
             exists z, In (x,z) (List.zip xs zs).
Proof.
  induction xs; intros; destruct ys; destruct zs;
    simpl in *; inversion H0; clear H0; try contradiction.
  - destruct H. inversion H; subst. eauto.
    edestruct IHxs; eauto.
Qed.

Lemma In_zip_snd : forall {A B} {x:A}{y:B} {xs}{ys}{C}(zs: list C),
             In (x,y) (List.zip xs ys) ->
             Datatypes.length xs = Datatypes.length zs ->
             exists z, In (z,y) (List.zip zs ys).
Proof.
  induction xs; intros; destruct ys; destruct zs;
    simpl in *; inversion H0; clear H0; try contradiction.
  - destruct H. inversion H; subst. eauto.
    edestruct IHxs; eauto.
Qed.

(* List simplifications, similar to Coq std library. *)

(*
Lemma map_length : forall l, length (map l) = length l.
Proof. Admitted.

Lemma map_nth : forall l d n,
    nth n (map l) (f d) = f (nth n l d).
Proof. Admitted.

Lemma map_app : forall l l',
    map (l++l') = (map l)++(map l').
Proof. Admitted.

Hint Rewrite
  rev_involutive
  rev_unit
  map_nth
  map_length
  seq_length
  app_length
  rev_length
  app_nil_r
  : list.
*)


Require Import List.
Require Import PeanoNat.
Import PeanoNat.Nat.

Open Scope list_scope.

Print filter.
Print map.

Ltac dismiss := eexists; reflexivity.  (* used to finish a goal {y | y = ...} in the obvious way *)

Section MapFilter.

  Variables A B : Set.

  Lemma mapfilt (f: A -> B) (p : A -> bool) l : {ll | ll = map f (filter p l)}.
  Proof.
    generalize l.
    fix H0 1.
    case l0 as [|x xs]; simpl.
    - eexists; reflexivity.
    - edestruct H0 as [r R].
      case (p x); simpl.
      + rewrite <- R.
        eexists; reflexivity.
      + rewrite <- R.
        eexists; reflexivity.
  Defined.

End MapFilter.

Extraction mapfilt.

Print length.

Section FilterLength.

  Variable A : Set.

  Lemma count (p : A -> bool) l : {y | y = length (filter p l)}.
  Proof.
    generalize l.
    fix H0 1.
    case l0 as [|x xs]; simpl.
    - dismiss.
    - edestruct H0 as [r R].
      case (p x); simpl.
      + rewrite <- R.
        dismiss.
      + rewrite <- R.
        dismiss.
  Defined.

  Lemma lt_S_S : forall n m, S n < S m <-> n < m.
  Proof.
    split.
    apply Lt.lt_S_n. apply Lt.lt_n_S.
  Qed.

  Lemma reflect_rewrite P p Q q : (P <-> Q) -> Bool.reflect P p -> Bool.reflect Q q -> p = q.
  Proof.
    intros. case H0; case H1; try reflexivity.
    - intros; absurd Q; try assumption; apply H; assumption.
    - intros; absurd P; try assumption; apply H; assumption.
  Qed.

  Lemma ltb_S_S : forall n m, (S n <? S m) = (n <? m).
  Proof.
    intros.
    eapply reflect_rewrite.
    eapply lt_S_S.
    apply ltb_spec0.
    apply ltb_spec0.
  Qed.

  Lemma less_than (p : A -> bool) n l :
    {y | y = (length (filter p l) <? n)}.
  Proof.
    generalize l n.
    fix H0 1.
    case l0 as [|x xs]; simpl.
    - dismiss.
    -
      case (p x); simpl.
      + intro; case n0.
        * compute. dismiss.
        * intros; rewrite ltb_S_S.
          ecase H0 as [r R].
          rewrite <- R. dismiss.
      + intros; ecase H0 as [r R].
        rewrite <- R. dismiss.
  Defined.

End FilterLength.

Extraction count.
Extraction less_than.