Require Import Setoid Morphisms.
Require Import kat normalisation rewriting kat_tac comparisons rel relalg boolean.


From mathcomp Require Import ssreflect ssrbool ssrfun ssrnat seq choice eqtype fintype finfun finset fingraph.

Set Implicit Arguments.
Unset Printing Implicit Defensive.
Unset Strict Implicit.
Set Bullet Behavior "Strict Subproofs".

(** * fhrel: The model of finite heterogeneous relations *)

(** Tactic for eliminating boolean logical connectives. Usually
followed by [firstoder]. This needs explicit calls to setoid_rewrite
do work under binders *)

#[export] Instance: Proper (iff ==> iff ==> iff ==> iff) and3. firstorder. Qed.
#[export] Instance: Proper (iff ==> iff ==> iff ==> iff ==> iff) and4. firstorder. Qed.
#[export] Instance: Proper (iff ==> iff ==> iff ==> iff ==> iff ==> iff) and5. firstorder. Qed.
#[export] Instance: Proper (iff ==> iff ==> iff ==> iff) or3. firstorder. Qed.
#[export] Instance: Proper (iff ==> iff ==> iff ==> iff ==> iff) or4. firstorder. Qed.

Ltac to_prop := 
  repeat first 
         [ setoid_rewrite <- (rwP andP)
         | setoid_rewrite <- (rwP orP)
         | setoid_rewrite <- (rwP and3P)
         | setoid_rewrite <- (rwP existsP)
         | setoid_rewrite <- (rwP forallP) 
         | setoid_rewrite <- (rwP eqP)
         | (* last because implyP also matches [exists _,_] *)
           setoid_rewrite <- (rwP implyP)]. 

(** Use phantom types to trigger inference of finType structures *)
Section FHRelType.
  Variables A B : finType.
  Definition fhrel_type := A -> B -> bool.
  Definition fhrel_of of phant A & phant B := fhrel_type.
End FHRelType.

Notation "{ 'fhrel' A & B }" := (fhrel_of (Phant A) (Phant B))
  (at level 0, format "{ 'fhrel'  A  &  B }") : type_scope.

(** Heterogeneous binary relations [hrel X Y] (i.e., [X -> Y -> Prop]) are
already declared as a model of relation algebra in the module
[rel]. Thus, we only need to provide the model for finite and
decidable relations between finite types [{fhrel A & B}] *)

Section FHRel.
Implicit Types A B C : finType.

(** ** Lattice Operations *)

(** The relations [e1 ≦ e2] and [e1 ≡ e2] and the lattice operations
are not declared but derived (up to conversion) via the powerset
construction on the lattice of booleans 
<<
Section LatticeOps.
Variables (A B : finType) (e1 e2 : {fhrel A & B}).
Implicit Types (x : A) (y : B).

Definition fhrel_weq := e1 =2 e2.
Definition fhrel_leq := forall x y, e1 x y -> e2 x y.
Definition fhrel_cup := fun x y => e1 x y || e2 x y.
Definition fhrel_cap := fun x y => e1 x y && e2 x y.
Definition fhrel_neg := fun x y => ~~ (e1 x y).
Definition fhrel_top := fun x y => true.
Definition fhrel_bot := fun x y => false.
End LatticeOps.
>>
*)

Canonical Structure fhrel_lattice_ops A B := 
  lattice.mk_ops {fhrel A & B} lattice.leq weq cup cap neg bot top.

Arguments lattice.leq : simpl never.
Arguments lattice.weq : simpl never.

(** Obtain the lattice laws using the standard powerset construction *)
#[export] Instance fhrel_lattice_laws A B: 
  lattice.laws (BL+STR+CNV+DIV) (fhrel_lattice_ops A B) := pw_laws _.

Lemma fhrel_leq_dec A B (e1 e2 : {fhrel A & B}) : decidable (e1 ≦ e2).
Proof. 
  apply: (@decP _ [forall x, forall y, e1 x y ==> e2 x y]).
  apply: (equivP idP); to_prop; reflexivity.
Qed.

Lemma fhrel_weq_dec A B (e1 e2 : {fhrel A & B}) : decidable (e1 ≡ e2).
Proof. 
  apply: (@decP _ [forall x, forall y, e1 x y == e2 x y]).
  apply: (equivP idP); to_prop; reflexivity.
Qed.

(** Enable rewriting of [lattice.leq] and [weq] using Ssreflect's rewrite tactic *)
#[export] Instance leq_rewrite_relation ops : RewriteRelation (@lattice.leq ops).
Qed.
#[export] Instance weq_rewrite_relation ops : RewriteRelation (@weq ops).
Qed.

(** ** Monoid Operations

We implement the monoid operations using Ssreflect's boolean
quantifiers and the transitive closure operation provided by the path
library *)

Section MonoidOps.
Variables (A B C : finType).

Definition fhrel_dot (e1 : {fhrel A & B}) (e2 : {fhrel B & C}) : {fhrel A & C} := 
  fun x y => [exists z, e1 x z && e2 z y].
Definition fhrel_cnv (e : {fhrel A & B}) : {fhrel B & A} := 
  fun x y => e y x.
Definition fhrel_str (e : {fhrel A & A}) : {fhrel A & A} := 
  connect e.
Definition fhrel_one : {fhrel A & A} := 
  @eq_op A.
Definition fhrel_rdv (e1 : {fhrel B & A}) (e2 : {fhrel C & A}) : {fhrel C & B} := 
  fun j i => [forall k, e1 i k ==> e2 j k].
Definition fhrel_ldv (e1 : {fhrel A & B}) (e2 : {fhrel A & C}) : {fhrel B & C} := 
  fun i j => [forall k, e1 k i ==> e2 k j].
Definition fhrel_inj (p : pred A) := 
  fun x y => (x == y) && p x.
End MonoidOps.

Definition fhrel_itr A (e : {fhrel A & A}) : {fhrel A & A} := 
  fhrel_dot e (connect e).

Canonical fhrel_monoid_ops := 
  monoid.mk_ops finType fhrel_lattice_ops
                fhrel_dot
                fhrel_one
                fhrel_itr 
                fhrel_str 
                fhrel_cnv 
                fhrel_ldv 
                fhrel_rdv.

(** Ensure that the [fhrel_*] definitions simplify, given enough arguments. *)
Arguments fhrel_dot {_ _ _} _ _ /.
Arguments fhrel_cnv {_ _} _ _ /.
Arguments fhrel_one {_} _ _ /.
Arguments fhrel_str {_} _ _ /.
Arguments fhrel_ldv {_} _ _ /.
Arguments fhrel_rdv {_} _ _ /.
Arguments fhrel_inj {_} _ _ _ /.

Lemma connect_iter (A : ob fhrel_monoid_ops) (e : fhrel_monoid_ops A A) (x y : A): 
    connect e x y <-> (exists u : nat, rel.iter A e u x y).
Proof.
  split.
  - case/connectP => p pth_p lst_p. exists (size p).
    elim: p x pth_p lst_p => /= [x _ -> // | z p IHp x /andP [xz pth_p] lst_p].
    exists z => //. exact: IHp.
  - case => n. elim: n x => /= [x <- // |n IHn x [z xz H]]. 
    exact: connect_trans (connect1 xz) (IHn _ _).
Qed.

(** We obtain the monoid laws using a faithful functor to the hrel model *)
Definition hrel_of (A B : finType) (e : {fhrel A & B}) : hrel A B := fun x y => e x y.
Ltac hrel_prop := do ! move => ?; rewrite /hrel_of /=; to_prop; by firstorder.

Lemma hrel_of_morphism (A B : finType) : morphism (BDL+STR+CNV+DIV) (@hrel_of A B).
Proof.
  split; try done; try hrel_prop.
  move => e1 e2 H x y. apply/eq_bool_iff. exact: H.
Qed.

Lemma hrel_of_functor : functor (BDL+STR+CNV+DIV) hrel_of.
Proof.
  apply (@Build_functor (BDL+STR+CNV+DIV) fhrel_monoid_ops hrel_monoid_ops id hrel_of).
  all: try done. all: try hrel_prop.
  - apply: hrel_of_morphism.
  - move => _ A e x y. rewrite /hrel_of/= /fhrel_itr /hrel_itr /=. to_prop. 
    setoid_rewrite connect_iter. by firstorder.
  - move => _ A e x y. exact: connect_iter.
Qed.

Lemma fhrel_monoid_laws_BDL: monoid.laws (BDL+STR+CNV+DIV) fhrel_monoid_ops.
Proof.
  eapply (laws_of_faithful_functor hrel_of_functor) => //.
  move => A B e1 e2 H x y. apply/eq_bool_iff. exact: H.
Qed.

#[export] Instance hrel_monoid_laws: monoid.laws (BL+STR+CNV+DIV) fhrel_monoid_ops.
Proof.
  case fhrel_monoid_laws_BDL => *.
  split; try assumption. exact: fhrel_lattice_laws.
Qed.

(** In ssreflect /= is used pervasively, so we block the
simplification of relation operators. Unfold selectively by using
[rewrite /dot/=] *)
Arguments dot : simpl never.
Arguments cnv : simpl never.
Arguments str : simpl never.
Arguments itr : simpl never.
Arguments lattice.leq : simpl never.
Arguments lattice.weq : simpl never.
Arguments monoid.one : simpl never.
Hint Unfold monoid.one : core.

(** Lemmas to eliminate [1 n m] *)
Lemma hrel_oneE (n : Set) a b : (1 : hrel n n) a b <-> a = b.
Proof. reflexivity. Qed.
Lemma fhrel_oneE A a b : (1 : {fhrel A & A}) a b = (a == b).
Proof. reflexivity. Qed.
Definition oneE := (hrel_oneE,fhrel_oneE).

(** The following is required since [top' x y] tries to infer an
[hrel] instance and then fails with a universe inconsistency as finite
types to not necessarily live in [Set] *)
Definition ftop_def (A B : finType) of phant A & phant B := 
  (@top (@mor fhrel_monoid_ops A B)).
Notation ftop A B := (ftop_def (Phant A) (Phant B)).

Definition fzero_def (A B : finType) of phant A & phant B := 
  (@bot (@mor fhrel_monoid_ops A B)).
Notation fzero A B := (fzero_def (Phant A) (Phant B)).

Definition fone_def (A : finType) of phant A := 
  (@one fhrel_monoid_ops A).
Notation fone A := (fone_def (Phant A)).

Arguments ftop_def A B /.
Arguments fzero_def A B /.
Arguments fone_def A /.

(** ** KAT Operations *)

(** "decidable" sets or predicates: Boolean functions *)
Definition fdset: ob fhrel_monoid_ops -> lattice.ops := pw_ops bool_lattice_ops.

Canonical Structure fhrel_kat_ops := 
  kat.mk_ops fhrel_monoid_ops fdset (@fhrel_inj).

Global Instance fhrel_kat_laws: kat.laws fhrel_kat_ops.
Proof.
  split.
  - by eapply lower_laws. 
  - move => A. by eapply lower_lattice_laws.
  - move => A.
    have H : Proper (lattice.leq ==> lattice.leq) (@fhrel_inj A).
    { move => e1 e2 H x y /=. by case: (_ == _) => //=. }
    split => //=.
    + move => x y. rewrite !weq_spec. by intuition.
    + move => _ f g x y /=. by case: (_ == _); case (f x); case (g x).
    + move => _ x y /=. by rewrite andbF.
  - move => A x y /=. by rewrite andbT.
  - move => A p q x y /=. rewrite /dot/=.
    apply/eq_bool_iff. to_prop. by firstorder;subst.
Qed.

(** ** Cardinality 
For finite relations we obtain cardinality operation by coercing
heterogeneous relations to prediactes on pairs *)

Definition fhrel_pred (aT rT: finType) (e : {fhrel aT & rT}) := 
  [pred x : aT * rT | e x.1 x.2].

Canonical fhrelPredType (aT rT: finType) := 
  @PredType (aT * rT) ({fhrel aT & rT}) (@fhrel_pred _ _).
Coercion fhrel_pred : fhrel_of >-> simpl_pred.

(* TOTHINK: Instanciate the cardinality development with this? *)
(* Definition fhrel_card (aT rT: finType) (e : {fhrel aT & rT}) := #|e|. *)

Section CardinalityBase.
Variables (aT rT : finType).
Implicit Types (e : {fhrel aT & rT}).

Lemma leq_card e e': e ≦ e' -> #|e| <= #|e'|.
Proof. move => A. apply: subset_leq_card. apply/subsetP => x. exact: A. Qed.

Lemma weq_card e e' : e ≡ e' -> #|e| = #|e'|.
Proof. rewrite weq_spec (rwP eqP) eqn_leq => [[A B]]. by rewrite !leq_card. Qed.

Lemma fhrel_card0 : #|fzero aT rT| = 0%N.
Proof. exact: card0. Qed.

Lemma fhrel_cardT : #|ftop aT rT| = #|aT| * #|rT|.
Proof. exact: eq_card_prod. Qed.

Lemma fhrel_card1 : #|fone aT| = #|aT|.
Proof.
  rewrite -(on_card_preimset (f := (fun x => (x,x)))).
  - rewrite eq_cardT ?cardT //= => x. by rewrite !inE oneE eqxx.
  - exists fst => //= [[x y]]. by rewrite inE oneE /= => /eqP->.
Qed.

Lemma card_cnv e : #|e°| = #|e|.
Proof. 
  rewrite -(on_card_preimset (f := (fun x => (x.2,x.1)))).
  - apply: eq_card => [[x y]]. by rewrite !inE.
  - apply: onW_bij. apply: (Bijective (g := fun x => (x.2,x.1))); by case.
Qed.

Lemma card_cup e1 e2 : #|e1 + e2| = #|e1| + #|e2| - #|e1 ∩ e2|.
Proof. by rewrite (rwP eqP) -cardUI -addnBA // subnn addn0. Qed.

Lemma card_capL e1 e2 : #|e1 ∩ e2| <= #|e1|.
Proof. apply: leq_card. by lattice. Qed.

Lemma card_capR e1 e2 : #|e1 ∩ e2| <= #|e2|.
Proof. apply: leq_card. by lattice. Qed.

Definition dom e := [pred x | [exists y, e x y]].
Definition ran e := [pred y | [exists x, e x y]].

Lemma card_dom e : #|dom e| = #|e ⋅ ftop rT unit|.
Proof.
  rewrite -[in RHS](on_card_preimset (f := (fun x : aT => (x,tt)))).
  - apply: eq_card => x. rewrite !inE /dot /=. 
    by apply/eq_bool_iff;to_prop; firstorder.
  - apply: onW_bij. by apply: (Bijective (g := fst)) => [|[? []]].
Qed.

End CardinalityBase.

Lemma ran_dom {A B} {e : {fhrel A & B}} : ran e =i dom e°.
Proof. move => x. by rewrite !inE. Qed.

Lemma card_ran A B (e : {fhrel A & B}) : 
  #|ran e| = #|ftop unit _⋅e|.
Proof. 
  rewrite (eq_card ran_dom) card_dom -card_cnv. 
  apply: weq_card. rewrite /ftop_def. 
  (* Why does ra. fail here? -- se below *)
  by rewrite cnvdot cnvtop cnv_invol.
Qed.

(* TOTHINK: This is actually a theorem of hrel, but there is no easy
way to transfer. The same is true for [fhrel_injective] and
[fhrel_univalent] *)
Lemma fhrel_surjective A B (e : {fhrel A & B}) : is_surjective e <-> forall y, exists x, e x y.
Proof.
  split => [H y|H y ?].
  - case/exists_inP : (H y y (eqxx _)) => x. by exists x.
  - move/eqP<-. apply/exists_inP. case: (H y) => x exy. by exists x.
Qed.

Lemma surjective_card A B (e : {fhrel A & B}) : 
  is_surjective e -> #|B| <= #|e|.
Proof.
  move/fhrel_surjective => E. 
  pose f y := (xchoose (E y),y).
  have inj_f : injective f by move => x y [].
  rewrite -(card_codom inj_f). 
  apply: subset_leq_card. apply/subsetP => [[x y]] /codomP => [[y'] [-> <-]]. 
  rewrite inE /=. exact: (xchooseP (E y)).
Qed.

Lemma fhrel_injective A B (e : {fhrel A & B}) : 
  is_injective e <-> forall x x' y, e x y -> e x' y -> x = x'.
Proof.
  rewrite /is_injective; split => [H x x' y E1 E2|H x x' E].
  - apply/eqP. apply: (H x x'). by apply/exists_inP;exists y.
  - apply/eqP. case/exists_inP : E. exact: H.
Qed.

Lemma injective_card A B (e : {fhrel A & B}) : 
  is_injective e -> #|e| <= #|B|.
Proof. 
  move/fhrel_injective => inj_e.
  rewrite -(card_in_imset (f := @snd A B)) ?max_card //.
  move => [x y] [x' y']. rewrite !inE /= => E1 E2 ?; subst. 
  by rewrite (inj_e _ _ _ E1 E2).
Qed.

Lemma fhrel_univalent A B (e : {fhrel A & B}) : 
  is_univalent e <-> forall x y y', e x y -> e x y' -> y = y'.
Proof. 
  split => [/@injective_cnv/fhrel_injective|H]. 
  - rewrite /cnv/= => H ? ? ?; exact: H.
  - rewrite /is_univalent. cnv_switch. rewrite cnv1 cnvdot. 
    rewrite -/(is_injective _) fhrel_injective => ? ? ?. exact: H.
Qed.

Lemma univalent_card A B (e : {fhrel A & B}) : 
  is_univalent e -> #|e| <= #|A|.
Proof. move => ?. rewrite -card_cnv. exact: injective_card. Qed.

Lemma total_card A B (e : {fhrel A & B}) : 
  is_total e -> #|A| <= #|e|.
Proof. move => ?. rewrite -card_cnv. exact: surjective_card. Qed.

End FHRel.

Notation ftop A B := (ftop_def (Phant A) (Phant B)).
Notation fzero A B := (fzero_def (Phant A) (Phant B)).
Notation fone A := (fone_def (Phant A)).

Ltac fold_fhrel := ra_fold fhrel_monoid_ops.
Tactic Notation "fold_fhrel" "in" hyp_list(H) := ra_fold fhrel_monoid_ops in H.
Tactic Notation "fold_fhrel" "in" "*" := ra_fold fhrel_monoid_ops in *.

(** Note that, [subrel e f] (which is convertible to [e ≦ f] if [e]
and [f] are homogeneous relations over some finite type) and [e =2 f]
(which is convertible to [e ≡ f] even in the heterogeneous case) are
used pervasively in MathComp. Consequently, [fold_fhrel] can be used
to convert their statements into relation algebra statements. See
below for an examle: *)

(** This is [connect_sub] *)
Goal forall (T : finType) (e e' : rel T), subrel e (connect e') -> subrel (connect e) (connect e'). 
move => T e e'. fold_fhrel. move => H. rewrite H. ka. Abort.

(** This is [connect_eq] *)
Goal forall (T : finType) (e e' : rel T), e =2 e' -> connect e =2 connect e'.
move => T e e'. fold_fhrel. move => H. by rewrite H. Abort.
