(***************************************************************************)
(* Formalization of the Chou, Gao and Zhang's decision procedure.*)
(* Julien Narboux (Julien.Narboux@inria.fr)                                     *)
(* LIX/INRIA FUTURS 2004-2008                                                     *)
(***************************************************************************)

Require Export area_elimination_lemmas.
Require Import Classical.

(** For the first time, we need decidability of the parallel predicate *)

Lemma parallel_dec : forall A B C D, parallel A B C D \/ ~ parallel A B C D.
Proof.
intros.
apply classic.
Qed.

Ltac cases_parallel A B C D := elim (parallel_dec A B C D);intros.

Definition Det3 (x1 x2 x3 y1 y2 y3 z1 z2 z3 : F) : F :=
  x1 * (y2 * z3) - x1 * (y3 * z2) - x2 * (y1 * z3) + x2 * (y3 * z1) +
  x3 * (y1 * z2) - x3 * (y2 * z1).

Lemma freepoint_elimination_aux : forall O U V B Y:Point, ~ Col O U V ->
S O B Y = 1/ (S O U V) * (S O B V * S O U Y + S O B U * S O Y V).
Proof with Geometry.
intros.

cases_parallel U V O Y.
rename H into T.
assert (O**Y / U**V = S U O Y / S O V U).
apply l2_15...
assert (S O B Y = S O B O + (O**Y/U**V) * S4 O U B V).
apply elim_area_on_parallel.
unfold on_parallel;repeat split...
eauto with Geom.
rewrite H in H1.
basic_simpl.
unfold S4 in *.
assert (parallel O Y U V).
Geometry.
unfold parallel, S4 in *.
IsoleVarRing (S O Y V) H2.
rewrite H2.
rewrite H1.
uniformize_signed_areas.
field.
split...

assert (exists W, inter_ll W U V O Y).
apply inter_ll_ex...
DecompEx H1 W.

cases_equality W O.
subst W.
unfold inter_ll in *.
intuition.
rename H1 into Hdiff.

assert (S B O W = 1 / S4 U O V Y * (S U O Y * S B O V + S V Y O * S B O U)).
apply  elim_area_inter_ll...
replace (S4 U O V Y) with (- S4 O U Y V) in H1.
2:Geometry.
replace ((S U O Y * S B O V + S V Y O * S B O U)) with
(S O B V * S O U Y + S O B U * S O Y V) in H1.
2:uniformize_signed_areas;field.
unfold inter_ll in *;DecompAndAll.
assert (O ** W / O ** Y = S O U V / S4 O U Y V).
apply co_side_ter...
cases_col B O W.

cases_equality V W.
subst W.
assert (Col O Y B).
eapply col_trans_1 with (B:=V)...
unfold Col in *.
uniformize_signed_areas.
rewrite H4.
rewrite H5.
rewrite H7.
ring.

cases_equality O B.
subst B.
basic_simpl.
ring.

cases_col  V O B.
assert (Col O Y B).
eapply col_trans_1 with (B:= W)...
assert (Col O Y V).
eapply col_trans_1 with (B:= B)...
unfold Col in *.
uniformize_signed_areas.
rewrite H9.
rewrite H10.
rewrite H11.
ring.

assert (U**W/V**W = S U O B / S V O B).
apply co_side...

cases_col V O Y.

cases_equality Y O.
subst Y.
basic_simpl.
ring.

assert (Col Y W V).
eapply col_trans_1 with (B:= O)...
assert (Col W U Y).
eapply col_trans_1 with (B:= V)...

cases_equality Y W.
Unset Regular Subst Tactic.
subst W.
Set Regular Subst Tactic.
clear H13 H12 H5.
assert (Col O V B).
eapply col_trans_1 with (B:= Y)...
unfold Col in *.
uniformize_signed_areas.
rewrite H4.
replace (S V O B) with (-0).
rewrite H11.
ring.
rewrite <- H5.
ring.

assert (Col Y U O).
eapply col_trans_1 with (B:= W)...
assert (Col O U V).
eapply col_trans_1 with (B:= Y)...
intuition.

assert (U**W/V**W = S U O Y / S V O Y).
apply co_side...
rewrite H10 in H12.

assert (Col O B Y).
eapply col_trans_1 with (B:= W)...
rewrite H13.
uniformize_signed_areas.
RewriteVar (S O B U) H12.
2:Geometry.
field.
split...

(** Second case *)
assert (O**Y / O**W = S B O Y / S B O W).
apply A6...
assert (O**Y / O**W = S4 O U Y V / S O U V).
replace (O ** Y / O ** W) with (1/(O ** W / O ** Y)).
rewrite H2.
field.
Geometry.
repeat apply nonzeromult...
field.
split...
unfold not;intro.
assert (O=Y).
Geometry.
subst Y.
assert (parallel U V O O)...
rewrite H7 in H8.
set (S O B V * S O U Y + S O B U * S O Y V) in *.
rewrite H1 in H8.
replace (S B O Y) with (-S O B Y) in H8.
2:Geometry.

RewriteVar (S O B Y) H8.
field;split...
apply nonzeromult...
apply nonzerodiv...

unfold not;intro.
rewrite H9 in H1.
basic_simpl.
assert (Col O Y B).
eapply col_trans_1 with (B:=W)...
Geometry.

Qed.

Lemma  free_points_area_elimination :
    forall O U V A B Y : Point,
    S O U V <> 0 ->
    S A B Y =
    Det3 (S O U A) (S O V A) 1 (S O U B) (S O V B) 1 (S O U Y) (S O V Y) 1 /
    S O U V.
Proof with Geometry.
intros.
unfold Det3.
replace (S A B Y) with (S A B O + S A O Y + S O B Y)...

replace (S A O Y) with (- S O A Y).
2:symmetry;Geometry.
replace (S O A Y) with (1/ (S O U V) * (S O A V * S O U Y + S O A U * S O Y V)).
2:symmetry;eapply freepoint_elimination_aux...
replace (S O B Y) with (1/ (S O U V) * (S O B V * S O U Y + S O B U * S O Y V)).
2:symmetry;eapply freepoint_elimination_aux...
replace (S A B O) with (S O A B).
2:Geometry.
replace (S O A B) with (1/ (S O U V) * (S O A V * S O U B + S O A U * S O B V)).
2:symmetry;eapply freepoint_elimination_aux...
uniformize_signed_areas.
field...
Qed.

Lemma free_points_ratio_elimination_1 : forall O U V A B C D : Point,
  parallel A B C D ->
  C<>D ->
  S O U V <> 0 ->
  S U A B <> 0 ->
  A**B / C**D = (S O U A * S O V B + S O U A * S O U V - S O V A * S O U B -
 S O U B * S O U V) /
(S O U A * S O V D - S O U A * S O V C + S O V A * S O U C -
 S O V A * S O U D + S O U V * S O U C - S O U V * S O U D).
Proof.
intros.

cases_equality A B.
subst.
basic_simpl;intuition.

assert (A**B / C**D = (S O A B + S O U A - S O U B) / (S U C D - S A C D)
 /\ (S U C D - S A C D) <> 0 ).
   elim (on_line_dex_spec_strong_f A B C D H H3).
   intros D' Hn. decompose [and] Hn;clear Hn.
   rewrite <- H6.
   assert (A<>D').
   intro;subst; basic_simpl; auto with Geom.
   assert (~ Col U A D').
     intro.
     assert (Col A B U).
       eapply (col_trans_1);eauto with Geom.
       assert (Col U A B); auto with Geom.

   rewrite (A6 A B D' U H5 H8) by auto with Geom.

   rewrite (A5 U A B O).
   assert (S U A D' = S U C D - S A C D) by
     (apply (l2_12a_strong_3 A D' D C U);auto).
   split.
   uniformize_signed_areas.
   rewrite H9; field; rewrite <- H9; auto with Geom.
   rewrite <- H9;auto with Geom.

use H4.
rewrite H5.
rewrite (free_points_area_elimination O U V O A B) in * by assumption.
rewrite (free_points_area_elimination O U V U C D) in * by assumption.
rewrite (free_points_area_elimination O U V A C D) in * by assumption.
unfold Det3 in *.
replace (S O V U) with (- S O U V) in * by auto with Geom.
basic_simpl.
field.
split;auto.
clear H5.
replace ((0 - - (S O U V * S O U C) - S O U V * S O U D + S O U C * S O V D -
      S O V C * S O U D) / S O U V -
     (S O U A * S O V C - S O U A * S O V D - S O V A * S O U C +
      S O V A * S O U D + S O U C * S O V D - S O V C * S O U D) / S O U V
)
with ((0 - - (S O U V * S O U C) - S O U V * S O U D + S O U C * S O V D -
      S O V C * S O U D - (S O U A * S O V C - S O U A * S O V D - S O V A * S O U C +
      S O V A * S O U D + S O U C * S O V D - S O V C * S O U D)) / S O U V) in H6 by (field;auto).
replace (0 - - (S O U V * S O U C) - S O U V * S O U D + S O U C * S O V D -
      S O V C * S O U D -
      (S O U A * S O V C - S O U A * S O V D - S O V A * S O U C +
       S O V A * S O U D + S O U C * S O V D - S O V C * S O U D)) with (S O U A * S O V D - S O U A * S O V C + S O V A * S O U C - S O V A * S O U D +
S O U V * S O U C - S O U V * S O U D) in H6 by ring.
intro Hx; rewrite Hx in H6; clear Hx.
basic_simpl;
intuition.
Qed.

Lemma free_point_ratio_elimination_2 : forall O U V A B C D : Point,
  parallel A B C D ->
  C<>D ->
  S O U V <> 0 ->
  S V A B <> 0 ->
  A**B / C**D = (S O V A * S O U B + S O V A * S O V U - S O U A * S O V B -
 S O V B * S O V U) /
(S O V A * S O U D - S O V A * S O U C + S O U A * S O V C -
 S O U A * S O V D + S O V U * S O V C - S O V U * S O V D).
Proof.
intros.
assert (S O V U <> 0).
intro; apply H1;uniformize_signed_areas;auto with Geom.
rewrite (free_points_ratio_elimination_1 O V U A B C D) by auto.
reflexivity.
Qed.

Lemma free_points_ratio_elimination_3 : forall O U V A B C D : Point,
  parallel A B C D ->
  A<>B ->
  C<>D ->
  S O U V <> 0 ->
  S U C D <> 0 ->
  A**B / C**D = (S O U C * S O V B - S O U C * S O V A + S O V C * S O U A -
  S O V C * S O U B + S O U V * S O U A - S O U V * S O U B)/
  (S O U C * S O V D + S O U C * S O U V - S O V C * S O U D -
  S O U D * S O U V).
Proof.
intros.
assert (A**B / C**D =  (S U A B - S C A B) / (S O C D + S O U C - S O U D)
 /\ (S O C D + S O U C - S O U D) <> 0 ).
assert (parallel C D A B) by auto with Geom.
   elim (on_line_dex_spec_strong_f C D A B H4 H1).
   intros D' Hn. decompose [and] Hn;clear Hn.
   rewrite <- H7.
   assert (C<>D').
   intro;subst; basic_simpl; auto with Geom.

   rewrite (A6 C D' D U H1) by auto with Geom.
   rewrite (A5 U C D O).
   assert (T:=A5 U C D O).
   assert (S U C D' = S U A B - S C A B) by
     (apply (l2_12a_strong_3 C D' B A U);auto).
   split.
   uniformize_signed_areas.
   rewrite H9.
   field.
   replace (S O C D + S U C O - - S U O D)
      with (S U C O + S U O D + S O C D) by ring.
   rewrite <- T;auto.
   replace (S O C D + S O U C - S O U D)
      with (S U C O + S U O D + S O C D)
        by (uniformize_signed_areas;ring).
   rewrite <- T;auto.

use H4.
rewrite H5.
rewrite (free_points_area_elimination O U V U A B) in * by assumption.
rewrite (free_points_area_elimination O U V C A B) in * by assumption.
rewrite (free_points_area_elimination O U V O C D) in * by assumption.
unfold Det3 in *.
replace (S O V U) with (- S O U V) in * by auto with Geom.
basic_simpl.
field.
split;auto.
clear H5.

replace ((S O U C * S O V D - S O V C * S O U D) / S O U V + S O U C - S O U D)
with ((S O U C * S O V D + S O U C * S O U V - S O V C * S O U D - S O U D * S O U V) / (S O U V))
in H6 by (field;auto).
intro.
rewrite H4 in H6.
basic_simpl;
intuition.
Qed.

Lemma free_points_ratio_elimination_4 : forall O U V A B C D : Point,
  parallel A B C D ->
  A<>B ->
  C<>D ->
  S O U V <> 0 ->
  S V C D <> 0 ->
  A**B / C**D = (S O V C * S O U B - S O V C * S O U A + S O U C * S O V A -
 S O U C * S O V B + S O V U * S O V A - S O V U * S O V B) /
(S O V C * S O U D + S O V C * S O V U - S O U C * S O V D -
 S O V D * S O V U).
intros.
assert (S O V U <> 0).
intro; assert (Col O U V) by auto with Geom;intuition.
rewrite (free_points_ratio_elimination_3 O V U A B C D) by auto.
reflexivity.
Qed.

Lemma free_points_ratio_elimination_5 : forall O U V A B C D: Point,
  parallel A B C D ->
  C<>D ->
  ~ Col O U V ->
  ~ Col A C D ->
  A**B / C**D = (S O U C * S O V A - S O U C * S O V B - S O V A * S O U B +
 S O V B * S O U A - S O V C * S O U A + S O V C * S O U B) /
(S O U C * S O V A - S O U C * S O V D - S O V A * S O U D -
 S O V C * S O U A + S O V C * S O U D + S O U A * S O V D) .
Proof.
intros.
rewrite (l2_15 A B C D) by auto with Geom.
assert (~ Col A D C) by auto with Geom.
unfold Col in H3.
rewrite (free_points_area_elimination O U V C A B) in * by assumption.
rewrite (free_points_area_elimination O U V A D C) in * by assumption.
unfold Det3 in *.
field.
split;auto.
basic_simpl.
replace (S O U A * S O V D - S O U A * S O V C - S O V A * S O U D +
      S O V A * S O U C + S O U D * S O V C - S O V D * S O U C)
   with (S O U C * S O V A - S O U C * S O V D - S O V A * S O U D - S O V C * S O U A +
S O V C * S O U D + S O U A * S O V D) in * by ring.
intro Hx; rewrite Hx in *.
replace (0 / S O U V) with 0 in * by (field;auto).
intuition.
Qed.

(*
set (X_C := S O U C).
set (X_A := S O U A).
set (X_B := S O U B).
set (X_D := S O U D).
set (Y_C := S O V C).
set (Y_A := S O V A).
set (Y_B := S O V B).
set (Y_D := S O V D).
*)

Lemma free_points_ratio_elimination_6 : forall O U V A B C D: Point,
  parallel A B C D ->
  C<>D ->
  ~ Col O U V ->
  ~ Col O A C ->
  Col A C D ->
  A**B / C**D = (S O U A * S O V B - S O V A * S O U B) /
(S O U C * S O V D - S O V C * S O U D).
Proof.
intros.
assert (~ Col O C D).
  intro.

  assert (Col C A O).
    apply (col_trans_1 C D A O );auto with Geom.
    intuition.

assert (Col B C D).
  cut (Col C D B).
  auto with Geom.
  apply (par_col_col_1 C D A B); auto with Geom.
rewrite <- (l2_7 C D A B O);auto.
unfold Col in H4.
rewrite (free_points_area_elimination O U V O A B) in * by assumption.
rewrite (free_points_area_elimination O U V O C D) in * by assumption.
unfold Det3 in *.
basic_simpl.
field.
split;auto.
intro Hx; rewrite Hx in *.
replace (0 / S O U V) with 0 in * by (field;auto).
intuition.
Qed.

Lemma free_points_ratio_elimination_6_non_zero_denom: forall O U V A B C D: Point,
  parallel A B C D ->
  C<>D ->
  ~ Col O U V ->
  ~ Col O A C ->
  Col A C D ->
  S O U C * S O V D - S O V C * S O U D <> 0.
Proof.
intros.
assert (~ Col O C D).
  intro.

  assert (Col C A O).
    apply (col_trans_1 C D A O );auto with Geom.
    intuition.
unfold Col in H4.
rewrite (free_points_area_elimination O U V O C D) in * by assumption.
unfold Det3 in *.
basic_simpl.
intro Hx; rewrite Hx in *.
replace (0 / S O U V) with 0 in * by (field;auto).
intuition.
Qed.

Lemma free_points_ratio_elimination_7 : forall O U V A B C D: Point,
  parallel A B C D ->
  C<>D ->
  ~ Col O U V ->
  ~ Col U A C ->
  Col A C D ->
  A**B / C**D =
 (S O U V * (S O U B - S O U A) - S O U A * S O V B + S O U B * S O V A) /
 (S O U V * (S O U D - S O U C) - S O U C * S O V D + S O U D * S O V C).
Proof.
intros.

rewrite (free_points_ratio_elimination_6 U O V A B C D) by auto with Geom.
assert (S U O C * S U V D - S U V C * S U O D <> 0)
by (apply (free_points_ratio_elimination_6_non_zero_denom U O V A B C D);auto with Geom).

rewrite (free_points_area_elimination O U V U V A) in * by assumption.
rewrite (free_points_area_elimination O U V U V B) in * by assumption.
rewrite (free_points_area_elimination O U V U V C) in * by assumption.
rewrite (free_points_area_elimination O U V U V D) in * by assumption.
unfold Det3 in *.
basic_simpl.
replace (S O V U) with (- S O U V) in * by auto with Geom.
replace (S U O A) with (- S O U A) in * by auto with Geom.
replace (S U O B) with (- S O U B) in * by auto with Geom.
replace (S U O C) with (- S O U C) in * by auto with Geom.
replace (S U O D) with (- S O U D) in * by auto with Geom.
basic_simpl.

set (xc := S O U C) in *.
set (xa := S O U A) in *.
set (xb := S O U B) in *.
set (xd := S O U D) in *.
set (yc := S O V C) in *.
set (ya := S O V A) in *.
set (yb := S O V B) in *.
set (yd := S O V D) in *.
set (X := S O U V) in *.
field.
repeat split;auto.
replace ((0 - - (X * X) - X * xd + X * yd) / X)
with (X -xd +yd) in H4 by (field;auto).
replace ((0 - - (X * X) - X * xc + X * yc) / X)
with (X - xc + yc) in H4 by (field;auto).
replace (-(xc * (X - xd + yd)) - - ((X - xc + yc) * xd))
  with (X * (xd - xc) - xc * yd + xd * yc) in H4 by ring.
auto.
replace (- (xc * ((0 - - (X * X) - X * xd + X * yd) / X)) -
     - ((0 - - (X * X) - X * xc + X * yc) / X * xd))
  with ((- (xc * (- - (X * X) - X * xd + X * yd)) -
- ((- - (X * X) - X * xc + X * yc) * xd)) / X) in H4
     by (field;auto).
intro Hx; rewrite Hx in *.
replace (0 / X) with 0 in * by (field;auto).
intuition.
Qed.

Lemma free_points_ratio_elimination_7_non_zero_denom :
  forall O U V A B C D: Point,
  parallel A B C D ->
  C<>D ->
  ~ Col O U V ->
  ~ Col U A C ->
  Col A C D ->
  (S O U V * (S O U D - S O U C) - S O U C * S O V D + S O U D * S O V C) <> 0.
Proof.
intros.
assert (S U O C * S U V D - S U V C * S U O D <> 0)
by (apply (free_points_ratio_elimination_6_non_zero_denom U O V A B C D);auto with Geom).
rewrite (free_points_area_elimination O U V U V C) in * by assumption.
rewrite (free_points_area_elimination O U V U V D) in * by assumption.
unfold Det3 in *.
basic_simpl.
replace (S O V U) with (- S O U V) in * by auto with Geom.
replace (S U O A) with (- S O U A) in * by auto with Geom.
replace (S U O B) with (- S O U B) in * by auto with Geom.
replace (S U O C) with (- S O U C) in * by auto with Geom.
replace (S U O D) with (- S O U D) in * by auto with Geom.
basic_simpl.

set (xc := S O U C) in *.
set (xa := S O U A) in *.
set (xb := S O U B) in *.
set (xd := S O U D) in *.
set (yc := S O V C) in *.
set (ya := S O V A) in *.
set (yb := S O V B) in *.
set (yd := S O V D) in *.
set (X := S O U V) in *.
replace ((0 - - (X * X) - X * xd + X * yd) / X)
with (X -xd +yd) in H4 by (field;auto).
replace ((0 - - (X * X) - X * xc + X * yc) / X)
with (X - xc + yc) in H4 by (field;auto).
replace (-(xc * (X - xd + yd)) - - ((X - xc + yc) * xd))
  with (X * (xd - xc) - xc * yd + xd * yc) in H4 by ring.
auto.
Qed.

Lemma aux: forall x, x<>0 -> -x<>0.
Proof.
auto with field_hints.
Qed.

Lemma free_points_ratio_elimination_8 : forall O U V A B C D: Point,
  parallel A B C D ->
  C<>D ->
  ~ Col O U V ->
  ~ Col V A C ->
  Col A C D ->
  A**B / C**D =
    ( S O U V * (S O V B - S O V A) + S O V A * S O U B - S O V B * S O U A) /
    ( S O U V * (S O V D - S O V C) + S O V C * S O U D - S O V D * S O U C).
Proof.
intros.
(*
set (X_C := S O U C).
set (X_A := S O U A).
set (X_B := S O U B).
set (X_D := S O U D).
set (Y_C := S O V C).
set (Y_A := S O V A).
set (Y_B := S O V B).
set (Y_D := S O V D).
*)
rewrite (free_points_ratio_elimination_7 O V U A B C D) by auto with Geom.
replace (S O V U) with (- S O U V) by auto with Geom.
field.
replace (- S O U V) with (S O V U) by auto with Geom.
split.
replace (S O U V) with (- S O V U) by auto with Geom.
replace (- S O V U * (S O V D - S O V C) + S O V C * S O U D - S O V D * S O U C)
with    (- (S O V U * (S O V D - S O V C) - S O V C * S O U D + S O V D * S O U C))
 by ring.
apply aux.
apply (free_points_ratio_elimination_7_non_zero_denom O V U A B C D); auto with Geom.
apply (free_points_ratio_elimination_7_non_zero_denom O V U A B C D); auto with Geom.
Qed.


(** * Heterogeneous relations *)

(* A categorical account of this file is given in [CategoryRelation.v] *)

(* begin hide *)
From Coq Require Import
     Logic.ChoiceFacts
     Morphisms
     Setoid
     Relation_Definitions
     RelationClasses.

From ITree Require Import Tacs.
(* end hide *)

Definition relationH (A B : Type) := A -> B -> Prop.

Section RelationH_Operations.

  Definition rel_compose {A B C} (S : relationH B C) (R : relationH A B): relationH A C :=
    fun x y => exists b, R x b /\ S b y.

  (** ** Relations for morphisms/parametricity *)

  (* Heterogeneous notion of [subrelation] *)
  Definition subrelationH {A B} (R S : relationH A B) : Prop :=
    forall (x : A) (y : B), R x y -> S x y.

  Definition eq_rel {A B} (R S : relationH A B) :=
      subrelationH R S /\ subrelationH S R.

  Definition transpose {A B: Type} (R: relationH A B): relationH B A :=
    fun x y => R y x.

  (* The graph of a function forms a relation *)
  Definition fun_rel {A B: Type} (f: A -> B): relationH A B :=
    fun x y => y = f x.

  (** ** Relations for morphisms/parametricity *)

  (** Logical relation for the [sum] type. *)
  Variant sum_rel {A1 A2 B1 B2 : Type}
      (RA : relationH A1 A2) (RB : relationH B1 B2)
  : relationH (A1 + B1) (A2 + B2) :=
  | inl_morphism a1 a2 : RA a1 a2 -> sum_rel RA RB (inl a1) (inl a2)
  | inr_morphism b1 b2 : RB b1 b2 -> sum_rel RA RB (inr b1) (inr b2).

  (** Logical relation for the [prod] type. *)
  Variant prod_rel {A1 A2 B1 B2 : Type}
      (RA : relationH A1 A2) (RB : relationH B1 B2)
    : relationH (A1 * B1) (A2 * B2) :=
  | prod_morphism a1 a2 b1 b2 : RA a1 a2 -> RB b1 b2 -> prod_rel RA RB (a1, b1) (a2, b2)
  .

  (* Heterogeneous properness *)
  Definition ProperH :=
    let U := Type in fun (A1 A2 : U) (R : relationH A1 A2) (m1 : A1) (m2 : A2) => R m1 m2.

  (* Non-dependent heterogeneous respectfulness. c.f. [respectful_hetero] *)
  Definition respectfulH :=
    let U := Type in
    fun (A1 A2 B1 B2 : U) (R : relationH A1 A2) (R' : relationH B1 B2) (f : A1 -> B1) (g : A2 -> B2) =>
      forall (x : A1) (y : A2), R x y -> R' (f x) (g y).

  Definition pointwise_relationH {A1 A2 B1 B2}
             (RA : relationH A1 A2) (RB : relationH B1 B2) : relationH (A1 -> B1) (A2 -> B2) :=
    fun f g => forall (a1 : A1) (a2 : A2), RA a1 a2 -> RB (f a1) (g a2).

End RelationH_Operations.

Global Hint Constructors prod_rel: core.
Global Hint Constructors sum_rel: core.

Arguments inl_morphism {A1 A2 B1 B2 RA RB}.
Arguments inr_morphism {A1 A2 B1 B2 RA RB}.
Arguments prod_morphism {A1 A2 B1 B2 RA RB}.

Arguments rel_compose [A B C] S R.
Arguments subrelationH [A B] R S.
Arguments transpose [A B] R.
Arguments sum_rel [A1 A2 B1 B2] RA RB.
Arguments prod_rel [A1 A2 B1 B2] RA RB.

Arguments ProperH {_ _}.
Declare Scope relationH_scope.

Module RelNotations.

  (* Notice the levels: (R ⊕ S ⊗ T ∘ U) is parsed as ((R ⊕ (S ⊗ T)) ∘ U) *)
  Infix "∘" := rel_compose (at level 40, left associativity) : relationH_scope.
  Infix "⊕" := sum_rel (at level 39, left associativity) : relationH_scope.
  Infix "⊗" := prod_rel (at level 38, left associativity) : relationH_scope.

  Infix "⊑" := subrelationH (at level 70, no associativity) : relationH_scope.
  Notation "† R" := (transpose R) (at level 5, right associativity) : relationH_scope.

  Infix "≡" := eq_rel (at level 70, no associativity) : relationH_scope.

  Notation " R ~~> R' " := (@respectfulH _ _ _ _ (R%signature) (R'%signature))
                             (right associativity, at level 55) : relationH_scope.

End RelNotations.

Import RelNotations.
Local Open Scope relationH_scope.

#[global]
Instance Proper_relation {A: Type} (R : relationH A A) :
  Proper (@eq A ==> @eq A ==> iff) R.
Proof.
  repeat intro.
  repeat red.
  split; intros.
  - rewrite <- H,<- H0. auto.
  - rewrite H, H0. auto.
Qed.

(* Properties of Heterogeneous Relations ************************************ *)

Class ReflexiveH {A: Type} (R : relationH A A) : Prop :=
  reflexive : forall (a:A), R  a a.

Class SymmetricH {A: Type} (R : relationH A A) : Prop :=
  symmetric : forall x y, R x y -> R y x.

Class TransitiveH {A: Type} (R : relationH A A) : Prop :=
  transitive : forall x y z, R  x y -> R  y z -> R x z.

Class PER {A : Type} (R : relationH A A) : Type :=
  {per_symm :> SymmetricH R;
    per_trans :> TransitiveH R
  }.

(** *Partitions on Heterogeneous Relations *)
(* https://en.wikipedia.org/wiki/Heterogeneous_relation#Difunctional
  Among homogeneous relations, equivalence relations partition the set.

  For heterogeneous relations, a partitioning relation is a
  _difunctional_ relation, R = F (†G), where F and G are univalent
  (functional), i.e. forall x y z, F x y /\ F x z => y = z.

  N.B.: For homogeneous relations, PER's are _difunctional_.

  This is also known as a "quasi-PER" (QPER) or zig-zag complete relation.
    (See Krishnaswami and Dreyer 2012, 2013.)

            a1 -----> b1
              -
                -
                  -
                    ->
            a2 -----> b2

     Given the following diagram, there must also be a (a2, b1) ∈ R. *)
(* Two possible formulations of Zigzag. *)
Class Zigzag {A B : Type} (R : relationH A B) : Type :=
  zigzag : R ∘ († R ∘ R) ⊑ R.

Class Zigzag' {A B : Type} (R : relationH A B) : Type :=
  zigzag' : forall {a b a' b'}, R a b -> R a' b -> R a' b' -> R a b'.

(* The two defs of Zigzag are equivalent. *)
Lemma ZZC_zigzag_zigzag'_iff :
  forall {A B : Type} (R : relationH A B),
    Zigzag' R <-> Zigzag R.
Proof.
  intros. split; unfold Zigzag', Zigzag. intros.
  - intros a b (? & (? & ? & ?) & ?).
    eauto.
  - intros. red in H. apply H. esplit; split. esplit; split.
    all: eauto.
Qed.

Class Preorder {A : Type} (R : relationH A A) : Type :=
  {
    pre_refl :> ReflexiveH R;
    pre_trans :> TransitiveH R
  }.

Class EquivalenceH {A : Type} (R : relationH A A) : Type :=
  {
    equiv_refl :> ReflexiveH R;
    equiv_symm :> SymmetricH R;
    equiv_trans :> TransitiveH R
  }.

Global Instance relationH_reflexive : forall (A:Type), ReflexiveH (@eq A).
Proof.
  repeat intro.
  reflexivity.
Defined.

Global Instance relationH_symmetric : forall (A:Type), SymmetricH (@eq A).
Proof.
  repeat intro. cbn; auto.
Defined.

Global Instance relationH_transitive : forall (A:Type), TransitiveH (@eq A).
Proof.
  repeat intro. cbn in *. etransitivity.
  apply H. apply H0.
Defined.

Global Instance relationH_PER {A : Type} : PER (@eq A).
  constructor; typeclasses eauto.
Defined.

Global Instance relationH_Preorder {A : Type} : Preorder (@eq A).
  constructor; typeclasses eauto.
Defined.

Global Instance relationH_Equiv {A : Type} : EquivalenceH  (@eq A).
  constructor; typeclasses eauto.
Defined.

Lemma ReflexiveH_Reflexive {A: Type} (R : relationH A A) :
  ReflexiveH R <-> Reflexive R.
Proof.
  split; intros.
  - red. apply H.
  - apply H.
Qed.

Lemma SymmetricH_Symmetric {A: Type} (R : relationH A A) :
  SymmetricH R <-> Symmetric R.
Proof.
  split; intros.
  - red. unfold SymmetricH in H. intros. specialize (H x y). cbn in H.
    apply H. assumption.
  - red. intros p HP. cbn in *. apply H.
Qed.

Lemma TransitiveH_Transitive {A: Type} (R : relationH A A) :
  TransitiveH R <-> Transitive R.
Proof.
  split; intros.
  - red. intros x y z H0 H1. unfold TransitiveH in H. eapply H; eauto.
  - red. intros p q HP HQ EQ.
    unfold Transitive in H. cbn in EQ.
    eapply H; eauto.
Qed.

Global Instance SymmetricH_Symmetric_ {A : Type} (R : relationH A A) {SR : SymmetricH R} :
  Symmetric R.
  apply SymmetricH_Symmetric; eauto.
Defined.

Global Instance TransitiveH_Transitive_ {A : Type} (R : relationH A A) {SR : TransitiveH R} :
  Transitive R.
  apply TransitiveH_Transitive; eauto.
Defined.

Global Instance relationH_PER_Symmetric {A : Type} (R : relationH A A) {PR : PER R}:
  Symmetric R.
  destruct PR. apply SymmetricH_Symmetric. apply per_symm0.
Defined.

Global Instance relationH_PER_Transitive {A : Type} (R : relationH A A) {PR : PER R}:
  Transitive R.
  destruct PR. apply TransitiveH_Transitive. apply per_trans0.
Defined.

Global Instance relationH_Equivalence_PER {A : Type} (R : relationH A A) {ER : Equivalence R}:
  PER R.
  destruct ER. split; eauto.
Defined.

(** ** subrelationH *)
Section SubRelationH.

  Lemma subrelationH_Reflexive {A B: Type} (R: relationH A B): R ⊑ R.
  Proof.
    intros!; auto.
  Qed.

  Lemma subrelationH_antisym {A B: Type} (R S: relationH A B) `{R ⊑ S} `{S ⊑ R}: R ≡ S.
  Proof.
    split; auto.
  Qed.

  Lemma subrelationH_trans {A B: Type} (R S T: relationH A B)
         `{R ⊑ S} `{S ⊑ T} : R ⊑ T.
  Proof.
    intros!; auto.
  Qed.

  Lemma subrelationH_refl_eq {A: Type} (R: relationH A A) (H : Reflexive R) : (@eq A) ⊑ R.
  Proof.
    intros!.
    rewrite H0. cbn. apply H.
  Qed.

End SubRelationH.

Section RelationEqRel.

  (* [eq_rel] is an equivalence relation *)
  Global Instance eq_rel_Reflexive {A B} : Reflexive (@eq_rel A B).
  Proof.
    red. unfold eq_rel, subrelationH. tauto.
  Qed.

  Global Instance eq_rel_Symmetric {A B} : Symmetric (@eq_rel A B).
  Proof.
    red. unfold eq_rel, subrelationH. tauto.
  Qed.

  Global Instance eq_rel_Transitive {A B} : Transitive (@eq_rel A B).
  Proof.
    red. unfold eq_rel, subrelationH. intros.
    destruct H, H0. split; eauto.
  Qed.

  Global Instance eq_rel_Equiv {A B} : Equivalence (@eq_rel A B).
  Proof.
    split; typeclasses eauto.
  Qed.

  Global Instance eq_rel_Proper {A B} : Proper (eq_rel ==> eq_rel ==> iff) (@eq_rel A B).
  Proof.
    intros ? ? EQ1 ? ? EQ2.
    rewrite EQ1,EQ2; reflexivity.
  Qed.

End RelationEqRel.

Section RelationCompose.

  (* [eq] define identities *)
  Lemma eq_id_r: forall {A B : Type} (R : relationH A B),
    ((@eq B) ∘ R) ≡ R.
  Proof.
    split; intros!.
    - cbn in *. destruct H as (b & HR & EQ).
      rewrite <- EQ. assumption.
    - cbn. exists y. split; auto.
  Qed.

  Lemma eq_id_l: forall {A B} (R : relationH A B),
      R ∘  (@eq A) ≡ R.
  Proof.
    split; intros!.
    - cbn in *. destruct H as (b & EQ & HR).
      rewrite EQ. assumption.
    - cbn. exists x. split; auto.
  Qed.

  Lemma R_id_PER :
    forall {A} (R : relationH A A), PER R -> R ∘ R ≡ R.
  Proof.
    intros; split; intros * x y HR; intuition.
    destruct HR as (? & ? & ?). etransitivity; eauto.
    esplit; split; eauto. etransitivity. symmetry; eauto. eauto.
  Qed.

  (* Composition is associative *)

  Lemma compose_assoc: forall {A B C D} (R : relationH A B) (S : relationH B C) (T : relationH C D),
      T ∘ S ∘ R ≡ T ∘ (S ∘ R).
  Proof.
    split; intros!; cbn in *.
    - repeat destruct H. repeat destruct H0.
      repeat (eexists; split; eauto).
    - repeat destruct H. repeat destruct H0.
      repeat (eexists; split; eauto).
  Qed.

  Global Instance Proper_compose: forall A B C,
      Proper
        (eq_rel ==> eq_rel ==> eq_rel) (@rel_compose A B C).
  Proof.
    intros ? ? ? S S' EQS R R' EQR.
    split; intros ? ? EQ; destruct EQ as (? & ? & ?); econstructor; split; (apply EQR || apply EQS); eauto.
  Qed.

End RelationCompose.

Section TransposeFacts.

  #[local]
   Instance transpose_Reflexive {A} (R : relationH A A) {RR: Reflexive R} : Reflexive † R | 100.
  Proof.
    red. intros x. apply RR.
  Qed.

  #[local]
  Instance transpose_Symmetric {A} (R : relationH A A) {RS: Symmetric R} : Symmetric † R | 100.
  Proof.
    red; intros x; unfold transpose; intros. apply SymmetricH_Symmetric in RS.
    apply RS. assumption.
  Qed.

  #[local]
  Instance transpose_Transitive {A} (R : relationH A A) {RT : Transitive R} : Transitive † R | 100.
  Proof.
    red; intros x; unfold transpose; intros.
    apply TransitiveH_Transitive in RT.
    unfold TransitiveH in RT.
    specialize (RT z y x). apply RT; eauto.
  Qed.

  (* [transpose] is a functor (from the opposite category into itself) *)
  Lemma transpose_eq {A: Type}
    : † (@eq A) ≡ (@eq A).
  Proof.
    split; unfold transpose; intros!; subst; auto.
  Qed.

  Lemma transpose_sym {A : Type} (R : relationH A A) {RS: Symmetric R}
    : † R ≡ R.
  Proof.
    unfold transpose; split; intros!; cbn in *.
    apply SymmetricH_Symmetric in RS. red in RS.
    apply (RS y x). assumption.
    apply SymmetricH_Symmetric in RS. red in RS.
    apply (RS x y). assumption.
  Qed.

  Lemma transpose_compose {A B C : Type}
        (R : relationH A B) (S : relationH B C)
    : † (S ∘ R) ≡ (†R ∘ †S).
  Proof.
    split; unfold transpose; cbn; intros!; cbn in *.
    - destruct H as (b & HR & HS). exists b. tauto.
    - destruct H as (b & HR & HS). exists b. tauto.
  Qed.

  Global Instance Proper_transpose {A B : Type}
    : Proper (eq_rel ==> eq_rel) (@transpose A B).
  Proof.
    intros ? ? EQ; split; unfold transpose; intros!; apply EQ; auto.
  Qed.

  (* [transpose] is an involution *)
  Lemma transpose_involution : forall {A B} (R : relationH A B),
      † † R ≡ R.
  Proof.
    intros A B R.
    split.
    - unfold subrelationH. unfold transpose. tauto.
    - unfold subrelationH, transpose. tauto.
  Qed.

  Lemma transpose_inclusion : forall {A B} (R1 : relationH A B) (R2 : relationH A B),
      R1 ⊑ R2 <-> († R1 ⊑ † R2).
  Proof.
    intros A B R1 R2.
    split.
    - intros HS.
      unfold subrelationH, transpose in *. eauto.
    - intros HS.
      unfold subrelationH, transpose in *. eauto.
  Qed.

  Global Instance transpose_Proper :forall A B, Proper (@eq_rel A B ==> eq_rel) (@transpose A B).
  Proof.
    intros A B R1 R2 (Hab & Hba).
    split.
    - apply transpose_inclusion in Hab. assumption.
    - apply transpose_inclusion in Hba. assumption.
  Qed.

  (* [transpose] is monotone *)
  Lemma transpose_monotone
         {A B} (R S: relationH A B) `{R ⊑ S}
    : †R ⊑ †S.
  Proof.
    unfold transpose; intros!.
    apply H. auto.
  Qed.

End TransposeFacts.

Section ProdRelFacts.

  (* [prod_rel] preserves the structure of equivalence relations (what does one call it for a [bifunctor]?) *)
  Section Equivalence.
    Context {R S : Type}.
    Context (RR : relationH R R).
    Context (SS : relationH S S).

    Global Instance prod_rel_refl `{Reflexive _ RR} `{Reflexive _ SS} : Reflexive (RR ⊗ SS).
    Proof.
      intros []. apply ReflexiveH_Reflexive in H. apply ReflexiveH_Reflexive in H0.
      cbn. split. apply H. apply H0.
    Qed.

    Global Instance prod_rel_sym `{Symmetric _ RR} `{Symmetric _ SS}  : Symmetric (RR ⊗ SS).
    Proof.
      intros ? ? ?. apply SymmetricH_Symmetric in H. apply SymmetricH_Symmetric in H0.
      destruct x; destruct y; cbn in *. destruct H1. split.
      - unfold SymmetricH in H. apply H. auto.
      - unfold SymmetricH in H0. apply H0. auto.
    Qed.

    Global Instance prod_rel_trans `{Transitive _ RR} `{Transitive _ SS}  : Transitive (RR ⊗ SS).
    Proof.
      intros!.
      apply TransitiveH_Transitive in H. apply TransitiveH_Transitive in H0.
      unfold TransitiveH in *.
      inversion H1; inversion H2; subst; eauto; inversion H9; subst.
      split. inversion H9.  eapply H;  eauto.
      eapply H0; eauto.
    Qed.

    Global Instance prod_rel_eqv `{Equivalence _ RR} `{Equivalence _ SS} : Equivalence (RR ⊗ SS).
    Proof.
      constructor; typeclasses eauto.
    Qed.

    Global Instance prod_rel_PER `{PER _ RR} `{PER _ SS} : @PER _ (RR ⊗ SS).
    Proof.
      constructor. destruct H, H0.
      eapply SymmetricH_Symmetric.
      eapply prod_rel_sym.
      eapply TransitiveH_Transitive.
      eapply prod_rel_trans.
    Qed.

  End Equivalence.

  Section Zigzag.

    Lemma ZZC_eq_tL :
      forall {A B} (R : relationH A B),
        Zigzag R -> † R ∘ R ∘ † R ≡ † R.
    Proof.
      red. repeat intro; split; repeat intro. red in H0.
      crunch. red in H1. crunch. apply H; repeat (esplit; eauto).
      red. repeat (esplit; eauto).
    Qed.

    Lemma ZZC_eq_tR :
      forall {A B} (R : relationH A B),
        Zigzag R -> R ∘ † R ∘ R ≡ R.
    Proof.
      red. repeat intro; split; repeat intro. red in H0.
      crunch. red in H1. crunch. apply H; repeat (esplit; eauto).
      red. repeat (esplit; eauto).
    Qed.

    Lemma ZZC_not_symmetric:
      exists A (P: relationH A A), Zigzag P /\ not (SymmetricH P).
    Proof.
      intros. exists nat. exists (fun x y => (x = 1 /\ y = 10) \/ (x = 2 /\ y = 20) \/ (x = 1 /\ y = 20) \/ (x = 2 /\ y = 10)).
      assert (Zigzag (fun x y => (x = 1 /\ y = 10) \/ (x = 2 /\ y = 20) \/ (x = 1 /\ y = 20) \/ (x = 2 /\ y = 10))). {
        red. red. intros. red in H.
        destruct H as (? & ? & ?). destruct H as (? & ? & ?). red in H1.
        intuition.
      }
      split. auto.

      intuition.
      red in H0.
      specialize (H0 1 20).
      assert (H1: 1 = 1 /\ 20 = 10 \/ 1 = 2 /\ 20 = 20 \/ 1 = 1 /\ 20 = 20 \/ 1 = 2 /\ 20 = 10) by intuition.
      specialize (H0 H1).
      intuition; try inversion H0; try inversion H2; try inversion H3.
    Qed.

    (* Zarrad and Gumm seems to suggest that difunctionality with reflexivity *and
      symmetry* implies transitivity (see page 15 linked below), but we see here
      that we only need reflexivity.
      [https://hal.inria.fr/hal-01446032/document *)
    Lemma ZZC_with_reflexivity_is_transitive:
      forall A (P : relationH A A), Zigzag P -> ReflexiveH P -> TransitiveH P.
    Proof.
      intros. red in H.
      red. intros. red in H.
      apply H. red. esplit; esplit. esplit. split. 2 : red.
      eauto. eapply H; esplit; esplit. esplit. split.
      3 : apply H0. 2 : eauto.
      eapply H. 2 : eauto. esplit. split; try esplit. split.
      all : eauto.
    Qed.

    Lemma PER_is_ZZC :
      forall A (P : relationH A A), PER P -> Zigzag P.
    Proof.
      intros. destruct H. unfold SymmetricH, TransitiveH in *.
      repeat intro. destruct H as (? & ? & ?). destruct H as (? & ? & ?).
      red in H1. eapply per_trans0.
      eapply H. eapply per_trans0.
      apply per_symm0. all : eauto.
    Qed.

    Instance Proper_Zigzag {A B} : Proper (@eq_rel A B ==> iff) Zigzag.
    Proof.
      repeat intro. split; intros; repeat intro; intuition.
      apply H. apply H0. eapply Proper_compose. eauto.
      eapply Proper_compose; eauto. eapply Proper_transpose; eauto. eauto.
      apply H. apply H0. symmetry in H. eapply Proper_compose. eauto.
      eapply Proper_compose; eauto. eapply Proper_transpose; eauto. eauto.
    Defined.

    Instance Zigzag_eq {A} : Zigzag (@eq A).
    Proof.
      apply PER_is_ZZC. typeclasses eauto.
    Qed.

    (* Pair of elements in A that share the same domain on B *)
    Definition left_inj {A B : Type} (R : relationH A B) : relationH A A :=
      † R ∘ R.

    (* Pair of elements in B that share the same domain on A *)
    Definition right_inj {A B : Type} (R : relationH A B) : relationH B B :=
      R ∘ † R.

    Notation "R ←" := (left_inj R) (at level 40).
    Notation "R →" := (right_inj R) (at level 40).

    Lemma ZZC_PER_l :
      forall A B (R : relationH A B), Zigzag R -> PER (R←).
    Proof.
      intros. red in H. split.
      (* The symmetric case doesn't need the zigzag property *)
      - clear H. repeat intro. destruct H as (? & ? & ?).
        esplit; split. eauto. eauto.
      (* The transitive case does, though.*)
      - repeat intro. destruct H0 as (? & ? & ?). destruct H1 as (? & ? & ?).
        esplit; split. eapply H. esplit; split. esplit; split.
        all : eauto.
    Qed.

    Lemma ZZC_PER_r :
      forall A B (R : relationH A B), Zigzag R -> PER (R→).
    Proof.
      intros. red in H. split.
      (* The symmetric case doesn't need the zigzag property *)
      - clear H. repeat intro. destruct H as (? & ? & ?).
        esplit; split. red. eauto. eauto.
      (* The transitive case does, though.*)
      - repeat intro. destruct H0 as (? & ? & ?). destruct H1 as (? & ? & ?).
        esplit; split. eauto. eapply H. esplit; split. esplit; split.
        all : eauto.
    Qed.

    Lemma ZZC_r :
      forall {A B} (R : relationH A B),
        Zigzag R -> Zigzag (R→).
    Proof.
      intros.
      apply PER_is_ZZC. apply ZZC_PER_r. auto.
    Qed.

    Lemma ZZC_l :
      forall {A B} (R : relationH A B),
        Zigzag R -> Zigzag (R←).
    Proof.
      intros.
      apply PER_is_ZZC. apply ZZC_PER_l. auto.
    Qed.

    Lemma ZZC_l_Symmetric :
      forall {A B} (R : relationH A B),
        Symmetric (R←).
    Proof.
      intros.
      red. intros * (? & ? & ?).
      esplit; split; eauto.
    Qed.

    Lemma ZZC_r_Symmetric :
      forall {A B} (R : relationH A B),
        Symmetric (R→).
    Proof.
      intros.
      red. intros * (? & ? & ?).
      esplit; split; eauto.
    Qed.

    Lemma Transitive_injL_iff :
      forall {A B} (R : relationH A B),
        Transitive (R←) <->
          (forall a a' b, R a b -> R a' b ->
              forall a'' b', R a' b' -> R a'' b' ->
                  exists b'', R a b'' /\ R a'' b'').
    Proof.
      intros.
      split; intros. eapply H. esplit; split. eauto. eauto.
      esplit; split; eauto.
      repeat intro. destruct H0 as (? & ? & ?). destruct H1 as (? & ? & ?).
      eapply H; eauto.
    Qed.

  End Zigzag.

  (* [prod_rel] is monotone in both parameters *)
  Lemma prod_rel_monotone
         {A B C D: Type} (R R': relationH A B) (S S': relationH C D)
         `{R ⊑ R'} `{S ⊑ S'}
  : R ⊗ S ⊑ R' ⊗ S'.
  Proof.
    intros!. destruct x, y. repeat red. repeat red in H1. destruct H1.
    split.
    - apply H. assumption.
    - apply H0. assumption.
  Qed.

  (* [prod_rel] is a bifunctor *)
  Lemma prod_rel_eq : forall (A B:Type),  (@eq A) ⊗ (@eq B) ≡ @eq (A * B).
  Proof.
    intros.
    unfold eq_rel; split; unfold subrelationH; intros.
    - destruct x, y. repeat red in H. destruct H. cbn.  subst; reflexivity.
    - destruct x; destruct y. cbn in H. repeat red. inversion H. split; reflexivity.
  Qed.

  Definition prod_fst_rel {A B : Type} (R : relationH (A * B) (A * B)) :
    relationH A A :=
    fun x y => forall (b1 b2 : B), R  (x, b1) (y, b2).

  Definition prod_snd_rel {A B : Type} (R : relationH (A * B) (A * B)) :
    relationH B B :=
    fun x y => forall (a1 a2 : A), R  (a1, x) (a2, y).

  Lemma prod_inv (A B : Type) :
    forall (R : relationH (A * B) (A * B)) (x1 x2 : A) (y1 y2 : B),
        prod_fst_rel R x1 x2 /\ prod_snd_rel R y1 y2 ->
        R (x1, y1) (x2, y2).
  Proof.
    intros.
    destruct H. unfold prod_fst_rel, prod_snd_rel in *. cbn in *.
    apply H0.
  Qed.

  Lemma prod_compose {A B C D E F: Type}
        (R: relationH A B) (S: relationH B C)
        (T: relationH D E) (U: relationH E F)
    : (S ∘ R) ⊗ (U ∘ T) ≡ (S ⊗ U) ∘ (R ⊗ T).
  Proof.
    split; intros!.
    - destruct x, y. repeat red. repeat red in H. destruct H.
      unfold fst, snd. cbn in H, H0.
      edestruct H as (b & HR & HS).
      edestruct H0 as (e & HT & HU).
      exists (b, e). split; cbn; split; eauto.
    - destruct x, y. repeat red. repeat red in H. destruct H.
      unfold fst, snd in H. destruct H.
      cbn.
      split. exists (fst x). split.
      destruct x. cbn. cbn in H. inversion H ; inversion H0; subst. tauto.
      inversion H; inversion H0; inversion H8; subst. inversion H8. subst.
      cbn; auto.
      inversion H; inversion H0. subst. inversion H8. subst.
      esplit. split; eauto.
  Qed.

  Global Instance Proper_prod_rel {A B C D}: Proper (eq_rel ==> eq_rel ==> eq_rel) (@prod_rel A B C D).
  Proof.
    intros!. split; intros!; destruct x1, y1; cbn in *; destruct H1; split;
    try apply H; try apply H0; eauto.
  Qed.

  (* Distributivity of [transpose] over [prod_rel] *)
  Lemma transpose_prod {A B C D: Type}
        (R: relationH A B) (S: relationH C D)
    : † (S ⊗ R) ≡ (†S ⊗ †R).
  Proof.
    split; unfold transpose; cbn; intros!; destruct x, y; cbn in *;
    destruct H; split; eauto.
  Qed.
End ProdRelFacts.

Section SumRelFacts.

  (* [sum_rel] preserves the structure of equivalence relations (what does one call it for a [bifunctor]?) *)
  Section Equivalence.
    Context {A B : Type}.
    Context (R : relationH A A).
    Context (S : relationH B B).

    Global Instance sum_rel_refl {RR: Reflexive R} {SR: Reflexive S} : Reflexive (R ⊕ S).
    Proof.
      intros []. apply ReflexiveH_Reflexive in RR.
      apply ReflexiveH_Reflexive in SR.
      cbn.
      constructor. apply RR.
      constructor. apply SR.
    Qed.

    Global Instance sum_rel_sym {RS: Symmetric R} {SS: Symmetric S} : Symmetric (R ⊕ S).
    Proof.
      intros ? ? ?. apply SymmetricH_Symmetric in RS.
      apply SymmetricH_Symmetric in SS.
      destruct x, y.
      - constructor. inversion H. subst. apply RS. auto.
      - inversion H.
      - inversion H.
      - constructor. inversion H. subst. apply SS. auto.
    Qed.

    Global Instance sum_rel_trans {RT: Transitive R} {ST: Transitive S}  : Transitive (R ⊕ S).
    Proof.
      intros!.
      apply TransitiveH_Transitive in RT. apply TransitiveH_Transitive in ST.
      unfold TransitiveH in *.
      destruct x, y, z; try contradiction; inversion H; inversion H0; subst.
      cbn in *.
      constructor. eauto. constructor. eauto.
    Qed.

    Global Instance sum_rel_eqv {RE: Equivalence R} {SE: Equivalence S} : Equivalence (R ⊕ S).
    Proof.
      constructor; typeclasses eauto.
    Qed.

  End Equivalence.

  (* [sum_rel] is monotone in both parameters *)
  Lemma sum_rel_monotone
         {A B C D: Type} (R R': relationH A B) (S S': relationH C D)
         `{R ⊑ R'} `{S ⊑ S'}
    : R ⊕ S ⊑ R' ⊕ S'.
  Proof.
    intros!; destruct x, y; repeat red; repeat red in H1;
    inversion H1; subst; constructor; eauto.
  Qed.

  Lemma sum_rel_eq : forall (A B: Type),  @eq A ⊕ @eq B ≡ @eq (A + B).
  Proof.
    intros. red.
    split; repeat intro; eauto.
    inversion H; subst; auto; try reflexivity.
    subst. destruct y; constructor; eauto.
  Qed.

  Lemma sum_compose {A B C D E F: Type}
        (R: relationH A B) (S: relationH B C)
        (T: relationH D E) (U: relationH E F)
  : (S ∘ R) ⊕ (U ∘ T) ≡ (S ⊕ U) ∘ (R ⊕ T).
  Proof.
    split; intros!.
    - destruct x, y; inv H.
      destruct H2 as (? & ? & ?); eexists; eauto.
      destruct H2 as (? & ? & ?); eexists; eauto.
    - destruct H as (? & H1 & H2); inv H1; inv H2.
      econstructor; eexists; eauto.
      econstructor; eexists; eauto.
  Qed.

  Global Instance Proper_sum_rel {A B C D}: Proper (eq_rel ==> eq_rel ==> eq_rel) (@sum_rel A B C D).
  Proof.
    intros!.
    split; intros!; destruct x1, y1; cbn in *; try inversion H1;
      try apply H; try apply H0; eauto; subst; inversion H1; subst;
        try econstructor; try apply H; try apply H0; eauto.
  Qed.

(*    [sum_rel] is a bifunctor *)

(* Note: we also have associators and unitors, forming a monoidal category.
    See [CategoryRelation.v] if needed. *)

  (* Distributivity of [transpose] over [sum_rel] *)
  Lemma transpose_sum {A B C D: Type}
        (R: relationH A B) (S: relationH C D)
    : † (S ⊕ R) ≡ (†S ⊕ †R).
  Proof.
    split; unfold transpose; cbn; intros!; destruct x, y; cbn in *;
      try inversion H; eauto; subst; inversion H; subst; try econstructor; eauto.
  Qed.

End SumRelFacts.

Lemma PER_reflexivityH1 : forall {A:Type} (R : relationH A A) (RS: SymmetricH R) (RT: TransitiveH R)
                            (a b : A), R  a b -> R a a.
Proof.
  intros.
  assert (R  b a). { specialize (RS a b). apply RS. assumption. }
  specialize (RT a b a). apply RT; auto.
Qed.

Lemma PER_reflexivityH2 : forall {A:Type} (R : relationH A A) (RS: SymmetricH R) (RT: TransitiveH R)
                            (a b : A), R  b a -> R a a.
Proof.
  intros.
  assert (R a b). { specialize (RS b a). apply RS. assumption. }
  specialize (RT a b a). apply RT; auto.
Qed.

Ltac PER_reflexivityH :=
  match goal with
  | [ H : ?R  ?X ?Y |- ?R  ?X ?X ] =>  eapply PER_reflexivityH1; eauto
  | [ H : ?R  ?Y ?X |- ?R  ?X ?X ] =>  eapply PER_reflexivityH2; eauto
  end; try apply per_symm ; try apply per_trans.

Definition diagonal_prop {A : Type} (P : A -> Prop) : relationH A A :=
  fun x y => (P  x /\ P y).

Lemma diagonal_prop_SymmetricH {A : Type} (P : A -> Prop) : SymmetricH (diagonal_prop P).
Proof.
  red. intros a1 a2 H.
  cbn in *. unfold diagonal_prop in *. tauto.
Qed.

Lemma diagonal_prop_TransitiveH {A : Type} (P : A -> Prop) : TransitiveH (diagonal_prop P).
Proof.
  red. intros.
  cbn in *. unfold diagonal_prop in *.
  tauto.
Qed.

Lemma diagonal_prop_PER {A : Type} (P : A -> Prop) : PER (diagonal_prop P).
Proof.
  constructor.
  red. intros.
  cbn in *. unfold diagonal_prop in *; tauto.
  red. intros.
  cbn in *. unfold diagonal_prop in *; tauto.
Qed.


(* This file provides a definition of continuity of functions between spaces of the form
Q -> A for some arbitrary types Q and A. It also proves some basic Lemmas about this notion.*)
From mathcomp Require Import all_ssreflect.
Require Import core_mf core_bs.
Require Import FunctionalExtensionality ClassicalChoice.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section CONTINUITY_DEFINITION.
Context (Q A Q' A' : Type).
(* Q is for questions, A is for answers*)
Notation B := (Q -> A).
Notation B' := (Q' -> A').
(* B is for Baire space. *)

(* It is sometimes hepfull thing of B as a language: An element of B is a - notneccessarily
meaningful - conversation: when a question q: Q, is asked in such a conversation, some
information phi(q): I is returned as answer. Usually the questions and answers can be encoded
as natural numbers, which will give the usual Baire space nat -> nat. *)

(* The set of meaningful conversations in a language is a subset of the Baire space corre-
sponding to that language. It is instructive to think about each meaningful conversation
as description of an abstract object. *)
Context (F: B ->> B').
(* F is a multivalued function and a good example of such a function is a translation languages.
Such a translation should assing to each meaningful description of an object in the input
language, i.e. element of (dom F) a description of the same object in the output language. *)

(* For such a translation to exists, it should at least be the case that each property of an
object that each question q' asked about an object in the output language can be answered by
asking questions from a finit list L about the object in the input lanuage. This property is called
continuity of the translation. *)

(* Note that we start from an arbitrary multivalued function F for which the return value on input
phi need not even be unique. Thus, before we start talking about finite lists determining the return
value, we first express wha it means for an input to determine the value. *)
Definition determines phi q' a' := forall Fphi, F phi Fphi -> a' = Fphi q'.

(* determines is closely connected to being single valued. *)
Lemma det_sing:
	(forall phi, phi \from_dom F -> forall q', exists a', determines phi q' a') <-> F \is_single_valued.
Proof.
split => [detall | sing].
	move => phi Fphi Fphi' FphiFphi FphiFphi'.
	apply functional_extensionality => q'.
	have [ | a' det] := (detall phi _ q'); first by exists Fphi.
	by rewrite -(det Fphi); first rewrite -(det Fphi').
move => phi [Fphi FphiFphi] q'.
exists (Fphi q') => Fphi' FphiFphi'.
by rewrite (sing phi Fphi Fphi').
Qed.

(* There is a dual concept that will also be usefull *)
Definition eligible phi q' a' := exists Fphi, F phi Fphi /\ a' = Fphi q'.
(* eligible is closely connected to being total *)

Lemma dom_elig:
	F \is_total -> forall phi q', exists a', eligible phi q' a'.
Proof.
move => tot phi q'; have [Fphi FphiFphi]:= tot phi.
by exists (Fphi q'); exists Fphi.
Qed.

Lemma elig_dom:
	inhabited Q' -> F \is_total <-> forall phi q', exists a', eligible phi q' a'.
Proof.
move => [q']; split; first exact dom_elig; move => eligall phi.
by have [_ [Fphi [FphiFphi _]]]:= eligall phi q'; exists Fphi.
Qed.

(* For being determined from a finite list we use the notion of functions conciding
on lists from core_bs.v *)
Definition cert L phi q' a' := forall psi, phi \and psi \coincide_on L -> determines psi q' a'.
(* cert is for certificate and cert L phi q' a' means that the values of phi on the list L
is enough to determine the return value a' on input q'. *)

Lemma cert_det phi q' a':
	(exists L, cert L phi q' a') -> determines phi q' a'.
Proof. by move => [] L crt elg; apply/ crt; apply coin_ref. Qed.

Lemma cert_mon L K phi q' a':
	L \is_sublist_of K -> cert L phi q' a' -> cert K phi q' a'.
Proof. by move => subl det psi coin; apply: det; apply (coin_mon subl). Qed.

Lemma cert_cons L phi psi q' a':
	phi \and psi \coincide_on L -> cert L phi q' a' -> cert L psi q' a'.
Proof.
move => coin det psi' coin' Fpsi' Fpsi'Fpsi'.
apply/ det; last by apply Fpsi'Fpsi'.
by apply (coin_trans coin coin').
Qed.

(* We define a multivalued modulus function that makes sense even if F is not continuous. *)
Definition mf_mod phiq L:= phiq.1 \from_dom F /\ forall Fphi, F phiq.1 Fphi -> cert L phiq.1 phiq.2 (Fphi phiq.2).
(* The following Lemma gives a good specification for mf_mod: L is a value if whenever there
exists an eligible return value, then L is a certificate for that value. *)

Lemma mod_elig_cert phiq L:
	mf_mod phiq L <-> phiq.1 \from_dom F /\ forall a', eligible phiq.1 phiq.2 a' -> cert L phiq.1 phiq.2 a'.
Proof.
split => [[phifd mod] | ]; first by split => // a' [Fphi [FphiFphi ->]]; apply/ mod.
by move => [phifd eligcert]; split => // Fphi FphiFphi; apply eligcert; exists Fphi.
Qed.

Lemma mod_mon phiq L K:
	L \is_sublist_of K -> mf_mod phiq L -> mf_mod phiq K.
Proof. by move => sl [phifd mod]; split => //; intros; apply/(cert_mon sl)/mod. Qed.

(* since we don't want to require a continuous operator to have a closed
Graph, we need to be a little careful with the definition and carry the
domain around most of the time. *)
Definition cont_xtndbl_to phi := forall q', (phi, q') \from_dom mf_mod.
Definition is_cont_in phi := phi \from_dom F /\ cont_xtndbl_to phi.
Definition is_cont := forall phi, phi \from_dom F -> cont_xtndbl_to phi.

Lemma cont_cont_in:
	is_cont <-> (forall phi, phi \from_dom F -> is_cont_in phi).
Proof.
split => [cont | cntn].
	by move => phi phifd; split => // q'; exact/ cont.
by move => phi phifd; exact/ (cntn phi phifd).2.
Qed.
End CONTINUITY_DEFINITION.

Notation "F '\is_continuous_around' phi" := (cont_xtndbl_to F phi) (at level 2).
Notation "F '\is_continuous'" := (is_cont F) (at level 2).
Notation "F '\is_continuous_in' phi" := (is_cont_in F phi) (at level 2).

Section CONTINUITY_LEMMAS.
Context (Q A Q' A' : Type).
Notation B := (Q -> A).
Notation B' := (Q' -> A').

Lemma elig_exte (F G: B ->> B') phi q' a':
	F \extends G -> eligible G phi q' a' -> eligible F phi q' a'.
Proof.
move => GeF [] Gphi [] GphiGphi eq.
by exists Gphi; split => //; apply/ GeF.
Qed.

Lemma det_exte (F G: B ->> B') phi q' a':
	G \extends F -> determines G phi q' a' -> determines F phi q' a'.
Proof.
move => GeF det Fpsi FpsiFpsi.
by apply det; apply GeF.
Qed.

Lemma cert_exte (F G: B ->> B') L phi q' a':
	G \extends F -> cert G L phi q' a' -> cert F L phi q' a'.
Proof.
move => GeF certi psi coin.
by apply/ det_exte; [apply GeF | apply certi].
Qed.

Definition c_dom (F: B ->> B') phi := closure (dom F) phi.

Lemma dom_cdom (F: B ->> B') phi:
	phi \from_dom F -> c_dom F phi.
Proof. exact: subs_clos. Qed.

(* The following is the reason why the phi \from_dom F is part of many definitions *)
Lemma cert_cdom (F: B ->> B') phi q' a':
	~ c_dom F phi -> exists L, cert F L phi q' a'.
Proof.
move => neg.
have [L Lprop]: exists L, forall psi, ~ (phi \and psi \coincide_on L /\ psi \from_dom F).
	apply NNPP => ex; apply neg => L; apply NNPP => negi.
	exfalso; apply ex; exists L => psi [] coin val.
	by apply negi; exists psi.
exists L => psi coin Fpsi FpsiFpsi.
exfalso; apply (Lprop psi).
by split; last by exists Fpsi.
Qed.

Definition is_mod (F: B ->> B') mf:= forall phi q', phi \from_dom F -> mf_mod F (phi, q') (mf phi q').
Notation "mf '\is_modulus_of' F" := (is_mod F mf) (at level 2).

Lemma mod_cont F mf:
	is_mod F mf <-> forall phi Fphi, F phi Fphi -> forall q', cert F (mf phi q') phi q' (Fphi q').
Proof.
split => [mod phi Fphi FphiFphi q' | ]; last by move => prop; split => //=; intros; apply prop.
by have phifd: phi \from_dom F; [exists Fphi | have [/=_ prop]:= (mod phi q' phifd); apply prop].
Qed.

Lemma cont_mod (F: B ->> B'):
	F \is_continuous <-> exists mf, mf \is_modulus_of F.
Proof.
split => [cont | [mf mprop] phi phifd q']; last by exists (mf phi q'); apply mprop.
have [mf mprop] := exists_choice (mf_mod F) nil.
exists (fun phi q' => mf (phi, q')); move => phi q' phifd.
by have [L Lprop]:= (cont phi phifd q'); exact (mprop _ _ Lprop).
Qed.

Lemma exists_mod F: F \is_continuous ->
	exists mf, mf \is_modulus_of F.
Proof. by intros; apply /cont_mod. Qed.

Lemma elig_restr P (F: B ->> B') phi q' a':
	eligible (F \restricted_to P) phi q' a' -> P phi /\ eligible F phi q' a'.
Proof. by move => [] Fphi [] []; split => //; exists Fphi. Qed.

Lemma restr_elig (P: B -> Prop) (F: B ->> B') phi q' a':
	P phi -> eligible F phi q' a' -> eligible (F \restricted_to P) phi q' a'.
Proof. by move => Pphi [] Fphi []; exists Fphi. Qed.

Lemma det_restr P (F: B ->> B') phi q' a':
	determines (F \restricted_to P) phi q' a' <-> (P phi -> determines F phi q' a').
Proof.
split; first by move => det Pphi Fphi val; apply det.
by move => prop Fphi [] Pphi; apply: (prop Pphi).
Qed.

Definition dom_cont (F: B ->> B') phi := (forall q', (phi, q') \from_dom (mf_mod F)).

Lemma dom_domc (F: B ->> B'):
	F \is_continuous -> forall phi, phi \from_dom F -> dom_cont F phi.
Proof. move => cont phi fd q'; by apply cont. Qed.

Lemma domc_cont (F: B ->> B'):
	(forall phi, phi \from_dom F -> dom_cont F phi ) <-> F \is_continuous.
Proof. by split => ass phi phifd; apply ass. Qed.

Lemma cont_domc (F: B ->> B'):
	(F \restricted_to (dom_cont F)) \is_continuous.
Proof.
move => phi [Fphi [domc FphiFphi]] q'.
have [L [/= phifd Lprop]]:= domc q'; exists L; split; first by exists Fphi.
move => Fphi' [/= _ val] psi coin.
by apply/ det_restr => domcpsi; apply/ Lprop.
Qed.

Lemma cont_sing (F: B ->> B'):
	F \is_continuous -> F \is_single_valued.
Proof.
move => cont; apply det_sing; intros.
have [L [[Fphi FphiFphi] /=Lprop]]:= cont phi H q'.
by exists (Fphi q'); apply cert_det; exists L; apply Lprop.
Qed.

Lemma cont_exte (F G: B ->> B'):
	G \tightens F -> G \is_continuous -> F \is_single_valued -> F \is_continuous.
Proof.
move => GtF Gcont Fsing phi; case; have GeF:= (sing_tight_exte Fsing GtF); intros => q'.
have [ | L [_ /=Lprop]]:= (Gcont phi _ q'); first by exists x; apply GeF.
by exists L; split; [exists x | intros; apply/ (cert_exte GeF)/ Lprop/GeF].
Qed.

Lemma cont_comp Q'' A'' (F: B ->> B') (G: B' ->> (Q'' -> A'')):
	F \is_continuous -> G \is_continuous -> G o F \is_continuous.
Proof.
move => Fcont Gcont phi [GFphi [[Fphi [FphiFphi GFphiGFphi]] doms]] q''.
have [mf ismod]:= (exists_mod Fcont).
have [ | L [/=_ Lprop]]:= (Gcont Fphi _ q''); first by apply doms.
set gather := fix gather K := match K with
	| nil => nil
	| cons q' K' => app (mf phi q') (gather K')
end.
exists (gather L); split; first by exists GFphi; split; [exists Fphi | apply doms].
move => GFphi' [[Fphi' [/=FphiFphi' GFphi'GFphi'] _]] psi coing.
move => GFpsi [[Fpsi [FpsiFpsi GFpsiGFpsi] _]].
suffices gprop: forall K, phi \and psi \coincide_on (gather K) -> Fphi \and Fpsi \coincide_on K.
	by apply /Lprop; [rewrite ((cont_sing Fcont) phi Fphi Fphi') | apply (gprop L) | ].
elim => // a K ih coin; have [coin1 coin2]:= ((coin_app phi psi (mf phi a) (gather K)).1 coin).
by split; [apply/ ((ismod _ a _).2 _ _ _ coin1) => //; exists Fphi | apply ih].
Qed.

Lemma comp_cont Q'' A'' (F: B ->> B') (G: B' ->> (Q'' -> A'')):
	F \is_continuous -> G \is_continuous -> G o F \is_continuous.
Proof. exact: cont_comp. Qed.

Lemma cnst_cont (Fphi: B'):
	(fun (phi: B) (Fphi': B') => forall q, Fphi' q = Fphi q) \is_continuous.
Proof.
by move => phi phifd q; exists nil; split => // Fphi' ->/= psi _ Fpsi ->.
Qed.
End CONTINUITY_LEMMAS.
Notation "mf '\is_modulus_of' F" := (is_mod F mf) (at level 2).


(** Borrowed from Pierce's "Software Foundations" *)

Require Import Arith Arith.EqNat.
Require Import Lia.

Inductive id : Type :=
  Id : nat -> id.

Reserved Notation "m i<= n" (at level 70, no associativity).
Reserved Notation "m i>  n" (at level 70, no associativity).
Reserved Notation "m i<  n" (at level 70, no associativity).

Inductive le_id : id -> id -> Prop :=
  le_conv : forall n m, n <= m -> (Id n) i<= (Id m)
where "n i<= m" := (le_id n m).

Inductive lt_id : id -> id -> Prop :=
  lt_conv : forall n m, n < m -> (Id n) i< (Id m)
where "n i< m" := (lt_id n m).

Inductive gt_id : id -> id -> Prop :=
  gt_conv : forall n m, n > m -> (Id n) i> (Id m)
where "n i> m" := (gt_id n m).

Notation "n i<= m" := (le_id n m).
Notation "n i>  m" := (gt_id n m).
Notation "n i<  m" := (lt_id n m).

Ltac prove_with th :=
  intros;
  repeat (match goal with H: id |- _ => destruct H end);
  match goal with n: nat, m: nat |- _ => set (th n m) end;
  repeat match goal with H: _ + {_} |- _ => inversion_clear H end;
  try match goal with H: {_} + {_} |- _ => inversion_clear H end;
  repeat
    match goal with
      H: ?n <  ?m |-  _                + {Id ?n i< Id ?m}  => right
    | H: ?n <  ?m |-  _                + {_}               => left
    | H: ?n >  ?m |-  _                + {Id ?n i> Id ?m}  => right
    | H: ?n >  ?m |-  _                + {_}               => left
    | H: ?n <  ?m |- {_}               + {Id ?n i< Id ?m}  => right
    | H: ?n <  ?m |- {Id ?n i< Id ?m}  + {_}               => left
    | H: ?n >  ?m |- {_}               + {Id ?n i> Id ?m}  => right
    | H: ?n >  ?m |- {Id ?n i> Id ?m}  + {_}               => left
    | H: ?n =  ?m |-  _                + {Id ?n =  Id ?m}  => right
    | H: ?n =  ?m |-  _                + {_}               => left
    | H: ?n =  ?m |- {_}               + {Id ?n =  Id ?m}  => right
    | H: ?n =  ?m |- {Id ?n =  Id ?m}  + {_}               => left
    | H: ?n <> ?m |-  _                + {Id ?n <> Id ?m}  => right
    | H: ?n <> ?m |-  _                + {_}               => left
    | H: ?n <> ?m |- {_}               + {Id ?n <> Id ?m}  => right
    | H: ?n <> ?m |- {Id ?n <> Id ?m}  + {_}               => left

    | H: ?n <= ?m |-  _                + {Id ?n i<= Id ?m} => right
    | H: ?n <= ?m |-  _                + {_}               => left
    | H: ?n <= ?m |- {_}               + {Id ?n i<= Id ?m} => right
    | H: ?n <= ?m |- {Id ?n i<= Id ?m} + {_}               => left
    end;
  try (constructor; assumption); congruence.

Lemma lt_eq_lt_id_dec: forall (id1 id2 : id), {id1 i< id2} + {id1 = id2} + {id2 i< id1}.
Proof. admit. Admitted.

Lemma gt_eq_gt_id_dec: forall (id1 id2 : id), {id1 i> id2} + {id1 = id2} + {id2 i> id1}.
Proof. admit. Admitted.

Lemma le_gt_id_dec : forall id1 id2 : id, {id1 i<= id2} + {id1 i> id2}.
Proof. admit. Admitted.

Lemma id_eq_dec : forall id1 id2 : id, {id1 = id2} + {id1 <> id2}.
Proof. admit. Admitted.

Lemma eq_id : forall (T:Type) x (p q:T), (if id_eq_dec x x then p else q) = p.
Proof. admit. Admitted.

Lemma neq_id : forall (T:Type) x y (p q:T), x <> y -> (if id_eq_dec x y then p else q) = q.
Proof. admit. Admitted.

Lemma lt_gt_id_false : forall id1 id2 : id,
    id1 i> id2 -> id2 i> id1 -> False.
Proof. admit. Admitted.

Lemma le_gt_id_false : forall id1 id2 : id,
    id2 i<= id1 -> id2 i> id1 -> False.
Proof. admit. Admitted.

Lemma le_lt_eq_id_dec : forall id1 id2 : id,
    id1 i<= id2 -> {id1 = id2} + {id2 i> id1}.
Proof. admit. Admitted.

Lemma neq_lt_gt_id_dec : forall id1 id2 : id,
    id1 <> id2 -> {id1 i> id2} + {id2 i> id1}.
Proof. admit. Admitted.

Lemma eq_gt_id_false : forall id1 id2 : id,
    id1 = id2 -> id1 i> id2 -> False.
Proof. admit. Admitted.


Require Import Classical.
Require Import ClassicalChoice.
Require Import FinFun.

Require Import List.
Require Import Morphisms EquivDec.

Require Import Utils.
Require Import ProbSpace.

Import ListNotations.

Local Open Scope prob.

Lemma classic_event_lem {T} : forall a:event T, event_lem a.
Proof.
  intros ??; apply classic.
Qed.

Lemma event_complement_swap_classic {T} (A B:event T) : ¬ A === B <-> A === ¬ B.
Proof.
  intros.
  apply event_complement_swap; auto using classic_event_lem.
Qed.

Program Instance trivial_sa (T:Type) : SigmaAlgebra T
  := {
      sa_sigma (f:event T) := (f === ∅ \/ f === Ω)
    }.
Next Obligation.
  intros ?? eqq.
  repeat rewrite eqq.
  tauto.
Qed.
Next Obligation.
  auto using classic_event_lem.
Qed.
Next Obligation.
  (* sigh. more classical reasoning needed *)
  destruct (classic (exists n, collection n === Ω))
  ; [right|left]; firstorder.
Qed.
Next Obligation.
  firstorder.
Qed.
Next Obligation.
  firstorder.
Qed.

Program Instance discrete_sa (T:Type) : SigmaAlgebra T
  := {
      sa_sigma := fun _ => True
    }.
Solve Obligations with (auto using classic_event_lem || firstorder).

Program Instance subset_sa (T:Type) (A:event T) : SigmaAlgebra T
  := {
      sa_sigma f := (f === ∅ \/ f === A \/ f === ¬ A \/ f === Ω)
    }.
Next Obligation.
  intros ?? eqq.
  repeat rewrite eqq.
  tauto.
Qed.
Next Obligation.
  auto using classic_event_lem.
Qed.
Next Obligation.
  (* sigh. more classical reasoning needed *)
  destruct (classic (exists n, collection n === Ω))
  ; [repeat right; firstorder | ].
  destruct (classic (exists n, collection n === A))
  ; destruct (classic (exists n, collection n === ¬ A)).
  + right; right; right.
    unfold union_of_collection, equiv, event_equiv; intros x.
    split; [firstorder | ].
    destruct (classic (A x)).
    * destruct H1 as [n1 H1].
      exists n1.
      apply H1; trivial.
    * destruct H2 as [n2 H2].
      exists n2.
      apply H2; trivial.
  + right; left.
    unfold union_of_collection, equiv, event_equiv; intros x.
    split.
    * intros [n cn].
      specialize (H n).
      destruct H as [eqq|[eqq|[eqq|eqq]]]
      ; apply eqq in cn
      ; firstorder.
    * intros ax.
      destruct H1 as [n1 H1].
      exists n1.
      apply H1; trivial.
  + right; right. left.
    unfold union_of_collection, equiv, event_equiv; intros x.
    split.
    * intros [n cn].
      specialize (H n).
      destruct H as [eqq|[eqq|[eqq|eqq]]]
      ; apply eqq in cn
      ; firstorder.
    * intros ax.
      destruct H2 as [n2 H2].
      exists n2.
      apply H2; trivial.
  + left.
    split; [| firstorder].
    intros [n cn].
    destruct (H n) as [eqq|[eqq|[eqq|eqq]]]
    ; apply eqq in cn
    ; firstorder.
Qed.
Next Obligation.
  replace event_equiv with equiv in * by reflexivity.
  repeat rewrite event_complement_swap_classic.
  rewrite event_not_not by auto using classic_event_lem.
  autorewrite with prob.
  tauto.
Qed.
Next Obligation.
  repeat right.
  reflexivity.
Qed.

Definition is_partition {T} (part:nat->event T)
  := collection_is_pairwise_disjoint part
     /\ union_of_collection part === Ω.

Definition sub_partition {T} (part1 part2 : nat -> event T)
  := forall n, part1 n === part2 n \/ part1 n === ∅.

Instance sub_partition_pre {T} : PreOrder (@sub_partition T).
Proof.
  constructor; red; unfold sub_partition; intuition eauto.
  - left; reflexivity.
  - specialize (H n).
    specialize (H0 n).
    intuition.
    + rewrite H1.
      tauto.
    + rewrite H1.
      tauto.
Qed.

Definition in_partition_union {T} (part:nat->event T) (f:event T) : Prop
  := exists subpart, sub_partition subpart part /\ (union_of_collection subpart) === f.

Instance in_partition_union_proper {T} (part:nat->event T) :
  Proper (event_equiv ==> iff) (in_partition_union part).
Proof.
  cut (Proper (event_equiv ==> Basics.impl) (in_partition_union part))
  ; unfold in_partition_union, Basics.impl.
  { intros HH x y xyeq.
    intuition eauto.
    symmetry in xyeq.
    intuition eauto.
  }
  intros x y xyeq [sub [sp uc]].
  rewrite xyeq in uc.
  eauto.
Qed.

Lemma sub_partition_diff {T} (sub part:nat->event T) :
  sub_partition sub part ->
  sub_partition (fun x : nat => part x \ sub x) part.
Proof.
  intros is_sub n.
  specialize (is_sub n).
  destruct is_sub as [eqq|eqq]
  ; rewrite eqq
  ; autorewrite with prob
  ; intuition.
Qed.

Program Instance countable_partition_sa {T} (part:nat->event T) (is_part:is_partition part) : SigmaAlgebra T
  := {
      sa_sigma := in_partition_union part
    }.
Next Obligation.
  auto using classic_event_lem.
Qed.
Next Obligation.
    unfold in_partition_union in *.
    unfold is_partition in *.
    apply choice in H.
    destruct H as [partish pH].
    exists (fun n => union_of_collection (fun x => partish x n)).
    split.
    + intros n.
      unfold union_of_collection.

      unfold union_of_collection in *.
      unfold is_partition in is_part.
      destruct (classic ((fun t : T => exists n0 : nat, partish n0 n t) === ∅)); [eauto | ].
      left.
      apply not_all_ex_not in H.
      destruct H as [nn Hnn].
      unfold event_none in Hnn.
      assert (HH':~ ~ (exists n0 : nat, partish n0 n nn)) by intuition.
      apply NNPP in HH'.
      destruct HH' as [nn2 pnn2].
      destruct (pH nn2) as [HH1 HH2].
      red in HH1.
      intros x.
      split.
      * intros [nn3 pnn3].
        destruct (pH nn3) as [HH31 HH32].
        red in HH31.
        destruct (HH31 n); apply H in pnn3; trivial.
        vm_compute in pnn3; intuition.
      * intros pnnn.
        specialize (HH1 n).
        destruct HH1 as [eqq|eqq]; [ | apply eqq in pnn2; vm_compute in pnn2; intuition ].
        apply eqq in pnnn.
        eauto.
    + intros x; unfold union_of_collection in *.
      split.
      * intros [n1 [n2 pnn]].
        exists n2.
        apply pH.
        eauto.
      * intros [n cn].
        apply pH in cn.
        destruct cn.
        eauto.
Qed.
Next Obligation.
  destruct is_part as [disj tot].
  destruct H as [sub [is_sub uc2]].
  rewrite <- uc2.
  exists (fun x => part x \ sub x).
  split.
  + apply sub_partition_diff; trivial.
  + intros x.
    unfold union_of_collection, event_complement, event_diff.
    { split.
      -
        intros [n [part1 sub1]].
        intros [nn sub2].
        destruct (n == nn); unfold equiv, complement in *.
        + subst; tauto.
        + specialize (disj _ _ c x part1).
          destruct (is_sub nn); [ | firstorder].
          apply H in sub2.
          tauto.
      - intros.
        unfold union_of_collection in tot.
        assert (xin:Ω x) by firstorder.
        apply tot in xin.
        destruct xin as [n partn].
        exists n.
        split; trivial.
        intros subx.
        eauto.
    }
Qed.
Next Obligation.
  exists part.
  destruct is_part as [disj tot].
  rewrite tot.
  split; reflexivity.
Qed.

Program Instance sigma_algebra_intersection {T} (coll:SigmaAlgebra T->Prop): SigmaAlgebra T
  := { sa_sigma := fun e => forall sa, coll sa -> @sa_sigma _ sa e
     }.
Next Obligation.
  intros x y xyeq.
  split; intros HH sa.
  + rewrite <- xyeq.
    auto.
  + rewrite xyeq.
    eauto.
Qed.
Next Obligation.
  auto using classic_event_lem.
Qed.
Next Obligation.
  apply sa_countable_union.
  auto.
Defined.
Next Obligation.
  eauto with prob.
Defined.
Next Obligation.
  eauto with prob.
Qed.

Definition all_included {T} (F:event T -> Prop) : SigmaAlgebra T -> Prop
  := fun sa => forall (e:event T), F e -> @sa_sigma _ sa e.

Instance generated_sa {T} (F:event T -> Prop) : SigmaAlgebra T
  := sigma_algebra_intersection (all_included F).

Lemma generated_sa_sub {T} (F:event T -> Prop) :
  forall x, F x -> @sa_sigma _ (generated_sa F) x.
Proof.
  unfold sa_sigma, generated_sa, sigma_algebra_intersection, all_included.
  eauto.
Qed.

Lemma generated_sa_minimal {T} (F:event T -> Prop) (sa':SigmaAlgebra T) :
  (forall x, F x -> @sa_sigma _ sa' x) ->
  (forall x, @sa_sigma _ (generated_sa F) x -> @sa_sigma _ sa' x).
Proof.
  intros ff x sax.
  unfold sa_sigma, generated_sa, sigma_algebra_intersection, all_included in sax.
  eauto.
Qed.

Definition event_set_product {T₁ T₂} (s₁ : event T₁ -> Prop) (s₂ : event T₂ -> Prop) : event (T₁ * T₂) -> Prop
  := fun (e:event (T₁ * T₂)) =>
       exists e₁ e₂,
         s₁ e₁ /\ s₂ e₂ ->
         e === (fun '(x₁, x₂) => e₁ x₁ /\ e₂ x₂).

Instance product_sa {T₁ T₂} (sa₁:SigmaAlgebra T₁) (sa₂:SigmaAlgebra T₂) : SigmaAlgebra (T₁ * T₂)
  := generated_sa (event_set_product (@sa_sigma _ sa₁) (@sa_sigma _ sa₂)).

Definition event_pullback {X Y:Type} (f:X->Y) (ex:event X) : event Y
  := fun y => exists x, f x = y.

Instance event_pullback_proper {X Y:Type} (f:X->Y) : Proper (event_equiv ==> event_equiv) (event_pullback f).
Proof.
  repeat red; intuition.
Qed.

Instance pullback_sa {X Y:Type} (sa:SigmaAlgebra Y) (f:X->Y) : SigmaAlgebra X
  := generated_sa (fun e => sa_sigma (event_pullback f e)).

Definition is_countable {T} (e:event T)
  := exists (coll:nat -> T -> Prop),
    (forall n t1 t2, coll n t1 -> coll n t2 -> t1 = t2) /\
    e === (fun a => exists n, coll n a).

Lemma is_countable_empty {T} : @is_countable T ∅.
Proof.
  exists (fun n t => False).
  firstorder.
Qed.

Instance is_countable_proper_sub {T} : Proper (event_sub --> Basics.impl) (@is_countable T).
Proof.
  unfold Proper, respectful, Basics.impl, Basics.flip, is_countable.
  intros x y sub [c cx].
  red in sub.
  exists (fun n t =>
            c n t /\ y t).
  firstorder.
Qed.

Instance is_countable_proper {T} : Proper (event_equiv ==> iff) (@is_countable T).
Proof.
  unfold Proper, respectful.
  intros x y eqq.
  split; intros.
  - apply (is_countable_proper_sub x y); trivial.
    apply event_equiv_sub; trivial.
    symmetry; trivial.
  - apply (is_countable_proper_sub y x); trivial.
    apply event_equiv_sub; trivial.
Qed.

Lemma union_of_collection_sup {T} (coll:nat->event T) n : (coll n) ≤ (union_of_collection coll).
Proof.
  unfold event_sub, union_of_collection.
  eauto.
Qed.

Definition F {T} (coll:nat->event T) (n:nat) : ({x:T | coll n x} -> nat) -> Prop
  := fun f => Injective f.

Lemma union_of_collection_is_countable {T} (coll:nat->event T) :
  (forall n : nat, is_countable (coll n)) -> is_countable (union_of_collection coll).
Proof.
  intros isc.
  apply choice in isc.
  destruct isc as [f fprop].
  exists (fun n => let '(n1,n2) := iso_b n in f n1 n2).
  split.
  - intros.
    case_eq (iso_b n); intros n1 n2 eqq.
    rewrite eqq in *.
    destruct (fprop n1)
      as [HH1 HH2].
    eapply HH1; eauto.
  - intros x.
    split.
    + intros [n1 ncoll].
      destruct (fprop n1) as [HH1 HH2].
      specialize (HH2 x).
      apply HH2 in ncoll.
      destruct ncoll as [n2 fx].
      exists (iso_f (n1,n2)).
      rewrite iso_b_f; trivial.
    + intros [n fx].
      case_eq (iso_b n).
      intros n1 n2 eqq.
      rewrite eqq in *.
      destruct (fprop n1) as [HH1 HH2].
      specialize (HH2 x).
      exists n1.
      apply HH2.
      eauto.
Qed.

(* The set of countable and c-countable sets forms a sigma algebra *)
Program Instance countable_sa (T:Type) : SigmaAlgebra T
  := {
      sa_sigma (f:event T) := is_countable f \/ is_countable (¬ f)
    }.
Next Obligation.
  unfold is_countable.
  intros ?? eqq.
  split; intros [[? HH]|[? HH]]
  ; rewrite eqq in HH || rewrite <- eqq in HH
  ; eauto.
Qed.
Next Obligation.
  auto using classic_event_lem.
Qed.
Next Obligation.
  destruct (classic (forall n, is_countable (collection n))).
  + (* they are all countable *)
    left.
    apply union_of_collection_is_countable; trivial.
  + apply not_all_ex_not in H0.
    destruct H0 as [n ncn].
    assert (iscnn:is_countable (¬ collection n)).
    { destruct (H n); intuition. }
    generalize (union_of_collection_sup collection n); intros subs.
    apply event_complement_sub_proper in subs.
    rewrite <- subs in iscnn.
    eauto.
Qed.
Next Obligation.
  rewrite event_not_not by auto using classic_event_lem.
  tauto.
Qed.
Next Obligation.
  right.
  rewrite event_not_all.
  apply is_countable_empty.
Qed.


Add LoadPath "C:\td202\GitHub\coq\views".
Require Import SetoidClass.
Require Import MySetoids.

Definition partial_dec_op (A : Type) := A -> A -> option A.

Definition lift_op_dec {A} (op : partial_dec_op A) : option A -> option A -> option A
  := fun x y => match x with
       | None => None
       | Some x' => match y with
         | None => None
         | Some y' => op x' y'
         end end.

Class PermAlgMixin {A} `{A_setoid : Setoid A} (op : partial_dec_op A) :=
  {
    pa_morph :> Proper (equiv ==> equiv ==> equiv) op;
    pa_comm : forall x y, op x y == op y x;
    pa_assoc : forall x y z, lift_op_dec op (op x y) (Some z)
                        == lift_op_dec op (Some x) (op y z);
    pa_unit : A;
    pa_unit_law : forall x, op pa_unit x == Some x
  }.

Module FracPerm.
  Require Import QArith.

  Definition T := { k : Q | 0 <= k <= 1 }.

  Definition FPequiv (a b : T) : Prop := proj1_sig a == proj1_sig b.
  Instance FPequiv_equivalence : Equivalence FPequiv.
   intuition.
   repeat intro; unfold FPequiv in *.
   rewrite H; trivial.
  Qed.
  Program Instance FPsetoid : Setoid T.

  Definition compat := fun (a b : T) => proj1_sig a + proj1_sig b <= 1.

  Require Import Tactics.
  Instance compat_morph : Proper (FPequiv ==> FPequiv ==> iff) compat.
   repeat intro.
   unfold FPequiv in *.
   unfold compat.
   split; intro; rewr auto.
  Qed.

  Definition compat_dec (a b : T) : {compat a b} + {~compat a b}.
   remember (proj1_sig a + proj1_sig b ?= 1) as c.
   destruct c;
   try solve [left; apply Qle_alt; rewrite <- Heqc; auto with *].
   right; unfold compat; rewrite Qle_alt; auto.
  Defined.

  Program Definition zero : T := 0.
  Program Definition full : T := 1.
  Solve All Obligations using intuition.

  Section plus.
    Variables x y : T.
    Hypothesis small : compat x y.
    Program Definition sum : T := exist _ (proj1_sig x + proj1_sig y) _.
    Obligation 1.
     intuition.
     destruct x; destruct y; simpl.
     destruct a.
     destruct a0.
     apply (Qplus_le_compat 0 _ 0); trivial.
    Qed.
  End plus.

  Definition plus (x y : T) : option T :=
    match compat_dec x y with
      | left l => Some (sum x y l)
      | _ => None
    end.

  Instance proj1_sig_morph : Proper (FPequiv ==> Qeq) (@proj1_sig _ _).
   firstorder.
  Qed.

  Ltac compat_incompat :=
    match goal with [H : compat _ _, H' : ~ compat _ _ |- _] => contradiction H'; rewr auto end.

Lemma Qle_plus_pos_eq : forall x y z, 0 <= x -> (x + y <= z)%Q -> y <= z.
intuition.
apply Qplus_le_r with x.
eapply Qle_trans; eauto.
rewrite <- Qplus_0_l at 1.
apply Qplus_le_l.
trivial.
Qed.

  Ltac plus_tac :=   cbv [Proper respectful compat]; intuition; repeat match goal with
     | H : Some _ = Some _ |- _ => inversion H; clear H; subst
     | H : Some _ = None |- _ => inversion H
     | H : None = Some _ |- _ => inversion H
     | H : ?X <= 1 |- ?Y <= 1 => let f := fresh in assert (Qeq Y X) as f by first [ring | rewr auto]; rewrite f; trivial
     | |- context [plus ?x ?y] => let f := fresh "PLUS" in remember (plus x y) as f; destruct f
     | x : T |- ?bah <= 1 => match bah with context [ x ] => let f1 := fresh x in let f2 := fresh in destruct x as [f1 f2]; destruct f2; simpl in * end
     | Ha : ?a <= 1 |- ?b <= 1 => let Hpd := fresh in
      assert (0 <= a - b) as Hpd by
        (ring_simplify;
         repeat (auto with *;
             match goal with XX : T |- _ => match goal with |- context [XX] =>
                let F := fresh in destruct XX as [XX F]; destruct F; simpl end end));
      apply (Qle_plus_pos_eq _ _ _ Hpd);
      let H' := fresh in assert (a - b + b == a)%Q by ring; rewrite H'; exact Ha
     | _ => progress (unfold plus in *; simpl)
     | |- context [compat_dec ?x ?y] => lazymatch goal with
            | H' : _ = compat_dec x y |- _ => fail
            | _ => let f := fresh "CD" in remember (compat_dec x y) as f; destruct f end
     | H : context [compat_dec ?x ?y] |- _ => lazymatch goal with
            | H' : _ = compat_dec x y |- _ => fail
            | _ => let f := fresh "CD" in remember (compat_dec x y) as f; destruct f end
     | _ => progress unfold FPequiv; unfold sum; simpl; first [ring | rewr auto]
     | H : compat ?x ?y -> False |- _ => contradiction H; clear dependent H; unfold compat in *
     | _ => progress unfold sum in *; simpl in *
     | _ => progress intuition
   end.

  Local Obligation Tactic := plus_tac.
  Program Instance FP_pa : PermAlgMixin plus := {| pa_unit := zero |}.

  Lemma compat_comm : forall a b, compat a b -> compat b a.
   plus_tac.
  Qed.
  Hint Resolve compat_comm.
  Lemma compat_plus1 : forall a b ab c, Some ab = plus a b -> compat ab c -> compat a c.
   plus_tac.
  Qed.
  Hint Resolve compat_plus1.
  Lemma compat_plus2 : forall a b ab c, Some ab = plus a b -> compat ab c -> compat b c.
   plus_tac.
  Qed.
  Hint Resolve compat_plus2.

  Lemma compat_plus_def : forall a b, forall H: compat a b,
   Some (sum a b H) == plus a b.
   plus_tac.
  Qed.
  Lemma compat_zero : forall a, compat zero a.
   plus_tac.
  Qed.
  Hint Resolve compat_zero.
  Lemma compat_zero2 : forall a, compat a zero.
   plus_tac.
  Qed.
  Hint Resolve compat_zero2.

  Lemma sum_morph : forall x x', FPequiv x x' -> forall y y', FPequiv y y' -> forall c c',
       FPequiv (sum x y c) (sum x' y' c').
   plus_tac.
  Qed.
  Hint Rewrite sum_morph.

  Lemma fp_match : forall x y z, forall P : compat x y,
       FPequiv (match plus x y with Some k => k | _ => z end) (sum x y P).
   plus_tac.
  Qed.

End FracPerm.

Module Type PermissionSeparationAlgebraParams.
  Parameter A : Type.
  Parameter PA : Type.
  Declare Instance PA_Setoid : Setoid PA.
  Parameter op : partial_dec_op PA.
  Declare Instance PA_PermAlg : PermAlgMixin op.
End PermissionSeparationAlgebraParams.

Require Import SeparationAlgebras.
Require Import Tactics.
Require Import Setof.
Module PermissionSeparationAlgebra (Export params : PermissionSeparationAlgebraParams).
  Definition S := A -> PA.
  Program Instance S_Setoid : Setoid S :=
    {| equiv := fun c1 c2 => forall t, c1 t == c2 t |}.
   Obligation 1.
    split;
     repeat intro; use_foralls; rewr auto.
   Qed.

  Definition PA_compat (p1 p2 : PA) : Prop :=
     match op p1 p2 with Some _ => True | _ => False end.
  Local Infix "#" := PA_compat (at level 50).
  Local Infix "+" := op.
  Instance PA_compat_morphism : Proper (equiv ==> equiv ==> Basics.impl) PA_compat.
   repeat intro.
   unfold PA_compat in *.
   remember (y + y0).
   assert (o == y + y0) by (subst; reflexivity).
   destruct o; intuition.
   rewrite <- H, <- H0 in H2.
   remember (x + x0).
   destruct o; intuition.
  Qed.

  Definition sepop : partial_op S :=
    fun c1 c2 => {|
            defined := forall t, c1 t # c2 t;
            val := fun t => match c1 t + c2 t with
               | Some perm => perm
               | _ => pa_unit
               end |}.

  Lemma sepop_fact : forall c1 c2, defined (sepop c1 c2) ->
    forall t, Some (val (sepop c1 c2) t) == c1 t + c2 t.
   simpl; unfold PA_compat.
   intros.
   use_foralls.
   remember (c1 t + c2 t).
   destruct o; intuition.
  Qed.

  Lemma PA_compat_comm : forall x y, x # y -> y # x.
   cbv.
   firstorder.
   generalize (pa_comm x y).
   destruct (x + y); destruct (y + x); intuition.
  Qed.
  Hint Resolve PA_compat_comm.

  Program Instance S_SA : SepAlg sepop :=
    {| sa_unit := singleton (fun t => pa_unit) |}.
  Obligation 1.
    repeat intro.
    split; simpl.
     intuition; use_foralls; rewr trivial.

     intuition; use_foralls.
     assert (x t + x0 t == y t + y0 t) as Heq.
      rewr auto.
     induction (x t + x0 t);
      induction (y t + y0 t); intuition.
  Qed.
  Obligation 2.
    split; simpl; intuition; use_foralls.
     assert (x t + y t == y t + x t) as Heq.
      apply pa_comm.
     induction (x t + y t);
      induction (y t + x t); intuition.
  Qed.

  Definition op_foo : forall x y, x # y -> PA.
    intros.
    unfold PA_compat in H.
    destruct (x + y).
    exact p.
    destruct H.
  Defined.

  Lemma op_foo_plus : forall x y, forall P : x # y, x + y = Some (op_foo x y P).
   intros.
   unfold op_foo.
   unfold PA_compat in *.
   destruct (x + y);
    easy.
  Qed.

  Obligation 3.
   split; simpl; intuition;
    repeat (match goal with Hx : A -> _, ht : A |- _ => generalize (Hx ht); clear Hx; intro Hx end);
             generalize (pa_assoc (m1 t) (m2 t) (m3 t)); intro; unfold PA_compat.
    rewrite (op_foo_plus _ _ H0) in *; simpl in *.
    destruct (m2 t + m3 t); intuition.
    rewrite (op_foo_plus _ _ H2) in *.
    destruct H1.

    rewrite (op_foo_plus _ _ H0) in *; simpl in *.
    rewrite (op_foo_plus _ _ H2) in *; simpl in *.
    destruct (m2 t + m3 t); intuition.
    destruct (m1 t + p); intuition.

    rewrite (op_foo_plus _ _ H) in *; simpl in *.
    destruct (m1 t + m2 t); intuition.
    rewrite (op_foo_plus _ _ H2) in *.
    destruct H1.

    rewrite (op_foo_plus _ _ H) in *; simpl in *.
    rewrite (op_foo_plus _ _ H2) in *; simpl in *.
    destruct (m1 t + m2 t); intuition.
    simpl in *.
    destruct (p + m3 t); intuition.

    unfold PA_compat in *.
    destruct (m1 t + m2 t); simpl in *; intuition.
     destruct (p + m3 t); simpl in *; intuition.
      destruct (m2 t + m3 t); simpl in *; intuition.
       destruct (m1 t + p1); simpl in *; intuition.
  Qed.

  Obligation 4.
   exists (fun x => pa_unit); intuition.
    exists (fun x => pa_unit); intuition.
     split;
      simpl; intuition.
      unfold PA_compat.
      generalize (pa_unit_law (m t)); intro.
      destruct (pa_unit + m t); intuition.

      use_foralls; unfold PA_compat in *.
      generalize (pa_unit_law (m t)); intro.
      destruct (pa_unit + m t); intuition.
  Qed.
  Obligation 5.
   destruct H0.
   unfold lift_val in *; simpl in *; intuition.
   use_foralls.
   rewrite <- H8.
   generalize (pa_unit_law (m1 t)); intro.
   rewrite <- H3, <- H6 in H9.
   destruct (i t + m1 t); intuition.
   unfold equiv in H9; simpl in H9.
   rewrite H9; reflexivity.
  Qed.
End PermissionSeparationAlgebra.