Require Export ProjectiveGeometry.Dev.basic_plane_facts.

Section s_hexamys.

Context `{PP : ProjectivePlane'}.
Context `{EP : EqDecidability Point}.
Context `{EL : EqDecidabilityL Line}.

Definition line A B := (proj1_sig (a1_exist A B)).
Definition inter l m := (proj1_sig (a2_exist l m)).

Definition on_inter A P Q R S := Incid A (line P Q) /\ Incid A (line R S).
Definition on_inter' A P Q R S := A = inter (line P Q) (line R S).

Definition Col A B C :=
 exists l : Line,
 Incid A l /\ Incid B l /\ Incid C l.

Definition Meet l1 l2 l3 :=
 exists P : Point, Incid P l1 /\ Incid P l2 /\ Incid P l3.

Definition is_transverse A' B' C' A B C :=
Col A' B' C' /\ Col A B' C /\ Col A C' B /\ Col B A' C.

Definition is_on_inter P A B C D :=
Col P A B /\ Col P C D.

Definition is_on_proper_inter P A B C D :=
Col P A B /\ Col P C D /\ ~A[==]B /\ ~C[==]D /\ line A B <> line C D.

Definition is_hexamy A B C D E F :=
  (~ A[==]B /\ ~ A[==]C /\ ~ A[==]D /\ ~ A[==]E /\ ~ A[==]F /\
  ~ B[==]C /\ ~ B[==]D /\ ~ B[==]E /\ ~ B[==]F /\
  ~ C[==]D /\ ~ C[==]E /\ ~ C[==]F /\
  ~ D[==]E /\ ~ D[==]F /\
  ~ E[==]F) /\
  let a:= inter (line B C) (line E F) in
  let b:= inter (line C D) (line F A) in
  let c:= inter (line A B) (line D E) in
Col a b c.

Definition hexamy := forall A B C D E F,
is_hexamy A B C D E F ->
is_hexamy B A C D E F.

Definition Col_on A B C l := Incid A l /\ Incid B l /\ Incid C l.

Ltac geo_norm :=
 unfold Col_on,
            is_on_inter, is_on_proper_inter,
            Col in * |-; use_all.

Ltac Apply_unicity := match goal with
| H1: ~?A [==] ?B, H2: ?Incid ?A ?l, H3: ?Incid ?B ?l, H4 : ?Incid ?A ?m, H5: ?Incid ?B ?m |- _ =>
let id:= fresh in assert (id: l=m); [try apply (a1_unique A B l m H1 H2 H3 H4 H5) | subst l]
| H1: ?l <> ?m, H2: ?Incid ?A ?l, H3: ?Incid ?A ?m, H4 : ?Incid ?B ?l, H5: ?Incid ?B ?m |- _ =>
let id:= fresh in assert (id: A[==]B); [try apply (a2_unique l m A B H1 H2 H3 H4 H5) | rewrite id in *; clear id]
end.

Ltac Collapse3 :=  progress (repeat (Apply_unicity; CleanDuplicatedHyps)).

Ltac cases_line l m :=
   elim (eq_dec_l l m); intro;
   [subst;try Collapse3|idtac].

Ltac cases_point A B :=
   elim (eq_dec_u A B); intros;
   [subst;try Collapse3|idtac].

Lemma line_wd : forall A B l,
 Incid A l ->
 Incid B l ->
 ~ A[==]B ->
 line A B = l.
Proof.
intros.
unfold line.
elim a1_exist;simpl.
intros.
use_all.
Collapse3.
reflexivity.
Qed.

Lemma line_wd_sym : forall A B l,
 Incid A l ->
 Incid B l ->
 ~ B[==]A ->
 line A B = l.
Proof.
intros.
unfold line.
elim a1_exist;simpl.
intros.
use_all.
Collapse3.
trivial.
Qed.

Ltac create_line A B l := elim (a1_exist A B);intros l Hl;decompose[and] Hl;clear Hl.

Ltac create_point l m P := elim (a2_exist l m);intros P HP;decompose[and] HP;clear HP.

Ltac create_inter A B C D P :=
  let AB:= fresh "l" in
  let CD:= fresh "l" in
  create_line A B AB; create_line C D CD; create_point AB CD P.

Ltac create_non_existing_line A B := progress first [ (match goal with
 HA : Incid A ?l , HB : Incid B ?l |- _ => idtac
end) | (let id:= fresh "l" in create_line A B id) ].

Ltac add_non_existing_lines := repeat (match goal with
_: context[line ?A ?B] |- _ => create_non_existing_line A B
| _: _ |- context[line ?A ?B] => create_non_existing_line A B
end).

Ltac remove_line_occ := repeat ( match goal with
 HAB: ~ ?A[==]?B, HA: Incid ?A ?l, HB: Incid ?B ?l,
 H: context[line ?A ?B] |- _ => rewrite (line_wd A B l) in * by assumption
| HAB: ~ ?B[==]?A, HA: Incid ?A ?l, HB: Incid ?B ?l,
 H: context[line ?A ?B] |- _ => rewrite (line_wd_sym A B l) in * by assumption
| HAB: ~ ?A[==]?B, HA: Incid ?A ?l, HB: Incid ?B ?l
 |- context[line ?A ?B] => rewrite (line_wd A B l) in * by assumption
| HAB: ~ ?B[==]?A, HA: Incid ?A ?l, HB: Incid ?B ?l
 |- context[line ?A ?B] => rewrite (line_wd_sym A B l) in * by assumption
end).

Lemma on_inter_points_wd : forall A B C D P l m,
 Incid A l ->
 Incid B l ->
 Incid C m ->
 Incid D m ->
 Incid P l ->
 Incid P m ->
 l <> m ->
 ~ A [==] B ->
 ~ C [==] D ->
 P = inter (line A B) (line C D).
Proof.
intros.
remove_line_occ.
unfold inter.
elim a2_exist.
intros.
simpl in *.
use_all.
Collapse3.
reflexivity.
Qed.

Lemma on_inter_points_wd_spec_1 : forall A B C D l m,
 Incid A l ->
 Incid B l ->
 Incid C m ->
 Incid D m ->
 Incid A m ->
 l <> m ->
 ~ A [==] B ->
 ~ C [==] D ->
 A = inter (line A B) (line C D).
Proof.
intros.
eapply on_inter_points_wd.
apply H.
apply H0.
apply H1.
apply H2.
auto.
auto.
auto.
auto.
auto.
Qed.

Lemma on_inter_points_wd_spec_2 : forall A B C D l m,
 Incid A l ->
 Incid B l ->
 Incid C m ->
 Incid D m ->
 Incid B m ->
 l <> m ->
 ~ A [==] B ->
 ~ C [==] D ->
 B = inter (line A B) (line C D).
Proof.
intros.
eapply on_inter_points_wd.
apply H.
apply H0.
apply H1.
apply H2.
auto.
auto.
auto.
auto.
auto.
Qed.

Lemma on_inter_points_wd_spec_3 : forall A B C D l m,
 Incid A l ->
 Incid B l ->
 Incid C m ->
 Incid D m ->
 Incid C l ->
 l <> m ->
 ~ A [==] B ->
 ~ C [==] D ->
 C = inter (line A B) (line C D).
Proof.
intros.
eapply on_inter_points_wd.
apply H.
apply H0.
apply H1.
apply H2.
auto.
auto.
auto.
auto.
auto.
Qed.

Lemma on_inter_points_wd_spec_4 : forall A B C D l m,
 Incid A l ->
 Incid B l ->
 Incid C m ->
 Incid D m ->
 Incid D l ->
 l <> m ->
 ~ A [==] B ->
 ~ C [==] D ->
 D = inter (line A B) (line C D).
Proof.
intros.
eapply on_inter_points_wd.
apply H.
apply H0.
apply H1.
apply H2.
auto.
auto.
auto.
auto.
auto.
Qed.

Lemma not_eq_sym_point : forall A B : Point, ~ A[==]B -> ~ B[==]A.
Proof.
 auto.
Qed.

Lemma not_eq_sym_line : forall l m : Line, l<>m -> m<>l.
Proof.
 auto.
Qed.

Ltac assumption_or_sym :=
  assumption ||
  (apply not_eq_sym_point;assumption) ||
  (apply not_eq_sym_line;assumption).

Ltac assumptions_or_sym := repeat split;try assumption_or_sym.

Ltac remove_inter_points_occ := repeat (match goal with

HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP1 : Incid ?P ?l,
HP2 : Incid ?P ?m |- context[inter (line ?A ?B) (line ?C ?D)] =>
rewrite <- (on_inter_points_wd A B C D P l m) in *; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?A ?m |- context[inter (line ?A ?B) (line ?C ?D)] =>
rewrite <- (on_inter_points_wd_spec_1 A B C D l m) in *; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?B ?m |- context[inter (line ?A ?B) (line ?C ?D)] =>
rewrite <- (on_inter_points_wd_spec_2 A B C D l m) in *; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?C ?l |- context[inter (line ?A ?B) (line ?C ?D)] =>
rewrite <- (on_inter_points_wd_spec_3 A B C D l m) in *; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?D ?l |- context[inter (line ?A ?B) (line ?C ?D)] =>
rewrite <- (on_inter_points_wd_spec_4 A B C D l m) in *; try assumption_or_sym

|

HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP1 : Incid ?P ?l,
HP2 : Incid ?P ?m ,
H: context[inter (line ?A ?B) (line ?C ?D)] |- _ =>
rewrite <- (on_inter_points_wd A B C D P l m) in H; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?A ?m,
H: context[inter (line ?A ?B) (line ?C ?D)]|- _ =>
rewrite <- (on_inter_points_wd_spec_1 A B C D l m) in H; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?B ?m,
H: context[inter (line ?A ?B) (line ?C ?D)] |- _ =>
rewrite <- (on_inter_points_wd_spec_2 A B C D l m) in H; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?C ?l,
H: context[inter (line ?A ?B) (line ?C ?D)] |- _ =>
rewrite <- (on_inter_points_wd_spec_3 A B C D l m) in H; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?D ?l,
H: context[inter (line ?A ?B) (line ?C ?D)] |- _ =>
rewrite <- (on_inter_points_wd_spec_4 A B C D l m) in H; try assumption_or_sym

end).

Lemma on_inter_wd : forall P l m,
 Incid P l ->
 Incid P m ->
 l <> m ->
 inter l m = P.
Proof.
intros.
unfold inter.
elim a2_exist.
simpl.
intros.
use_all.
Collapse3.
trivial.
Qed.

Lemma on_inter_wd_sym : forall P l m,
 Incid P l ->
 Incid P m ->
 l <> m ->
 inter m l = P.
Proof.
intros.
unfold inter.
elim a2_exist.
simpl.
intros.
use_all.
Collapse3.
trivial.
Qed.

Ltac remove_inter_occ := match goal with
| H : ?Incid ?I ?l, H1 : ?Incid ?I ?m, H2 : ?l <> ?m |- ?I = ?inter ?l ?m => rewrite (on_inter_wd I l m) by solve[intuition]
| H : ?Incid ?I ?l, H1 : ?Incid ?I ?m, H2 : ?l <> ?m |- ?I = ?inter ?m ?l => rewrite (on_inter_wd_sym I l m) by solve[intuition]
end.

Ltac remove_inter_occ_aux :=
first [erewrite on_inter_wd_sym in * by eassumption |
       erewrite on_inter_wd     in * by eassumption].

Lemma col_col_on_inter : forall A B C D I,
 Col A B I -> Col C D I ->
 ~ A[==]B -> ~ C[==]D -> (line A B) <> (line C D) ->
 I = inter (line A B) (line C D).
Proof.
intros.
geo_norm.
remove_line_occ.
remove_inter_occ.
reflexivity.
Qed.

Lemma incid_line_left : forall A B, Incid A (line A B).
Proof.
intros.
intros; unfold line.
repeat (elim a1_exist); simpl; intuition.
Qed.

Lemma incid_line_right : forall A B, Incid B (line A B).
Proof.
intros; unfold line.
repeat (elim a1_exist); simpl; intuition.
Qed.

Hint Resolve incid_line_left incid_line_right.

Lemma col_incid : forall A B C, ~B[==]C -> Col A B C -> Incid A (line B C).
Proof.
intros.
geo_norm.
remove_line_occ.
auto.
Qed.

Lemma col_comm : forall A B C, Col A B C -> Col B A C.
Proof.
intros; firstorder.
Qed.

Lemma col_comm2 : forall A B C, Col A B C -> Col A C B.
Proof with (intros; firstorder).
intros; firstorder.
Qed.

Lemma col_comm3 : forall A B C, Col A B C -> Col B C A.
Proof.
intros; firstorder.
Qed.

Lemma col_comm4 : forall A B C, Col A B C -> Col C A B.
Proof.
intros; firstorder.
Qed.

Lemma col_comm5 : forall A B C, Col A B C -> Col C B A.
Proof.
intros; firstorder.
Qed.

Lemma inter_comm : forall l m, inter l m = inter m l.
Proof.
intros;
elim (eq_dec_l l m).
intro;subst.
trivial.

intros; unfold inter.
repeat (elim a2_exist); simpl;intros.
use_all.
Collapse3.
reflexivity.
Qed.

Lemma line_comm : forall A B, (line A B)=(line B A).
Proof.
intros; elim (eq_dec_u A B).
intros; rewrite a; auto.
intros ; unfold line; repeat (elim a1_exist); simpl; intros; use_all.
Collapse3.
reflexivity.
Qed.

Hint Resolve inter_comm line_comm col_comm col_comm2 col_comm3 col_comm4 col_comm5.

Lemma  line_neq_neq :
 forall A B C D, forall l m, ~A[==]B -> ~C[==]D ->
 Incid A l -> Incid B l -> Incid C m -> Incid D m -> (line A B) <> (line C D) -> l<>m.
Proof.
intros.
unfold line in *; revert H5.
repeat (elim a1_exist);simpl.
intros;use_all;Collapse3;assumption.
Qed.

Lemma incid_inter_left :
forall A B C D, Incid (inter (line A B) (line C D)) (line A B).
Proof.
intros; unfold inter; repeat (elim a2_exist); simpl; firstorder.
Qed.

Lemma incid_inter_right :
forall A B C D, Incid (inter (line A B) (line C D)) (line C D).
Proof.
intros; unfold inter; repeat (elim a2_exist); simpl; firstorder.
Qed.

Hint Resolve incid_inter_left incid_inter_right.

(* Invariance by permutation of hexamy property *)

Lemma hexamy_rot_left : forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy B C D E F A.
Proof.
intros; unfold is_hexamy in *.
unfold Col in *;intuition;use_all.
exists x;intuition.
rewrite inter_comm;auto.
Qed.

Lemma hexamy_rot_right : forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy F A B C D E.
Proof.
intros; unfold is_hexamy in *.
unfold Col in *;intuition;use_all.
exists x;intuition.
rewrite inter_comm; auto.
Qed.

Hint Resolve hexamy_rot_left hexamy_rot_right : permut.

Lemma hexamy_swap_2_3 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A C B D E F.
Proof.
intros; apply hexamy_rot_right; apply H;
       apply hexamy_rot_left; exact H0.
Qed.

Lemma hexamy_swap_2_4 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A D C B E F.
Proof.
intros;
apply hexamy_rot_right; apply H;
apply hexamy_rot_right; apply H;
apply hexamy_rot_left; apply H;
apply hexamy_rot_left; exact H0.
Qed.

Lemma hexamy_swap_2_5 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A E C D B F.
Proof.
intros;
apply H; apply hexamy_rot_left; apply H;
apply hexamy_rot_left; apply H;
apply hexamy_rot_right; apply H;
apply hexamy_rot_right; apply H; exact H0.
Qed.

Lemma hexamy_swap_2_6 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A F C D E B.
Proof.
intros;
apply H; apply hexamy_rot_left; apply H;
apply hexamy_rot_right; apply H; exact H0.
Qed.

Lemma hexamy_swap_3_4 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A B D C E F.
Proof.
intros;
do 2 apply hexamy_rot_right;
apply H; apply hexamy_rot_left;
apply hexamy_rot_left; exact H0.
Qed.

Lemma hexamy_swap_3_5 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A B E D C F.
Proof.
intro H; intro A; intro B; intro C; intro D; intro E; intro F; intro H0;
       apply hexamy_rot_right; apply hexamy_rot_right;
       apply H; apply hexamy_rot_right; apply H;
       apply hexamy_rot_left; apply H;
       apply hexamy_rot_left; apply hexamy_rot_left; exact H0.
Qed.

Lemma hexamy_swap_3_6 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A B F D E C.
Proof.
intros.
do 2 apply hexamy_rot_right;
apply H.
apply hexamy_rot_right.
apply H.
do 2 apply hexamy_rot_right.
apply H;
apply hexamy_rot_right; apply H;
apply hexamy_rot_left; exact H0.
Qed.

Lemma hexamy_swap_4_5 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A B C E D F.
Proof.
intros.
do 3 apply hexamy_rot_left;
apply H;
do 3 apply hexamy_rot_left;
exact H0.
Qed.

Lemma hexamy_swap_4_6 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A B C F E D.
Proof.
intros.
do 3 apply hexamy_rot_right.
apply H.
apply hexamy_rot_right.
apply H.
apply hexamy_rot_left.
apply H.
do 3 apply hexamy_rot_left;
exact H0.
Qed.

Lemma hexamy_swap_5_6 :  hexamy -> forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A B C D F E.
Proof.
intros;
do 2 apply hexamy_rot_left;
apply H;
do 2 apply hexamy_rot_right;
exact H0.
Qed.

Ltac put_in_front P := repeat (match goal with
 H:_ |- is_hexamy P ?B ?C ?D ?E ?F => idtac
|H:_ |- is_hexamy ?A ?B ?C ?D ?E ?F => apply hexamy_rot_left
|H:_ |- _ => fail "goal must be hexamy"
end).

Ltac hexamy_permut_1:= match goal with
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy _ _ _ _ _ _  => put_in_front A
end.

Ltac hexamy_permut_2 := match goal with
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B _ _ _ _  => idtac
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?X ?B ?Y ?Z ?T  => cut (is_hexamy A B X Y Z T) ; [apply (hexamy_swap_2_3 HH) | idtac ]
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?X ?Y ?B ?Z ?T  => cut (is_hexamy A B Y X Z T) ; [apply (hexamy_swap_2_4 HH) | idtac]
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?X ?Y ?Z ?B ?T  => cut (is_hexamy A B Y Z X T) ; [apply (hexamy_swap_2_5 HH)|idtac]
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?X ?Y ?Z ?T ?B  => cut (is_hexamy A B Y Z T X) ; [apply (hexamy_swap_2_6 HH)| idtac]
end.

Ltac hexamy_permut_3 := match goal with
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?C _ _ _  => idtac
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?X ?C ?Y ?Z  => cut (is_hexamy A B C X Y Z) ; [apply (hexamy_swap_3_4 HH) | idtac ]
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?X ?Y ?C ?Z  => cut (is_hexamy A B C Y X Z) ; [apply (hexamy_swap_3_5 HH) | idtac]
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?X ?Y ?Z ?C  => cut (is_hexamy A B C Y Z X) ; [apply (hexamy_swap_3_6 HH)|idtac]
end.

Ltac hexamy_permut_4 := match goal with
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?C ?D _ _  => idtac
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?C ?X ?D ?Y  => cut (is_hexamy A B C D X Y) ; [apply (hexamy_swap_4_5 HH) | idtac ]
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?C ?X ?Y ?D  => cut (is_hexamy A B C D Y X) ; [apply (hexamy_swap_4_6 HH) | idtac]
end.

Ltac hexamy_permut_5 := match goal with
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?C ?D ?E _  => idtac
| HH: hexamy, H: is_hexamy ?A ?B ?C ?D ?E ?F |- is_hexamy ?A ?B ?C ?D ?X ?E  => cut (is_hexamy A B C D E X) ; [apply (hexamy_swap_5_6 HH) | idtac ]
end.

Ltac hexamy_permut := hexamy_permut_1 ; hexamy_permut_2 ; hexamy_permut_3 ; hexamy_permut_4 ; hexamy_permut_5 ; assumption.

Lemma hexamy_swap_right : hexamy ->
forall A B C D E F,
 is_hexamy A B C D E F ->  is_hexamy A B C D F E.
Proof.
intros.
hexamy_permut.
Qed.

Lemma col_line_eq : forall A B C,
 Col A B C -> ~A[==]B -> ~A[==]C ->
 line A B = line A C.
Proof.
intros.
unfold line.
repeat elim a1_exist;intros.
simpl.
unfold Col in H.
use H.
use p.
use p0.
assert (x=x1).
eapply a1_unique;eauto.
subst.
assert (x1=x0).
eapply a1_unique; try apply H0;auto.
subst.
auto.
Qed.

Lemma col_trivial_1: forall A B, Col A A B.
Proof.
intros.
create_line A B lAB.
exists lAB.
auto.
Qed.

Lemma col_trivial_2: forall A B, Col A B B.
Proof.
intros.
create_line A B lAB.
exists lAB.
auto.
Qed.

Lemma col_trivial_3: forall A B, Col A B A.
Proof.
intros.
create_line A B lAB.
exists lAB.
auto.
Qed.

Hint Resolve col_trivial_1 col_trivial_2 col_trivial_3.

Ltac solve_col := match goal with
 HA: Incid ?A ?l, HB: Incid ?B ?l, HC : Incid ?C ?l |- Col ?A ?B ?C => exists l; auto
| H:_ |- Col ?A ?A ?B => auto
| H:_ |- Col ?A ?B ?B => auto
| H:_ |- Col ?A ?B ?A => auto
end.

 Ltac revert_all_inter T := (match goal with
H: context[inter (line _ _) (line _ _)] |- _ => revert H
end;revert_all_inter T;intro) || T.

Ltac remove_inter_points_occ_all := revert_all_inter remove_inter_points_occ.

Ltac remove_inter_points_occ_assum := do 3  (match goal with

|HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP1 : Incid ?P ?l,
HP2 : Incid ?P ?m ,
H: context[inter (line ?A ?B) (line ?C ?D)] |- _ =>
rewrite <- (on_inter_points_wd A B C D P l m) in H; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?A ?m,
H: context[inter (line ?A ?B) (line ?C ?D)]|- _ =>
rewrite <- (on_inter_points_wd_spec_1 A B C D l m) in H; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?B ?m,
H: context[inter (line ?A ?B) (line ?C ?D)] |- _ =>
rewrite <- (on_inter_points_wd_spec_2 A B C D l m) in H; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?C ?l,
H: context[inter (line ?A ?B) (line ?C ?D)] |- _ =>
rewrite <- (on_inter_points_wd_spec_3 A B C D l m) in H; try assumption_or_sym

| HA: Incid ?A ?l,
HB: Incid ?B ?l,
HC: Incid ?C ?m,
HD: Incid ?D ?m,
HP2 : Incid ?D ?l,
H: context[inter (line ?A ?B) (line ?C ?D)] |- _ =>
rewrite <- (on_inter_points_wd_spec_4 A B C D l m) in H; try assumption_or_sym

end).

Ltac hexamy_proof_1  A B C D E F :=
  let T := fresh "hexa" in
 assert (T:is_hexamy A B C D E F);
  [unfold is_hexamy;split;[assumptions_or_sym|
                                        remove_inter_points_occ; remove_line_occ; try solve [solve_col]]|
   idtac].

Ltac print_goal := match goal with
H:_ |- ?X => idtac X
end.

Ltac hexamy_proof A B C D E F A' B' C' D' E' F' :=
  let T := fresh "hexa" in
  let U := fresh "hexa" in
  assert (T:is_hexamy A B C D E F);
  [unfold is_hexamy;split;[assumptions_or_sym|
                                        remove_inter_points_occ; remove_line_occ; try solve [solve_col];print_goal]|
   assert (U:is_hexamy A' B' C' D' E' F') by hexamy_permut;
   unfold is_hexamy in U;use U;
     remove_inter_points_occ_assum;auto].

(* This first definition of Pappus is the most general one. *)

Definition pappus_strong :=
 forall A B C A' B' C' P Q R,
 (~ A[==]B /\ ~A[==]C /\ ~A[==]A' /\ ~A[==]B' /\ ~A[==]C' /\
  ~ B[==]C /\ ~B[==]A' /\ ~B[==]B' /\ ~B[==]C' /\
  ~ C[==]A' /\ ~ C[==]B' /\ ~ C[==]C' /\
  ~ A'[==]B' /\ ~ A'[==]C' /\
  ~ B'[==]C' \/
 (line A B' <> line A' B /\ ~ A[==]B' /\ ~ A'[==]B /\
  line B C' <> line B' C /\ ~ B[==]C' /\ ~ B'[==]C /\
  line A C' <> line A' C /\ ~ A[==]C' /\ ~ A'[==]C) ) ->
 Col A B C -> Col A' B' C' ->
 is_on_inter P A B' A' B ->
 is_on_inter Q B C' B' C ->
 is_on_inter R A C' A' C ->
 Col P Q R.

(* This second definition of Pappus' configuration assumes that all the 6 points are distincts
and that the intersection are all well defined. This implies also that the line AB and A'B'
are distinct. This is the figure without any particular case. *)

Definition pappus_weak :=
 forall A B C A' B' C' P Q R,
 Col A B C -> Col A' B' C' ->
 ~ A[==]B /\ ~A[==]C /\ ~A[==]A' /\ ~A[==]B' /\ ~A[==]C' /\
 ~ B[==]C /\ ~B[==]A' /\ ~B[==]B' /\ ~B[==]C' /\
 ~ C[==]A' /\ ~ C[==]B' /\ ~ C[==]C' /\
 ~ A'[==]B' /\ ~ A'[==]C' /\
 ~ B'[==]C' ->
 is_on_proper_inter P A B' A' B ->
 is_on_proper_inter Q B C' B' C ->
 is_on_proper_inter R A C' A' C ->
 Col P Q R.

Lemma is_on_proper_inter_is_on_inter : forall P A B C D,
 is_on_proper_inter P A B C D -> is_on_inter P A B C D.
Proof.
intros.
unfold is_on_proper_inter, is_on_inter in *.
intuition.
Qed.

Lemma pappus_pappus_strong : pappus_weak <-> pappus_strong.
Proof.
unfold pappus_weak, pappus_strong.
split;intros.

2:apply (H  A B C A' B' C');auto using  is_on_proper_inter_is_on_inter.

decompose [or] H0;clear H0.

  elim (eq_dec_l (line A' B) (line A B')).
  intros.
  geo_norm.
  subst.
  remove_line_occ.
  subst.
  rename  x5 into l.
  rename x6 into m.
  rename x3 into lAB'.
  rename x2 into lB'C.
  rename x1 into lBC'.
  rename x0 into lA'C.
  rename x into lAC'.
  Collapse3.
  solve_col.

  intro.

  elim (eq_dec_l (line B' C) (line B C')).
  intros.
  geo_norm.
  subst.
  remove_line_occ.
  subst.
  Collapse3.
  solve_col.

  intro.

  elim (eq_dec_l (line A' C) (line A C')).
  intros.
  geo_norm.
  subst.
  remove_line_occ.
  subst.
  Collapse3.
  solve_col.

  intro.

  apply (H  A B C A' B' C'); auto;

  unfold is_on_inter, is_on_proper_inter in *;intuition.

use H6.

cases_point A B.
rewrite a in *.
geo_norm.
remove_line_occ.
Collapse3.
solve_col.

cases_point A C.
rewrite a in *.
geo_norm.
remove_line_occ.
Collapse3.
solve_col.

cases_point B C.
rewrite a in *.
geo_norm.
remove_line_occ.
Collapse3.
solve_col.

cases_point A' B'.
rewrite a in *.
geo_norm.
remove_line_occ.
Collapse3.
solve_col.

cases_point A' C'.
rewrite a in *.
geo_norm.
remove_line_occ.
Collapse3.
solve_col.

cases_point B' C'.
rewrite a in *.
geo_norm.
remove_line_occ.
Collapse3.
solve_col.

cases_point A A'.
rewrite a in *.
geo_norm.
remove_line_occ.
Collapse3.
solve_col.

cases_point A B'.
rewrite a in *.
geo_norm.
remove_line_occ.
Collapse3.
solve_col.

cases_point A C'.
rewrite a in *.
geo_norm.
remove_line_occ.
Collapse3.
solve_col.

cases_point B A'.
rewrite a in *.
geo_norm.
remove_line_occ.
Collapse3.
solve_col.

cases_point B B'.
rewrite a in *.
geo_norm.
remove_line_occ.
Collapse3.
solve_col.

cases_point B C'.
rewrite a in *.
geo_norm.
remove_line_occ.
Collapse3.
solve_col.

cases_point C A'.
rewrite a in *.
geo_norm.
remove_line_occ.
Collapse3.
solve_col.

cases_point C B'.
rewrite a in *.
geo_norm.
remove_line_occ.
Collapse3.
solve_col.

cases_point C C'.
rewrite a in *.
geo_norm.
remove_line_occ.
Collapse3.
solve_col.

apply (H  A B C A' B' C'); try assumption.
intuition.

unfold is_on_proper_inter, is_on_inter in *; use_all;auto.
unfold is_on_proper_inter, is_on_inter in *; use_all;auto.
unfold is_on_proper_inter, is_on_inter in *; use_all;auto.
Qed.

Ltac solve_eql := solve [intro; repeat subst; try Collapse3;intuition].
Ltac solve_eqp := solve [intro; repeat new_subst; try Collapse3;intuition].

Ltac not_eq_pt_all := match goal with
| A:Point,B:Point |- _ => assert_if_not_exist (~ A[==]B);[ solve_eqp | idtac]
end.

Ltac not_eq_li_all := match goal with
 | L:Line,M:Line |- _ => assert_if_not_exist (L<>M);[ solve_eql | idtac]
end.

Ltac collapse_all n := do n (not_eq_pt_all; not_eq_li_all); Collapse3.

Lemma hexamy_special_case :  forall A B C D E F,
 ~ A[==]B /\ ~ A[==]C /\ ~ A[==]D /\ ~ A[==]E /\ ~ A[==]F /\
 ~ B[==]C /\ ~ B[==]D /\ ~ B[==]E /\ ~ B[==]F /\
 ~ C[==]D /\ ~ C[==]E /\ ~ C[==]F /\
 ~ D[==]E /\ ~ D[==]F /\
 ~ E[==]F ->
 Col A B C -> Col D E F -> is_hexamy A B C D E F.
Proof.
intros.
unfold is_hexamy.
split.
solve [auto].
geo_norm;remove_line_occ;solve_col.
Qed.

(* This theorem shows that Pappus property implies the Hexamys property *)

Ltac not_eqp A B:= assert (~A[==]B) by solve_eqp.
Ltac not_eql l m:= assert (l<>m) by solve_eql.

Ltac Collapse_no_hyps := match goal with
| HAl: ?Incid ?A ?l, HBl: ?Incid ?B ?l, HAm: ?Incid ?A ?m, HBm: ?Incid ?B ?m |- _ =>
let id:= fresh in assert (id: l=m) by (apply (a1_unique A B l m);[solve_eqp| apply HAl | apply HBl| apply HAm| apply HBm]);subst l
| HAl: ?Incid ?A ?l, HBl: ?Incid ?B ?l, HAm: ?Incid ?A ?m, HBm: ?Incid ?B ?m |- _ =>
let id:= fresh in assert (id: A[==]B) by ( apply (a2_unique l m A B);[solve_eql| apply HAl | apply HAm| apply HBl| apply HBm]);rewrite id in *;clear id
end.

Ltac not_eqp_4 A B C D := match goal with
H1: ?Incid A ?l,
H2: ?Incid B ?l,
H3: ?Incid C ?m,
H4: ?Incid D ?m|- _ => not_eql l m
end.

Lemma hexamy_prop: pappus_strong -> forall A B C D E F,
 (line C D) <> (line A F) ->
 (line B C) <> (line E F) ->
 (line A B) <> (line D E) ->

 (line A C) <> (line E F) ->
 (line B F) <> (line C D) ->
 is_hexamy A B C D E F -> is_hexamy B A C D E F.
Proof.
intro HPappus.
intros.
unfold is_hexamy in *.
use H4.
split;[repeat split;auto|idtac].
create_line A B lAB.
create_line A C lAC.
create_line A D lAD.
create_line A E lAE.
create_line A F lAF.

create_line B C lBC.
create_line B D lBD.
create_line B E lBE.
create_line B F lBF.

create_line C D lCD.
create_line C E lCE.
create_line C F lCF.

create_line D E lDE.
create_line D F lDF.

create_line E F lEF.

create_inter B C E F a.
create_inter C D F A b.
create_inter A B D E c.
Collapse3.

replace (line A B) with l3 in * by (rewrite (line_wd A B l3) by assumption;trivial).
replace (line B C) with l  in * by (rewrite (line_wd B C l)  by assumption;trivial).
replace (line E F) with l0 in * by (rewrite (line_wd E F l0) by assumption;trivial).
replace (line C D) with l1 in * by (rewrite (line_wd C D l1) by assumption;trivial).
replace (line A F) with l2 in * by (rewrite (line_wd A F l2) by assumption;trivial).
replace (line D E) with l4 in * by (rewrite (line_wd D E l4) by assumption;trivial).
replace (line A C) with lAC in * by (rewrite (line_wd A C lAC) by assumption;trivial).
replace (line B F) with lBF in * by (rewrite (line_wd B F lBF) by assumption;trivial).
replace (line A D) with lAD in * by (rewrite (line_wd A D lAD) by assumption;trivial).
replace (line C E) with lCE in * by (rewrite (line_wd C E lCE) by assumption;trivial).
replace (line F B) with lBF in * by (rewrite (line_wd_sym F B lBF) by assumption;trivial).
replace (line A E) with lAE in * by (rewrite (line_wd A E lAE) by assumption;trivial).
replace (line E C) with lCE in * by (rewrite (line_wd_sym E C lCE) by assumption;trivial).
replace (line F A) with l2 in * by (rewrite (line_wd_sym F A l2) by assumption;trivial).
replace (line B A) with l3 in * by (rewrite (line_wd_sym B A l3) by assumption;trivial).
create_point lAC l0 b'.

revert H6;repeat remove_inter_occ_aux;intro.

geo_norm.
cases_line lAD l2.
cases_point c b.
rewrite a0 in *;Collapse3.
remove_inter_occ_aux.
solve[intuition].
Collapse3.
cases_point a E.
rewrite a0 in *;Collapse3.

create_inter B F C b w.
Collapse3.
remove_inter_occ_aux.

cut (Col w b' c).
solve[intuition].
apply (HPappus b F A B C E w b' c).
left.
repeat split;solve[intuition].
solve_col.
solve_col.
unfold is_on_inter;split;solve_col.
unfold is_on_inter;split;solve_col.
unfold is_on_inter;split;solve_col.

Collapse3.
solve[intuition].

cases_line l3 lAE.
cases_point a c.
rewrite a0 in *;Collapse3.
solve[intuition].
Collapse3.
cases_point b F.
rewrite a0 in *;Collapse3.
remove_inter_occ_aux.
solve_col.
Collapse3.
remove_inter_occ_aux.
solve_col.

cases_line l0 l2.
Collapse_no_hyps.
Collapse_no_hyps.
replace (inter l1 lBF) with B.
solve_col.
unfold inter;elim a2_exist; intros; simpl;geo_norm;Collapse3;solve[intuition].

cases_line lCE l0.
Collapse_no_hyps.
cases_point c b'.
rewrite a in *.
solve [intuition].
exists x.
repeat split;auto.
unfold inter;elim a2_exist;simpl;intros;use_all;solve[intuition].

cases_line lAD l4.
cases_point b' c.
rewrite a0 in *.
solve[intuition].
cases_point b c.
rewrite a0 in *.
Collapse3.
cases_point a c.
rewrite a1 in *.
Collapse3.

solve[intuition].
exists lCE.
repeat split; auto.
unfold inter;elim a2_exist;simpl;intros;use_all;solve[intuition].

Collapse3.
replace (inter l1 lCF) with C.
solve_col.
unfold inter;elim a2_exist;simpl;intros;use_all;Collapse3;solve[intuition].

cases_line l1 l4.
not_eqp a b.
not_eqp a c.

cases_point b c.
rewrite a0 in *.
Collapse_no_hyps.

replace (inter l4 lBF) with c.
solve [intuition].
unfold inter; elim a2_exist; simpl;intros; geo_norm; Collapse3;solve[intuition].
Collapse3.
rewrite (on_inter_wd_sym c);solve[intuition].

cases_line l1 l0.
remove_inter_occ_aux.
solve[solve_col].

cases_line l4 l0.
Collapse_no_hyps.
cases_point b c.
rewrite a0 in *.
Collapse3.
solve[intuition].
cases_point b' c.
rewrite a0 in *.
solve[intuition].
Collapse_no_hyps.
Collapse_no_hyps.
Collapse_no_hyps.
replace (inter l1 l0) with D.
solve_col.
unfold inter;elim a2_exist;simpl;intros;use_all;Collapse3;reflexivity.

cases_line lAC l2.
Collapse_no_hyps.
cases_point c B.
rewrite a0 in *.
Collapse3.
exists lBF.
repeat split;auto.
unfold inter; elim a2_exist;simpl;intros;use p;solve [auto].
Collapse3.
exists lBF.
repeat split;auto.
unfold inter; elim a2_exist;simpl;intros;use p;solve [auto].

cases_line lAC l.
Collapse_no_hyps.
replace (inter l1 lBF) with B.
solve [solve_col].
unfold inter; elim a2_exist;simpl;intros;use p;Collapse3;solve[intuition].

cases_line lAC l1.
Collapse_no_hyps.
Collapse_no_hyps.
Collapse_no_hyps.
replace (inter l1 lBF) with b'.
solve_col.
unfold inter; elim a2_exist;simpl;intros;use_all;Collapse3;solve[auto].

not_eqp a b.

not_eqp a c.
not_eqp a b'.
not_eqp A a.
not_eqp b' a.
not_eqp C a.

not_eqp b c.
not_eqp b b'.
not_eqp C b.
not_eqp A b.

not_eqp A c.
not_eqp c b'.
not_eqp C c.

not_eqp A b'.
not_eqp A C.

not_eqp b' C.

assert (Col A b' C) by solve_col.

assert (is_on_inter F a b' A b) by (unfold is_on_inter;split;solve_col).
assert (is_on_inter B a C A c) by (unfold is_on_inter;split;solve_col).

create_line c b' lcb'.
create_point l1 lcb' P.

assert (is_on_inter (inter l1 lcb') b C b' c).
  unfold is_on_inter;split.

  exists l1;
  repeat split;auto;
  unfold inter;
  elim (a2_exist);intro;
  simpl;intuition.

  exists lcb';
  repeat split;auto;
  unfold inter;
  elim (a2_exist);intro;
  simpl;intuition.

assert (Col F (inter l1 lcb') B).
apply (HPappus a b c A b' C F (inter l1 lcb') B).
solve[intuition].
solve_col.
solve_col.
solve[intuition].
solve[intuition].
solve[intuition].

replace (inter l1 lcb') with (inter l1 lBF) in *.

geo_norm.
Collapse3.

solve_col.

geo_norm.
Collapse3.

unfold inter at 1;elim a2_exist;intro;simpl.
intros;use p;Collapse3;reflexivity.
Qed.

(* hexamy_desargues_no_cevian *)

Lemma hexamy_desargues_no_cevian :
  hexamy ->
  forall O A B C A' B' C' I J K P Q,
  line A B <> line B C ->
  line A' B' <>  line B' C' ->
  line A' B' <> line A B ->
  line B' C' <> line B C ->
  line O A <> line O C ->
  line A' C' <> line A C ->
  ~O[==]A -> ~O[==]B -> ~O[==]C ->
  ~O[==]A' -> ~O[==]B' -> ~O[==]C' ->
  ~O[==]I -> ~O[==]J -> ~O[==]K ->
  ~A[==]B -> ~A[==]C ->
  ~A[==]A' -> ~A[==]B' -> ~A[==]C' ->
  ~A[==]I -> ~A[==]J -> ~A[==]K ->
  ~B[==]C ->
  ~B[==]A' -> ~B[==]B' -> ~B[==]C' ->
  ~B[==]I -> ~B[==]J -> ~B[==]K ->
  ~C[==]A' -> ~C[==]B' -> ~C[==]C' ->
  ~C[==]I -> ~C[==]J -> ~C[==]K ->
  ~A'[==]B' -> ~A'[==]C' ->
  ~A'[==]I -> ~A'[==]J -> ~A'[==]K ->
  ~B'[==]C' ->
  ~B'[==]I -> ~B'[==]J -> ~B'[==]K ->
  ~C'[==]I -> ~C'[==]J -> ~C'[==]K ->
  ~I[==]J -> ~I[==]K ->
  ~J[==]K ->

  ~ Col A' B C ->
  ~ Col B' A C ->
  ~ Col C' A B ->
  ~ Col A B' C' ->
  ~ Col B A' C' ->
  ~ Col C A' B' ->

  Col P B C ->
  Col P A' B' ->
  Col Q A B ->
  Col Q B' C' ->

  Col O A A' ->
  Col O B B' ->
  Col O C C' ->
  Col A' C' I ->
  Col A C I ->
  Col A B J ->
  Col A' B' J ->
  Col B C K ->
  Col B' C' K ->
  Col I J K.
Proof.
intros.

geo_norm.
remove_line_occ.
Collapse3.

not_eqp P Q.
not_eqp A P.
not_eqp C Q.
not_eqp A' Q.
not_eqp C' P.

hexamy_proof  A A' P C C' Q A Q C' A' P C.

cases_line x8 x9.
intuition.
cases_point A Q.
rewrite <-a in *.
destruct H54;exists x8;intuition.
assumption.

cases_line x9 x10.
intuition.
cases_point A' P.
rewrite <-a in *.
destruct H51;exists x11;intuition.
assumption.

cases_line x10 x11.
intuition.
cases_point P C.
rewrite <-a in *.
destruct H56;exists x10;intuition.
assumption.

cases_line x8 x9.
intuition.
cases_point C' Q.
rewrite <-a in *.
destruct H53;exists x9;intuition.
assumption.

cases_line x10 x11.
intuition.
cases_point P C.
rewrite <-a in *.
destruct H56;exists x10;intuition.
assumption.

cases_line x8 x9.
intuition.
cases_point Q A.
rewrite <-a in *.
destruct H54;exists x8;intuition.
assumption.

cases_line x9 x10.
intuition.
cases_point A' P.
rewrite <-a in *.
destruct H51;exists x11;intuition.
assumption.

cases_line x8 x9.
intuition.
cases_point C' Q.
rewrite <-a in *.
destruct H53;exists x9;intuition.
assumption.
Qed.

(* hexamy_desargues_no_cevian except in B' *)

Lemma hexamy_desargues_no_cevian_1pt_B' :
  hexamy ->
  forall O A B C A' B' C' I J K P Q,
  line A B <> line B C ->
  line A' B' <>  line B' C' ->
  line A' B' <> line A B ->
  line B' C' <> line B C ->
  line O A <> line O C ->
  line A' C' <> line A C ->
  ~O[==]A -> ~O[==]B -> ~O[==]C ->
  ~O[==]A' -> ~O[==]B' -> ~O[==]C' ->
  ~O[==]I -> ~O[==]J -> ~O[==]K ->
  ~A[==]B -> ~A[==]C ->
  ~A[==]A' -> ~A[==]B' -> ~A[==]C' ->
  ~A[==]I -> ~A[==]J -> ~A[==]K ->
  ~B[==]C ->
  ~B[==]A' -> ~B[==]B' -> ~B[==]C' ->
  ~B[==]I -> ~B[==]J -> ~B[==]K ->
  ~C[==]A' -> ~C[==]B' -> ~C[==]C' ->
  ~C[==]I -> ~C[==]J -> ~C[==]K ->
  ~A'[==]B' -> ~A'[==]C' ->
  ~A'[==]I -> ~A'[==]J -> ~A'[==]K ->
  ~B'[==]C' ->
  ~B'[==]I -> ~B'[==]J -> ~B'[==]K ->
  ~C'[==]I -> ~C'[==]J -> ~C'[==]K ->
  ~I[==]J -> ~I[==]K ->
  ~J[==]K ->

  ~ Col A' B C ->
  Col B' A C ->
  ~ Col C' A B ->
  ~ Col A B' C' ->
  ~ Col C A' B' ->

  Col P B C ->
  Col P A' B' ->
  Col Q A B ->
  Col Q B' C' ->

  Col O A A' ->
  Col O B B' ->
  Col O C C' ->
  Col A' C' I ->
  Col A C I ->
  Col A B J ->
  Col A' B' J ->
  Col B C K ->
  Col B' C' K ->
  Col I J K.
Proof.
intros.

geo_norm.
remove_line_occ.
Collapse3.
not_eqp P Q.
not_eqp A P.
not_eqp C Q.
not_eqp A' Q.
not_eqp C' P.

hexamy_proof  A A' P C C' Q A Q C' A' P C.

cases_line x8 x9.
intuition.
cases_point A Q.
rewrite <-a in *.
destruct H54;exists x8;intuition.
assumption.

cases_line x9 x10.
intuition.
cases_point A' P.
rewrite <-a in *.
destruct H51;exists x11;intuition.
assumption.

cases_line x10 x11.
intuition.
cases_point P C.
rewrite <-a in *.
destruct H55;exists x10;intuition.
assumption.

cases_line x8 x9.
intuition.
cases_point C' Q.
rewrite <-a in *.
destruct H53;exists x9;intuition.
assumption.

cases_line x10 x11.
intuition.
cases_point P C.
rewrite <-a in *.
destruct H55;exists x10;intuition.
assumption.

cases_line x8 x9.
intuition.
cases_point Q A.
rewrite <-a in *.
destruct H54;exists x8;intuition.
assumption.

cases_line x9 x10.
intuition.
cases_point A' P.
rewrite <-a in *.
destruct H51;exists x11;intuition.
assumption.

cases_line x8 x9.
intuition.
cases_point C' Q.
rewrite <-a in *.
destruct H53;exists x9;intuition.
assumption.
Qed.

(* hexamy_desargues_no_cevian except in B : same proof that in B' *)

Lemma hexamy_desargues_no_cevian_1pt_B :
  hexamy ->
  forall O A B C A' B' C' I J K P Q,
  line A B <> line B C ->
  line A' B' <>  line B' C' ->
  line A' B' <> line A B ->
  line B' C' <> line B C ->
  line O A <> line O C ->
  line A' C' <> line A C ->
  ~O[==]A -> ~O[==]B -> ~O[==]C ->
  ~O[==]A' -> ~O[==]B' -> ~O[==]C' ->
  ~O[==]I -> ~O[==]J -> ~O[==]K ->
  ~A[==]B -> ~A[==]C ->
  ~A[==]A' -> ~A[==]B' -> ~A[==]C' ->
  ~A[==]I -> ~A[==]J -> ~A[==]K ->
  ~B[==]C ->
  ~B[==]A' -> ~B[==]B' -> ~B[==]C' ->
  ~B[==]I -> ~B[==]J -> ~B[==]K ->
  ~C[==]A' -> ~C[==]B' -> ~C[==]C' ->
  ~C[==]I -> ~C[==]J -> ~C[==]K ->
  ~A'[==]B' -> ~A'[==]C' ->
  ~A'[==]I -> ~A'[==]J -> ~A'[==]K ->
  ~B'[==]C' ->
  ~B'[==]I -> ~B'[==]J -> ~B'[==]K ->
  ~C'[==]I -> ~C'[==]J -> ~C'[==]K ->
  ~I[==]J -> ~I[==]K ->
  ~J[==]K ->

  ~ Col A' B C ->
  Col B A' C' ->
  ~ Col C' A B ->
  ~ Col A B' C' ->
  ~ Col C A' B' ->

  Col P B C ->
  Col P A' B' ->
  Col Q A B ->
  Col Q B' C' ->

  Col O A A' ->
  Col O B B' ->
  Col O C C' ->
  Col A' C' I ->
  Col A C I ->
  Col A B J ->
  Col A' B' J ->
  Col B C K ->
  Col B' C' K ->
  Col I J K.
Proof.
intros.

geo_norm.
remove_line_occ.
Collapse3.
not_eqp P Q.
not_eqp A P.
not_eqp C Q.
not_eqp A' Q.
not_eqp C' P.

hexamy_proof  A A' P C C' Q A Q C' A' P C.

cases_line x8 x9.
intuition.
cases_point A Q.
rewrite <-a in *.
destruct H54;exists x8;intuition.
assumption.

cases_line x9 x10.
intuition.
cases_point A' P.
rewrite <-a in *.
destruct H51;exists x11;intuition.
assumption.

cases_line x10 x11.
intuition.
cases_point P C.
rewrite <-a in *.
destruct H55;exists x10;intuition.
assumption.

cases_line x8 x9.
intuition.
cases_point C' Q.
rewrite <-a in *.
destruct H53;exists x9;intuition.
assumption.

cases_line x10 x11.
intuition.
cases_point P C.
rewrite <-a in *.
destruct H55;exists x10;intuition.
assumption.

cases_line x8 x9.
intuition.
cases_point Q A.
rewrite <-a in *.
destruct H54;exists x8;intuition.
assumption.

cases_line x9 x10.
intuition.
cases_point A' P.
rewrite <-a in *.
destruct H51;exists x11;intuition.
assumption.

cases_line x8 x9.
intuition.
cases_point C' Q.
rewrite <-a in *.
destruct H53;exists x9;intuition.
assumption.
Qed.

(* hexamy_desargues_no_cevian except in A' *)

Lemma hexamy_desargues_no_cevian_1pt_A' :
  hexamy ->
  forall O B A C B' A' C' I J K P Q,
  line B A <> line A C ->
  line B' A' <>  line A' C' ->
  line B' A' <> line B A ->
  line A' C' <> line A C ->
  line O B <> line O C ->
  line B' C' <> line B C ->
  ~O[==]A -> ~O[==]B -> ~O[==]C ->
  ~O[==]A' -> ~O[==]B' -> ~O[==]C' ->
  ~O[==]I -> ~O[==]J -> ~O[==]K ->
  ~A[==]B -> ~A[==]C ->
  ~A[==]A' -> ~A[==]B' -> ~A[==]C' ->
  ~A[==]I -> ~A[==]J -> ~A[==]K ->
  ~B[==]C ->
  ~B[==]A' -> ~B[==]B' -> ~B[==]C' ->
  ~B[==]I -> ~B[==]J -> ~B[==]K ->
  ~C[==]A' -> ~C[==]B' -> ~C[==]C' ->
  ~C[==]I -> ~C[==]J -> ~C[==]K ->
  ~A'[==]B' -> ~A'[==]C' ->
  ~A'[==]I -> ~A'[==]J -> ~A'[==]K ->
  ~B'[==]C' ->
  ~B'[==]I -> ~B'[==]J -> ~B'[==]K ->
  ~C'[==]I -> ~C'[==]J -> ~C'[==]K ->
  ~I[==]J -> ~I[==]K ->
  ~J[==]K ->

   Col A' B C ->
  ~ Col B' A C ->
  ~ Col C' A B ->
  ~ Col B A' C' ->
  ~ Col C A' B' ->

  Col P A C ->
  Col P B' A' ->
  Col Q B A ->
  Col Q A' C' ->

  Col O A A' ->
  Col O B B' ->
  Col O C C' ->
  Col B' C' I ->
  Col B C I ->
  Col A B J ->
  Col A' B' J ->
  Col A C K ->
  Col A' C' K ->
  Col I J K.
Proof.
intros HH O A B C A' B' C' I J K P Q.
assert(HH0 := hexamy_desargues_no_cevian_1pt_B' HH O A B C A' B' C' I J K P Q).
intros.
apply HH0;try assumption.
intuition.
intuition.
intuition.
intuition.
intuition.
intuition.
Qed.

(* hexamy_desargues_no_cevian except in A *)

Lemma hexamy_desargues_no_cevian_1pt_A :
  hexamy ->
  forall O B A C B' A' C' I J K P Q,
  line B A <> line A C ->
  line B' A' <>  line A' C' ->
  line B' A' <> line B A ->
  line A' C' <> line A C ->
  line O B <> line O C ->
  line B' C' <> line B C ->
  ~O[==]A -> ~O[==]B -> ~O[==]C ->
  ~O[==]A' -> ~O[==]B' -> ~O[==]C' ->
  ~O[==]I -> ~O[==]J -> ~O[==]K ->
  ~A[==]B -> ~A[==]C ->
  ~A[==]A' -> ~A[==]B' -> ~A[==]C' ->
  ~A[==]I -> ~A[==]J -> ~A[==]K ->
  ~B[==]C ->
  ~B[==]A' -> ~B[==]B' -> ~B[==]C' ->
  ~B[==]I -> ~B[==]J -> ~B[==]K ->
  ~C[==]A' -> ~C[==]B' -> ~C[==]C' ->
  ~C[==]I -> ~C[==]J -> ~C[==]K ->
  ~A'[==]B' -> ~A'[==]C' ->
  ~A'[==]I -> ~A'[==]J -> ~A'[==]K ->
  ~B'[==]C' ->
  ~B'[==]I -> ~B'[==]J -> ~B'[==]K ->
  ~C'[==]I -> ~C'[==]J -> ~C'[==]K ->
  ~I[==]J -> ~I[==]K ->
  ~J[==]K ->

   Col A B' C' ->
  ~ Col B' A C ->
  ~ Col C' A B ->
  ~ Col B A' C' ->
  ~ Col C A' B' ->

  Col P A C ->
  Col P B' A' ->
  Col Q B A ->
  Col Q A' C' ->

  Col O A A' ->
  Col O B B' ->
  Col O C C' ->
  Col B' C' I ->
  Col B C I ->
  Col A B J ->
  Col A' B' J ->
  Col A C K ->
  Col A' C' K ->
  Col I J K.
Proof.
intros HH O A B C A' B' C' I J K P Q.
assert(HH0 := hexamy_desargues_no_cevian_1pt_B HH O A B C A' B' C' I J K P Q).
intros.
apply HH0;try assumption.
intuition.
intuition.
intuition.
intuition.
intuition.
intuition.
Qed.

(* hexamy_desargues_no_cevian except in C' *)

Lemma hexamy_desargues_no_cevian_1pt_C' :
  hexamy ->
  forall O A C B A' C' B' I J K P Q,
  line A C <> line C B ->
  line A' C' <>  line C' B' ->
  line A' C' <> line A C ->
  line C' B' <> line C B ->
  line O A <> line O B ->
  line A' B' <> line A B ->
  ~O[==]A -> ~O[==]B -> ~O[==]C ->
  ~O[==]A' -> ~O[==]B' -> ~O[==]C' ->
  ~O[==]I -> ~O[==]J -> ~O[==]K ->
  ~A[==]B -> ~A[==]C ->
  ~A[==]A' -> ~A[==]B' -> ~A[==]C' ->
  ~A[==]I -> ~A[==]J -> ~A[==]K ->
  ~B[==]C ->
  ~B[==]A' -> ~B[==]B' -> ~B[==]C' ->
  ~B[==]I -> ~B[==]J -> ~B[==]K ->
  ~C[==]A' -> ~C[==]B' -> ~C[==]C' ->
  ~C[==]I -> ~C[==]J -> ~C[==]K ->
  ~A'[==]B' -> ~A'[==]C' ->
  ~A'[==]I -> ~A'[==]J -> ~A'[==]K ->
  ~B'[==]C' ->
  ~B'[==]I -> ~B'[==]J -> ~B'[==]K ->
  ~C'[==]I -> ~C'[==]J -> ~C'[==]K ->
  ~I[==]J -> ~I[==]K ->
  ~J[==]K ->

  ~ Col A' B C ->
  Col C' A B ->
  ~ Col B' A C ->
  ~ Col A B' C' ->
  ~ Col B A' C' ->

  Col P C B ->
  Col P A' C' ->
  Col Q A C ->
  Col Q C' B' ->

  Col O A A' ->
  Col O B B' ->
  Col O C C' ->
  Col A' B' I ->
  Col A B I ->
  Col A C J ->
  Col A' C' J ->
  Col B C K ->
  Col B' C' K ->
  Col I J K.
Proof.
intros HH O A B C A' B' C' I J K P Q.
assert(HH0 := hexamy_desargues_no_cevian_1pt_B' HH O A B C A' B' C' I J K P Q).
intros.
apply HH0;try assumption.
intuition.
intuition.
intuition.
intuition.
intuition.
intuition.
Qed.

(* hexamy_desargues_no_cevian except in C *)

Lemma hexamy_desargues_no_cevian_1pt_C :
  hexamy ->
  forall O A C B A' C' B' I J K P Q,
  line A C <> line C B ->
  line A' C' <>  line C' B' ->
  line A' C' <> line A C ->
  line C' B' <> line C B ->
  line O A <> line O B ->
  line A' B' <> line A B ->
  ~O[==]A -> ~O[==]B -> ~O[==]C ->
  ~O[==]A' -> ~O[==]B' -> ~O[==]C' ->
  ~O[==]I -> ~O[==]J -> ~O[==]K ->
  ~A[==]B -> ~A[==]C ->
  ~A[==]A' -> ~A[==]B' -> ~A[==]C' ->
  ~A[==]I -> ~A[==]J -> ~A[==]K ->
  ~B[==]C ->
  ~B[==]A' -> ~B[==]B' -> ~B[==]C' ->
  ~B[==]I -> ~B[==]J -> ~B[==]K ->
  ~C[==]A' -> ~C[==]B' -> ~C[==]C' ->
  ~C[==]I -> ~C[==]J -> ~C[==]K ->
  ~A'[==]B' -> ~A'[==]C' ->
  ~A'[==]I -> ~A'[==]J -> ~A'[==]K ->
  ~B'[==]C' ->
  ~B'[==]I -> ~B'[==]J -> ~B'[==]K ->
  ~C'[==]I -> ~C'[==]J -> ~C'[==]K ->
  ~I[==]J -> ~I[==]K ->
  ~J[==]K ->

  ~ Col A' B C ->
  Col C A' B' ->
  ~ Col B' A C ->
  ~ Col A B' C' ->
  ~ Col B A' C' ->

  Col P C B ->
  Col P A' C' ->
  Col Q A C ->
  Col Q C' B' ->

  Col O A A' ->
  Col O B B' ->
  Col O C C' ->
  Col A' B' I ->
  Col A B I ->
  Col A C J ->
  Col A' C' J ->
  Col B C K ->
  Col B' C' K ->
  Col I J K.
Proof.
intros HH O A B C A' B' C' I J K P Q.
assert(HH0 := hexamy_desargues_no_cevian_1pt_B HH O A B C A' B' C' I J K P Q).
intros.
apply HH0;try assumption.
intuition.
intuition.
intuition.
intuition.
intuition.
intuition.
Qed.

(* hexamy_desargues_near_cevian_case except in A *)

Lemma desargues_near_cevian_case_1pt_A :
 hexamy ->
 forall O A B C A' B' C' P Q R PI,
  line A B <> line B C ->
  line A' B' <>  line B' C' ->
  line A' B' <> line A B ->
  line B' C' <> line B C ->
  line O A <> line O C ->
  line A' C' <> line A C ->
  ~A[==]B   -> ~B[==]C -> ~A[==]C ->
  ~A'[==]B'  -> ~B'[==]C' -> ~A'[==]C' ->
  ~A[==]A' -> ~B[==]B' -> ~C[==]C' ->
  ~O[==]A -> ~O[==]B -> ~O[==]C ->
  ~O[==]A' -> ~O[==]B' -> ~O[==]C' ->
  PI = inter (line O B) (line P Q) ->
  A' <> inter (line A' C') (line A PI) ->
  Col O A A' ->
  Col O B B' ->
  Col O C C' ->
  Col A' C' Q ->
  Col A C Q ->
  Col A B P ->
  Col A' B' P ->
  Col B C R ->
  Col B' C' R ->

  Col B' A C ->
  Col C' A B ->

  forall II, Col O B II -> Col P Q II -> O<>II ->
  Col P Q R.
Proof.
intro hexa;
intros.
geo_norm.
remove_line_occ.
elim (eq_dec_u P Q);intros.
rewrite <-a;create_line P R lPR;firstorder.

create_inter P Q B C R1.
create_inter P Q B' C' R2.
assert (R1 [==] R2).

create_inter A' C' A II L.
not_eqp L B'.
create_inter A B L B' N.
not_eqp A L.
create_inter A L C C' M.
Collapse3.
remove_line_occ.
assert (Col L N B') by firstorder.

not_eqp II A.

not_eqp P A'.
not_eql l8 l7.
not_eqp A P.
not_eqp B' II.

not_eqp P II.
not_eql l0 l3.

not_eqp Q C.

not_eqp II Q.
(*not_eql l10 l9.*)

not_eqp O Q.
not_eql l2 l3.

not_eqp B' Q.
not_eqp II L.

not_eqp_4 L B' A P.
not_eqp_4 B' II P A'.
not_eqp_4 II A A' L.

not_eqp_4 P II L A'.
not_eqp_4 II B' A' A.

not_eqp A II.
not_eqp A' II.
not_eqp L P.
not_eqp B' P.
not_eqp B' A.

not_eqp A' L.

assert (Col O N Q) by
 hexamy_proof A' L B' II A P A' A P II B' L.

geo_norm;Collapse3.

not_eql x l7.
not_eql x l5.
not_eql x x0.
not_eqp C II.
not_eqp B II.
not_eqp B Q.
not_eqp A Q.

not_eqp_4 C B O II.
not_eqp_4 B A II Q.
not_eqp_4 A O Q C.

not_eqp_4 C O II A.
not_eqp_4 O Q A B.
not_eqp_4 Q II B C.

assert (Col R1 M N) by
  hexamy_proof C B A O II Q C O Q II A B.

geo_norm.

not_eqp C' Q.
not_eqp C' II.
not_eqp Q L.
not_eqp O L.

not_eqp_4 C' B' O II.
not_eqp_4 B' Q II L.
not_eqp_4 Q O L C'.
not_eqp_4 C' O II L.
not_eqp_4 O Q L B'.
not_eqp_4 Q II B' C'.

not_eqp L C'.

assert (Col R2 M N) by
  hexamy_proof C' B' Q O II L C' O Q II L B'.

geo_norm.

cases_line x1 x2.
Collapse_no_hyps.
reflexivity.

Collapse3.
Collapse_no_hyps.
Collapse_no_hyps.
Collapse_no_hyps.
solve[intuition].

rewrite H74 in *.
geo_norm;Collapse3;solve_col.
Qed.

(* hexamy_desargues_near_cevian_case except in B *)

Lemma desargues_near_cevian_case_1pt_B :
 hexamy ->
 forall O B C A B' C' A' P Q R PI,
  line B C <> line C A ->
  line B' C' <>  line C' A' ->
  line B' C' <> line B C ->
  line C' A' <> line C A ->
  line O B <> line O A ->
  line B' A' <> line B A ->
  ~A[==]B   -> ~B[==]C -> ~A[==]C ->
  ~A'[==]B'  -> ~B'[==]C' -> ~A'[==]C' ->
  ~A[==]A' -> ~B[==]B' -> ~C[==]C' ->
  ~O[==]A -> ~O[==]B -> ~O[==]C ->
  ~O[==]A' -> ~O[==]B' -> ~O[==]C' ->
  PI = inter (line O C) (line P Q) ->
  B' <> inter (line B' A') (line B PI) ->
  Col O A A' ->
  Col O B B' ->
  Col O C C' ->
  Col B' A' Q ->
  Col B A Q ->
  Col B C P ->
  Col B' C' P ->
  Col C A R ->
  Col C' A' R ->

  Col C' B A ->
  Col A' B C ->

  forall II, Col O C II -> Col P Q II -> O<>II ->
  Col P Q R.
Proof.
intros HH O A B C A' B' C' P Q R PI.
assert(HH0 := desargues_near_cevian_case_1pt_A HH O A B C A' B' C' P Q R PI).
intros.
apply HH0 with (II := II);try assumption.
intuition.
intuition.
intuition.
intuition.
Qed.

(* hexamy_desargues_near_cevian_case except in C *)

Lemma desargues_near_cevian_case_1pt_C :
 hexamy ->
 forall O C A B C' A' B' P Q R PI,
  line C A <> line A B ->
  line C' A' <>  line A' B' ->
  line C' A' <> line C A ->
  line A' B' <> line A B ->
  line O C <> line O B ->
  line C' B' <> line C B ->
  ~A[==]B   -> ~B[==]C -> ~A[==]C ->
  ~A'[==]B'  -> ~B'[==]C' -> ~A'[==]C' ->
  ~A[==]A' -> ~B[==]B' -> ~C[==]C' ->
  ~O[==]A -> ~O[==]B -> ~O[==]C ->
  ~O[==]A' -> ~O[==]B' -> ~O[==]C' ->
  PI = inter (line O A) (line P Q) ->
  C' <> inter (line C' B') (line C PI) ->
  Col O A A' ->
  Col O B B' ->
  Col O C C' ->
  Col C' B' Q ->
  Col C B Q ->
  Col C A P ->
  Col C' A' P ->
  Col A B R ->
  Col A' B' R ->

  Col A' B C ->
  Col B' A C ->

  forall II, Col O A II -> Col P Q II -> O<>II ->
  Col P Q R.
Proof.
intros HH O A B C A' B' C' P Q R PI.
assert(HH0 := desargues_near_cevian_case_1pt_A HH O A B C A' B' C' P Q R PI).
intros.
apply HH0 with (II := II);try assumption.
intuition.
intuition.
intuition.
intuition.
intuition.
intuition.
Qed.

(* hexamy_desargues_cevian_case *)

Lemma desargues_cevian_case :
 hexamy ->
 forall O A B C A' B' C' P Q R PI,
  line A B <> line B C ->
  line A' B' <>  line B' C' ->
  line A' B' <> line A B ->
  line B' C' <> line B C ->
  line O A <> line O C ->
  line A' C' <> line A C ->
  ~A[==]B   -> ~B[==]C -> ~A[==]C ->
  ~A'[==]B'  -> ~B'[==]C' -> ~A'[==]C' ->
  ~A[==]A' -> ~B[==]B' -> ~C[==]C' ->
  ~O[==]A -> ~O[==]B -> ~O[==]C ->
  ~O[==]A' -> ~O[==]B' -> ~O[==]C' ->
  PI = inter (line O B) (line P Q) ->
  A' <> inter (line A' C') (line A PI) ->
  Col O A A' ->
  Col O B B' ->
  Col O C C' ->
  Col A' C' Q ->
  Col A C Q ->
  Col A B P ->
  Col A' B' P ->
  Col B C R ->
  Col B' C' R ->

  Col A' B C ->
  Col B' A C ->
  Col C' A B ->

  forall II, Col O B II -> Col P Q II -> O<>II ->
  Col P Q R.
Proof.
intros HH O A B C A' B' C' P Q R PI.
assert(HH0 := desargues_near_cevian_case_1pt_A HH O A B C A' B' C' P Q R PI).
intros.
apply HH0 with (II := II);try assumption.
Qed.

End s_hexamys.


Load functions.

Lemma polEmpty {Pi} (H:@formula Pi) : pol H [] = Some TT.
Proof.
  destruct H;reflexivity.
Qed.

Lemma substEmpty {Pi} (H F:@formula Pi) : subst H F [] = Some F.
Proof.
  destruct H;reflexivity.
Qed.

Lemma appInv {X Y} (f:X->Y) x b: app f x = Some b <-> exists a, x=Some a /\ b=f a.
Proof.
  unfold app.
  split.
  - intros H. destruct x.
    + exists x;split;congruence.
    + congruence.
  - intros (a&H0&H1). now subst.
Qed.

Lemma evalDestruct {Pi} (A:Pi->bool) F: eval A F = 0 \/ eval A F = 1.
Proof.
  induction F;cbn.
  all: try (destruct IHF1 as [->| ->], IHF2 as [-> | ->];cbn;tauto).
  - now left.
  - now right.
  - destruct A;tauto.
  - destruct eval;tauto.
Qed.

Lemma evalInd {Pi} (A:Pi->bool) F (p:nat->Prop): (eval A F = 0 -> p 0) -> (eval A F = 1 -> p 1) -> forall b, eval A F = b -> p b.
Proof.
  intros.
  destruct (evalDestruct A F);subst;rewrite H2;eauto.
Qed.


(** * HoareAsLogic: Hoare Logic as a Logic *)

(* $Date: 2013-07-17 16:19:11 -0400 (Wed, 17 Jul 2013) $ *)

Require Export Hoare.

(** The presentation of Hoare logic in chapter [Hoare] could be
    described as "model-theoretic": the proof rules for each of the
    constructors were presented as _theorems_ about the evaluation
    behavior of programs, and proofs of program correctness (validity
    of Hoare triples) were constructed by combining these theorems
    directly in Coq.

    Another way of presenting Hoare logic is to define a completely
    separate proof system -- a set of axioms and inference rules that
    talk about commands, Hoare triples, etc. -- and then say that a
    proof of a Hoare triple is a valid derivation in _that_ logic.  We
    can do this by giving an inductive definition of _valid
    derivations_ in this new logic. *)

Inductive hoare_proof : Assertion -> com -> Assertion -> Type :=
  | H_Skip : forall P,
      hoare_proof P (SKIP) P
  | H_Asgn : forall Q V a,
      hoare_proof (assn_sub V a Q) (V ::= a) Q
  | H_Seq  : forall P c Q d R,
      hoare_proof P c Q -> hoare_proof Q d R -> hoare_proof P (c;;d) R
  | H_If : forall P Q b c1 c2,
    hoare_proof (fun st => P st /\ bassn b st) c1 Q ->
    hoare_proof (fun st => P st /\ ~(bassn b st)) c2 Q ->
    hoare_proof P (IFB b THEN c1 ELSE c2 FI) Q
  | H_While : forall P b c,
    hoare_proof (fun st => P st /\ bassn b st) c P ->
    hoare_proof P (WHILE b DO c END) (fun st => P st /\ ~ (bassn b st))
  | H_Consequence  : forall (P Q P' Q' : Assertion) c,
    hoare_proof P' c Q' ->
    (forall st, P st -> P' st) ->
    (forall st, Q' st -> Q st) ->
    hoare_proof P c Q.

Tactic Notation "hoare_proof_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "H_Skip" | Case_aux c "H_Asgn" | Case_aux c "H_Seq"
  | Case_aux c "H_If" | Case_aux c "H_While" | Case_aux c "H_Consequence" ].

(** We don't need to include axioms corresponding to [hoare_consequence_pre]
    or [hoare_consequence_post], because these can be proven easily
    from [H_Consequence]. *)

Lemma H_Consequence_pre : forall (P Q P': Assertion) c,
    hoare_proof P' c Q ->
    (forall st, P st -> P' st) ->
    hoare_proof P c Q.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma H_Consequence_post  : forall (P Q Q' : Assertion) c,
    hoare_proof P c Q' ->
    (forall st, Q' st -> Q st) ->
    hoare_proof P c Q.
Proof.
  (* FILL IN HERE *) Admitted.

(** Now, for example, let's construct a proof object representing a
    derivation for the hoare triple
      {{assn_sub X (X+1) (assn_sub X (X+2) (X=3))}} X::=X+1;; X::=X+2 {{X=3}}.
    We can use Coq's tactics to help us construct the proof object. *)

Example sample_proof
             : hoare_proof
                 (assn_sub X (APlus (AId X) (ANum 1))
                   (assn_sub X (APlus (AId X) (ANum 2))
                     (fun st => st X = 3) ))
                 (X ::= APlus (AId X) (ANum 1);; (X ::= APlus (AId X) (ANum 2)))
                 (fun st => st X = 3).
Proof.
  eapply H_Seq; apply H_Asgn.
Qed.

(*
Print sample_proof.
====>
  H_Seq
    (assn_sub X (APlus (AId X) (ANum 1))
       (assn_sub X (APlus (AId X) (ANum 2)) (fun st : state => st X = VNat 3)))
    (X ::= APlus (AId X) (ANum 1))
    (assn_sub X (APlus (AId X) (ANum 2)) (fun st : state => st X = VNat 3))
    (X ::= APlus (AId X) (ANum 2)) (fun st : state => st X = VNat 3)
    (H_Asgn
       (assn_sub X (APlus (AId X) (ANum 2)) (fun st : state => st X = VNat 3))
       X (APlus (AId X) (ANum 1)))
    (H_Asgn (fun st : state => st X = VNat 3) X (APlus (AId X) (ANum 2)))
*)

(** **** Exercise: 2 stars (hoare_proof_sound) *)
(** Prove that such proof objects represent true claims. *)

Theorem hoare_proof_sound : forall P c Q,
  hoare_proof P c Q -> {{P}} c {{Q}}.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** We can also use Coq's reasoning facilities to prove metatheorems
    about Hoare Logic.  For example, here are the analogs of two
    theorems we saw in chapter [Hoare] -- this time expressed in terms
    of the syntax of Hoare Logic derivations (provability) rather than
    directly in terms of the semantics of Hoare triples.

    The first one says that, for every [P] and [c], the assertion
    [{{P}} c {{True}}] is _provable_ in Hoare Logic.  Note that the
    proof is more complex than the semantic proof in [Hoare]: we
    actually need to perform an induction over the structure of the
    command [c]. *)

Theorem H_Post_True_deriv:
  forall c P, hoare_proof P c (fun _ => True).
Proof.
  intro c.
  com_cases (induction c) Case; intro P.
  Case "SKIP".
    eapply H_Consequence.
    apply H_Skip.
    intros. apply H.
    (* Proof of True *)
    intros. apply I.
  Case "::=".
    eapply H_Consequence_pre.
    apply H_Asgn.
    intros. apply I.
  Case ";;".
    eapply H_Consequence_pre.
    eapply H_Seq.
    apply (IHc1 (fun _ => True)).
    apply IHc2.
    intros. apply I.
  Case "IFB".
    apply H_Consequence_pre with (fun _ => True).
    apply H_If.
    apply IHc1.
    apply IHc2.
    intros. apply I.
  Case "WHILE".
    eapply H_Consequence.
    eapply H_While.
    eapply IHc.
    intros; apply I.
    intros; apply I.
Qed.

(** Similarly, we can show that [{{False}} c {{Q}}] is provable for
    any [c] and [Q]. *)

Lemma False_and_P_imp: forall P Q,
  False /\ P -> Q.
Proof.
  intros P Q [CONTRA HP].
  destruct CONTRA.
Qed.

Tactic Notation "pre_false_helper" constr(CONSTR) :=
  eapply H_Consequence_pre;
    [eapply CONSTR | intros ? CONTRA; destruct CONTRA].

Theorem H_Pre_False_deriv:
  forall c Q, hoare_proof (fun _ => False) c Q.
Proof.
  intros c.
  com_cases (induction c) Case; intro Q.
  Case "SKIP". pre_false_helper H_Skip.
  Case "::=". pre_false_helper H_Asgn.
  Case ";;". pre_false_helper H_Seq. apply IHc1. apply IHc2.
  Case "IFB".
    apply H_If; eapply H_Consequence_pre.
    apply IHc1. intro. eapply False_and_P_imp.
    apply IHc2. intro. eapply False_and_P_imp.
  Case "WHILE".
    eapply H_Consequence_post.
    eapply H_While.
    eapply H_Consequence_pre.
      apply IHc.
      intro. eapply False_and_P_imp.
    intro. simpl. eapply False_and_P_imp.
Qed.

(** As a last step, we can show that the set of [hoare_proof] axioms is
    sufficient to prove any true fact about (partial) correctness.
    More precisely, any semantic Hoare triple that we can prove can
    also be proved from these axioms.  Such a set of axioms is said
    to be _relatively complete_. *)

(** This proof is inspired by the one at
http://www.ps.uni-saarland.de/courses/sem-ws11/script/Hoare.html
*)

(** To prove this fact, we'll need to invent some intermediate
    assertions using a technical device known as _weakest preconditions_.
    Given a command [c] and a desired postcondition assertion [Q],
    the weakest precondition [wp c Q] is an assertion [P] such that
    [{{P}} c {{Q}}] holds, and moreover, for any other assertion [P'],
    if [{{P'}} c {{Q}}] holds then [P' -> P].  We can more directly
    define this as follows: *)

Definition wp (c:com) (Q:Assertion) : Assertion :=
  fun s => forall s', c / s || s' -> Q s'.

(** **** Exercise: 1 star (wp_is_precondition) *)

Lemma wp_is_precondition: forall c Q,
  {{wp c Q}} c {{Q}}.
(* FILL IN HERE *) Admitted.

(** **** Exercise: 1 star (wp_is_weakest) *)

Lemma wp_is_weakest: forall c Q P',
   {{P'}} c {{Q}} -> forall st, P' st -> wp c Q st.
(* FILL IN HERE *) Admitted.

(** The following utility lemma will also be useful. *)

Lemma bassn_eval_false : forall b st, ~ bassn b st -> beval st b = false.
Proof.
  intros b st H. unfold bassn in H. destruct (beval st b).
    exfalso. apply H. reflexivity.
    reflexivity.
Qed.

(** **** Exercise: 4 stars (hoare_proof_complete) *)
(** Complete the proof of the theorem. *)

Theorem hoare_proof_complete: forall P c Q,
  {{P}} c {{Q}} -> hoare_proof P c Q.
Proof.
  intros P c. generalize dependent P.
  com_cases (induction c) Case; intros P Q HT.
  Case "SKIP".
    eapply H_Consequence.
     eapply H_Skip.
      intros.  eassumption.
      intro st. apply HT.  apply E_Skip.
  Case "::=".
    eapply H_Consequence.
      eapply H_Asgn.
      intro st. apply HT. econstructor. reflexivity.
      intros; assumption.
  Case ";;".
    apply H_Seq with (wp c2 Q).
     eapply IHc1.
       intros st st' E1 H. unfold wp. intros st'' E2.
         eapply HT. econstructor; eassumption. assumption.
     eapply IHc2. intros st st' E1 H. apply H; assumption.
  (* FILL IN HERE *) Admitted.

(** Finally, we might hope that our axiomatic Hoare logic is _decidable_;
    that is, that there is an (terminating) algorithm (a _decision procedure_)
    that can determine  whether or not a given Hoare triple is valid (derivable).
    But such a decision procedure cannot exist!

    Consider the triple [{{True}} c {{False}}]. This triple is valid
    if and only if [c] is non-terminating.  So any algorithm that could
    determine validity of arbitrary triples could solve the Halting Problem.

    Similarly, the triple [{{True} SKIP {{P}}] is valid if and only if
    [forall s, P s] is valid, where [P] is an arbitrary assertion of Coq's
    logic. But it is known that there can be no decision procedure for
    this logic.

*)

(** Overall, this axiomatic style of presentation gives a clearer picture of what it
    means to "give a proof in Hoare logic."  However, it is not
    entirely satisfactory from the point of view of writing down such
    proofs in practice: it is quite verbose.  The section of chapter
    [Hoare2] on formalizing decorated programs shows how we can do even
    better. *)


(** * Conditional weakest pre-expectation (cwp) semantics for the cpGCL. *)

Set Implicit Arguments.
From Coq Require Import
  Basics
  Nat
  QArith
  Reals
  List
  Lia
  Lra
  Equivalence
.

Local Open Scope program_scope.
Local Open Scope equiv_scope.

From zar Require Import
  cpGCL
  cpo
  misc
  order
  eR
  tactics
.

Local Open Scope order_scope.
Local Open Scope eR_scope.

Create HintDb cwp.

(** [f] is an expectation. *)
Definition expectation {A} : Type := A -> eR.

(** [f] is a bounded expectation (bounded above by constant [b]). *)
Definition bounded {A : Type} (f : A -> eR) (b : eR) := forall x, f x <= b.

Fixpoint loop_approx {A}
  (e : A -> bool) (g : (A -> eR) -> A -> eR) (f : A -> eR) (n : nat) : A -> eR :=
  match n with
  | O => fun st => 0
  | S n' => fun st => if e st then g (loop_approx e g f n') st else f st
  end.

Fixpoint dec_loop_approx {A}
  (e : A -> bool) (g : (A -> eR) -> A -> eR) (f : A -> eR) (n : nat) : A -> eR :=
  match n with
  | O => fun st => 1
  | S n' => fun st => if e st then g (dec_loop_approx e g f n') st else f st
  end.

(* (* The continuous loop automorphism. *) *)
(* Definition loop_F {A} (e : St -> bool) (g : (St -> A) -> St -> A) (f : St -> A) *)
(*   : (St -> A) -> St -> A := *)
(*   fun k s => if e s then g k s else f s. *)

(* The continuous loop automorphism. *)
Definition loop_F {A B} (e : A -> bool) (g : (A -> B) -> A -> B) (f : A -> B)
  : (A -> B) -> A -> B :=
  fun k s => if e s then g k s else f s.

Definition loop_approx' {A}
  (e : A -> bool) (g : (A -> eR) -> A -> eR) (f : A -> eR) (n : nat) : A -> eR :=
  iter_n (loop_F e g f) (const 0) n.

Definition loop_approx'' {A}
  (e : A -> bool) (g : (A -> eR) -> A -> eR) (f : A -> eR) (n : nat) : A -> eR :=
  iter_n (loop_F e g f) (fun s => if e s then 0 else f s) n.

Definition dec_loop_approx'
  (e : St -> bool) (g : (St -> eR) -> St -> eR) (f : St -> eR) (n : nat) : St -> eR :=
  iter_n (loop_F e g f) (const 1) n.

Lemma monotone_loop_F {A} `{OType A}
  (e : St -> bool) (g : (St -> A) -> St -> A) (f : St -> A) :
  monotone g ->
  monotone (loop_F e g f).
Proof.
  unfold loop_F; intros Hg x y Hxy s;
    destruct (e s); try reflexivity; apply Hg; auto.
Qed.
#[global] Hint Resolve monotone_loop_F : cwp.

Lemma monotone_loop_F' {A B} `{OType A} (e : B -> bool) F f f' g g' :
  monotone F ->
  f ⊑ f' ->
  g ⊑ g' ->
  loop_F e F f g ⊑ loop_F e F f' g'.
Proof.
  intros HF Hf Hg s.
  unfold loop_F.
  destruct (e s).
  - apply HF; auto.
  - apply Hf.
Qed.

Lemma loop_approx_loop_approx' {A}
  (e : A -> bool) (g : (A -> eR) -> A -> eR) (f : A -> eR) :
  loop_approx e g f = loop_approx' e g f.
Proof.
  unfold loop_approx', loop_F.
  ext n; revert e g f; induction n; intros e g f; simpl; auto.
  ext s; destruct (e s); auto.
  rewrite IHn; auto.
Qed.

Lemma dec_loop_approx_dec_loop_approx'
  (e : St -> bool) (g : (St -> eR) -> St -> eR) (f : St -> eR) :
  dec_loop_approx e g f = dec_loop_approx' e g f.
Proof.
  unfold dec_loop_approx', loop_F.
  ext n; revert e g f; induction n; intros e g f; simpl; auto.
  ext s; destruct (e s); auto.
  rewrite IHn; auto.
Qed.

Corollary loop_approx_iter_n_loop_F {A}
  (e : A -> bool) (g : (A -> eR) -> A -> eR) (f : A -> eR) :
  loop_approx e g f = iter_n (loop_F e g f) (const 0).
Proof. apply loop_approx_loop_approx'. Qed.

Corollary dec_loop_approx_iteR_n_loop_F
  (e : St -> bool) (g : (St -> eR) -> St -> eR) (f : St -> eR) :
  dec_loop_approx e g f = iter_n (loop_F e g f) (const 1).
Proof. apply dec_loop_approx_dec_loop_approx'. Qed.

(** 4 possible configurations. Can draw square sort of like political
    compass thing. *)

Fixpoint wp_ (fl : bool) (c : cpGCL) (f : St -> eR) (st : St) : eR :=
  match c with
  | CSkip => f st
  | CAbort => 0
  | CAssign x e => f (upd x (e st) st)
  | CSeq c1 c2 => wp_ fl c1 (wp_ fl c2 f) st
  | CIte e c1 c2 => if e st then wp_ fl c1 f st else wp_ fl c2 f st
  | CChoice e k =>
      Q2eR (e st) * wp_ fl (k true) f st + (1 - Q2eR (e st)) * wp_ fl (k false) f st
  | CUniform e k =>
      sum (map (fun i => wp_ fl (k i) f st / INeR (e st)) (range (e st)))
  | CWhile e body => iter (loop_F e (wp_ fl body) f) (const 0) st
  | CObserve e => if e st then f st else if fl then 1 else 0
  end.

Definition wp : cpGCL -> (St -> eR) -> St -> eR := wp_ false.
Definition wpfail : cpGCL -> (St -> eR) -> St -> eR := wp_ true.
Definition fail (c : cpGCL) : St -> eR := wpfail c (const 0).

Fixpoint wlp_ (fl : bool) (c : cpGCL) (f : St -> eR) (st : St) : eR :=
  match c with
  | CSkip => f st
  | CAbort => 1
  | CAssign x e => f (upd x (e st) st)
  | CSeq c1 c2 => wlp_ fl c1 (wlp_ fl c2 f) st
  | CIte e c1 c2 => if e st then wlp_ fl c1 f st else wlp_ fl c2 f st
  | CChoice e k =>
      Q2eR (e st) * wlp_ fl (k true) f st + (1 - Q2eR (e st)) * wlp_ fl (k false) f st
  | CUniform e k =>
      sum (map (fun i => wlp_ fl (k i) f st / INeR (e st)) (range (e st)))
  | CWhile e body => dec_iter (loop_F e (wlp_ fl body) f) (const 1) st
  | CObserve e => if e st then f st else if fl then 1 else 0
  end.

Definition wlp : cpGCL -> (St -> eR) -> St -> eR := wlp_ false.
Definition wlpfail : cpGCL -> (St -> eR) -> St -> eR := wlp_ true.
Definition fail_or_diverge (c : cpGCL) : St -> eR := wlpfail c (const 0).

Definition cwp (c : cpGCL) (f : St -> eR) (st : St) : eR :=
  wp c f st / wlp c (const 1) st.

(** In unconditional setting, wp and wlp have the following nice properties:
    1) wp is strict on 0,
    2) wlp is strict on 1,
    3) wp + wlp = 1 on bounded expectations.

    In conditional setting, wp is still strict on 0 but the other two
    properties are lost. We present two different ways to restore the
    desired properties and examine their relative merits. There's no
    reason to use one to the exclusion of the other, so we may as well
    introduce both and use whichever is most convenient.

    Wpfail bundles failure with wp in a least fixed point construction,
    and wlpfail bundles failure along with wlp (which itself bundles
    nontermination with wp) in a greatest fixed point construction.

    Both wpfail and wlpfail yield their own versions of the invariant
    sum property:
    [ wpfail + wlp = 1 on bounded expectations ]
    [ wp + wlpfail = 1 on bounded expectations ]

    Which one, if either, is better? Differences:
    1) Wlpfail makes it hard to separate nontermination and observation
       failure. Wpfail makes probability of failure easy: [wpfail (const 0)].
       In contrast, [wlpfail (const 0)] computes the sum of nontermination
       and failure probabilities, which can be used to place an upper bound
       on either one of them but can't be used to determine either one
       exactly (unless the other is known).
    2) Wpfail is not strict on 0. This seems to suggest, along with wlp
       also being not strict on 1, that something may be deeply wrong with
       this option. However, wlpfail *is* strict on 1.
 *)

(* Reveals the geometric (i.i.d.) structure of the condition loop, and
   clearly expresses the fact that the semantics is undefined for
   programs that condition on impossible events (probability of
   observation failure is 1). *)
(* Definition cwp' (c : cpGCL) (f : St -> eR) (st : St) : eR := *)
(*   wp c f st / (1 - fail c st). *)

(** [unroll e c i] is the ith finite unrolling of the loop with guard
    condition [e] and body [c]. *)
Fixpoint unroll (e : St -> bool) (c : cpGCL) (i : nat) : cpGCL :=
  match i with
  | O => CIte e CAbort CSkip
  | S i' => CIte e (CSeq c (unroll e c i')) CSkip
  end.

Lemma chain_iter_n'' {A B} `{OType B} s z (e : A -> bool) g f :
  z ⊑ f ->
  z ⊑ g z ->
  monotone g ->
  chain (fun i => iter_n (fun (k : A -> B) (x : A) =>
                            if e x then g k x else f x) z i s).
Proof.
  intros Hzf Hzg Hg; apply monotone_chain.
  2: { apply chain_id. }
  intros i j Hij; simpl.
  revert s; apply leq_arrow, chain_leq; auto; apply chain_iter_n'.
  + unfold const; simpl; intro s; destr; auto.
  + intros h h' Hh s; destr; try reflexivity; apply Hg; auto.
Qed.

Lemma dec_chain_iter_n'' {A B} `{OType B} s z (e : A -> bool) g f :
  f ⊑ z ->
  g z ⊑ z ->
  monotone g ->
  dec_chain (fun i => iter_n (fun (k : A -> B) (x : A) =>
                                if e x then g k x else f x) z i s).
Proof.
  intros Hzf Hzg Hg.
  replace (fun i : nat => iter_n (fun (k : A -> B) (x : A) =>
                                    if e x then g k x else f x) z i s)
    with ((fun i => iter_n (fun (k : A -> B) (x : A) =>
                              if e x then g k x else f x) z i s) ∘ id)
    by reflexivity.
  apply antimonotone_dec_chain.
  2: { apply chain_id. }
  intros i j Hij; simpl; unfold flip.
  revert s; apply leq_arrow, dec_chain_leq; auto; apply dec_chain_iter_n'.
  + unfold const; simpl; intro s; destr; auto.
  + intros h h' Hh s; destr; try reflexivity; apply Hg; auto.
Qed.

Lemma monotone_wlp (b : bool) (c : cpGCL) : monotone (wlp_ b c).
Proof.
  induction c; intros f f' Hf st; simpl.
  - apply Hf.
  - eRauto.
  - eRauto.
  - apply IHc1, IHc2; auto.
  - destruct (b0 st).
    + apply IHc1; auto.
    + apply IHc2; auto.
  - apply eRplus_le_compat; apply eRmult_le_compat_l; try apply H; eRauto.
  - apply monotone_sum; eRauto.
    apply list_rel_map, Forall_list_rel, Forall_forall.
    intros i Hi; apply eRle_div, H; auto.
  - unfold dec_iter.
    rewrite 2!inf_apply_eR.
    apply leq_eRle.
    eapply pointwise_le_infimum_le.
    2: { apply inf_spec. }
    2: { apply inf_spec. }
    intro i; revert st; apply leq_arrow.
    eapply monotone_iter_n; try reflexivity.
    intros g g' Hg.
    apply monotone_loop_F'; auto.
  - destruct (b0 st); eRauto.
Qed.
#[global] Hint Resolve monotone_wlp : cwp.

Lemma bounded_wlp (b : bool) (c : cpGCL) (f : St -> eR) :
  wf_cpGCL c ->
  bounded f 1 ->
  bounded (wlp_ b c f) 1.
Proof.
  revert f; induction c; intros f Hwf Hf st; simpl; auto;
    inversion Hwf; subst; auto with cwp; auto.
  - reflexivity.
  - apply IHc1; auto.
  - destruct (b0 st).
    + apply IHc1; auto.
    + apply IHc2; auto.
  - pose proof (H false f (H3 false) Hf st) as H'.
    specialize (H true f (H3 true) Hf st).
    pose proof (H3 false) as X'.
    specialize (H3 true); eRauto.
  - replace (fun i : nat => wlp_ b (c i) f st / INeR (n st)) with
      (fun i : nat => / INeR (n st) * wlp_ b (c i) f st).
    2: { ext i; rewrite eRmult_comm; reflexivity. }
    rewrite sum_map_scalar.
    apply eRmult_le_reg_r with (r := INeR (n st)).
    + replace 0 with (INeR 0) by apply INeR_0.
      apply lt_INeR; auto.
    + apply not_infty_INeR.
    + rewrite eRmult_comm.
      rewrite <- eRmult_assoc.
      rewrite eRinv_r.
      2: { apply eRlt_neq'.
           replace 0 with (INeR 0) by apply INeR_0.
           apply lt_INeR; auto. }
      2: { apply not_infty_INeR. }
      rewrite 2!eRmult_1_l.
      replace (INeR (n st)) with (INeR (n st) * 1) by eRauto.
      replace (INeR (n st)) with (INeR (length (range (n st)))).
      2: { rewrite range_length; auto. }
      apply sum_map_ub.
      apply Forall_forall; intros i Hi.
      apply H; auto.
      (* apply in_range in Hi; eapply X; eauto. *)
  - unfold dec_iter, loop_F.
    rewrite inf_apply_eR.
    apply leq_eRle.
    apply ge_inf with O.
    reflexivity.
  - specialize (Hf st); destruct (b0 st); eRauto.
    destruct b; eRauto.
Qed.
#[global] Hint Resolve bounded_wlp : cwp.

Lemma monotone_wp (fl : bool) (c : cpGCL) : monotone (wp_ fl c).
Proof.
  induction c; intros f f' Hf st; simpl.
  - apply Hf.
  - reflexivity.
  - eRauto.
  - apply IHc1, IHc2; auto.
  - destruct (b st).
    + apply IHc1; auto.
    + apply IHc2; auto.
  - apply eRplus_le_compat.
     + apply eRmult_le_compat_l.
       * eRauto.
       * apply H; auto.
     + apply eRmult_le_compat_l.
       * eRauto.
       * apply H; auto.
  - apply sum_le, list_rel_map, Forall_list_rel.
    apply Forall_forall; intros i Hi.
    apply eRle_div, H; auto.
  - unfold iter.
    rewrite 2!sup_apply_eR.
    apply leq_eRle.
    eapply pointwise_le_supremum_le.
    2: { apply sup_spec. }
    2: { apply sup_spec. }
    intro i; revert st; apply leq_arrow.
    eapply monotone_iter_n; try reflexivity.
    intros g g' Hg.
    apply monotone_loop_F'; auto.
  - destruct (b st); eRauto.
Qed.
#[global] Hint Resolve monotone_wp : cwp.

Lemma bounded_wpfail b c f ub :
  wf_cpGCL c ->
  1 <= ub ->
  bounded f ub ->
  bounded (wp_ b c f) ub.
Proof.
  revert f; induction c; intros f Hwf Hub Hf st; simpl;
    inversion Hwf; subst; eauto with cwp.
  - eRauto.
  - apply IHc1; auto.
  - destruct (b0 st).
    + apply IHc1; auto.
    + apply IHc2; auto.
  - apply eRle_convex_sum; try apply H; eRauto.
  - replace (fun i : nat => wp_ b (c i) f st / INeR (n st)) with
      (fun i : nat => / INeR (n st) * wp_ b (c i) f st).
    2: { ext i; rewrite eRmult_comm; reflexivity. }
    rewrite sum_map_scalar.
    apply eRmult_le_reg_r with (r := INeR (n st)).
    + replace 0 with (INeR 0) by apply INeR_0.
      apply lt_INeR; auto.
    + apply not_infty_INeR.
    + rewrite eRmult_comm.
      rewrite <- eRmult_assoc.
      rewrite eRinv_r.
      2: { apply eRlt_neq'.
           replace 0 with (INeR 0) by apply INeR_0.
           apply lt_INeR; auto. }
      2: { apply not_infty_INeR. }
      rewrite eRmult_1_l.
      rewrite eRmult_comm.
      (* replace (INeR (n s)) with (INeR (n s) * 1) by eRauto. *)
      replace (INeR (n st)) with (INeR (length (range (n st)))).
      2: { rewrite range_length; auto. }
      apply sum_map_ub.
      apply Forall_forall; intros i Hi.
      apply H; auto.
      (* apply in_range in Hi; eapply X; eauto. *)
  - unfold iter, loop_F.
    rewrite sup_apply_eR.
    apply leq_eRle.
    apply ge_sup; intro i.
    replace ub with (const ub st) by reflexivity.
    apply leq_arrow.
    apply iter_n_bounded.
    { intro; unfold const; eRauto. }
    intros g Hg s'; unfold const; destr.
    + apply IHc; auto.
    + apply Hf.
  - specialize (Hf st); destruct (b0 st); eRauto.
    destruct b; eRauto.
Qed.
#[global] Hint Resolve bounded_wpfail : cwp.

Lemma wcontinuous_loop_F (e : St -> bool) (g : (St -> eR) -> St -> eR) (f : St -> eR) :
  wcontinuous g ->
  wcontinuous (loop_F e g f).
Proof.
  unfold loop_F.
  intros Hg ch Hch h Hh.
  apply supremum_apply.
  intro st.
  unfold compose.
  apply supremum_cond.
  2: { apply supremum_const. }
  replace (fun i => g (ch i) st) with (fun i => (g ∘ ch) i st) by reflexivity.
  apply apply_supremum, Hg; auto.
Qed.

Lemma dec_wcontinuous_loop_F (e : St -> bool) (g : (St -> eR) -> St -> eR) (f : St -> eR) :
  dec_wcontinuous g ->
  dec_wcontinuous (loop_F e g f).
Proof.
  unfold loop_F.
  intros Hg ch Hch h Hh.
  apply infimum_apply.
  intro st.
  unfold compose.
  apply infimum_cond.
  2: { apply infimum_const. }
  replace (fun i => g (ch i) st) with (fun i => (g ∘ ch) i st) by reflexivity.
  apply apply_infimum, Hg; auto.
Qed.

Lemma loop_approx_monotone {A} (e : A -> bool) g :
  monotone g ->
  monotone (loop_approx e g).
Proof.
  intros Hg f f' Hf i.
  revert e g Hg f f' Hf.
  induction i; intros e g Hg f f' Hf st; simpl.
  - eRauto.
  - destr; eRauto; apply Hg; auto.
Qed.

Lemma dec_loop_approx_monotone {A} (e : A -> bool) g :
  monotone g ->
  monotone (dec_loop_approx e g).
Proof.
  intros Hg f f' Hf i.
  revert e g Hg f f' Hf.
  induction i; intros e g Hg f f' Hf st; simpl.
  - eRauto.
  - destr; eRauto; apply Hg; auto.
Qed.

Lemma loop_approx_continuous {A} (e : A -> bool) g i s ch :
  chain ch ->
  monotone g ->
  (forall ch s, chain ch -> g (sup ch) s = sup (fun i => g (ch i) s)) ->
  loop_approx e g (sup ch) i s = sup (fun j => loop_approx e g (ch j) i s).
Proof.
  unfold loop_approx, loop_F.
  revert e g s ch; induction i; intros e g s ch Hch Hmono Hg; simpl.
  - apply equ_eR; rewrite sup_const; reflexivity.
  - destruct (e s) eqn:Hes.
    + rewrite <- Hg.
      * f_equal.
        ext s'.
        rewrite IHi; auto.
        rewrite sup_apply_eR; auto.
      * intros j s'.
        simpl.
        apply loop_approx_monotone; auto.
    + apply sup_apply_eR.
Qed.

Lemma dec_loop_approx_continuous {A} (e : A -> bool) g i s ch :
  dec_chain ch ->
  monotone g ->
  (forall ch s, dec_chain ch -> g (inf ch) s = inf (fun i => g (ch i) s)) ->
  dec_loop_approx e g (inf ch) i s = inf (fun j => dec_loop_approx e g (ch j) i s).
Proof.
  unfold dec_loop_approx, loop_F.
  revert e g s ch; induction i; intros e g s ch Hch Hmono Hg; simpl.
  - apply equ_eR; rewrite inf_const; reflexivity.
  - destruct (e s) eqn:Hes.
    + rewrite <- Hg.
      * f_equal.
        ext s'.
        rewrite IHi; auto.
        rewrite inf_apply_eR; auto.
      * intros j s'.
        simpl.
        apply dec_loop_approx_monotone; auto.
    + apply inf_apply_eR.
Qed.

Lemma sum_map_sup {A} (l : list A) f :
  Forall (fun a => chain (fun i : nat => f a i)) l ->
  sum (map (fun x => sup (fun i : nat => f x i)) l) =
    sup (fun i : nat => sum (map (fun x => f x i) l)).
Proof.
  revert f; induction l; intros f Hl; simpl.
  { apply equ_eR; rewrite sup_const; reflexivity. }
  inv Hl; rewrite IHl; clear IHl; auto.
  rewrite <- sup_sum; auto.
  intro i; apply monotone_sum; eRauto.
  apply list_rel_map, Forall_list_rel.
  apply Forall_forall; intros j Hj.
  eapply Forall_forall in H2; eauto; apply H2.
Qed.

Lemma sum_map_inf l f :
  Forall (fun a => dec_chain (fun i : nat => f a i)) l ->
  sum (map (fun i : nat => inf (fun j : nat => f i j)) l) =
    inf (fun x : nat => sum (map (fun i0 : nat => f i0 x) l)).
Proof.
  revert f; induction l; intros f Hl; simpl.
  { apply equ_eR; rewrite inf_const; reflexivity. }
  inv Hl; rewrite IHl; clear IHl; auto.
  rewrite <- inf_sum; auto.
  intro i; apply monotone_sum; eRauto.
  apply list_rel_map, Forall_list_rel.
  apply Forall_forall; intros j Hj.
  eapply Forall_forall in H2; eauto; apply H2.
Qed.

(** wp is continuous. *)
Theorem wp_continuous (b : bool) (c : cpGCL) (ch : nat -> St -> eR) :
  wf_cpGCL c ->
  chain ch ->
  wp_ b c (sup ch) = sup (wp_ b c ∘ ch).
Proof.
  revert ch.
  induction c; intros ch Hwf Hch; inv Hwf; unfold compose; simpl; auto.
  - symmetry.
    apply equ_f_eR, supremum_sup.
    apply supremum_const.
  - ext st.
    rename s into x.
    set (f' := fun s => upd x (e s) s).
    assert (upd x (e st) st = f' st).
    { reflexivity. }
    rewrite 2!sup_apply_eR; auto.
  - rewrite IHc2; auto.
    rewrite IHc1; auto.
    apply monotone_chain; auto with cwp.
  - ext st.
    apply equ_eR.
    rewrite sup_apply.
    + apply equ_eR.
      destruct (b0 st) eqn:Hest.
      * erewrite IHc1; eauto; apply equ_eR; rewrite sup_apply; reflexivity.
      * erewrite IHc2; eauto; apply equ_eR; rewrite sup_apply; reflexivity.
  - ext st.
    rewrite sup_apply_eR.
    rewrite 2!H; auto.
    symmetry.
    apply equ_eR.
    apply supremum_sup.
    apply supremum_sum.
    { apply chain_scalar.
      set (g := fun f => wp (c true) f st).
      replace (fun i => wp (c true) (ch i) st) with (g ∘ ch).
      - apply monotone_chain.
        + intros i j Hij; apply monotone_wp; apply chain_leq; auto.
        + apply chain_id.
      - unfold compose, g; reflexivity. }
    { apply chain_scalar.
      set (g := fun f => wp (c false) f st).
      replace (fun i => wp (c false) (ch i) st) with (g ∘ ch).
      - apply monotone_chain.
        + intros i j Hij; apply monotone_wp; apply chain_leq; auto.
        + apply chain_id.
      - unfold compose, g; reflexivity. }
    { rewrite sup_apply_eR, sup_scalar; apply sup_spec. }
    { rewrite sup_apply_eR, sup_scalar; apply sup_spec. }
  - ext s.
    rewrite sup_apply_eR.
    replace (fun i : nat => wp_ b (c i) (@sup _ (@OType_arrow _ _ OType_eR) ch) s / INeR (n s))
      with (fun i : nat => / INeR (n s) * wp_ b (c i) (sup ch) s).
    2: { ext i; apply eRmult_comm. }
    rewrite sum_map_scalar.
    replace (fun i : nat => sum (map (fun i0 : nat => wp_ b (c i0) (ch i) s / INeR (n s))
                              (range (n s)))) with
      (fun i : nat => / INeR (n s) * sum (map (fun i0 : nat => wp_ b (c i0) (ch i) s)
                                       (range (n s)))).
    2: { ext i.
         replace (fun i0 : nat => wp_ b (c i0) (ch i) s / INeR (n s)) with
           (fun i0 : nat => / INeR (n s) * wp_ b (c i0) (ch i) s).
         2: { ext j; apply eRmult_comm. }
         rewrite sum_map_scalar; reflexivity. }
    rewrite <- sup_scalar.
    f_equal.
    replace (fun i : nat => wp_ b (c i) (sup ch) s) with
      (fun i : nat => sup (wp_ b (c i) ∘ ch) s).
    2: { ext i; rewrite H; auto. }
    replace (fun i : nat => sup (wp_ b (c i) ∘ ch) s) with
      (fun i : nat => sup (fun j => wp_ b (c i) (ch j) s)).
    2: { ext i; rewrite sup_apply_eR; reflexivity. }
    apply sum_map_sup.
    apply Forall_forall; intros i Hi.
    intro j; apply monotone_wp; auto.
  - apply equ_f_eR, equ_arrow, equ_arrow, equ_f_eR.
    unfold iter.
    rewrite <- loop_approx_iter_n_loop_F.
    replace (sup (fun (x : nat) (st : St) =>
                    sup (iter_n (loop_F b0 (wp_ b c) (ch x)) (const 0)) st))
      with (sup
              (fun (x : nat) (st : St) =>
                 sup (loop_approx b0 (wp_ b c) (ch x)) st)).
    2: { f_equal; ext i; ext s.
         apply equ_eR.
         rewrite sup_apply.
         rewrite sup_apply.
         apply equ_eR; f_equal; ext j.
         rewrite loop_approx_iter_n_loop_F; reflexivity. }
    apply equ_f_eR.
    symmetry.
    apply supremum_sup.
    split.
    + intros i s; simpl.
      apply leq_eRle.
      rewrite 2!sup_apply.
      apply ge_sup.
      intro j.
      apply le_sup with j.
      apply loop_approx_monotone; auto with cwp.
      apply sup_spec.
    + intros ub Hub s.
      rewrite sup_apply.
      pose proof Hub as H.
      apply sup_spec in H.
      simpl in H.
      specialize (H s).
      etransitivity.
      2: { apply H. }
      simpl.
      rewrite sup_apply.
      apply leq_eRle.
      apply ge_sup.
      intro i. simpl.
      assert (Hsup: supremum (loop_approx b0 (wp_ b c) (sup ch) i s)
                      (fun j => loop_approx b0 (wp_ b c) (ch j) i s)).
      { split.
        - intro j.
          apply loop_approx_monotone; eauto with cwp.
          apply sup_spec.
        - intros x Hx.
          rewrite loop_approx_continuous; eauto with cwp.
          + apply ge_sup; auto.
          + intros ch0 s0 Hch0.
            rewrite IHc; auto.
            apply sup_apply_eR. }
      apply Hsup.
      intro j.
      apply le_sup with j.
      rewrite sup_apply.
      apply le_sup with i; eRauto.
  - ext s.
    destruct (b0 s) eqn:Hes.
    + rewrite 2!sup_apply_eR.
      f_equal; ext i; rewrite Hes; auto.
    + rewrite sup_apply_eR.
      apply equ_eR.
      symmetry.
      apply supremum_sup.
      destruct b; apply supremum_const'; apply equ_arrow;
        intro i; rewrite Hes; reflexivity.
Qed.

(** wlp is continuous. *)
Theorem wlp_continuous (b : bool) (c : cpGCL) (ch : nat -> St -> eR) :
  wf_cpGCL c ->
  dec_chain ch ->
  wlp_ b c (inf ch) = inf (wlp_ b c ∘ ch).
Proof.
  revert ch.
  induction c; intros ch Hwf Hch; inv Hwf; unfold compose; simpl; auto.
  - symmetry.
    apply equ_f_eR, infimum_inf.
    apply infimum_const.
  - ext st.
    rename s into x.
    set (f' := fun s => upd x (e s) s).
    assert (upd x (e st) st = f' st).
    { reflexivity. }
    rewrite 2!inf_apply_eR; auto.
  - rewrite IHc2; auto.
    rewrite IHc1; auto.
    apply monotone_dec_chain; auto with cwp.
  - ext st.
    apply equ_eR.
    rewrite inf_apply.
    + apply equ_eR.
      destruct (b0 st) eqn:Hest.
      * erewrite IHc1; eauto; apply equ_eR; rewrite inf_apply; reflexivity.
      * erewrite IHc2; eauto; apply equ_eR; rewrite inf_apply; reflexivity.
  - ext st.
    rewrite inf_apply_eR.
    rewrite 2!H; auto.
    symmetry.
    apply equ_eR.
    apply infimum_inf.
    apply infimum_sum.
    { apply dec_chain_scalar.
      set (g := fun f => wlp_ b (c true) f st).
      replace (fun i => wlp_ b (c true) (ch i) st) with (g ∘ ch).
      - apply monotone_dec_chain; auto.
        intros i j Hij; apply monotone_wlp; auto.
      - unfold compose, g; reflexivity. }
    { apply dec_chain_scalar.
      set (g := fun f => wlp_ b (c false) f st).
      replace (fun i => wlp_ b (c false) (ch i) st) with (g ∘ ch).
      - apply monotone_dec_chain; auto.
        intros i j Hij; apply monotone_wlp; auto.
      - unfold compose, g; reflexivity. }
    { rewrite inf_apply_eR, inf_scalar; eRauto; apply inf_spec. }
    { rewrite inf_apply_eR, inf_scalar; eRauto; apply inf_spec. }
  - ext s.
    rewrite inf_apply_eR.
    replace (fun i : nat => wlp_ b (c i) (@inf _ (@OType_arrow _ _ OType_eR) ch) s / INeR (n s))
      with (fun i : nat => / INeR (n s) * wlp_ b (c i) (inf ch) s).
    2: { ext i; apply eRmult_comm. }
    rewrite sum_map_scalar.
    replace (fun i : nat => sum (map (fun i0 : nat => wlp_ b (c i0) (ch i) s / INeR (n s))
                              (range (n s)))) with
      (fun i : nat => / INeR (n s) * sum (map (fun i0 : nat => wlp_ b (c i0) (ch i) s)
                                            (range (n s)))).
    2: { ext i.
         replace (fun i0 : nat => wlp_ b (c i0) (ch i) s / INeR (n s)) with
           (fun i0 : nat => / INeR (n s) * wlp_ b (c i0) (ch i) s).
         2: { ext j; apply eRmult_comm. }
         rewrite sum_map_scalar; reflexivity. }
    rewrite <- inf_scalar.
    2: { simpl; destr.
         - assert (0 < INR (n s))%R.
           { replace 0%R with (INR 0) by auto.
             apply lt_INR; auto. }
           lra.
         - intro HC; inv HC. }
    f_equal.
    replace (fun i : nat => wlp_ b (c i) (inf ch) s) with
      (fun i : nat => inf (wlp_ b (c i) ∘ ch) s).
    2: { ext i; rewrite H; auto. }
    replace (fun i : nat => inf (wlp_ b (c i) ∘ ch) s) with
      (fun i : nat => inf (fun j => wlp_ b (c i) (ch j) s)).
    2: { ext i; rewrite inf_apply_eR; reflexivity. }
    apply sum_map_inf.
    apply Forall_forall; intros i Hi.
    intro j; apply monotone_wlp; auto.
  - apply equ_f_eR, equ_arrow, equ_arrow, equ_f_eR.
    unfold dec_iter.
    rewrite <- dec_loop_approx_iteR_n_loop_F.
    replace (inf (fun (x : nat) (st : St) =>
                    inf (iter_n (loop_F b0 (wlp_ b c) (ch x)) (const 1)) st))
      with (inf
              (fun (x : nat) (st : St) =>
                 inf (dec_loop_approx b0 (wlp_ b c) (ch x)) st)).
    2: { f_equal; ext i; ext s.
         apply equ_eR.
         rewrite 2!inf_apply.
         apply equ_eR; f_equal; ext j.
         rewrite dec_loop_approx_iteR_n_loop_F; reflexivity. }
    apply equ_f_eR.
    symmetry.
    apply infimum_inf.
    split.
    + intros i s; simpl.
      apply leq_eRle.
      rewrite 2!inf_apply.
      apply le_inf.
      intro j.
      apply ge_inf with j.
      apply dec_loop_approx_monotone; auto with cwp.
      apply inf_spec.
    + intros ub Hub s.
      rewrite inf_apply.
      pose proof Hub as H.
      apply inf_spec in H.
      simpl in H.
      specialize (H s).
      etransitivity.
      { apply H. }
      simpl.
      rewrite inf_apply.
      apply leq_eRle.
      apply le_inf.
      intro i. simpl.
      assert (Hinf: infimum (dec_loop_approx b0 (wlp_ b c) (inf ch) i s)
                      (fun j => dec_loop_approx b0 (wlp_ b c) (ch j) i s)).
      { split.
        - intro j.
          apply dec_loop_approx_monotone; eauto with cwp.
          apply inf_spec.
        - intros x Hx.
          rewrite dec_loop_approx_continuous; eauto with cwp.
          + apply le_inf; auto.
          + intros ch0 s0 Hch0.
            rewrite IHc; auto.
            apply inf_apply_eR. }
      apply Hinf.
      intro j.
      apply ge_inf with j.
      rewrite inf_apply.
      apply ge_inf with i; eRauto.
  - ext s.
    destruct (b0 s) eqn:Hes.
    + rewrite 2!inf_apply_eR.
      f_equal; ext i; rewrite Hes; auto.
    + rewrite inf_apply_eR.
      apply equ_eR.
      symmetry.
      apply infimum_inf.
      destruct b; apply infimum_const'; apply equ_arrow;
        intro i; rewrite Hes; reflexivity.
Qed.

Lemma loop_F_bounded {A} `{OType A} e F f g (ub : A) (s : St) :
  F f s ⊑ ub ->
  g s ⊑ ub ->
  loop_F e F g f s ⊑ ub.
Proof. intros HF Hg; unfold loop_F; destr; auto. Qed.

Lemma wp_unroll_loop b G c f :
  wf_cpGCL c ->
  wp_ b (CWhile G c) f = wp_ b (CIte G (CSeq c (CWhile G c)) CSkip) f.
Proof.
  intro Hwf.
  apply equ_f_eR; simpl.
  rewrite iter_unfold.
  { reflexivity. }
  { apply wcontinuous_loop_F.
    intros ch Hch s Hs.
    assert (s = sup ch).
    { apply equ_f_eR; symmetry; apply supremum_sup; auto. }
    subst; rewrite wp_continuous; auto; apply sup_spec. }
  { intro; unfold const; eRauto. }
Qed.

Lemma wlp_unroll_loop b G c f :
  wf_cpGCL c ->
  bounded f 1 ->
  wlp_ b (CWhile G c) f = wlp_ b (CIte G (CSeq c (CWhile G c)) CSkip) f.
Proof.
  intros Hwf Hf.
  apply equ_f_eR; simpl.
  rewrite dec_iter_unfold.
  { reflexivity. }
  { apply dec_wcontinuous_loop_F.
    intros ch Hch s Hs.
    assert (s = inf ch).
    { apply equ_f_eR; symmetry; apply infimum_inf; auto. }
    subst; rewrite wlp_continuous; auto; apply inf_spec. }
  intro s.
  { apply loop_F_bounded.
    - apply bounded_wlp; auto; intro; reflexivity.
    - apply Hf. }
Qed.

Theorem cwp_unroll_loop G c f :
  wf_cpGCL c ->
  cwp (CWhile G c) f = cwp (CIte G (CSeq c (CWhile G c)) CSkip) f.
Proof.
  intro Hwf; apply equ_f_eR, equ_arrow; intro st.
  unfold cwp, wp, wlp.
  apply equ_eR; f_equal.
  - rewrite wp_unroll_loop; auto.
  - rewrite wlp_unroll_loop; auto; intro; reflexivity.
Qed.

Lemma wp_strict c :
  wp c (const 0) = const 0.
Proof.
  unfold wp.
  induction c; simpl; auto; ext s.
  - rewrite IHc2, IHc1; reflexivity.
  - destr; try rewrite IHc1; auto; rewrite IHc2; auto.
  - rewrite 2!H; unfold const; eRauto.
  - apply sum_0, Forall_forall; intros x Hx.
    apply in_map_iff in Hx.
    destruct Hx as [i [? Hin]]; subst.
    rewrite H; eRauto.
  - unfold iter, const.
    apply equ_eR; rewrite sup_apply.
    apply sup_const'.
    apply equ_arrow; intro i; unfold const.
    transitivity (const 0 s); try reflexivity.
    revert s; apply equ_arrow, iter_n_const.
    + apply monotone_loop_F, monotone_wp.
    + apply equ_arrow; intro s; unfold loop_F; destr; try reflexivity.
      unfold const in IHc; rewrite IHc; reflexivity.
  - destr; reflexivity.
Qed.

Lemma wlpfail_costrict (c : cpGCL) :
  wf_cpGCL c ->
  wlpfail c (const 1) = const 1.
Proof.
  intro Hwf.
  unfold wlpfail.
  induction c; simpl; auto; ext s; inv Hwf.
  - rewrite IHc2, IHc1; auto; reflexivity.
  - destr; try rewrite IHc1; auto; rewrite IHc2; auto.
  - rewrite 2!H; unfold const; eRauto.
  - replace (fun i : nat => wlp_ true (c i) (const 1) s / INeR (n s)) with
      (fun i : nat => / INeR (n s) * wlp_ true (c i) (const 1) s).
    2: { ext i; apply eRmult_comm. }
    rewrite sum_map_scalar.
    apply eRmult_eq_reg_r with (r := INeR (n s)); auto with eR.
    unfold const.
    rewrite eRmult_1_l, eRmult_comm, <- eRmult_assoc.
    rewrite eRinv_r; auto with eR.
    rewrite eRmult_1_l, sum_map_const with (c:=1).
    { rewrite eRmult_1_r, range_length; reflexivity. }
    apply Forall_forall; intros i Hi.
    rewrite H; auto.
  - unfold dec_iter, const.
    rewrite inf_apply_eR.
    apply equ_eR.
    apply inf_const'.
    apply equ_arrow; intro i; unfold const.
    transitivity (const 1 s); try reflexivity.
    revert s; apply equ_arrow, iter_n_const.
    + apply monotone_loop_F, monotone_wlp.
    + apply equ_arrow; intro s; unfold loop_F; destr; try reflexivity.
      unfold const in IHc; rewrite IHc; auto; reflexivity.
  - destr; reflexivity.
Qed.

(** [wp b c f = 1 - wlp (~ b) c (1 - f)] *)
Lemma wp_wlp_sum (fl : bool) (c : cpGCL) (f : St -> eR) (st : St) :
  wf_cpGCL c ->
  bounded f 1 ->
  wp_ fl c f st + wlp_ (negb fl) c (fun s => 1 - f s) st = 1.
Proof.
  revert fl f st; induction c; intros fl f st Hwf Hf; inv Hwf; simpl.
  - eRauto.
  - eRauto.
  - eRauto.
  - replace (wlp_ (negb fl) c2 (fun s : St => 1 - f s))
      with (fun s => 1 - wp_ fl c2 f s).
    2: { ext s; symmetry; eapply eRplus_eq_minus; eRauto. }
    apply IHc1; auto.
    apply bounded_wpfail; auto; reflexivity.
  - destruct (b st) eqn:Hest.
    + apply IHc1; auto.
    + apply IHc2; auto.
  - rewrite <- eRplus_assoc, eRplus_factor, 2!H; eRauto.
  - rewrite sum_map_plus.
    replace (fun x : nat =>
               wp_ fl (c x) f st / INeR (n st) +
                 wlp_ (negb fl) (c x) (fun s : St => 1 - f s) st / INeR (n st))
      with (fun x : nat => / INeR (n st) *
                        (wp_ fl (c x) f st +
                           wlp_ (negb fl) (c x) (fun s : St => 1 - f s) st)).
    2: { ext i; rewrite eRmult_plus_distr_l.
         rewrite eRmult_comm; f_equal; apply eRmult_comm. }
    rewrite sum_map_scalar.
    apply eRmult_eq_reg_r with (r := INeR (n st)); auto with eR.
    rewrite eRmult_1_l, eRmult_comm, <- eRmult_assoc.
    rewrite eRinv_r; auto with eR.
    rewrite eRmult_1_l, sum_map_const with (c:=1).
    { rewrite eRmult_1_r, range_length; reflexivity. }
    apply Forall_forall; intros i Hi.
    rewrite H; auto.
  - unfold iter, dec_iter.
    rewrite sup_apply_eR, inf_apply_eR.
    eapply supremum_infimum_sum with (ub:=1%R).
    6: { apply sup_spec. }
    6: { apply inf_spec. }
    { apply chain_iter_n''.
      - intro; unfold const; eRauto.
      - intro; unfold const; eRauto.
      - apply monotone_wp. }
    { apply dec_chain_iter_n''.
      - intro; unfold const; eRauto.
      - apply bounded_wlp; auto; intro; reflexivity.
      - apply monotone_wlp. }
    { intro i; revert st; apply leq_arrow, iter_n_bounded.
      - simpl; eRauto.
      - intros g Hle s.
        apply loop_F_bounded.
        + apply bounded_wpfail; auto.
          * eRauto.
          * apply Hle.
        + apply Hf. }
    { intro i; revert st; apply leq_arrow, iter_n_bounded.
      - simpl; eRauto.
      - intros g Hle s.
        apply loop_F_bounded.
        + apply bounded_wlp; auto.
        + eRauto. }
    intro i; simpl.
    revert st; induction i; intro st; simpl.
    + unfold const; eRauto.
    + unfold loop_F; destr.
      2: { eRauto. }
      unfold as_bool. simpl.
      replace (iter_n (fun (k : St -> eR) (s : St) =>
                         if b s then wlp_ (negb fl) c k s else 1 - f s)
                 (const 1) i) with
        (fun s => 1 - (iter_n (fun (k : St -> eR) (s : St) =>
                              if b s then wp_ fl c k s else f s)
                      (const 0) i) s).
      { apply IHc; auto.
        intro s; apply leq_eRle; revert s.
        apply leq_arrow, iter_n_bounded.
        - intro; eRauto.
        - intros g Hg s; destr.
          + apply bounded_wpfail; auto; reflexivity.
          + apply Hf. }
      ext s.
      symmetry; apply eRplus_eq_minus; eRauto.
  - destruct (b st).
    + eRauto.
    + destruct fl; simpl; eRauto.
Qed.

(** [wlp b c f = 1 - wp (~ b) c (1 - f)] *)
Lemma wlp_wp_sum (fl : bool) (c : cpGCL) (f : St -> eR) (st : St) :
  wf_cpGCL c ->
  bounded f 1 ->
  wlp_ fl c f st + wp_ (negb fl) c (fun s => 1 - f s) st = 1.
Proof.
  intros Hwf Hf.
  rewrite eRplus_comm.
  replace (wlp_ fl c f st) with
    (wlp_ (negb (negb fl)) c (fun s => 1 - (fun s' => 1 - f s') s) st).
  2: { f_equal.
       - apply negb_involutive.
       - ext s; eRauto. }
  apply wp_wlp_sum; auto.
  intro; eRauto.
Qed.

Lemma wlp_fail (c : cpGCL) (st : St) :
  wf_cpGCL c ->
  wlp c (const 1) st = 1 - fail c st.
Proof.
  intro Hwf.
  cut (wlp c (const 1) st + fail c st = 1).
  { intro H; apply eRplus_eq_minus.
    - eRauto.
    - rewrite eRplus_comm; apply H. }
  unfold wlp, fail, wpfail.
  replace (wp_ true c (const 0) st) with
    (wp_ (negb false) c (fun s => 1 - const 1 s) st).
  { apply wlp_wp_sum; auto.
    intro s; eRauto. }
  f_equal; ext s; eRauto.
Qed.

Lemma score_wp (e : St -> Q) (f : St -> eR) (st : St) :
  wp (CScore e) f st = Q2eR (e st) * f st.
Proof. unfold wp; simpl; eRauto. Qed.

Lemma score_wlp (e : St -> Q) (f : St -> eR) (st : St) :
  wlp (CScore e) f st = Q2eR (e st) * f st.
Proof. unfold wlp; simpl; eRauto. Qed.

Lemma score_cwp (e : St -> Q) (f : St -> eR) (st : St) :
  (0 < e st)%Q ->
  cwp (CScore e) f st = f st.
Proof.
  intro Hlt; unfold cwp, wlp.
  rewrite score_wp.
  simpl; unfold const; eRauto.
  rewrite eRmult_div_cancel; eRauto; intro HC.
  replace 0 with (Q2eR 0) in HC.
  { apply eq_eR_Qeq in HC.
    - rewrite HC in Hlt; inv Hlt.
    - apply Qlt_le_weak; auto.
    - apply Qle_refl. }
  apply Q2eR_0.
Qed.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice.
Require Import UniMath.Bicategories.Limits.Products.
Require Import UniMath.Bicategories.Limits.Pullbacks.
Require Import UniMath.Bicategories.Limits.PullbackFunctions.
Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration.
Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.UniversalArrow.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.ConstProduct.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.PullbackFunctor.
Import Products.Notations.

Local Open Scope cat.

Definition is_cartesian_closed_bicat
           (B : bicat_with_binprod)
  : UU
  := ∏ (x : B),
     right_universal_arrow
       (const_prod_psfunctor B x).

Definition make_is_cartesian_closed_bicat
           (B : bicat_with_binprod)
           (HB : is_univalent_2_1 B)
           (exp : B -> B → B)
           (app : ∏ (x y : B), exp x y ⊗ x --> y)
           (app2 : ∏ (x y₁ y₂ : B)
                     (f g : y₁ --> exp x y₂)
                     (α : f ⊗₁ id₁ x · app x y₂ ==> g ⊗₁ id₁ x · app x y₂),
                   f ==> g)
           (app2_eq : ∏ (x y₁ y₂ : B)
                        (f g : y₁ --> exp x y₂)
                        (α : f ⊗₁ id₁ x · app x y₂ ==> g ⊗₁ id₁ x · app x y₂),
                      app2 x y₁ y₂ f g α ⊗₂ id₂ (id₁ x) ▹ app x y₂ = α)
           (H : ∏ (x y₁ y₂ : B)
                  (f g : y₁ --> exp x y₂)
                  (α : f ⊗₁ id₁ x · app x y₂ ==> g ⊗₁ id₁ x · app x y₂)
                  (β₁ β₂ : f ==> g)
                  (p₁ : β₁ ⊗₂ id₂ (id₁ x) ▹ app x y₂ = α)
                  (p₂ : β₂ ⊗₂ id₂ (id₁ x) ▹ app x y₂ = α),
                β₁ = β₂)
           (lam : ∏ (x y₁ y₂ : B)
                    (f : y₁ ⊗ x --> y₂),
                  y₁ --> exp x y₂)
           (app_lam : ∏ (x y₁ y₂ : B)
                        (f : y₁ ⊗ x --> y₂),
                      invertible_2cell (lam x y₁ y₂ f ⊗₁ id₁ x · app x y₂) f)
  : is_cartesian_closed_bicat B.
Proof.
  intro x.
  use make_right_universal_arrow'.
  - exact HB.
  - exact (exp x).
  - exact (app x).
  - intros y₁ y₂ f g α.
    simple refine (_ ,, _).
    + exact (app2 x y₁ y₂ f g α).
    + exact (app2_eq x y₁ y₂ f g α).
  - exact (H x).
  - intros y₁ y₂ f.
    simple refine (_ ,, _).
    + exact (lam x y₁ y₂ f).
    + exact (app_lam x y₁ y₂ f).
Defined.

Definition exponentiable_morphism
           (B : bicat_with_pb)
           {b₁ b₂ : B}
           (f : b₁ --> b₂)
  : UU
  := right_universal_arrow (pb_psfunctor B f).

Definition locally_cartesian_closed_bicat
           (B : bicat_with_pb)
  : UU
  := ∏ (b₁ b₂ : B)
       (f : b₁ --> b₂),
     exponentiable_morphism B f.

Definition bicat_has_exponentials
           (B : bicat_with_pb)
  : UU
  := ∏ (b₁ b₂ : B)
       (f : b₁ --> b₂),
     (internal_sfib f → exponentiable_morphism B f)
     ×
     (internal_sopfib f → exponentiable_morphism B f).