Require Export DevCoq.Dev.basic_matroid_list.

Parameter rk_singleton_ge : forall P, rk (P :: nil)  >= 1.
Parameter rk_couple_ge : forall P Q, ~ P = Q -> rk(P :: Q :: nil) >= 2.
Parameter rk_three_points_on_lines : forall A B, exists C, rk (A :: B :: C :: nil) = 2 /\ rk (B :: C :: nil) = 2 /\ rk (A :: C :: nil) = 2.
Parameter rk_inter : forall A B C D, exists J, rk (A :: B :: J :: nil) = 2 /\ rk (C :: D :: J :: nil) = 2.
Parameter rk_lower_dim : exists P0 P1 P2, rk( P0 :: P1 :: P2 :: nil) >=3.

Lemma rk_singleton_1 : forall A, rk(A :: nil) <= 1.
Proof.
intros.
apply matroid1_b_useful.
intuition.
Qed.

Lemma rk_singleton : forall A, rk(A :: nil) = 1.
Proof.
intros.
assert(H := rk_singleton_ge A).
assert(HH := rk_singleton_1 A).
omega.
Qed.

Lemma rk_couple_2 : forall A B, rk(A :: B :: nil) <= 2.
Proof.
intros.
apply matroid1_b_useful.
intuition.
Qed.

Lemma rk_couple : forall A B : Point,~ A = B -> rk(A :: B :: nil) = 2.
Proof.
intros.
assert(HH := rk_couple_2 A B).
assert(HH0 := rk_couple_ge A B H).
omega.
Qed.

Lemma rk_triple_3 : forall A B C : Point, rk (A :: B :: C :: nil) <= 3.
Proof.
intros.
apply matroid1_b_useful.
intuition.
Qed.

Lemma couple_rk1 : forall A B, rk(A :: B :: nil) = 2 -> ~ A = B.
Proof.
intros.
intro.
rewrite H0 in H.
assert(HH : equivlist (B :: B :: nil) (B :: nil));[my_inO|].
rewrite HH in H.
assert(HH0 := rk_singleton_1 B).
omega.
Qed.

Lemma couple_rk2 : forall A B, rk(A :: B :: nil) = 1 -> A = B.
Proof.
intros.
case_eq(eq_dec A B).
intros.
assumption.
intros.
assert(HH := rk_couple A B n).
omega.
Qed.

Lemma rk_quadruple_inter_aux : forall A B C D E,
~ A = C ->
~ A = D ->
~ B = C ->
~ B = D ->
rk(A :: B :: E :: nil) = 2 ->
rk(C :: D :: E :: nil) = 2 ->
rk(A :: B :: C :: D :: nil) = 2 \/ rk(A :: B :: C :: D :: nil) = 3.
Proof.
intros.

assert (HH0 : rk((A :: B :: E :: nil) ++ (C :: D :: E :: nil)) + rk(list_inter (A :: B :: E :: nil) (C :: D :: E :: nil)) <=
       rk(A :: B :: E :: nil) + rk(C :: D :: E :: nil)).
apply matroid3_useful;my_inO.
assert(HH1 : equivlist (list_inter (A :: B :: E :: nil) (C :: D :: E :: nil))  (E :: nil)).
my_inO.
assert(HH2 := rk_singleton E).
rewrite HH1 in HH0.
rewrite HH2 in HH0.
rewrite H3 in HH0.
rewrite H4 in HH0.

assert(HH3 : rk(A :: B :: E :: C :: D :: E :: nil) = 2 \/ rk(A :: B :: E :: C :: D :: E :: nil) = 3).
apply le_lt_or_eq in HH0;simpl in HH0.
destruct HH0.
assert(HH4 : rk(A :: B :: E :: C :: D :: E :: nil) < 3).
solve[intuition].
assert(HH5 : incl (A :: B :: E :: nil) (A :: B :: E :: C :: D :: E :: nil));[my_inO|].
assert(HH6 := matroid2 (A :: B :: E :: nil) (A :: B :: E :: C :: D :: E :: nil) HH5).
omega.
omega.

destruct HH3.

assert(HH3 := rk_couple A C H).
assert(HH4 : incl (A :: C :: nil) (A :: B :: C :: D :: nil));[my_inO|].
assert(HH5 : incl (A :: B :: C :: D :: nil) (A :: B :: E :: C :: D :: E :: nil));[my_inO|].
assert(HH6 := matroid2 (A :: C :: nil) (A :: B :: C :: D :: nil) HH4).
assert(HH7 := matroid2 (A :: B :: C :: D :: nil) (A :: B :: E :: C :: D :: E :: nil) HH5).
omega.

assert(HH3 : incl (A :: B :: C :: D :: nil) (A :: B :: E :: C :: D :: E :: nil));[my_inO|].
assert(HH4 := matroid2 (A :: B :: C :: D :: nil) (A :: B :: E :: C :: D :: E :: nil) HH3).
rewrite H5 in HH4.
apply le_lt_or_eq in HH4.
destruct HH4.
assert(HH5 := rk_couple A C H).
assert(HH6 : incl (A :: C :: nil) (A :: B :: C :: D :: nil));[my_inO|].
assert(HH7 := matroid2 (A :: C :: nil) (A :: B :: C :: D :: nil) HH6).
omega.
omega.
Qed.

Lemma rk_quadruple_inter_aux2 : forall B C D E,
~ B = C ->
~ B = D ->
rk(D :: B :: E :: nil) = 2 ->
rk(C :: D :: E :: nil) = 2 ->
rk(D :: B :: C :: D :: nil) = 2 \/ rk(D :: B :: C :: D :: nil) = 3.
Proof.
intros.

assert (HH0 : rk((D :: B :: E :: nil) ++ (C :: D :: E :: nil)) + rk(list_inter (D :: B :: E :: nil) (C :: D :: E :: nil)) <=
       rk(D :: B :: E :: nil) + rk(C :: D :: E :: nil)).
apply matroid3_useful;my_inO.
assert (HH1 : equivlist (list_inter (D :: B :: E :: nil) (C :: D :: E :: nil)) (D :: E :: nil));[my_inO|].
rewrite HH1 in HH0.
case_eq(eq_dec D E).
intros;subst.
rewrite H1 in HH0;rewrite H2 in HH0.
assert(HH2 : equivlist (E :: E :: nil) (E :: nil));[my_inO|].
replace (rk (E :: E :: nil)) with (rk(E :: nil)) in HH0.
2:rewrite HH2;intuition.
assert(HH3 := rk_singleton E).
rewrite HH3 in HH0.

assert(HH4 : rk(E :: B :: E :: C :: E :: E :: nil) = 2 \/ rk((E :: B :: E :: C :: E :: E :: nil)) = 3).
apply le_lt_or_eq in HH0;simpl in HH0.
destruct HH0.
assert(HH5 : rk((E :: B :: E :: C :: E :: E :: nil)) < 3).
solve[intuition].
assert(HH4 : incl (E :: B :: E :: nil) (E :: B :: E :: C :: E :: E :: nil));[my_inO|].
assert(HH6 := matroid2 (E :: B :: E :: nil) (E :: B :: E :: C :: E :: E :: nil) HH4).
omega.
omega.

assert(HH5 : equivlist (E :: B :: E :: C :: E :: E :: nil) (E :: B :: C :: E :: nil));[my_inO|].
rewrite HH5 in HH4.
omega.

intros.
rewrite H1 in HH0;rewrite H2 in HH0.
assert(HH2 := rk_couple D E n).
rewrite HH2 in HH0.
assert(HH3 : rk((D :: B :: E :: nil) ++ (C :: D :: E :: nil)) = 2).
assert(HH4 : incl (D :: E :: nil) ((D :: B :: E :: nil) ++ (C :: D :: E :: nil))).
my_inO.

assert(HH5 := matroid2 (D :: E :: nil) ((D :: B :: E :: nil) ++ (C :: D :: E :: nil)) HH4).
omega.
assert(HH4 := rk_couple B C H).
assert(HH5 : incl (B :: C :: nil) (D :: B :: C :: D :: nil));[my_inO|].
assert(HH6 := matroid2 (B :: C :: nil) (D :: B :: C :: D :: nil) HH5).
assert(HH7 : incl (D :: B :: C :: D :: nil) ((D :: B :: E :: nil) ++ (C :: D :: E :: nil)));[my_inO|].
assert(HH8 := matroid2 (D :: B :: C :: D :: nil) ((D :: B :: E :: nil) ++ (C :: D :: E :: nil)) HH7).
omega.
Qed.

Lemma rk_quadruple_inter : forall A B C D E,
rk(A :: B :: E :: nil) = 2 ->
rk(C :: D :: E :: nil) = 2 ->
rk(A :: B :: C :: D :: nil) = 1 \/ rk(A :: B :: C :: D :: nil) = 2 \/ rk(A :: B :: C :: D :: nil) = 3.
Proof.
intros.
case_eq(eq_dec A C);
case_eq(eq_dec A D);
case_eq(eq_dec B C);
case_eq(eq_dec B D).

intros.
rewrite e;rewrite e1.
case_eq(eq_dec C D).
intros;rewrite e3.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n);assert(HH : equivlist (D :: D :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e;rewrite e1.
case_eq(eq_dec C D).
intros;rewrite e2.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n0);assert(HH : equivlist (C :: C :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e;rewrite e1.
case_eq(eq_dec C D).
intros;rewrite e2.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n0);assert(HH : equivlist (C :: D :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e in *.
assert(HH0 := rk_quadruple_inter_aux2 B C D E n0 n H H0).
omega.

intros.
rewrite e0;rewrite e1.
case_eq(eq_dec C D).
intros;rewrite e2.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n0);assert(HH : equivlist (C :: C :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e;rewrite e0.
case_eq(eq_dec C D).
intros;rewrite e1.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n1);assert(HH : equivlist (C :: C :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e;rewrite e0.
case_eq(eq_dec C D).
intros;rewrite e1.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n1);assert(HH : equivlist (C :: D :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e in *.
assert(HH0 : equivlist (C :: D :: E :: nil) (D :: C :: E :: nil));[my_inO|].
rewrite HH0 in H0.
assert(HH1 := rk_quadruple_inter_aux2 B D C E n n0 H H0).
assert(HH2 : equivlist (C :: B :: C :: D :: nil) (C :: B :: D :: C :: nil));[my_inO|].
rewrite HH2.
omega.

intros.
rewrite e;rewrite e1.
case_eq(eq_dec C D).
intros;rewrite e2.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n0);assert(HH : equivlist (D :: D :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e;rewrite e0.
case_eq(eq_dec C D).
intros;rewrite e1.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n1);assert(HH : equivlist (D :: C :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e;rewrite e0.
case_eq(eq_dec C D).
intros;rewrite e1.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n1);assert(HH : equivlist (D :: D :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e in *.
assert(HH0 := rk_quadruple_inter_aux2 B C D E n0 n H H0).
omega.

intros.
rewrite e in  *.
assert(HH0 : equivlist (A :: D :: E :: nil) (D :: A :: E :: nil));[my_inO|].
rewrite HH0 in H.
assert(HH1 := rk_quadruple_inter_aux2 A C D E n0 n H H0).
assert(HH2 : equivlist (D :: A :: C :: D :: nil) (A :: D :: C :: D :: nil));[my_inO|].
rewrite HH2 in HH1.
omega.

intros.
rewrite e in  *.
assert(HH0 : equivlist (A :: C :: E :: nil) (C :: A :: E :: nil));[my_inO|].
rewrite HH0 in H.
assert(HH1 : equivlist (C :: D :: E :: nil) (D :: C :: E :: nil));[my_inO|].
rewrite HH1 in H0.
assert(HH2 := rk_quadruple_inter_aux2 A D C E n0 n1 H H0).
assert(HH3 : equivlist (C :: A :: D :: C :: nil) (A :: C :: C :: D :: nil));[my_inO|].
rewrite HH3 in HH2.
omega.

intros.
rewrite e in *.
assert(HH0 : equivlist (A :: D :: E :: nil) (D :: A :: E :: nil));[my_inO|].
rewrite HH0 in H.
assert(HH1 := rk_quadruple_inter_aux2 A C D E n1 n0 H H0).
assert(HH2 : equivlist (A :: D :: C :: D :: nil) (D :: A :: C :: D :: nil));[my_inO|].
rewrite HH2.
omega.

intros.
assert(HH0 := rk_quadruple_inter_aux A B C D E n2 n1 n0 n H H0).
omega.
Qed.

Lemma rk_quadruple_max_3 : forall X Y Z W: Point,rk(X :: Y :: Z :: W :: nil) <= 3.
intros.
assert(HH0 := rk_inter X Y Z W).
destruct HH0.
destruct H.
assert(HH1 := rk_quadruple_inter X Y Z W x H H0).
omega.
Qed.

Lemma rk_quintuple_inter_aux : forall A B C D E,
~ A = C ->
~ A = D ->
~ B = C ->
~ B = D ->
rk(A :: B :: E :: nil) = 2 ->
rk(C :: D :: E :: nil) = 2 ->
rk(A :: B :: C :: D :: E :: nil) = 2 \/ rk(A :: B :: C :: D :: E :: nil) = 3.
Proof.
intros.

assert (HH0 : rk((A :: B :: E :: nil) ++ (C :: D :: E :: nil)) + rk(list_inter (A :: B :: E :: nil) (C :: D :: E :: nil)) <=
       rk(A :: B :: E :: nil) + rk(C :: D :: E :: nil)).
apply matroid3_useful;my_inO.
assert(HH1 : equivlist (list_inter (A :: B :: E :: nil) (C :: D :: E :: nil))  (E :: nil)).
my_inO.
assert(HH2 := rk_singleton E).
rewrite HH1 in HH0.
rewrite HH2 in HH0.
rewrite H3 in HH0.
rewrite H4 in HH0.

assert(HH3 : rk(A :: B :: E :: C :: D :: E :: nil) = 2 \/ rk(A :: B :: E :: C :: D :: E :: nil) = 3).
apply le_lt_or_eq in HH0;simpl in HH0.
destruct HH0.
assert(HH4 : rk(A :: B :: E :: C :: D :: E :: nil) < 3).
solve[intuition].
assert(HH5 : incl (A :: B :: E :: nil) (A :: B :: E :: C :: D :: E :: nil));[my_inO|].
assert(HH6 := matroid2 (A :: B :: E :: nil) (A :: B :: E :: C :: D :: E :: nil) HH5).
omega.
omega.

destruct HH3.

assert(HH3 := rk_couple A C H).
assert(HH4 : incl (A :: C :: nil) (A :: B :: C :: D :: E :: nil));[my_inO|].
assert(HH5 : incl (A :: B :: C :: D :: E :: nil) (A :: B :: E :: C :: D :: E :: nil));[my_inO|].
assert(HH6 := matroid2 (A :: C :: nil) (A :: B :: C :: D :: E :: nil) HH4).
assert(HH7 := matroid2 (A :: B :: C :: D :: E :: nil) (A :: B :: E :: C :: D :: E :: nil) HH5).
omega.

assert(HH3 : incl (A :: B :: C :: D :: E :: nil) (A :: B :: E :: C :: D :: E :: nil));[my_inO|].
assert(HH4 := matroid2 (A :: B :: C :: D :: E :: nil) (A :: B :: E :: C :: D :: E :: nil) HH3).
rewrite H5 in HH4.
apply le_lt_or_eq in HH4.
destruct HH4.
assert(HH5 := rk_couple A C H).
assert(HH6 : incl (A :: C :: nil) (A :: B :: C :: D :: E :: nil));[my_inO|].
assert(HH7 := matroid2 (A :: C :: nil) (A :: B :: C :: D :: E :: nil) HH6).
omega.
omega.
Qed.

Lemma rk_quintuple_inter_aux2 : forall B C D E,
~ B = C ->
~ B = D ->
rk(D :: B :: E :: nil) = 2 ->
rk(C :: D :: E :: nil) = 2 ->
rk(D :: B :: C :: D :: E :: nil) = 2 \/ rk(D :: B :: C :: D :: E :: nil) = 3.
Proof.
intros.

assert (HH0 : rk((D :: B :: E :: nil) ++ (C :: D :: E :: nil)) + rk(list_inter (D :: B :: E :: nil) (C :: D :: E :: nil)) <=
       rk(D :: B :: E :: nil) + rk(C :: D :: E :: nil)).
apply matroid3_useful;my_inO.
assert (HH1 : equivlist (list_inter (D :: B :: E :: nil) (C :: D :: E :: nil)) (D :: E :: nil));[my_inO|].
rewrite HH1 in HH0.
case_eq(eq_dec D E).
intros;subst.
rewrite H1 in HH0;rewrite H2 in HH0.
assert(HH2 : equivlist (E :: E :: nil) (E :: nil));[my_inO|].
replace (rk (E :: E :: nil)) with (rk(E :: nil)) in HH0.
2:rewrite HH2;intuition.
assert(HH3 := rk_singleton E).
rewrite HH3 in HH0.

assert(HH4 : rk(E :: B :: E :: C :: E :: E :: nil) = 2 \/ rk((E :: B :: E :: C :: E :: E :: nil)) = 3).
apply le_lt_or_eq in HH0;simpl in HH0.
destruct HH0.
assert(HH5 : rk((E :: B :: E :: C :: E :: E :: nil)) < 3).
solve[intuition].
assert(HH4 : incl (E :: B :: E :: nil) (E :: B :: E :: C :: E :: E :: nil));[my_inO|].
assert(HH6 := matroid2 (E :: B :: E :: nil) (E :: B :: E :: C :: E :: E :: nil) HH4).
omega.
omega.

assert(HH5 : equivlist (E :: B :: E :: C :: E :: E :: nil) (E :: B :: C :: E :: E :: nil));[my_inO|].
rewrite HH5 in HH4.
omega.

intros.
rewrite H1 in HH0;rewrite H2 in HH0.
assert(HH2 := rk_couple D E n).
rewrite HH2 in HH0.
assert(HH3 : rk((D :: B :: E :: nil) ++ (C :: D :: E :: nil)) = 2).
assert(HH4 : incl (D :: E :: nil) ((D :: B :: E :: nil) ++ (C :: D :: E :: nil)));[my_inO|].
assert(HH5 := matroid2 (D :: E :: nil) ((D :: B :: E :: nil) ++ (C :: D :: E :: nil)) HH4).
omega.
assert(HH4 := rk_couple B C H).
assert(HH5 : incl (B :: C :: nil) (D :: B :: C :: D :: E :: nil));[my_inO|].
assert(HH6 := matroid2 (B :: C :: nil) (D :: B :: C :: D :: E :: nil) HH5).
assert(HH7 : incl (D :: B :: C :: D :: E :: nil) ((D :: B :: E :: nil) ++ (C :: D :: E :: nil)));[my_inO|].
assert(HH8 := matroid2 (D :: B :: C :: D :: E :: nil) ((D :: B :: E :: nil) ++ (C :: D :: E :: nil)) HH7).
omega.
Qed.

Lemma rk_quintuple_inter : forall A B C D E,
rk(A :: B :: E :: nil) = 2 ->
rk(C :: D :: E :: nil) = 2 ->
rk(A :: B :: C :: D :: E :: nil) = 1 \/ rk(A :: B :: C :: D :: E :: nil) = 2 \/ rk(A :: B :: C :: D :: E :: nil) = 3.
Proof.
intros.
case_eq(eq_dec A C);
case_eq(eq_dec A D);
case_eq(eq_dec B C);
case_eq(eq_dec B D).

intros;rewrite <-e2;rewrite e;rewrite e1.
case_eq(eq_dec D E).
intros;rewrite e3.
assert(HH0 : equivlist (E :: E :: E :: E :: E :: nil) (E :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton E);omega.
intros.
assert(HH0 := rk_couple D E n);assert(HH : equivlist (D :: D :: D :: D :: E :: nil) (D :: E :: nil));[my_inO|].
rewrite HH;omega.

intros;apply False_ind;apply n;rewrite e;rewrite <-e0;rewrite e1;reflexivity.

intros;apply False_ind;apply n;rewrite e;rewrite <-e0;rewrite e1;reflexivity.

intros;rewrite e in *.
assert(HH := rk_quintuple_inter_aux2 B C D E n0 n H H0);intuition.

intros;apply False_ind;apply n;rewrite <-e;rewrite e0;rewrite <-e1;reflexivity.

intros;rewrite e;rewrite e0.
assert(HH0 : equivlist (C :: C :: C :: D :: E :: nil) (C :: D :: E :: nil));[my_inO|].
rewrite HH0;right;left;assumption.

intros;rewrite e;rewrite e0.
assert(HH0 : equivlist (C :: D :: C :: D :: E :: nil) (C :: D :: E :: nil));[my_inO|].
rewrite HH0;right;left;assumption.

intros;rewrite e in *.
assert(HH : equivlist (C :: D :: E :: nil) (D :: C :: E :: nil));[my_inO|];rewrite HH in H0.
assert(HH0 := rk_quintuple_inter_aux2 B D C E n n0 H H0).
assert(HH1 : equivlist (C :: B :: D :: C :: E :: nil) (C :: B :: C :: D :: E :: nil));[my_inO|].
rewrite HH1 in HH0;intuition.

intros;apply False_ind;apply n;rewrite <-e0;rewrite e;rewrite e1;reflexivity.

intros;rewrite e;rewrite e0.
assert(HH0 : equivlist (D :: C :: C :: D :: E :: nil) (C :: D :: E :: nil));[my_inO|].
rewrite HH0;right;left;assumption.

intros;rewrite e;rewrite e0.
assert(HH0 : equivlist (D :: D :: C :: D :: E :: nil) (C :: D :: E :: nil));[my_inO|].
rewrite HH0;right;left;assumption.

intros;rewrite e in *.
assert(HH0 := rk_quintuple_inter_aux2 B C D E n0 n H H0);intuition.

intros;rewrite e in *.
assert(HH : equivlist (A :: D :: E :: nil) (D :: A :: E :: nil));[my_inO|];rewrite HH in H.
assert(HH0 := rk_quintuple_inter_aux2 A C D E n0 n H H0).
assert(HH1 : equivlist (D :: A :: C :: D :: E :: nil) (A :: D :: C :: D :: E :: nil));[my_inO|].
rewrite HH1 in HH0;intuition.

intros;rewrite e in *.
assert(HH : equivlist (A :: C :: E :: nil) (C :: A :: E :: nil));[my_inO|];rewrite HH in H.
assert(HH0 : equivlist (C :: D :: E :: nil) (D :: C :: E :: nil));[my_inO|];rewrite HH0 in H0.
assert(HH1 := rk_quintuple_inter_aux2 A D C E n0 n1 H H0).
assert(HH2 : equivlist (C :: A :: D :: C :: E :: nil) (A :: C :: C :: D :: E :: nil));[my_inO|].
rewrite HH2 in HH1;intuition.

intros;rewrite e in *.
assert(HH : equivlist (A :: D :: E :: nil) (D :: A :: E :: nil));[my_inO|];rewrite HH in H.
assert(HH0 := rk_quintuple_inter_aux2 A C D E n1 n0 H H0).
assert(HH1 : equivlist (D :: A :: C :: D :: E :: nil) (A :: D :: C :: D :: E :: nil));[my_inO|].
rewrite HH1 in HH0;intuition.

intros.
assert(HH := rk_quintuple_inter_aux A B C D E n2 n1 n0 n H H0);intuition.
Qed.

Lemma rk_quintuple_max_3 : forall X Y Z W V: Point, rk(X :: Y :: Z :: W :: V :: nil) <= 3.
Proof.
intros.

assert(HH := rk_lower_dim).
destruct HH;destruct H;destruct H.
assert(HH := rk_triple_3 x x0 x1).
assert(HH0 : rk (x :: x0 :: x1 :: nil) = 3);[omega|].
assert(HH1 := rk_quadruple_max_3 x x0 x1 X).
assert(HH2 := rk_quadruple_max_3 x x0 x1 Y).
assert(HH3 := rk_quadruple_max_3 x x0 x1 Z).
assert(HH4 := rk_quadruple_max_3 x x0 x1 W).
assert(HH5 := rk_quadruple_max_3 x x0 x1 V).
assert(HH6 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: nil));[my_inO|].
assert(HH7 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: Y :: nil));[my_inO|].
assert(HH8 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: Z :: nil));[my_inO|].
assert(HH9 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: W :: nil));[my_inO|].
assert(HH10 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: V :: nil));[my_inO|].
assert(HH11 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: nil) HH6).
assert(HH12 : rk (x :: x0 :: x1 :: X :: nil) = 3);[omega|].
assert(HH13 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: Y :: nil) HH7).
assert(HH14 : rk (x :: x0 :: x1 :: Y :: nil) = 3);[omega|].
assert(HH15 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: Z :: nil) HH8).
assert(HH16 : rk (x :: x0 :: x1 :: Z :: nil) = 3);[omega|].
assert(HH17 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: W :: nil) HH9).
assert(HH18 : rk (x :: x0 :: x1 :: W :: nil) = 3);[omega|].
assert(HH19 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: V :: nil) HH10).
assert(HH20 : rk (x :: x0 :: x1 :: V :: nil) = 3);[omega|].
clear H HH HH1 HH2 HH3 HH4 HH5 HH6 HH7 HH8 HH9 HH10 HH11 HH13 HH15 HH17 HH19.

case_eq(eq_dec X Y);intros.
rewrite e;assert(HH21 : equivlist (Y :: Y :: Z :: W :: V :: nil) (Y :: Z :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 Y Z W V);assumption.
case_eq(eq_dec X Z);intros.
rewrite e;assert(HH21 : equivlist (Z :: Y :: Z :: W :: V :: nil) (Y :: Z :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 Y Z W V);assumption.
case_eq(eq_dec X W);intros.
rewrite e;assert(HH21 : equivlist (W :: Y :: Z :: W :: V :: nil) (Y :: Z :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 Y Z W V);assumption.
case_eq(eq_dec X V);intros.
rewrite e;assert(HH21 : equivlist (V :: Y :: Z :: W :: V :: nil) (Y :: Z :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 Y Z W V);assumption.
case_eq(eq_dec Y Z);intros.
rewrite e;assert(HH21 : equivlist (X :: Z :: Z :: W :: V :: nil) (X :: Z :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 X Z W V);assumption.
case_eq(eq_dec Y W);intros.
rewrite e;assert(HH21 : equivlist (X :: W :: Z :: W :: V :: nil) (X :: Z :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 X Z W V);assumption.
case_eq(eq_dec Y V);intros.
rewrite e;assert(HH21 : equivlist (X :: V :: Z :: W :: V :: nil) (X :: Z :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 X Z W V);assumption.
case_eq(eq_dec Z W);intros.
rewrite e;assert(HH21 : equivlist (X :: Y :: W :: W :: V :: nil) (X :: Y :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 X Y W V);assumption.
case_eq(eq_dec Z V);intros.
rewrite e;assert(HH21 : equivlist (X :: Y :: V :: W :: V :: nil) (X :: Y :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 X Y W V);assumption.
case_eq(eq_dec W V);intros.
rewrite e;assert(HH21 : equivlist (X :: Y :: Z :: V :: V :: nil) (X :: Y :: Z :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 X Y Z V);assumption.
clear H H0 H1 H2 H3 H4 H5 H6 H7 H8.

assert (HH23 : rk((x :: x0 :: x1 :: X :: nil) ++ (x :: x0 :: x1 :: Y :: nil)) + rk(list_inter (x :: x0 :: x1 :: X :: nil) (x :: x0 :: x1 :: Y :: nil)) <=
       rk(x :: x0 :: x1 :: X :: nil) + rk(x :: x0 :: x1 :: Y :: nil)).
apply matroid3_useful;my_inO.
assert(HH24 : equivlist (list_inter (x :: x0 :: x1 :: X :: nil) (x :: x0 :: x1 :: Y :: nil))  (x :: x0 :: x1 :: nil));[my_inO|].
rewrite HH24 in HH23;clear HH24.
assert(HH25 : equivlist ((x :: x0 :: x1 :: X :: nil) ++ x :: x0 :: x1 :: Y :: nil) (x :: x0 :: x1 :: X :: Y :: nil));[my_inO|].
rewrite HH25 in HH23;clear HH25.
assert(HH26 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: Y :: nil));[my_inO|].
assert(HH27 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: Y :: nil) HH26).
assert(HH28 : rk(x :: x0 :: x1 :: X :: Y :: nil) = 3);[omega|].
clear HH12 HH14 HH23 HH26 HH27.

assert (HH29 : rk((x :: x0 :: x1 :: X :: Y :: nil) ++ (x :: x0 :: x1 :: Z :: nil)) + rk(list_inter (x :: x0 :: x1 :: X :: Y :: nil) (x :: x0 :: x1 :: Z :: nil)) <=
       rk(x :: x0 :: x1 :: X :: Y :: nil) + rk(x :: x0 :: x1 :: Z :: nil)).
apply matroid3_useful;my_inO.
assert(HH30 : equivlist (list_inter (x :: x0 :: x1 :: X :: Y :: nil) (x :: x0 :: x1 :: Z :: nil))  (x :: x0 :: x1 :: nil));[my_inO|].
rewrite HH30 in HH29;clear HH30.
assert(HH31 : equivlist ((x :: x0 :: x1 :: X :: Y :: nil) ++ x :: x0 :: x1 :: Z :: nil) (x :: x0 :: x1 :: X :: Y :: Z :: nil));[my_inO|].
rewrite HH31 in HH29;clear HH31.
assert(HH32 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: Y :: Z :: nil));[my_inO|].
assert(HH33 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: Y ::  Z :: nil) HH32).
assert(HH34 : rk(x :: x0 :: x1 :: X :: Y :: Z :: nil) = 3);[omega|].
clear HH16 HH28 HH29 HH32 HH33.

assert (HH35 : rk((x :: x0 :: x1 :: X :: Y :: Z :: nil) ++ (x :: x0 :: x1 :: W :: nil)) + rk(list_inter (x :: x0 :: x1 :: X :: Y :: Z :: nil) (x :: x0 :: x1 :: W :: nil)) <=
       rk(x :: x0 :: x1 :: X :: Y :: Z :: nil) + rk(x :: x0 :: x1 :: W :: nil)).
apply matroid3_useful;my_inO.
assert(HH36 : equivlist (list_inter (x :: x0 :: x1 :: X :: Y :: Z :: nil) (x :: x0 :: x1 :: W :: nil))  (x :: x0 :: x1 :: nil));[my_inO|].
rewrite HH36 in HH35;clear HH36.
assert(HH37 : equivlist ((x :: x0 :: x1 :: X :: Y :: Z :: nil) ++ x :: x0 :: x1 :: W :: nil) (x :: x0 :: x1 :: X :: Y :: Z :: W :: nil));[my_inO;left;my_inO|].
rewrite HH37 in HH35;clear HH37.
assert(HH38 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: Y :: Z :: W :: nil));[my_inO|].
assert(HH39 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: Y ::  Z :: W :: nil) HH38).
assert(HH40 : rk(x :: x0 :: x1 :: X :: Y :: Z :: W ::nil) = 3);[omega|].
clear HH18 HH34 HH35 HH38 HH39.

assert (HH41 : rk((x :: x0 :: x1 :: X :: Y :: Z :: W :: nil) ++ (x :: x0 :: x1 :: V :: nil)) + rk(list_inter (x :: x0 :: x1 :: X :: Y :: Z :: W ::nil) (x :: x0 :: x1 :: V :: nil)) <=
       rk(x :: x0 :: x1 :: X :: Y :: Z :: W :: nil) + rk(x :: x0 :: x1 :: V :: nil)).
apply matroid3_useful;my_inO.
assert(HH42 : equivlist (list_inter (x :: x0 :: x1 :: X :: Y :: Z :: W :: nil) (x :: x0 :: x1 :: V :: nil))  (x :: x0 :: x1 :: nil));[my_inO|].
rewrite HH42 in HH41;clear HH42.
assert(HH43 : equivlist ((x :: x0 :: x1 :: X :: Y :: Z :: W :: nil) ++ x :: x0 :: x1 :: V :: nil) (x :: x0 :: x1 :: X :: Y :: Z :: W :: V :: nil));[my_inO;left;my_inO|].
rewrite HH43 in HH41;clear HH43.
assert(HH44 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: Y :: Z :: W :: V :: nil));[my_inO|].
assert(HH45 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: Y ::  Z :: W :: V :: nil) HH44).
assert(HH46 : rk(x :: x0 :: x1 :: X :: Y :: Z :: W ::V :: nil) = 3);[omega|].
clear HH20 HH40 HH41 HH44 HH45.
assert(HH47 : incl (X :: Y :: Z :: W :: V :: nil)(x :: x0 :: x1 :: X :: Y :: Z :: W :: V :: nil));[my_inO|].
assert(HH48 := matroid2 (X :: Y :: Z :: W :: V :: nil)(x :: x0 :: x1 :: X :: Y :: Z :: W :: V :: nil) HH47).
omega.
Qed.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List Arith Nat Lia Max Wellfounded Coq.Setoids.Setoid.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list finite.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.TRAKHTENBROT
  Require Import notations fol_ops fo_sig fo_terms fo_logic.

Import fol_notations.

Set Default Proof Using "Type".

Set Implicit Arguments.

Local Notation ø := vec_nil.
Local Infix "∊" := In (at level 70, no associativity).
Local Infix "⊑" := incl (at level 70, no associativity).

(* * The first order theory of membership *)

Section membership.

  (* We develop a theory of finitary and computable and
      extensional membership. We build pair, ordered pairs
      and ordered triples and show their properties *)

  Variable (X : Type) (mem : X -> X -> Prop).

  Infix "∈" := mem.
  Notation "x ∉ y" := (~ x ∈ y).

  Definition mb_incl x y := forall a, a ∈ x -> a ∈ y.
  Definition mb_equiv x y := forall a, a ∈ x <-> a ∈ y.

  Infix "⊆" := mb_incl.
  Infix "≈" := mb_equiv.
  Notation "x ≉ y" := (~ x ≈ y).

  Definition mb_transitive t := forall x y, x ∈ y -> y ∈ t -> x ∈ t.

  Fact mb_incl_refl x : x ⊆ x.
  Proof. red; auto. Qed.

  Fact mb_incl_trans x y z : x ⊆ y -> y ⊆ z -> x ⊆ z.
  Proof. unfold mb_incl; auto. Qed.

  Fact mb_equiv_eq x y : x ≈ y <-> x ⊆ y /\ y ⊆ x.
  Proof. firstorder. Qed.

  Fact mb_equiv_refl_True x : x ≈ x <-> True.    Proof. unfold mb_equiv; tauto. Qed.
  Fact mb_equiv_refl x : x ≈ x.                  Proof. unfold mb_equiv; tauto. Qed.

  Fact mb_equiv_sym x y : x ≈ y -> y ≈ x.
  Proof. do 2 rewrite mb_equiv_eq; tauto. Qed.

  Fact mb_equiv_trans x y z : x ≈ y -> y ≈ z -> x ≈ z.
  Proof. repeat rewrite mb_equiv_eq; unfold mb_incl; intros [] []; split; auto. Qed.

  Add Parametric Relation: (X) (mb_equiv)
      reflexivity proved by mb_equiv_refl
      symmetry proved by mb_equiv_sym
      transitivity proved by mb_equiv_trans
    as mb_equiv_equivalence.

  Hint Resolve mb_equiv_refl mb_equiv_sym : core.

  (* The only FOL axiom: sets are characterized by their elements *)

  Definition mb_member_ext := forall x y z, x ≈ y -> x ∈ z -> y ∈ z.

  Variable (mb_axiom_ext : mb_member_ext).

  Fact mb_equiv_mem x y : x ≈ y -> forall z, x ∈ z <-> y ∈ z.
  Proof using mb_axiom_ext. split; apply mb_axiom_ext; auto. Qed.

   Add Parametric Morphism: (mem) with signature
     (mb_equiv) ==> (mb_equiv) ==> (iff) as mb_mem_congruence.
  Proof using mb_axiom_ext.
    intros x y H1 a b H2; red in H1, H2; split;
     rewrite <- H2; apply mb_axiom_ext; auto.
  Qed.

  Add Parametric Morphism: (fun x y => x ⊆ y) with signature
     (mb_equiv) ==> (mb_equiv) ==> (iff) as mb_incl_congruence.
  Proof using mb_axiom_ext.
    intros x y H1 a b H2; split; intros H z.
    + rewrite <- H1, <- H2; auto.
    + rewrite H1, H2; auto.
  Qed.

  Reserved Notation "p ≋ ⦃ a , b ⦄" (at level 70, format "p  ≋  ⦃ a , b ⦄").
  Reserved Notation "p ≋ ⦅ a , b ⦆" (at level 70, format "p  ≋  ⦅ a , b ⦆").
  Reserved Notation "t ≋ ⦉ v ⦊" (at level 70, format "t  ≋  ⦉ v ⦊").

  Definition mb_is_pair p x y := forall a, a ∈ p <-> a ≈ x \/ a ≈ y.

  Notation "p ≋ ⦃ a , b ⦄" := (mb_is_pair p a b).

  Fact mb_is_pair_comm p x y : p ≋ ⦃x,y⦄ -> p ≋ ⦃y,x⦄.
  Proof. unfold mb_is_pair; fol equiv fa; intro; tauto. Qed.

  Add Parametric Morphism: (mb_is_pair) with signature
     (mb_equiv) ==> (mb_equiv) ==> (mb_equiv) ==> (iff) as mb_is_pair_congruence.
  Proof using mb_axiom_ext.
    intros p q H1 x x' H2 y y' H3.
    fol equiv fa; intro.
    rewrite H1, H2, H3; tauto.
  Qed.

  Fact mb_is_pair_fun p q x y : p ≋ ⦃x,y⦄ -> q ≋ ⦃x,y⦄ -> p ≈ q.
  Proof. intros H1 H2; red in H1, H2; intro; rewrite H1, H2; tauto. Qed.

  (* Many cases here, automation helps !! *)

  Fact mb_is_pair_inj p x y x' y' :
         p ≋ ⦃x,y⦄
      -> p ≋ ⦃x',y'⦄
      -> x ≈ x' /\ y ≈ y'
      \/ x ≈ y' /\ y ≈ x'.
  Proof.
    unfold mb_is_pair; intros H1 H2.
    generalize (proj1 (H2 x)) (proj1 (H2 y)); rewrite H1, H1, mb_equiv_refl_True, mb_equiv_refl_True.
    generalize (proj1 (H1 x')) (proj1 (H1 y')); rewrite H2, H2, mb_equiv_refl_True, mb_equiv_refl_True.
    intros [] [] [] []; auto.
  Qed.

  Fact mb_is_pair_inj' p x y : p ≋ ⦃x,x⦄ -> p ≋ ⦃y,y⦄ -> x ≈ y.
  Proof. intros H1 H2; generalize (mb_is_pair_inj H1 H2); tauto. Qed.

  (* Ordered pairs (x,y) := {{x},{x,y}}, Kuratowski encoding *)

  Definition mb_is_opair p x y := exists a b, a ≋ ⦃x,x⦄ /\ b ≋ ⦃x,y⦄ /\ p ≋ ⦃a,b⦄.

  Notation "p ≋ ⦅ a , b ⦆" := (mb_is_opair p a b).

  Add Parametric Morphism: (mb_is_opair) with signature
     (mb_equiv) ==> (mb_equiv) ==> (mb_equiv) ==> (iff) as mb_is_opair_congruence.
  Proof using mb_axiom_ext.
    intros p q H1 x x' H2 y y' H3.
    do 2 (fol equiv ex; intro).
    rewrite H1, H2, H3; tauto.
  Qed.

  Fact mb_is_opair_fun p q x y : p ≋ ⦅x,y⦆ -> q ≋ ⦅x,y⦆  -> p ≈ q.
  Proof using mb_axiom_ext.
    intros (a & b & H1 & H2 & H3) (u & v & G1 & G2 & G3).
    generalize (mb_is_pair_fun H1 G1) (mb_is_pair_fun H2 G2); intros E1 E2.
    rewrite E1, E2 in H3.
    revert H3 G3; apply mb_is_pair_fun.
  Qed.

  Fact mb_is_opair_inj p x y x' y' : p ≋ ⦅x,y⦆  -> p ≋ ⦅x',y'⦆ -> x ≈ x' /\ y ≈ y'.
  Proof using mb_axiom_ext.
    intros (a & b & H1 & H2 & H3) (u & v & G1 & G2 & G3).
    generalize (mb_is_pair_inj H3 G3); intros [ (E1 & E2) | (E1 & E2) ].
    + rewrite E1 in H1; rewrite E2 in H2.
      generalize (mb_is_pair_inj' H1 G1); intros E; split; auto.
      rewrite E in H2.
      generalize (mb_is_pair_inj H2 G2); intros [ | (E3 & E4) ]; try tauto.
      rewrite E4; auto.
    + rewrite E1 in H1; rewrite E2 in H2.
      generalize (mb_is_pair_inj H2 G1) (mb_is_pair_inj H1 G2).
      intros [ (E3 & E4) | (E3 & E4) ] [ (E5 & E6) | (E5 & E6) ];
        rewrite E4, <- E5; auto.
  Qed.

  (* n-tuples *)

  Fixpoint mb_is_tuple t n (v : vec X n) :=
    match v with
      | vec_nil => forall z, z ∉ t
      | x##v    => exists t', t ≋ ⦅x,t'⦆ /\ t' ≋ ⦉v⦊
    end
  where "t ≋ ⦉ v ⦊" := (mb_is_tuple t v).

  Fact mb_is_tuple_congr p q n (v : vec X n) : p ≈ q -> p ≋ ⦉v⦊ -> q ≋ ⦉v⦊ .
  Proof using mb_axiom_ext.
    revert p q; induction v as [ | n x v IHv ]; intros p q.
    + simpl; intros E H x; rewrite <- E; auto.
    + intros E (t & H1 & H2); exists t; split; auto.
      rewrite <- E; auto.
  Qed.

  Fact mb_is_tuple_fun p q n (v : vec _ n) : p ≋ ⦉v⦊  -> q ≋ ⦉v⦊  -> p ≈ q.
  Proof using mb_axiom_ext.
    revert p q; induction v as [ | n x v IHv ]; intros p q.
    + simpl; intros H1 H2.
      apply mb_equiv_eq; split.
      * intros z Hz; apply H1 in Hz; tauto.
      * intros z Hz; apply H2 in Hz; tauto.
    + intros (p' & H1 & H2) (q' & H3 & H4).
      generalize (IHv _ _ H2 H4); intros E.
      rewrite E in H1.
      revert H1 H3; apply mb_is_opair_fun.
  Qed.

  Fact mb_is_tuple_inj t n (v w : vec _ n) p :
         t ≋ ⦉v⦊  -> t ≋ ⦉w⦊  -> vec_pos v p ≈ vec_pos w p.
  Proof using mb_axiom_ext.
    intros H1 H2; revert t w H1 H2 p; induction v as [ | n x v IHv ]; intros t w.
    + intros _ _ p; invert pos p.
    + vec split w with y.
      intros (p & H1 & H2) (q & H3 & H4).
      destruct (mb_is_opair_inj H1 H3) as (E1 & E2).
      apply mb_is_tuple_congr with (1 := E2) in H2.
      specialize (IHv _ _ H2 H4).
      intros j; invert pos j; auto.
  Qed.

  (* mb_has_* from elements in l *)

  Definition mb_has_pairs (l : X) :=
     forall x y, x ∈ l -> y ∈ l -> exists p, p ≋ ⦃x,y⦄ .

  Definition mb_has_tuples (l : X) n :=
    forall v : vec _ n, (forall p, vec_pos v p ∈ l) -> exists t, t ≋ ⦉v⦊.

  Definition mb_is_tuple_in r n (v : vec _ n) :=
    exists t, t ≋ ⦉v⦊ /\ t ∈ r.

  Notation "t ∋ ⦉ v ⦊" := (mb_is_tuple_in t v) (at level 70, format "t  ∋  ⦉ v ⦊").

  Fact mb_is_tuple_in_congr x y n (v : vec _ n) : y ≈ x -> x ∋ ⦉v⦊ -> y ∋ ⦉v⦊ .
  Proof using mb_axiom_ext.
    intros E (t & H1 & H2); exists t; split; auto.
    rewrite  E; auto.
  Qed.

  (* mb total and functional *)

  Definition mb_is_tot n (l s : X) :=
    forall v, (forall p : pos n, vec_pos v p ∈ l)
            -> exists x p t, x ∈ l /\ p ∈ s /\ p ≋ ⦅x,t⦆  /\ t ≋ ⦉v⦊.

  Definition mb_is_fun (l s : X) :=
    forall p q x x' y, x ∈ l -> x' ∈ l
                    -> p ∈ s -> q ∈ s
                    -> p ≋ ⦅x,y⦆
                    -> q ≋ ⦅x',y⦆
                    -> x ≈ x'.

  (* Meta-level properties on the model *)

  Variable (Rdec : forall x y, { x ∈ y } + { x ∉ y })
           (Xfin : finite_t X).

  Local Definition lX : list X := proj1_sig Xfin.
  Local Definition HX : forall x, In x lX := proj2_sig Xfin.

  Hint Resolve HX : core.

  Fact mb_incl_choose x y : { z | z ∈ x /\ z ∉ y } + { x ⊆ y }.
  Proof using Xfin Rdec.
    set (P z := z ∈ x /\ z ∉ y).
    set (Q z := z ∈ x -> z ∈ y).
    destruct list_dec with (P := P) (Q := Q) (l := lX)
      as [ (z & _ & H2 & H3) | H ]; unfold P, Q in *; clear P Q.
    + intros z; destruct (Rdec z x); destruct (Rdec z y); tauto.
    + left; exists z; auto.
    + right; intros z; apply H; auto.
  Qed.

  Fact mb_incl_dec x y : { x ⊆ y } + { ~ x ⊆ y }.
  Proof using Xfin Rdec.
    destruct (mb_incl_choose x y) as [ (?&?&?) |]; auto.
  Qed.

  Fact mb_equiv_dec x y : { x ≈ y } + { x ≉ y }.
  Proof using Xfin Rdec.
    destruct (mb_incl_dec x y); [ destruct (mb_incl_dec y x) | ].
    1: left; apply mb_equiv_eq; auto.
    all: right; rewrite mb_equiv_eq; tauto.
  Qed.

  Hint Resolve mb_equiv_dec : core.

  Fact mb_is_pair_dec p x y : { p ≋ ⦃x,y⦄ } + { ~ p ≋ ⦃x,y⦄ }.
  Proof using Xfin Rdec.
    unfold mb_is_pair.
    apply (fol_quant_sem_dec fol_fa); auto; intros u.
    apply fol_equiv_dec; auto.
    apply (fol_bin_sem_dec fol_disj); auto.
  Qed.

  Hint Resolve mb_is_pair_dec : core.

  Fact mb_is_opair_dec p x y : { p ≋ ⦅x,y⦆  } + { ~ p ≋ ⦅x,y⦆  }.
  Proof using Xfin Rdec.
    unfold mb_is_opair.
    do 2 (apply (fol_quant_sem_dec fol_ex); auto; intro).
    repeat (apply (fol_bin_sem_dec fol_conj); auto).
  Qed.

  Hint Resolve mb_is_opair_dec : core.

  Fact mb_is_tuple_dec t n (v : vec _ n) : { t ≋ ⦉v⦊  } + { ~ t ≋ ⦉v⦊  }.
  Proof using Xfin Rdec.
    revert t; induction v as [ | x n v IHv ]; intros t.
    + apply (fol_quant_sem_dec fol_fa); auto; intro.
      apply (fol_bin_sem_dec fol_imp); auto.
    + simpl; apply (fol_quant_sem_dec fol_ex); auto; intro.
      apply (fol_bin_sem_dec fol_conj); auto.
  Qed.

  Hint Resolve mb_is_tuple_dec : core.

  Fact mb_is_tuple_in_dec r n (v : vec _ n) : { r ∋ ⦉v⦊  } + { ~ r ∋ ⦉v⦊  }.
  Proof using Xfin Rdec.
    apply (fol_quant_sem_dec fol_ex); auto; intro.
    apply (fol_bin_sem_dec fol_conj); auto.
  Qed.

End membership.

Section FOL_encoding.

  (* First order encoding here *)

  (* Maybe we can redo the whole devel here with fo_definable.v *)

  Notation Σ2 := (Σrel 2).
  Variable (Y : Type) (M2 : fo_model Σ2 Y).

  Let mem a b := fom_rels M2 tt (a##b##ø).
  Infix "∈ₘ" := mem (at level 59, no associativity).

  Definition Σ2_mem x y := @fol_atom Σ2 tt (£x##£y##ø).
  Infix "∈" := Σ2_mem.

  Definition Σ2_non_empty l := ∃ 0 ∈ (1+l).
  Definition Σ2_incl x y := ∀ 0 ∈ (S x) ⤑ 0 ∈ (S y).
  Definition Σ2_equiv x y := ∀ 0 ∈ (S x) ↔ 0 ∈ (S y).

  Infix "⊆" := Σ2_incl.
  Infix "≈" := Σ2_equiv.

  Definition Σ2_transitive t := ∀∀ 1 ∈ 0 ⤑ 0 ∈ (2+t) ⤑ 1 ∈ (2+t).

  Definition Σ2_extensional := ∀∀∀ 2 ≈ 1 ⤑ 2 ∈ 0 ⤑ 1 ∈ 0.

  Definition Σ2_is_pair p x y := ∀ 0 ∈ (S p) ↔ 0 ≈ S x ⟇ 0 ≈ S y.

  Definition Σ2_is_opair p x y :=
         ∃∃   Σ2_is_pair 1    (2+x) (2+x)
            ⟑ Σ2_is_pair 0    (2+x) (2+y)
            ⟑ Σ2_is_pair (2+p) 1     0.

  Fact Σ2_is_opair_vars p x y : fol_vars (Σ2_is_opair p x y) ⊑ p::x::y::nil.
  Proof. cbv; tauto. Qed.

  (* A 0-tuple <> is the empty set
     A (1+n)-tuple <x##v> is a pair (x,k) where k is the n-tuple <v>
   *)

  Fixpoint Σ2_is_tuple t n : vec nat n -> fol_form Σ2 :=
    match n with
      | 0       => fun _ => ∀ 0 ∈ (S t) ⤑ ⊥
      | S n     => fun v => ∃ Σ2_is_opair (S t) (S (vec_head v)) 0
                            ⟑ Σ2_is_tuple 0 (vec_map S (vec_tail v))
    end.

  Fact Σ2_is_tuple_vars t n v : fol_vars (@Σ2_is_tuple t n v) ⊑ t::vec_list v.
  Proof.
    revert t v; induction n as [ | n IHn ]; intros t v.
    + vec nil v; cbv; tauto.
    + vec split v with x; simpl Σ2_is_tuple.
      intros i; rewrite fol_vars_quant, in_flat_map.
      intros (j & H1 & H2).
      rewrite fol_vars_bin, in_app_iff in H1.
      destruct H1 as [ H1 | H1 ].
      * apply Σ2_is_opair_vars in H1.
        destruct H1 as [ | [ | [ | [] ] ] ]; subst j; simpl in *; tauto.
      * apply IHn in H1.
        destruct H1 as [ <- | H1 ].
        - simpl in *; tauto.
        - rewrite vec_list_vec_map, in_map_iff in H1.
          destruct H1 as (y & <- & H1); simpl in *.
          destruct H2 as [ -> | [] ]; tauto.
  Qed.

  (* v is n-tuple belonging to r *)

  Definition Σ2_is_tuple_in r n v := ∃ @Σ2_is_tuple 0 n (vec_map S v) ⟑ 0 ∈ (S r).

  Fact Σ2_is_tuple_in_vars r n v : fol_vars (@Σ2_is_tuple_in r n v) ⊑ r::vec_list v.
  Proof.
    unfold Σ2_is_tuple_in.
    intros x; rewrite fol_vars_quant, in_flat_map.
    intros (y & H1 & H2).
    rewrite fol_vars_bin, in_app_iff in H1.
    destruct H1 as [ H1 | H1 ].
    + apply Σ2_is_tuple_vars in H1.
      simpl in H1; rewrite vec_list_vec_map, in_map_iff in H1.
      destruct H1 as [ <- | (z & <- & H1) ]; simpl in *; try tauto.
      destruct H2 as [ <- | [] ]; auto.
    + simpl in H1.
      destruct H1 as [ <- | [ <- | [] ] ]; simpl in *; tauto.
  Qed.

  Definition Σ2_has_tuples l n :=
       fol_mquant fol_fa n ( (fol_vec_fa (vec_set_pos (fun p : pos n => pos2nat p ∈ (l+n))))
                                         ⤑ ∃ Σ2_is_tuple 0 (vec_set_pos (fun p : pos n => S (pos2nat p)))).

  Definition Σ2_is_tot n l s :=
       fol_mquant fol_fa n ( (fol_vec_fa (vec_set_pos (fun p : pos n => pos2nat p ∈ (l+n))))
                                         ⤑ ∃∃∃ 2 ∈ ((3+l)+n) ⟑ 1 ∈ ((3+s)+n) ⟑ Σ2_is_opair 1 2 0 ⟑ @Σ2_is_tuple 0 n (vec_set_pos (fun p : pos n => 3+pos2nat p)) ).

  Definition Σ2_is_fun l s :=
    ∀∀∀∀∀ 2 ∈ (5+l) ⤑ 1 ∈ (5+l) ⤑
          4 ∈ (5+s) ⤑ 3 ∈ (5+s) ⤑
          Σ2_is_opair 4 2 0 ⤑
          Σ2_is_opair 3 1 0 ⤑
          2 ≈ 1.

  Definition Σ2_list_in l lv := fol_lconj (map (fun x => x ∈ l) lv).

  Notation "⟪ A ⟫" := (fun ψ => fol_sem M2 ψ A).

  Section semantics.

    Fact Σ2_transitive_spec t ψ : ⟪Σ2_transitive t⟫ ψ = mb_transitive mem (ψ t).
    Proof. reflexivity. Qed.

    Fact Σ2_non_empty_spec l ψ : ⟪Σ2_non_empty l⟫ ψ = exists x, x ∈ₘ ψ l.
    Proof. reflexivity. Qed.

    Fact Σ2_incl_spec x y ψ : ⟪Σ2_incl x y⟫ ψ = mb_incl mem (ψ x) (ψ y).
    Proof. reflexivity. Qed.

    Fact Σ2_equiv_spec x y ψ : ⟪Σ2_equiv x y⟫ ψ = mb_equiv mem (ψ x) (ψ y).
    Proof. reflexivity. Qed.

    Fact Σ2_extensional_spec ψ : ⟪Σ2_extensional⟫ ψ = mb_member_ext mem.
    Proof. reflexivity. Qed.

    Fact Σ2_is_pair_spec p x y ψ : ⟪Σ2_is_pair p x y⟫ ψ = mb_is_pair mem (ψ p) (ψ x) (ψ y).
    Proof. reflexivity. Qed.

    Fact Σ2_is_opair_spec p x y ψ : ⟪Σ2_is_opair p x y⟫ ψ = mb_is_opair mem (ψ p) (ψ x) (ψ y).
    Proof. reflexivity. Qed.

    Fact Σ2_is_tuple_spec t n v ψ : ⟪@Σ2_is_tuple t n v⟫ ψ <-> mb_is_tuple mem (ψ t) (vec_map ψ v).
    Proof.
      induction n as [ | n IHn ] in t, v, ψ |- *.
      + vec nil v; reflexivity.
      + vec split v with x.
        simpl Σ2_is_tuple.
        simpl mb_is_tuple.
        rewrite fol_sem_quant_fix.
        fol equiv ex; intros y.
        rewrite fol_sem_bin_fix.
        fol equiv conj.
        * reflexivity.
        * rewrite IHn, vec_map_map; reflexivity.
    Qed.

    Fact Σ2_is_tuple_in_spec r n v ψ : ⟪@Σ2_is_tuple_in r n v⟫ ψ <-> mb_is_tuple_in mem (ψ r) (vec_map ψ v).
    Proof.
      simpl; fol equiv ex; intro; fol equiv conj.
      + rewrite Σ2_is_tuple_spec, vec_map_map; simpl; reflexivity.
      + reflexivity.
    Qed.

    Fact Σ2_has_tuples_spec l n ψ : ⟪Σ2_has_tuples l n⟫ ψ <-> mb_has_tuples mem (ψ l) n.
    Proof.
      unfold Σ2_has_tuples.
      rewrite fol_sem_mforall.
      fol equiv fa; intros v.
      rewrite fol_sem_bin_fix.
      fol equiv imp.
      + rewrite fol_sem_vec_fa.
        fol equiv; intros p.
        rew vec; simpl.
        now rewrite env_vlift_fix0, env_vlift_fix1.
      + rewrite fol_sem_quant_fix.
        fol equiv ex; intros x.
        rewrite Σ2_is_tuple_spec; simpl.
        fol equiv rel.
        apply vec_pos_ext; intros p.
        rew vec; simpl.
        rewrite env_vlift_fix0; auto.
    Qed.

    Fact Σ2_is_fun_spec l s ψ : ⟪Σ2_is_fun l s⟫ ψ = mb_is_fun mem (ψ l) (ψ s).
    Proof. reflexivity. Qed.

    Fact Σ2_is_tot_spec n l s ψ : ⟪Σ2_is_tot n l s⟫ ψ <-> mb_is_tot mem n (ψ l) (ψ s).
    Proof.
      unfold Σ2_is_tot, mb_is_tot.
      rewrite fol_sem_mforall.
      fol equiv; intros v.
      rewrite fol_sem_bin_fix.
      fol equiv imp.
      + rewrite fol_sem_vec_fa.
        fol equiv; intros p.
        rew vec; simpl.
        rewrite env_vlift_fix0, env_vlift_fix1; tauto.
      + rewrite fol_sem_quant_fix; fol equiv ex; intros x.
        rewrite fol_sem_quant_fix; fol equiv ex; intros p.
        rewrite fol_sem_quant_fix; fol equiv ex; intros t.
        do 3 (rewrite fol_sem_bin_fix).
        repeat fol equiv conj.
        * simpl; rewrite env_vlift_fix1; tauto.
        * simpl; rewrite env_vlift_fix1; tauto.
        * rewrite Σ2_is_opair_spec; simpl; tauto.
        * rewrite Σ2_is_tuple_spec; simpl.
          fol equiv.
          apply vec_pos_ext; intros q; rew vec.
          simpl; rewrite env_vlift_fix0; auto.
    Qed.

    Fact Σ2_list_in_spec l lv ψ : ⟪Σ2_list_in l lv⟫ ψ <-> forall x, x ∊ lv -> ψ x ∈ₘ ψ l.
    Proof.
      unfold Σ2_list_in; rewrite fol_sem_lconj.
      split.
      + intros H x Hx.
        apply (H (_ ∈ _)), in_map_iff.
        exists x; auto.
      + intros H f; rewrite in_map_iff.
        intros (x & <- & ?); apply H; auto.
    Qed.

  End semantics.

End FOL_encoding.


Theorem Ex022 (A B C : Prop): (A -> B) -> (A -> B -> C) -> (A -> C).
Proof.
  intros.
  apply H0.
  + exact H1.
  + apply H. exact H1.
Qed.


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

(* Original author: Russell O'Connor *)
(* This file is Public Domain *)

From Coq Require Import Lists.List  Ensembles  Peano_dec  Eqdep_dec
  Arith Compare_dec.

Require Import misc  Compat815 (* provisional *).

(* begin snippet LanguageDef *)
(* change suggested in the article by Russel O'Connor
   P. Casteran *)

Record Language : Type := language
 { Relations : Set;
   Functions : Set;
   arityR : Relations -> nat;
   arityF : Functions -> nat}.

(* end snippet LanguageDef *)

(* begin snippet TermDef *)
Section First_Order_Logic.

Variable L : Language.

Inductive Term : Set :=
  | var : nat -> Term
  | apply : forall f : Functions L, Terms  (arityF L f) -> Term
with Terms : nat -> Set :=
  | Tnil : Terms 0
  | Tcons : forall n : nat, Term -> Terms n -> Terms (S n).
 (* end snippet TermDef *)

Scheme Term_Terms_ind := Induction for Term Sort Prop
  with Terms_Term_ind := Induction for Terms Sort Prop.

Scheme Term_Terms_rec := Minimality for Term Sort Set
  with Terms_Term_rec := Minimality for Terms Sort Set.

Scheme Term_Terms_rec_full := Induction for Term  Sort Set
  with Terms_Term_rec_full := Induction for Terms Sort Set.

(* begin snippet FormulaDef *)
Inductive Formula : Set :=
  | equal : Term -> Term -> Formula
  | atomic : forall r : Relations L,
      Terms (arityR L r) -> Formula
  | impH : Formula -> Formula -> Formula
  | notH : Formula -> Formula
  | forallH : nat -> Formula -> Formula.
(* end snippet FormulaDef *)

(* begin snippet SystemDef *)
Definition Formulas := list Formula.
Definition System := Ensemble Formula.
Definition mem := Ensembles.In.
(* end snippet SystemDef *)

(* begin snippet FolFull *)
Definition orH (A B : Formula) := impH (notH A) B.
Definition andH (A B : Formula) := notH (orH (notH A) (notH B)).
Definition iffH (A B : Formula) := andH (impH A B) (impH B A).
Definition existH (x : nat) (A : Formula) :=
  notH (forallH x (notH A)).

(* end snippet FolFull *)

(* begin snippet FolPlus *)
Definition ifThenElseH (A B C : Formula) := andH (impH A B) (impH (notH A) C).
(* end snippet FolPlus *)

(* begin snippet formDec1:: no-out *)
Section Formula_Decidability.

Definition language_decidable :=
  ((forall x y : Functions L, {x = y} + {x <> y}) *
   (forall x y : Relations L, {x = y} + {x <> y}))%type.

Hypothesis language_dec : language_decidable.
(* end snippet formDec1 *)

Let nilTermsHelp : forall n : nat, n = 0 -> Terms n.
Proof.
  intros n H; induction n as [| n Hrecn].
  - apply Tnil.
  - discriminate H.
Defined.

Lemma nilTerms : forall x : Terms 0, Tnil = x.
Proof.
  assert (H: forall (n : nat) (p : n = 0) (x : Terms n),
             nilTermsHelp n p = x).
  { intros n p x; induction x as [| n t x Hrecx].
    - reflexivity.
    - discriminate p.
  }
  replace Tnil with (nilTermsHelp 0 (refl_equal 0)).
  - apply H.
  - auto.
Qed.

(** Decomposition Lemma for [Terms] *)
Let consTermsHelp : forall n : nat, Terms n -> Set.
Proof.
  intros n H; case n.
  - exact
      (forall p : 0 = n,
          {foo : unit | eq_rec _ (fun z => Terms z) Tnil _ p = H}).
  - intros n0;
      exact
        (forall p : S n0 = n,
            {t : Term * Terms n0 |
              eq_rec _ (fun z => Terms z) (Tcons n0 (fst t) (snd t)) _ p = H}).
Defined.

Lemma consTerms :
 forall (n : nat) (x : Terms (S n)),
 {t : Term * Terms n | Tcons n (fst t) (snd t) = x}.
Proof.
  assert (H: forall (n : nat) (x : Terms n), consTermsHelp n x).
  { intros n x; induction x as [| n t x Hrecx].
    - simpl in |- *; intros p; exists tt.
      elim p using K_dec_set.
      + apply eq_nat_dec.
      + reflexivity.
    - simpl in |- *; intro p; exists (t, x).
      elim p using K_dec_set.
      + apply eq_nat_dec.
      + simpl in |- *; reflexivity.
  }
  intros n x; assert (H0: consTermsHelp _ x) by apply H.
  simpl in H0; apply (H0 (refl_equal (S n))).
Qed.

Arguments Term_Terms_rec_full P P0: rename.

(* TODO --> term_eqdec *)
(* begin snippet formDec2:: no-out *)
Lemma term_dec : forall x y : Term, {x = y} + {x <> y}.
(* end snippet formDec2 *)
Proof.
  destruct language_dec as [a b].
  assert
    (H: forall (f g : Functions L) (p : f = g)
               (ts : Terms (arityF L f))
               (ss : Terms (arityF L g))
               (q : arityF L f = arityF L g),
        eq_rec _ (fun x => Terms x) ts _ q = ss <->
          apply f ts = apply g ss).
  { intros f g p;  eapply eq_ind
      with
      (x := g)
      (P :=
         fun a =>
           forall (ts : Terms (arityF L a))
                  (ss : Terms (arityF L g))
                  (q : arityF L a = arityF L g),
             eq_rec (arityF L a)
               (fun x : nat => Terms x) ts
               (arityF L g) q = ss <->
               apply a ts = apply g ss).
    - intros ts ss q;
        apply
          K_dec_set
        with
        (x := arityF L g)
        (P := fun z =>
                eq_rec (arityF L g)
                  (fun x : nat => Terms x) ts
                  (arityF L g) z = ss <->
                  apply g ts = apply g ss).
      apply eq_nat_dec; simpl in |- *.
      split.
      + intros H; rewrite <- H; auto.
      + intros H; inversion H as [H1].
        eapply
          inj_right_pair2 with
          (P :=
             fun f : Functions L =>
               Terms (arityF L f)); assumption.
    - auto.
  }
  intro x; elim x using
             Term_Terms_rec_full
    with
    (P0 := fun (n : nat) (ts : Terms n) =>
             forall ss : Terms n, {ts = ss} + {ts <> ss}).
  intros n y; induction y as [n0| f t].
  induction (eq_nat_dec n n0) as [a0 | b0].
  + rewrite a0; left; auto.
  + right; intro H0; inversion H0; contradiction.
  + right; discriminate.
  + intros f t H0 y; induction y as [n| f0 t0].
    * right; discriminate.
    * induction (a f f0).
      assert (H1: arityF L f0 = arityF L f).
      { rewrite a0. reflexivity. }
      set (ss' := eq_rec _ (fun z : nat => Terms z) t0 _ H1) in *.
      assert (H2: f0 = f) by auto.
      induction (H0 ss').
      -- left; induction (H _ _ H2 t0 t H1).
         symmetry  in |- *; apply H3; symmetry  in |- *.
         apply a1.
      -- right.
         intros H3.  induction (H _ _ H2 t0 t H1) as [H4 H5].
         elim b0;  symmetry  in |- *; apply H5.
         symmetry  in |- *; assumption.
      -- right. intro H1; inversion H1.
         contradiction.
  + left; apply nilTerms.
  + intros n t H0 t0 H1 ss.
    induction (consTerms _ ss).
    induction x0 as (a0, b0); simpl in p.
    induction (H1 b0)  as [a1 | b1].
    * induction (H0 a0).
      -- left; rewrite a1, a2; assumption.
      -- right; intro H2.
         elim b1.
         rewrite <- p in H2; inversion H2; reflexivity.
    * right; intro H2; elim b1.
      rewrite <- p in H2; inversion H2.
      eapply inj_right_pair2 with (P := fun n : nat => Terms n).
      apply eq_nat_dec.
      assumption.
Qed.

(* TODO -> terms_eqdec *)
(* begin snippet formDec3:: no-out *)
Lemma terms_dec n  (x y : Terms n): {x = y} + {x <> y}.
(* end snippet formDec3 *)
Proof.
  induction x as [| n t x Hrecx].
  - left; apply nilTerms.
  - induction (consTerms _ y) as [(a,b) p].
    simpl in p.
    induction (Hrecx b) as [a0 | b0].
    + induction (term_dec t a) as [a1| b0].
      * left; now rewrite a1, a0.
      * right. intro H; elim b0.
        rewrite <- p in H.
        inversion H; reflexivity.
    + right. intro H; elim b0.
      rewrite <- p in H.
      inversion H.
      eapply inj_right_pair2 with (P := fun n : nat => Terms n).
      * apply eq_nat_dec.
      * assumption.
Qed.

(*  -> formula_eqdec *)

(* begin snippet formDec4:: no-out *)
Lemma formula_dec : forall x y : Formula, {x = y} + {x <> y}.
(* end snippet formDec4 *)
Proof.
  induction language_dec as [a b].
  simple induction x; simple induction y;
    (right; discriminate) || intros.
  - induction (term_dec t t1) as [a0 | b0].
    + induction (term_dec t0 t2) as [a1 | b0].
      * left; now rewrite a0, a1.
      * right; unfold not in |- *. intros H. elim b0.
        inversion H; reflexivity.
    + right; unfold not in |- *; intros H; elim b0.
      inversion H; reflexivity.
  - induction (b r r0) as [a0 | b0].
    assert
 (H: forall (f g : Relations L) (p : f = g)
            (ts : Terms (arityR L f))
            (ss : Terms (arityR L g))
            (q : arityR L f = arityR L g),
     eq_rec _ (fun x => Terms x) ts _ q = ss <->
       atomic f ts = atomic g ss).
    { intros f g p; eapply eq_ind with
        (x := g)
        (P :=
           fun a =>
             forall (ts : Terms (arityR L a))
                    (ss : Terms (arityR L g))
                    (q : arityR L a = arityR L g),
               eq_rec _ (fun x => Terms x) ts _ q = ss <->
                 atomic a ts = atomic g ss).
      - intros ts ss q; elim q using K_dec_set.
        + apply eq_nat_dec.
        + simpl in |- *; split.
          * intros H; rewrite H; reflexivity.
          * intros H; inversion H.
            eapply inj_right_pair2 with
              (P :=
                 fun f : Relations L =>
                   Terms (arityR L f)).
            -- assumption.
            -- assumption.
      - auto.
    }
    assert (H0: arityR L r = arityR L r0)
    by (rewrite a0; reflexivity).
    induction
      (terms_dec _
         (eq_rec (arityR L r) (fun x : nat => Terms x) t
            (arityR L r0) H0) t0) as [a1 | b1].
    + left; induction (H _ _ a0 t t0 H0); auto.
    + right; induction (H _ _ a0 t t0 H0); tauto.
    + right. intro H; inversion H; auto.
  - destruct (H f1) as [a0 | b0].
    + destruct (H0 f2) as [a1 | b1].
      * left; now rewrite a0, a1.
      * right; intro H3; inversion H3; auto.
    + right;  intro H3; inversion H3; auto.
  - destruct (H f0) as [e | ne].
    + left; now rewrite e.
    + right; intro H1; inversion H1; auto.
  - destruct (eq_nat_dec n n0) as [e | ne].
    + destruct (H f0) as [a0 | b0].
      * left; now rewrite a0, e.
      * right;  intro H1; inversion H1; auto.
    + right; inversion 1; auto.
Qed.

(* begin snippet formDec5:: no-out *)
End Formula_Decidability.
(* end snippet formDec5 *)

Section Formula_Depth_Induction.

(* begin snippet depthDef *)
Fixpoint depth (A : Formula) : nat :=
  match A with
  | equal _ _ => 0
  | atomic _ _ => 0
  | impH A B => S (Nat.max (depth A) (depth B))
  | notH A => S (depth A)
  | forallH _ A => S (depth A)
  end.

Definition lt_depth (A B : Formula) : Prop := depth A < depth B.
(* end snippet depthDef *)

Lemma depthImp1 : forall A B : Formula, lt_depth A (impH A B).
Proof.
  intros A B; red; apply Nat.lt_succ_r, Nat.le_max_l.
Qed.

Lemma depthImp2 : forall A B : Formula, lt_depth B (impH A B).
Proof.
  intros A B; red; apply Nat.lt_succ_r, Nat.le_max_r.
Qed.

Lemma depthNot : forall A : Formula, lt_depth A (notH A).
Proof. intro A; red; auto. Qed.

Lemma depthForall : forall (A : Formula) (v : nat),
    lt_depth A (forallH v A).
Proof. intros A v; red; auto. Qed.

Lemma eqDepth :
 forall A B C : Formula, depth B = depth A ->
                         lt_depth B C -> lt_depth A C.
Proof. intros A B C H; red; now rewrite <- H. Qed.

(* Todo: upgrade to Type/rect  *)
Definition Formula_depth_rec_rec :
  forall P : Formula -> Set,
  (forall a : Formula, (forall b : Formula, lt_depth b a -> P b) -> P a) ->
  forall (n : nat) (b : Formula), depth b <= n -> P b.
Proof.
 intros P H n; induction n as [| n Hrecn].
 - intros b H0; apply H.
   intros b0 H1; unfold lt_depth in H1.
   rewrite Nat.le_0_r in H0; rewrite H0 in H1.
   apply Nat.nlt_0_r in H1. contradiction.
 - intros b H0; apply H.
   intros b0 H1; apply Hrecn; apply Nat.lt_succ_r .
   apply Nat.lt_le_trans with (depth b).
   + apply H1.
   + apply H0.
Defined.

(* Todo: upgrade to Type/rect  *)
Definition Formula_depth_rec (P : Formula -> Set)
  (rec : forall a : Formula,
      (forall b : Formula, lt_depth b a -> P b) -> P a)
  (a : Formula) : P a :=
  Formula_depth_rec_rec P rec (depth a) a (le_n (depth a)).

(* solves a compatibility issue *)

(* Todo: upgrade to Type/rect  *)
Lemma Formula_depth_rec_indep :
 forall (Q P : Formula -> Set)
   (rec : forall a : Formula,
          (forall b : Formula, lt_depth b a -> Q b -> P b) -> Q a -> P a),
 (forall (a : Formula)
    (z1 z2 : forall b : Formula, lt_depth b a -> Q b -> P b),
  (forall (b : Formula) (p : lt_depth b a) (q : Q b), z1 b p q = z2 b p q) ->
  forall q : Q a, rec a z1 q = rec a z2 q) ->
 forall (a : Formula) (q : Q a),
 Formula_depth_rec (fun x : Formula => Q x -> P x) rec a q =
 rec a
   (fun (b : Formula) _ =>
    Formula_depth_rec (fun x : Formula => Q x -> P x) rec b) q.
Proof.
  intros Q P rec H.
  unfold Formula_depth_rec in |- *.
  set (H0 := Formula_depth_rec_rec (fun x : Formula => Q x -> P x) rec)
    in *.
  assert
    (H1: forall (n m : nat) (b : Formula) (l1 : depth b <= n)
                (l2 : depth b <= m) (q : Q b), H0 n b l1 q = H0 m b l2 q).
  { simple induction n.
    - simpl in |- *.
      intros m b l1 l2 q; induction m as [| m Hrecm].
      + simpl in |- *; apply H.
        intros b0 p q0.
        induction  (* Warning to fix *)
          (Nat.nlt_0_r (depth b0)
             (eq_ind_r (fun n0 : nat => depth b0 < n0) p
                (Compat815.le_n_0_eq (depth b) l1))).
      + intros; simpl ; apply H.
        intros b0 p q0.
        induction (* warning to fix *)
          (Nat.nlt_0_r (depth b0)
             (eq_ind_r (fun n0 : nat => depth b0 < n0) p
                (Compat815.le_n_0_eq (depth b) l1))).
    - simple induction m.
      + intros b l1 l2 q; simpl in |- *; apply H.
        intros  b0 p q0.
        induction (*warning to fix *)
          (Nat.nlt_0_r  (depth b0)
             (eq_ind_r (fun n1 : nat => depth b0 < n1) p
                (Compat815.le_n_0_eq (depth b) l2))).
      + intros n1 H2 b l1 l2 q;  simpl in |- *; apply H.
        intros  b0 p q0.
        apply H1.
  }
  intros a q;
    replace (H0 (depth a) a (le_n (depth a)) q) with
    (H0 (S (depth a)) a (Nat.le_succ_diag_r (depth a)) q).
  - simpl in |- *; apply H.
    intros; apply H1.
  - apply H1.
Qed.

(* Todo: upgrade to Type/rect  *)
Definition Formula_depth_rec2rec (P : Formula -> Set)
  (f1 : forall t t0 : Term, P (equal t t0))
  (f2 : forall (r : Relations L)
               (t : Terms (arityR L r)),
        P (atomic r t))
  (f3 : forall f : Formula, P f -> forall f0 : Formula, P f0 -> P (impH f f0))
  (f4 : forall f : Formula, P f -> P (notH f))
  (f5 : forall (v : nat) (a : Formula),
        (forall b : Formula, lt_depth b (forallH v a) -> P b) ->
        P (forallH v a)) (a : Formula) :
  (forall b : Formula, lt_depth b a -> P b) -> P a :=
  match a return ((forall b : Formula, lt_depth b a -> P b) -> P a) with
  | equal t s => fun _ => f1 t s
  | atomic r t => fun _ => f2 r t
  | impH f g =>
      fun hyp => f3 f (hyp f (depthImp1 f g)) g (hyp g (depthImp2 f g))
  | notH f => fun hyp => f4 f (hyp f (depthNot f))
  | forallH n f => fun hyp => f5 n f hyp
  end.

(* Todo: upgrade to Type/rect  *)
Definition Formula_depth_rec2 (P : Formula -> Set)
  (f1 : forall t t0 : Term, P (equal t t0))
  (f2 : forall (r : Relations L) (t : Terms (arityR L r)),
        P (atomic r t))
  (f3 : forall f : Formula, P f -> forall f0 : Formula, P f0 -> P (impH f f0))
  (f4 : forall f : Formula, P f -> P (notH f))
  (f5 : forall (v : nat) (a : Formula),
        (forall b : Formula, lt_depth b (forallH v a) -> P b) ->
        P (forallH v a)) (a : Formula) : P a :=
  Formula_depth_rec P (Formula_depth_rec2rec P f1 f2 f3 f4 f5) a.

(* Todo: upgrade to Type/rect  *)
Remark Formula_depth_rec2rec_nice :
 forall (Q P : Formula -> Set)
   (f1 : forall t t0 : Term, Q (equal t t0) -> P (equal t t0))
   (f2 : forall (r : Relations L)
                (t : Terms (arityR L r)),
         Q (atomic r t) -> P (atomic r t))
   (f3 : forall f : Formula,
         (Q f -> P f) ->
         forall f0 : Formula,
         (Q f0 -> P f0) -> Q (impH f f0) -> P (impH f f0)),
 (forall (f g : Formula) (z1 z2 : Q f -> P f),
  (forall q : Q f, z1 q = z2 q) ->
  forall z3 z4 : Q g -> P g,
  (forall q : Q g, z3 q = z4 q) ->
  forall q : Q (impH f g), f3 f z1 g z3 q = f3 f z2 g z4 q) ->
 forall f4 : forall f : Formula, (Q f -> P f) -> Q (notH f) -> P (notH f),
 (forall (f : Formula) (z1 z2 : Q f -> P f),
  (forall q : Q f, z1 q = z2 q) ->
  forall q : Q (notH f), f4 f z1 q = f4 f z2 q) ->
 forall
   f5 : forall (v : nat) (a : Formula),
        (forall b : Formula, lt_depth b (forallH v a) -> Q b -> P b) ->
        Q (forallH v a) -> P (forallH v a),
 (forall (v : nat) (a : Formula)
    (z1 z2 : forall b : Formula, lt_depth b (forallH v a) -> Q b -> P b),
  (forall (b : Formula) (q : lt_depth b (forallH v a)) (r : Q b),
   z1 b q r = z2 b q r) ->
  forall q : Q (forallH v a), f5 v a z1 q = f5 v a z2 q) ->
 forall (a : Formula)
   (z1 z2 : forall b : Formula, lt_depth b a -> Q b -> P b),
 (forall (b : Formula) (p : lt_depth b a) (q : Q b), z1 b p q = z2 b p q) ->
 forall q : Q a,
 Formula_depth_rec2rec (fun x : Formula => Q x -> P x) f1 f2 f3 f4 f5 a z1 q =
 Formula_depth_rec2rec (fun x : Formula => Q x -> P x) f1 f2 f3 f4 f5 a z2 q.
Proof.
  intros Q P f1 f2 f3 H f4 H0 f5 H1 a z1 z2 H2 q.
  induction a as [t t0| r t| a1 Hreca1 a0 Hreca0| a Hreca| n a Hreca].
  - auto.
  - auto.
  - simpl in |- *; apply H.
    + intros q0; apply H2.
    + intros q0; apply H2.
  - simpl in |- *; apply H0; intros q0; apply H2.
  - simpl in |- *; apply H1, H2.
Qed.

(* Todo: upgrade to Type/rect  *)
Lemma Formula_depth_rec2_imp :
  forall (Q P : Formula -> Set)
         (f1 : forall t t0 : Term, Q (equal t t0) -> P (equal t t0))
         (f2 : forall (r : Relations L)
                      (t : Terms (arityR L r)),
             Q (atomic r t) -> P (atomic r t))
         (f3 : forall f : Formula,
             (Q f -> P f) ->
             forall f0 : Formula,
               (Q f0 -> P f0) -> Q (impH f f0) -> P (impH f f0)),
    (forall (f g : Formula) (z1 z2 : Q f -> P f),
        (forall q : Q f, z1 q = z2 q) ->
        forall z3 z4 : Q g -> P g,
          (forall q : Q g, z3 q = z4 q) ->
          forall q : Q (impH f g), f3 f z1 g z3 q = f3 f z2 g z4 q) ->
    forall f4 : forall f : Formula, (Q f -> P f) -> Q (notH f) -> P (notH f),
      (forall (f : Formula) (z1 z2 : Q f -> P f),
          (forall q : Q f, z1 q = z2 q) ->
          forall q : Q (notH f), f4 f z1 q = f4 f z2 q) ->
      forall
        f5 : forall (v : nat) (a : Formula),
        (forall b : Formula, lt_depth b (forallH v a) -> Q b -> P b) ->
        Q (forallH v a) -> P (forallH v a),
        (forall (v : nat) (a : Formula)
                (z1 z2 : forall b : Formula,
                    lt_depth b (forallH v a) -> Q b -> P b),
            (forall (b : Formula) (q : lt_depth b (forallH v a)) (r : Q b),
                z1 b q r = z2 b q r) ->
            forall q : Q (forallH v a), f5 v a z1 q = f5 v a z2 q) ->
        forall (a b : Formula) (q : Q (impH a b)),
          Formula_depth_rec2 (fun x : Formula => Q x -> P x) f1 f2 f3 f4 f5
            (impH a b) q =
            f3 a (Formula_depth_rec2 (fun x : Formula => Q x -> P x) f1 f2 f3 f4 f5 a) b
              (Formula_depth_rec2 (fun x : Formula => Q x -> P x) f1 f2 f3 f4 f5 b) q.
Proof.
  intros; unfold Formula_depth_rec2 at 1 in |- *;
    rewrite Formula_depth_rec_indep.
  - simpl in |- *; reflexivity.
  - intros; apply Formula_depth_rec2rec_nice; auto.
Qed.

(* Todo: upgrade to Type/rect  *)
Lemma Formula_depth_rec2_not :
 forall (Q P : Formula -> Set)
   (f1 : forall t t0 : Term, Q (equal t t0) -> P (equal t t0))
   (f2 : forall (r : Relations L)
                (t : Terms (arityR L r)),
         Q (atomic r t) -> P (atomic r t))
   (f3 : forall f : Formula,
         (Q f -> P f) ->
         forall f0 : Formula,
         (Q f0 -> P f0) -> Q (impH f f0) -> P (impH f f0)),
 (forall (f g : Formula) (z1 z2 : Q f -> P f),
  (forall q : Q f, z1 q = z2 q) ->
  forall z3 z4 : Q g -> P g,
  (forall q : Q g, z3 q = z4 q) ->
  forall q : Q (impH f g), f3 f z1 g z3 q = f3 f z2 g z4 q) ->
 forall f4 : forall f : Formula, (Q f -> P f) -> Q (notH f) -> P (notH f),
 (forall (f : Formula) (z1 z2 : Q f -> P f),
  (forall q : Q f, z1 q = z2 q) ->
  forall q : Q (notH f), f4 f z1 q = f4 f z2 q) ->
 forall
   f5 : forall (v : nat) (a : Formula),
        (forall b : Formula, lt_depth b (forallH v a) -> Q b -> P b) ->
        Q (forallH v a) -> P (forallH v a),
 (forall (v : nat) (a : Formula)
    (z1 z2 : forall b : Formula, lt_depth b (forallH v a) -> Q b -> P b),
  (forall (b : Formula) (q : lt_depth b (forallH v a)) (r : Q b),
   z1 b q r = z2 b q r) ->
  forall q : Q (forallH v a), f5 v a z1 q = f5 v a z2 q) ->
 forall (a : Formula) (q : Q (notH a)),
 Formula_depth_rec2
   (fun x : Formula => Q x -> P x) f1 f2 f3 f4 f5 (notH a) q =
   f4 a (Formula_depth_rec2 (fun x : Formula => Q x -> P x)
           f1 f2 f3 f4 f5 a) q.
Proof.
  intros; unfold Formula_depth_rec2 at 1; rewrite Formula_depth_rec_indep.
  - reflexivity.
  - apply Formula_depth_rec2rec_nice; auto.
Qed.

(* Formula_depth_rec2_forall is used in
codeSubFormula.v:917: (Formula_depth_rec2_forall L) (in a Proof)
codeSubFormula.v:6279: (Formula_depth_rec2_forall L)
folProp.v:558: (Formula_depth_rec2_forall L)
*)

(* Todo: upgrade to Type/rect  *)
Lemma Formula_depth_rec2_forall :
 forall (Q P : Formula -> Set)
   (f1 : forall t t0 : Term, Q (equal t t0) -> P (equal t t0))
   (f2 : forall (r : Relations L) (t : Terms (arityR L r)),
         Q (atomic r t) -> P (atomic r t))
   (f3 : forall f : Formula,
         (Q f -> P f) ->
         forall f0 : Formula,
         (Q f0 -> P f0) -> Q (impH f f0) -> P (impH f f0)),
 (forall (f g : Formula) (z1 z2 : Q f -> P f),
  (forall q : Q f, z1 q = z2 q) ->
  forall z3 z4 : Q g -> P g,
  (forall q : Q g, z3 q = z4 q) ->
  forall q : Q (impH f g), f3 f z1 g z3 q = f3 f z2 g z4 q) ->
 forall f4 : forall f : Formula, (Q f -> P f) -> Q (notH f) -> P (notH f),
 (forall (f : Formula) (z1 z2 : Q f -> P f),
  (forall q : Q f, z1 q = z2 q) ->
  forall q : Q (notH f), f4 f z1 q = f4 f z2 q) ->
 forall
   f5 : forall (v : nat) (a : Formula),
        (forall b : Formula, lt_depth b (forallH v a) -> Q b -> P b) ->
        Q (forallH v a) -> P (forallH v a),
 (forall (v : nat) (a : Formula)
    (z1 z2 : forall b : Formula, lt_depth b (forallH v a) -> Q b -> P b),
  (forall (b : Formula) (q : lt_depth b (forallH v a)) (r : Q b),
   z1 b q r = z2 b q r) ->
  forall q : Q (forallH v a), f5 v a z1 q = f5 v a z2 q) ->
 forall (v : nat) (a : Formula) (q : Q (forallH v a)),
 Formula_depth_rec2 (fun x : Formula => Q x -> P x) f1 f2 f3 f4 f5
   (forallH v a) q =
 f5 v a
   (fun (b : Formula) _ (q : Q b) =>
    Formula_depth_rec2 (fun x : Formula => Q x -> P x) f1 f2 f3 f4 f5 b q) q.
Proof.
  intros Q P f1 f2 f3 H f4 H0 f5 H1 v a q.
  unfold Formula_depth_rec2 at 1 in |- *;
    rewrite Formula_depth_rec_indep.
  - simpl in |- *; apply H1; reflexivity.
  - apply Formula_depth_rec2rec_nice; auto.
Qed.

(* Todo: use the Type version (when done)  *)
Definition Formula_depth_ind :
  forall P : Formula -> Prop,
  (forall a : Formula, (forall b : Formula, lt_depth b a -> P b) -> P a) ->
  forall a : Formula, P a.
Proof.
  intros P H a;
    assert (H0: forall (n : nat) (b : Formula), depth b <= n -> P b).
  { induction n as [| n Hrecn].
    - intros b H0; apply H.
      intros b0 H1; unfold lt_depth in H1.
      rewrite  (Nat.le_0_r) in H0; rewrite H0 in H1.
      destruct (Nat.nlt_0_r _ H1).
    - intros b H0; apply H; intros b0 H1.
      apply Hrecn.
      apply Nat.lt_succ_r.
      apply Nat.lt_le_trans with (depth b).
      + apply H1.
      + apply H0.
  }
  eapply H0; apply le_n.
Qed.

Lemma Formula_depth_ind2 :
 forall P : Formula -> Prop,
 (forall t t0 : Term, P (equal t t0)) ->
 (forall (r : Relations L)
         (t : Terms (arityR L r)),
     P (atomic r t)) ->
 (forall f : Formula, P f -> forall f0 : Formula, P f0 -> P (impH f f0)) ->
 (forall f : Formula, P f -> P (notH f)) ->
 (forall (v : nat) (a : Formula),
  (forall b : Formula, lt_depth b (forallH v a) -> P b) -> P (forallH v a)) ->
 forall f : Formula, P f.
Proof.
  intros P H H0 H1 H2 H3 f; apply Formula_depth_ind.
  simple induction a; auto.
  - intros f0 H4 f1 H5 H6; apply H1.
    + apply H6, depthImp1.
    + apply H6, depthImp2.
  - intros f0 H4 H5; apply H2, H5.
    apply depthNot.
Qed.

End Formula_Depth_Induction.

End First_Order_Logic.

Arguments Term_Terms_ind  L P P0 : rename.
Arguments Terms_Term_ind L P P0 : rename.

Arguments Term_Terms_rec L P P0 : rename.
Arguments Terms_Term_rec L P P0 : rename.

Arguments Term_Terms_rec_full L P P0 : rename.
Arguments Terms_Term_rec_full L P P0 : rename.

(** Changes by PC *)

(* begin snippet implicitArguments *)
Arguments impH {L} _ _.
Arguments notH {L} _.
Arguments forallH {L} _ _.
Arguments orH {L} _ _.
Arguments andH {L} _ _.
Arguments iffH {L} _ _.
Arguments equal {L} _ _.
Arguments existH {L} _ _.
Arguments var {L} _.
Arguments atomic {L} _ _.
Arguments apply {L} _ _.
Arguments ifThenElseH {L} _ _ _.
Arguments Tnil {L}.
Arguments Tcons {L} {n} _ _.
(* end snippet implicitArguments *)

(** Experimental, unstable !!!

The original code of this library contains some redefinitions like

<<
Definition Formula := Formula LNN.
>>

We plan to use systematically implicit arguments and avoid such redefinitions, which make more complex formula and term displaying, e.g. in goals or results of computation.

*)

Module FolNotations.
Declare Scope fol_scope.
Delimit Scope fol_scope with fol.

Infix "=" := (equal _): fol_scope.
Infix "\/" := (orH): fol_scope.
Infix "/\" := (andH):fol_scope.
Infix "->" := (impH): fol_scope.
Notation "~ A" := (@notH _ A): fol_scope.
Notation "A <-> B" := (@iffH _ A B): fol_scope.

Notation k_ t := (apply  (t:Functions _)  (Tnil)).

Notation app1 f arg :=
  (apply  (f: Functions _)  (Tcons arg (Tnil))).
About Tnil.
Notation app2 f arg1 arg2 :=
  (apply   (f: Functions _)
     (Tcons  arg1 (Tcons  arg2 (Tnil)))).

Notation "t = u" := (@equal _ t u): fol_scope.
Notation "t <> u" := (~ t = u)%fol : fol_scope.

(** the following notations may be used if some computation expands a disjunction, conjuction, etc. in terms of implication and negation *)

Reserved Notation "x '\/'' y" (at level 85, right associativity).
Reserved Notation "x '/\'' y" (at level 80, right associativity).
Reserved Notation "x '<->'' y" (at level 95, no associativity).
Reserved Notation "x '<->''' y" (at level 95, no associativity).

Notation "x \/' y" := (~ x -> y)%fol : fol_scope.
Notation "x /\' y" := (~ (~ x \/'  ~ y))%fol : fol_scope.
Notation "x <->'' y" := ((x -> y) /\ (y -> x))%fol:  fol_scope.
Notation "x <->' y" := (~ (~ (x -> y) \/' ~(y -> x)))%fol : fol_scope.

Notation exH' v A := (~ (forallH v (~ A)))%fol.

Notation "'v_' i" := (var i) (at level 3) : fol_scope.

Notation "'exH' x .. y , p" := (existH  x .. (existH y p) ..)
  (x at level 0, y at level 0, at level 200, right associativity) : fol_scope.

Notation "'allH' x .. y , p" := (forallH  x .. (forallH y p) ..)
  (x at level 0, y at level 0, at level 200, right associativity) : fol_scope.

End FolNotations.

Export FolNotations.

Section LExamples.
Variable L: Language.
Variables P Q : Formula L.

Let ex1 : Formula L :=  (P /\ Q)%fol.
About impH.
Let ex2 : Formula L := (~ (~~P -> ~Q))%fol.
Print ex2.
Let ex3 : Formula L:= (~(~P \/ ~Q))%fol.
Print ex3.
Compute ex3.
Print ex1.
Compute ex1.

Check (forallH 5 (v_ 5 = v_ 5) -> forallH 0 (v_ 0 = v_ 0))%fol.

End LExamples.

(*

Notation "t = u" := (@equal _ t u): cfol_scope.

Notation app1 f arg :=
  (apply  (f: Functions _)
     (Tcons  arg Tnil)).

Notation app2 f arg1 arg2 :=
  (apply   (f: Functions _)
     (Tcons arg1 (Tcons arg2 Tnil))).

Notation v_ := (var).

 Section Consistance.
  Goal forall L A B, @orH L A B = (A \/ B)%cfol.
   reflexivity. Qed.

  Goal forall L A B, andH (L:=L) A B = (A /\ B)%cfol.
    reflexivity. Qed.

 End Consistance.

End CFOL_notations.
*)

Section Correctness.
 Variable L: Language.
 Variables P Q R : Formula L.

 Goal (P \/ Q)%fol = (P \/' Q)%fol.
 reflexivity.
 Qed.

Goal (P /\ Q)%fol = (P /\' Q)%fol.
Proof. reflexivity. Qed.

End Correctness.

Section JustTry.
Variable L: Language.
Check (@var L 1 = var 2)%fol.
Check (v_ 1 = v_ 2)%fol: Formula L.
Check (exH 1, (v_ 1 = v_ 1))%fol : Formula L.
Compute (exH 1, (v_ 1 = v_ 1))%fol : Formula L.

Check (v_ 1 = v_ 1 \/ v_ 2 = v_ 2)%fol: Formula L.
Compute (v_ 1 = v_ 1 \/ v_ 2 = v_ 2)%fol: Formula L.

Check (v_ 1 = v_ 1 \/ v_ 2 = v_ 2)%fol: Formula L.
Compute (v_ 1 = v_ 1 \/ v_ 2 = v_ 2)%fol: Formula L.

Check (v_ 1 = v_ 1 \/ v_ 2 = v_ 2)%fol: Formula L.
Compute (v_ 1 = v_ 1 \/ v_ 2 = v_ 2)%fol: Formula L.

Check (v_ 1 = v_ 1 \/ v_ 2 = v_ 2)%fol: Formula L.
Compute (v_ 1 = v_ 1 \/ v_ 2 = v_ 2)%fol: Formula L.

Check (v_ 1 = v_ 1 <-> ~ v_ 2 = v_ 2)%fol: Formula L.
Compute (v_ 1 = v_ 1 <-> ~ v_ 2 = v_ 2)%fol: Formula L.

End JustTry.


(** * The very classical example of GCD computation in Hoare logic.

 This file is part of the "Tutorial on Hoare Logic".
 For an introduction to this Coq library,
 see README #or index.html#.

 This file illustrates how to use the Hoare logic described in file
 ##[hoarelogicsemantics]##

 I use here the very classical example of "great common divisor"
 computations through successive subtractions.
*)

Set Implicit Arguments.

Require Import ZArith.
Require Import Znumtheory.
Require Import hoarelogic.
Require Import Zwf.
Require Import Wellfounded.
Require Import Lia.

(** * Implementation of the expression language *)
Module Example <: ExprLang.

(** Here, I use only two global variables [VX] and [VY] of type [Z]
(binary integers). *)
Inductive ExVar: Type -> Type :=
  VX: (ExVar Z) |
  VY: (ExVar Z).

Definition Var:=ExVar.

(** An environment is just a pair of integers. First component
represents [VX] and second component represents [VY].  This is
expressed in [upd] and [get] below. *)
Definition Env:= (Z*Z)%type.

Definition upd (A:Type): (ExVar A) -> A -> Env -> Env :=
 fun x =>
   match x in (ExVar A) return A -> Env -> Env with
   | VX => fun vx e => (vx,snd e)
   | VY => fun vy e => (fst e,vy)
   end.

Definition get (A:Type): (ExVar A) -> Env -> A :=
 fun x =>
   match x in (ExVar A) return Env -> A with
   | VX => fun e => fst e
   | VY => fun e => snd e
   end.

(** I consider only two binary operators [PLUS] and [MINUS]. Their
meaning is given by [eval_binOP] below *)
Inductive binOP: Type := PLUS | MINUS.

Definition eval_binOP: binOP -> Z -> Z -> Z :=
 fun op => match op with
  | PLUS => Zplus
  | MINUS => Zminus
 end.

(** I consider only three comparison operators [EQ], [NEQ] and
[LE]. Their meaning is given by [eval_relOP] below *)
Inductive relOP: Type := EQ | NEQ | LE.

Definition eval_relOP: relOP -> Z -> Z -> bool :=
 fun op => match op with
  | EQ => Zeq_bool
  | NEQ => Zneq_bool
  | LE => Zle_bool
 end.

(** Here is the abstract syntax of expressions. The semantics is given
by [eval] below *)
Inductive ExExpr: Type -> Type :=
 | const: forall (A:Type), A -> (ExExpr A)
 | binop: binOP -> (ExExpr Z) -> (ExExpr Z) -> (ExExpr Z)
 | relop: relOP -> (ExExpr Z) -> (ExExpr Z) -> (ExExpr bool)
 | getvar: forall (A:Type), (ExVar A) -> (ExExpr A).

Definition Expr:= ExExpr.

Fixpoint eval (A:Type) (expr:Expr A) (e:Env) { struct expr } : A :=
 match expr in ExExpr A return A with
 | const A v => v
 | binop op e1 e2 => eval_binOP op (eval e1 e) (eval e2 e)
 | relop op e1 e2 => eval_relOP op (eval e1 e) (eval e2 e)
 | getvar A x => (get x e)
end.

End Example.

(** * Instantiation of the Hoare logic on this language. *)
Module HL :=  HoareLogic(Example).
Import HL.
Import Example.

(** These coercions makes the abstract syntax more user-friendly *)
Coercion getvar: ExVar >-> ExExpr.
Coercion binop: binOP >-> Funclass.
Coercion relop: relOP >-> Funclass.

(** A last coercion useful for assertions *)
Coercion get: ExVar >-> Funclass.

(** ** A [gcd] computation in this language *)
Definition gcd :=
  (Iwhile (NEQ VX VY)
          (Iif (LE VX VY)
               (Iset VY (MINUS VY VX))
               (Iset VX (MINUS VX VY)))).

(** A small technical lemma on the mathematical notion of gcd (called
[Zis_gcd]) *)
Lemma Zgcd_minus: forall a b d:Z, Zis_gcd a (b - a) d -> Zis_gcd a b d.
Proof.
  intros a b d H; case H; constructor; intuition (auto with zarith).
  replace b with (b-a+a)%Z.
  auto with zarith.
  lia.
Qed.

Global Hint Resolve Zgcd_minus: zarith.

(** Two other lemmas relating [Zneq_bool] function with inequality
relation *)
Lemma Zneq_bool_false: forall x y, Zneq_bool x y=false -> x=y.
Proof.
 intros x y H0; apply Zcompare_Eq_eq; generalize H0; clear H0; unfold Zneq_bool. case (x ?= y)%Z; auto;
 try (intros; discriminate); auto.
Qed.

Lemma Zneq_bool_true: forall x y, Zneq_bool x y=true -> x<>y.
Proof.
 intros x y; unfold Zneq_bool.
 intros H H0; subst.
 rewrite Z.compare_refl in H.
 discriminate.
Qed.

Global Hint Resolve Zneq_bool_true Zneq_bool_false Zle_bool_imp_le Zis_gcd_intro: zarith.

(** ** Partial correctness proof of [gcd] *)
Lemma gcd_partial_proof:
 forall x0 y0, (fun e => (VX e)=x0 /\ (VY e)=y0)
   |= gcd  {= fun e => (Zis_gcd x0 y0 (VX e)) =}.
Proof.
 intros x0 y0.
 apply PHL.soundness.
 simpl.
 intros e; intuition subst.
 (** after PO generation, I provide the invariant and simplify the goal *)
 constructor 1 with (x:=fun e'=>
  forall d, (Zis_gcd (VX e') (VY e') d)
              ->(Zis_gcd (VX e) (VY e) d)); simpl.
 intuition auto with zarith.
 (** - invariant => postcondition *)
 replace (snd e') with (fst e') in H; auto with zarith.
Qed.

(** ** Total correctness proof of [gcd] *)

Lemma gcd_total_proof:
 forall x0 y0, (fun e => (VX e)=x0 /\ (VY e)=y0 /\ x0 > 0 /\ y0 > 0)
  |= gcd  [= fun e => (Zis_gcd x0 y0 (VX e)) =].
Proof.
 intros x0 y0.
 apply THL.soundness.
 simpl.
 intros e; intuition subst.
 (** after simplification, I provide the invariant and then the variant *)
 constructor 1 with (x:=fun e' => (VX e') > 0 /\ (VY e') > 0 /\
  forall d, (Zis_gcd (VX e') (VY e') d)
              ->(Zis_gcd (VX e) (VY e) d)); simpl.
 constructor 1 with (x:=fun e1 e0 => Zwf 0 ((VX e1)+(VY e1)) ((VX e0)+(VY e0))).
 (** - proof that my variant is a well_founded relation *)
 constructor 1.
 apply wf_inverse_image with (f:=fun e=>(VX e)+(VY e)).
 auto with datatypes.
 (** - other goals *)
  unfold Zwf; simpl; (intuition auto with zarith).
 (** -- invariant => postcondition
      --- gcd part like in partial correctness proof
 *)
  replace (snd e') with (fst e') in H5; auto with zarith.
  (** --- new VY in branch "then" is positive *)
  cut ((fst e')<=(snd e')); auto with zarith.
  cut ((fst e')<>(snd e')); auto with zarith.
Qed.

(** ** Another example: infinite loops in partial correctness.

Basic Hoare logic is not well-suited for reasoning about non-terminating programs.
In total correctness, postconditions of non-terminating programs are not provable.
In partial correctness, a non-terminating program satisfies any (unsatisfiable) postcondition.

For example, in an informal "meaning", the program below enumerates all multiples of 3. But this meaning
can not be expressed here (even in partial correctness).
*)

Definition enum_3N :=
  (Iseq (Iset VX (const 0))
        (Iwhile (const true)
                (Iset VX (PLUS VX (const 3))))).

Lemma enum_3N_stupid:
 (fun e => True) |= enum_3N  {= fun e => False =}.
Proof.
 apply PHL.soundness.
 simpl.
 constructor 1 with (x:=fun _:Env => True).
 intuition (discriminate || auto).
Qed.

(** "Tutorial on Hoare Logic" Library. Copyright 2007 Sylvain Boulme.

This file is distributed under the terms of the
 "GNU LESSER GENERAL PUBLIC LICENSE" version 3.
*)