Require Import Env Free Sty Subst Tac Var.

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

Lemma Free_unit_absurd : forall X, Free X unit -> False.
Proof. introv H. inverts H. Qed.

Hint Extern 1 =>
  match goal with
  | H : Free _ unit |- _ =>
      apply Free_unit_absurd in H; contradiction
  end
: free.

Lemma Free_mu_absurd : forall X S, Free X (mu X S) -> False.
Proof. introv H; inverts H; auto. Qed.

Hint Extern 1 =>
  match goal with
  | H : Free ?Y (mu ?Y _) |- _ =>
      apply Free_mu_absurd in H; contradiction
  end
: free.

Lemma Closed_var_absurd :
  forall X,
  Closed (var X) -> False.
Proof. introv H. unfold Closed in H. specialize H with X. auto with free. Qed.

Hint Extern 1 =>
  match goal with
  | H : Closed (var _) |- _ =>
    apply Closed_var_absurd in H; contradiction
  end
: free.

(* -------------------------------------------------------------------------- *)
(* Inversion of Free *)

Lemma Free_inv_mu : forall X Y S, Free X (mu Y S) -> X <> Y.
Proof. introv H; inverts H; auto. Qed.

Hint Extern 1 (?X1 <> ?Y1) =>
  match goal with
  | H : Free ?X1 (mu ?Y1 ?S1) |- _ =>
      apply Free_inv_mu in H; assumption
  end
: free.

Lemma Free_inv_var : forall X Y, Free X (var Y) -> X = Y.
Proof. introv H; inverts H; auto. Qed.

Hint Extern 1 (?X1 = ?Y1) =>
  solve [apply Free_inv_var; assumption]
: free.

Ltac Free_inv_auto X S :=
  match goal with
  | H : Free X unit |- _ => inverts H
  | H : Free X (send _ S) |- _ => inverts H
  | H : Free X (recv _ S) |- _ => inverts H
  | H : Free X (echoice S _) |- _ => inverts H
  | H : Free X (echoice _ S) |- _ => inverts H
  | H : Free X (ichoice S _) |- _ => inverts H
  | H : Free X (ichoice _ S) |- _ => inverts H
  | H : Free X (mu _ S) |- _ => inverts H
  end
.

Hint Extern 4 (Free ?X ?S) =>
  Free_inv_auto X S
: free.

Hint Extern 2 (Free _ _) =>
  match goal with
  | H : Free _ _ \/ _ |- _ => decompose_or H
  | H : _ \/ Free _ _ |- _ => decompose_or H
  end
: free.

Lemma Nonfree_shortcut :
  (forall X S B, ~ Free X S -> ~ Free X (send B S)) /\
  (forall X S B, ~ Free X S -> ~ Free X (recv B S)) /\
  (forall X S1 S2,  ~ Free X S1 -> ~ Free X S2 -> ~ Free X (echoice S1 S2)) /\
  (forall X S1 S2,  ~ Free X S1 -> ~ Free X S2 -> ~ Free X (ichoice S1 S2)) /\
  (forall X Y S, ~ Free X S -> ~ Free X (mu Y S)).
Proof.
  splits; auto with free;
    introv HS1 HS2 contra; inverts1 contra; decompose_or contra; auto.
Qed.

Hint Extern 2 (~ Free _ _) => apply Nonfree_shortcut : free.

(* -------------------------------------------------------------------------- *)
(* Closed automation *)

Lemma Closed_inv :
  forall S S',
  StySubSimple S S' ->
  Closed S' ->
  Closed S.
Proof.
  introv sub; inverts sub; introv H; unfold Closed in *; try split; intro Y;
  specialize H with Y; contradict H; auto with free.
Qed.

Hint Extern 2 (Closed ?S) =>
  match goal with
  | H : Closed _ |- _ =>
      solve [apply (Closed_inv S) in H; [assumption | auto with stysub]]
  end
: free.

(* -------------------------------------------------------------------------- *)
(* Non-automation lemmas *)

Lemma Free_dec : forall S X, {Free X S} + {~ Free X S}.
Proof.
  intros S X. induction S;
    repeat (
      match goal with
      | H : {_} + {_} |- _ => decompose sum H; clear H
      end
    );
    auto with free;
    destruct (eq_Var_dec X v); subst; auto with free.
Defined.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall C E D B F A : Universe, ((wd_ B F /\ (wd_ C E /\ (wd_ E D /\ (wd_ C D /\ (wd_ C B /\ (wd_ B A /\ (col_ D E B /\ (col_ D E F /\ col_ A B F)))))))) -> col_ D E A)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj18synthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus (plus lv0 lv1) lv2)) (plus lv1 (Succ (plus lv2 lv0)))).
Admitted.
QuickChick conj18synthconj4.


Require Import Raft.

Section CandidateTermGtLogInterface.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition candidate_term_gt_log net :=
    forall (h : name),
      type (nwState net h) = Candidate ->
      (forall e, In e (log (nwState net h)) -> currentTerm (nwState net h) > eTerm e).

  Class candidate_term_gt_log_interface : Prop :=
    {
      candidate_term_gt_log_invariant :
        forall net,
          raft_intermediate_reachable net ->
          candidate_term_gt_log net
    }.
End CandidateTermGtLogInterface.


(* ------------------------------------------------------------------------------------------------ *)
From Coq      Require Import PArray Uint63.
From mathcomp Require Import all_ssreflect all_algebra finmap.

From Polyhedra Require Import extra_misc vector_order inner_product.
From PolyhedraHirsch Require Import extra_int extra_array graph high_graph.

Require Import NArith.BinNat NArith.BinNatDef.

Import Order.Theory.

(* ------------------------------------------------------------------------------------------------ *)
Set   Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Unset SsrOldRewriteGoalsOrder.

(* ------------------------------------------------------------------------------------------------ *)
Section RelFunc.

Definition rel_func {T T' U U' : Type} (r1 : T -> U -> Prop) (r2 : T' -> U' -> Prop)
  (f : T -> T') (g : U -> U') := (forall x y, r1 x y -> r2 (f x) (g y)).

Lemma rel_func_if {t t' T T' : Type} (r : t -> T -> Prop) (r' : t' -> T' -> Prop)
  (b : t -> bool) (B : T -> bool) (f_t f_f : t -> t') (F_t F_f : T -> T'):
  (rel_func r eq) b B ->
  (forall x X, r x X -> b x -> r' (f_t x) (F_t X))->
  (forall x X, r x X -> ~~ b x -> r' (f_f x) (F_f X))->
  (rel_func r r') (fun x=> if b x then f_t x else f_f x) (fun X=> if B X then F_t X else F_f X).
Proof.
move=> bB fF_t fF_f x X xX; rewrite -(bB _ _ xX).
case/boolP: (b x); [exact:fF_t|exact:fF_f].
Qed.

End RelFunc.

Notation "R =~> R'" := (rel_func R R') (at level 70, right associativity, format "R  =~>  R'").

Section Composition.

Definition rel_comp {T U V : Type} (r1 : T -> U -> Prop) (r2 : U -> V -> Prop)
  (x : T) (X : V) := exists2 xX : U, r1 x xX & r2 xX X.

Local Notation "R |~ R'" := (rel_comp R R') (at level 65, right associativity, format "R  |~  R'").

Lemma rel_comp_func {T U V T' U' V': Type}
  (r1 : T -> U -> Prop) (r2 : U -> V -> Prop)
  (r1' : T' -> U' -> Prop) (r2' : U' -> V' -> Prop)
  (f : T -> T') (g : U -> U') (h : V -> V'):
  (r1 =~> r1') f g -> (r2 =~> r2') g h ->
  (r1 |~ r2 =~> r1' |~ r2') f h.
Proof.
move=> r1r1' r2r2' x z [y r1_xy r2_yz].
exists (g y); [exact:r1r1'|exact:r2r2'].
Qed.

Lemma rel_comp_func2 {T U V T' U' V' T'' U'' V'': Type}
  (r1 : T -> U -> Prop) (r2 : U -> V -> Prop)
  (r1' : T' -> U' -> Prop) (r2' : U' -> V' -> Prop)
  (r1'' : T'' -> U'' -> Prop) (r2'' : U'' -> V'' -> Prop)
  (f : T -> T' -> T'') (g : U -> U' -> U'')
  (h : V -> V' -> V''):
  (r1 =~> r1' =~> r1'') f g -> (r2 =~> r2' =~> r2'') g h ->
  (r1 |~ r2 =~> r1' |~ r2' =~> r1'' |~  r2'') f h.
Proof.
move=> fg gh x X [xX r1_x r2_x] y Y [yY r1'_y r2'_y].
exists (g xX yY); [exact/fg|exact/gh].
Qed.

Definition rel_equiv {t T : Type} (r r' : t -> T -> Prop):=
  forall x X, r x X <-> r' x X.

Lemma rel_equiv_refl {t T : Type} (r : t -> T -> Prop):
  rel_equiv r r.
Proof. by []. Qed.

Lemma rel_comp_eqL {t T : Type} (r : t -> T -> Prop):
  rel_equiv r (eq |~ r).
Proof. move=> x y; split; [by move=> ?; exists x|by case=> ? ->]. Qed.

Lemma rel_comp_eqR {t T : Type} (r : t -> T -> Prop):
  rel_equiv r (r |~ eq).
Proof. move=> x y; split; [by move=> ?; exists y|by case=> ?? <-]. Qed.

Lemma rel_equiv_func {t t' T T' : Type}
  (r1 r2 : t -> T -> Prop) (r1' r2' : t' -> T' -> Prop):
  rel_equiv r1 r2 -> rel_equiv r1' r2' ->
  rel_equiv (r1 =~> r1') (r2 =~> r2').
Proof. by move=> r1r2 r1r2' f F; split; move=> fF x X /r1r2 /fF /r1r2'. Qed.

Lemma rel_equiv_func2 {t t' t'' T T' T'' : Type}
  (r1 r2 : t -> T -> Prop) (r1' r2' : t' -> T' -> Prop)
  (r1'' r2'' : t'' -> T'' -> Prop):
  rel_equiv r1 r2 -> rel_equiv r1' r2' -> rel_equiv r1'' r2'' ->
  rel_equiv (r1 =~> r1' =~> r1'') (r2 =~> r2' =~> r2'').
Proof. move=> ???; apply/rel_equiv_func=> //; exact/rel_equiv_func. Qed.

End Composition.

Notation "R |~ R'" := (rel_comp R R') (at level 70, right associativity, format "R  |~  R'").

Section RelCouple.

Definition rel_couple {t t' T T' : Type} (r : t -> T -> Prop) (r' : t' -> T' -> Prop):=
  fun x X=> r x.1 X.1 /\ r' x.2 X.2.

Lemma rel_couple_func {t1 t2 t1' t2' T1 T2 T1' T2' : Type}
  (r1 : t1 -> T1 -> Prop) (r1' : t1' -> T1' -> Prop)
  (r2 : t2 -> T2 -> Prop) (r2' : t2' -> T2' -> Prop)
  (f1 : t1 -> t1') (f2 : t2 -> t2') (F1 : T1 -> T1') (F2 : T2 -> T2'):
  (r1 =~> r1') f1 F1 -> (r2 =~> r2') f2 F2 ->
  (rel_couple r1 r2 =~> rel_couple r1' r2') (fun x=> (f1 x.1, f2 x.2)) (fun X=> (F1 X.1, F2 X.2)).
Proof.
move=> fF1 fF2 [x1 x2] [X1 X2] /= [] /= /fF1 ? /fF2 ?.
by split.
Qed.

Lemma rel_couple_func_fst {t1 t2 t1' T1 T2 T1' : Type}
  (r1 : t1 -> T1 -> Prop) (r2 : t2 -> T2 -> Prop)
  (r1' : t1' -> T1' -> Prop)
  (f : t1 -> t1') (F : T1 -> T1'):
  (r1 =~> r1') f F ->
  (rel_couple r1 r2 =~> r1') (fun x=> f x.1) (fun X=> F X.1).
Proof. move=> fF x X [? _]; exact/fF. Qed.

Lemma rel_couple_func_snd {t1 t2 t2' T1 T2 T2' : Type}
  (r1 : t1 -> T1 -> Prop) (r2 : t2 -> T2 -> Prop)
  (r2' : t2' -> T2' -> Prop)
  (f : t2 -> t2') (F : T2 -> T2'):
  (r2 =~> r2') f F ->
  (rel_couple r1 r2 =~> r2') (fun x=> f x.2) (fun X=> F X.2).
Proof. move=> fF x X [_ ?]; exact/fF. Qed.

Lemma rel_couple_comp {t1 T1 T1' t2 T2 T2' : Type}
  (r1 : t1 -> T1 -> Prop) (r2 : t2 -> T2 -> Prop)
  (r1' : T1 -> T1' -> Prop) (r2' : T2 -> T2' -> Prop):
  forall x Y,
  ((rel_couple r1 r2) |~ (rel_couple r1' r2')) x Y <->
  rel_couple (r1 |~ r1') (r2 |~ r2') x Y.
Proof.
case=> x1 x2 [Y1 Y2]; split.
- case=> -[X1 X2] [/= x1X1 x2X2] [/= X1Y1 X2Y2].
  by split=> /=; [exists X1|exists X2].
- case=> /= -[X1 x1X1 X1Y1] [X2 x2X2 X2Y2].
  by exists (X1,X2); split=> //.
Qed.
End RelCouple.

Section RelArray.

Definition rel_array {t T : Type} (r : t -> T -> Prop) a A :=
  (length a = length A) /\ (forall i, (i < length a)%O -> r a.[i] A.[i]).

Lemma rel_array_length {t T : Type} (r : t -> T -> Prop): (rel_array r =~> eq) length length.
Proof. by move=> ?? []. Qed.

Lemma rel_array_r {t T : Type} (r : t -> T -> Prop) a A:
  rel_array r a A -> (forall i, (i < length a)%O -> r a.[i] A.[i]).
Proof. by case. Qed.

Lemma rel_array_make {t T : Type} (r : t -> T -> Prop) k:
  (r =~> rel_array r) (fun x=> make k x) (fun X=> make k X).
Proof.
move=> x X xX; split; rewrite ?length_make //.
by move=> i _; rewrite !get_make.
Qed.

Lemma rel_array_write {t T : Type} (r : t -> T -> Prop) k x X:
  r x X ->
  (rel_array r =~> rel_array r) (fun a=> set a k x) (fun A=> set A k X).
Proof.
move=> xX a A aA [:len_eq]; split; rewrite ?length_set.
  abstract: len_eq; exact: (rel_array_length aA).
move=> i i_len; case/boolP: (k == i).
- by move/eqP=> ->; rewrite !get_set_same -?ltEint -?len_eq ?i_len.
- move=> k_n_i; rewrite !get_set_other; try exact/eqP.
  exact/(rel_array_r aA).
Qed.

Lemma rel_array_iall {t T : Type} (r : t -> T -> Prop) f :
  (rel_array r =~> eq) (fun a=> iall f (length a)) (fun A=> iall f (length A)).
Proof. by move=> a A aA; rewrite (rel_array_length aA). Qed.

Lemma rel_array_iall_dep {t T : Type} (r : t -> T -> Prop) f F:
  (eq =~> r =~> eq) f F ->
  (rel_array r =~> eq)
    (fun a=> iall (fun i=> f i a.[i]) (length a))
    (fun A=> iall (fun i=> F i A.[i]) (length A)).
Proof.
move=> fF a A aA; rewrite -(rel_array_length aA); apply/eq_in_all.
move=> i; rewrite mem_irangeE le0x /= => i_len.
by apply/fF=> //; apply/(rel_array_r aA).
Qed.

Lemma rel_array_map {t t' T T' : Type}
  (r : t -> T -> Prop) (r' : t' -> T' -> Prop)
  (f : t -> t') (F : T -> T'):
  (r =~> r') f F ->
  (rel_array r =~> rel_array r') (arr_map f) (arr_map F).
Proof.
move=> fF a A aA; split.
- rewrite !length_arr_map; exact/(rel_array_length aA).
- move=> i; rewrite !arr_map_nth length_arr_map => /(rel_array_r aA).
  exact/fF.
Qed.

Fixpoint rel_seq_r {t T : Type} (r : t -> T -> Prop) (s : seq t) (S : seq T):=
  match s, S with
  |h::q, H::Q => r h H /\ rel_seq_r r q Q
  |[::], [::] => True
  |_, _ => False
  end.

Lemma rel_array_to_seq {t T : Type} (r : t -> T -> Prop):
  (rel_array r =~> (rel_seq_r r)) arr_to_seq arr_to_seq.
Proof.
move=> x X xX.
move: (rel_array_length xX)=> /(congr1 int_to_nat); rewrite -!size_arr_to_seq.
have: (forall k, k < size (arr_to_seq x) -> r (nth (default x) (arr_to_seq x) k) (nth (default X) (arr_to_seq X) k)).
  move=> k; rewrite size_arr_to_seq=> k_len; rewrite !nth_arr_to_seq -?(rel_array_length xX) //.
  apply:rel_array_r=> //; rewrite ltEint_nat; apply/leq_ltn_trans/k_len/nat_to_int_le.
elim: (arr_to_seq x) (arr_to_seq X)=> [|a l IH] [|a' l'] //= nth_al size_l; split.
- apply/(nth_al 0)/ltn0Sn.
- by apply/IH/succn_inj=> // k; rewrite -ltnS=> /nth_al /=.
Qed.

Lemma rel_array_fold_pair {t1 t2 t' T1 T2 T' : Type}
  (r1 : t1 -> T1 -> Prop) (r2 : t2 -> T2 -> Prop) (r' : t' -> T' -> Prop)
  (f : t1 -> t2 -> t' -> t') (F : T1 -> T2 -> T' -> T'):
  (r1 =~> r2 =~> r' =~> r') f F ->
  (rel_array r1 =~> rel_array r2 =~> r' =~> r') (arr_fold_pair f) (arr_fold_pair F).
Proof.
move=> fF x X xX y Y yY a A aA.
move: (rel_array_to_seq xX) (rel_array_to_seq yY); rewrite /arr_fold_pair.
elim: (arr_to_seq x) (arr_to_seq X) (arr_to_seq y) (arr_to_seq Y) a A aA=> /= [|xa xl IH].
- by case=> //; case=> [|??]; case.
- case=> // Xa Xl; case=> [|ya yl]; case=> //= Ya Yl a A aA [xXa xXl] [yYa yYl].
  apply/IH=> //; exact/fF.
Qed.

Lemma rel_array_fold_pair_in {t1 t2 t' T1 T2 T' : Type}
  (r1 : t1 -> T1 -> Prop) (r2 : t2 -> T2 -> Prop) (r' : t' -> T' -> Prop)
  (f : t1 -> t2 -> t' -> t') (F : T1 -> T2 -> T' -> T')
  a1 A1 a2 A2:
  (length A1 = length A2) ->
  (forall i, (i < length A1)%O -> (r' =~> r') (f a1.[i] a2.[i]) (F A1.[i] A2.[i])) ->
  rel_array r1 a1 A1 -> rel_array r2 a2 A2 ->
  (r' =~> r') (arr_fold_pair f a1 a2) (arr_fold_pair F A1 A2).
Proof.
move=> len_eq h_in a1A1 a2A2 z Z zZ.
rewrite /arr_fold_pair /arr_to_seq (rel_array_length a1A1) (rel_array_length a2A2).
rewrite -len_eq.
have: forall i, i \in irange0 (length A1) ->
  (r' =~> r') (f a1.[i] a2.[i]) (F A1.[i] A2.[i]) by
  move=> i; rewrite mem_irangeE le0x /=; exact:h_in.
elim/last_ind: (irange0 _)=> //= t h IH h_in_IH.
rewrite !map_rcons !zip_rcons ?size_map // !foldl_rcons /=.
apply/h_in_IH; last apply/IH; rewrite ?mem_rcons ?inE ?eqxx //.
by move=> i it; apply/h_in_IH; rewrite mem_rcons inE it orbT.
Qed.

Lemma rel_array_eq {t T : Type} (r : t -> T -> Prop)
  (rel_t : rel t) (rel_T : rel T):
  (r =~> r =~> eq) rel_t rel_T ->
  (rel_array r =~> rel_array r =~> eq)
    (eq_array_rel rel_t) (eq_array_rel rel_T).
Proof.
move=> tT x X xX y Y yY; rewrite /eq_array_rel /arr_all_pair.
congr andb; rewrite ?(rel_array_length xX) ?(rel_array_length yY) //.
move: (rel_array_to_seq xX) (rel_array_to_seq yY).
elim: (arr_to_seq x) (arr_to_seq X) (arr_to_seq y) (arr_to_seq Y)=> [|xa xl IH].
- by case=> /= [|Xa Xl]; case=> [|??]; case.
- case=> // Xa Xl [|ya yl] [|Ya Yl] //=.
  case=> ?? [??]; congr andb; [exact:tT|exact:IH].
Qed.

Lemma rel_array_lex {t T : Type} (r : t -> T -> Prop)
  (cmp : t -> t -> comparison) (Cmp : T -> T -> comparison):
  (r =~> r =~> eq) cmp Cmp ->
  (rel_array r =~> rel_array r =~> eq) (lex_array_rel cmp) (lex_array_rel Cmp).
Proof.
move=> cC x X xX y Y yY [: len_eq]; congr andb.
  abstract : len_eq; rewrite ?(rel_array_length xX) ?(rel_array_length yY) //.
rewrite /lex_array_rel_.
set a := arr_fold_pair _ _ _ _; set A := arr_fold_pair _ _ _ _.
suff ->: a = A by [].
apply:(rel_array_fold_pair)=> //; [|exact:xX|exact:yY].
move=> p P pP q Q qQ c C ->; case: C=> //; exact/cC.
Qed.

Lemma rel_array_arr_mk_fun {t T : Type} (r : t -> T -> Prop) f F n:
  (n <= max_length)%O ->
  (forall i, (i < n)%O -> r (f i) (F i)) ->
  (r =~> rel_array r) (arr_mk_fun f n) (arr_mk_fun F n).
Proof.
move=> n_max fF x X xX; split; rewrite ?length_arr_mk_fun //.
move=> i i_n; rewrite !nth_arr_mk_fun //.
exact/fF.
Qed.

Lemma rel_array_dot {t T : Type} (r : t -> T -> Prop)
  addf addF mulf mulF x0 X0:
  (r =~> r =~> r) addf addF ->
  (r =~> r =~> r) mulf mulF ->
  r x0 X0 ->
  (rel_array r =~> rel_array r =~> r)
  (array_dot addf mulf x0) (array_dot addF mulF X0).
Proof.
move=> addh mulh x0h a A aA b B bB.
apply: rel_array_fold_pair=> //; [|exact:aA|exact:bB].
move=> ?????????; apply/addh=> //; exact/mulh.
Qed.

Lemma rel_array_mul_row_mx {t T : Type} (r : t -> T -> Prop)
  addf addF mulf mulF x0 X0:
  (r =~> r =~> r) addf addF ->
  (r =~> r =~> r) mulf mulF ->
  r x0 X0 ->
  (rel_array r =~> rel_array (rel_array r) =~> rel_array r)
  (array_mul_row_mx addf mulf x0) (array_mul_row_mx addF mulF X0).
Proof.
move=> addh mulh x0h a A aA b B bB.
apply: rel_array_map; [|exact:bB].
exact:rel_array_dot.
Qed.

Lemma rel_array_mulmx {t T : Type} (r : t -> T -> Prop)
  addf addF mulf mulF x0 X0:
  (r =~> r =~> r) addf addF ->
  (r =~> r =~> r) mulf mulF ->
  r x0 X0 ->
  (rel_array (rel_array r) =~> rel_array (rel_array r) =~>
  rel_array (rel_array r))
  (array_mulmx addf mulf x0) (array_mulmx addF mulF X0).
Proof.
move=> addh mulh x0h a A aA b B bB.
apply:rel_array_map; [|exact:aA].
by move=> ???; apply:rel_array_mul_row_mx.
Qed.

End RelArray.

Section RelSpec.

Definition rel_spec {t T : Type} (r : t -> T -> Prop) (R : T -> T -> Prop) :=
  forall x X Y, r x X -> r x Y -> R Y X.

Lemma rel_spec_couple {t1 t2 T1 T2 : Type}
  (r1 : t1 -> T1 -> Prop) (r2 : t2 -> T2 -> Prop)
  (R1 : T1 -> T1 -> Prop) (R2 : T2 -> T2 -> Prop):
  rel_spec r1 R1 -> rel_spec r2 R2 ->
  rel_spec (rel_couple r1 r2) (rel_couple R1 R2).
Proof.
move=> rR1 rR2 [a b] [A B] [A' B'] [/= aA bB] [/= aA' bB'].
split; [exact:(rR1 _ _ _ aA aA')|exact:(rR2 _ _ _ bB bB')].
Qed.

Lemma rel_spec_comp {t T TT : Type}
  (r : t -> T -> Prop) (R : T -> TT -> Prop)
  (eq_T : T -> T -> Prop) (eq_TT : TT -> TT -> Prop):
  rel_spec r eq_T -> rel_spec R eq_TT ->
  (forall X Y Z, eq_T Y X -> R X Z -> R Y Z)->
  rel_spec (r |~ R) eq_TT.
Proof.
move=> rT RTT eq_h x XX YY [X xX XXX] [Y xY YYY].
by move: (rT _ _ _ xX xY)=> /eq_h/(_ XXX)/RTT; apply.
Qed.

Lemma rel_spec_array {t T : Type}
  (r : t -> T -> Prop) (eq_T : T -> T -> Prop):
  rel_spec r eq_T ->
  rel_spec (rel_array r)
    (fun a b=> (length a = length b) /\
      (forall i, (i < length a)%O -> eq_T a.[i] b.[i])).
Proof.
move=> r_spec a A B aA aB; split;
  rewrite -?(rel_array_length aA) -?(rel_array_length aB) //.
move=> i i_len; move: (rel_array_r aA i_len) (rel_array_r aB i_len).
apply/r_spec.
Qed.

End RelSpec.
(* ------------------------------------------------------------------------------------------------ *)

Section RelInt.

Definition rel_int (i : Uint63.int) (n : nat):= n = i.
Definition rel_int_ord {m : nat} (i : Uint63.int) (n : 'I_m.+1) := rel_int i (val n).

Lemma rel_int_eq: (rel_int =~> rel_int =~> eq)
  (@eq_op _) (@eq_op _).
Proof.
move=> x X xX y Y yY; apply/idP/idP.
- by move/eqP/(congr1 int_to_nat); rewrite xX yY => ->; rewrite eqxx.
- by rewrite xX yY=> /eqP /int_to_nat_inj ->.
Qed.

Lemma rel_int_ord_lt (m : nat):
  (@rel_int_ord m =~> @rel_int_ord m =~> eq)
    (fun i j=> (i < j)%O) (fun I J=> (I < J)%nat).
Proof. by move=> x X xX y Y yY; rewrite xX yY ltEint_nat. Qed.

End RelInt.

Section ArraySet.

Context {T : finType}.

Definition rel_array_set (lt_T : rel T) (a : array T) (s : {set T}):=
  rel_sorted lt_T a /\ s = [set a.[i] | i in irange0 (length a)].

Context (lt_T : rel T).

Lemma rel_array_set_iall f F a A:
  (forall i, (i < length a)%O -> f i = F a.[i])->
  rel_array_set lt_T a A ->
  (iall f (length a)) = [forall i, (i \in A) ==> F i].
Proof.
move=> fF aA; apply/idP/idP.
- move/allP=> h; apply/forallP=> k; apply/implyP.
  case: aA=> _ ->; case/imsetP=> i; rewrite mem_irangeE le0x /=.
  move=> /[dup] /fF + + ->; move=> <- ?; apply/h.
  by rewrite mem_irangeE le0x.
- move/forallP=> h; apply/allP=> i; rewrite mem_irangeE le0x /=.
  move=> i_len; rewrite (fF _ i_len).
  move: h=> /(_ a.[i])/implyP; apply.
  by case: aA=> _ ->; apply/imset_f; rewrite mem_irangeE le0x /=.
Qed.

Hypothesis irr_lt_T : irreflexive lt_T.
Hypothesis tra_lt_T : transitive lt_T.

Lemma rel_array_set_length:
  (rel_array_set lt_T =~> rel_int)
  length (fun A => #|A|).
Proof.
move=> a A [std_a ->]; rewrite card_in_imset.
- move=> i j; rewrite !mem_irangeE !le0x /=; exact/sorted_rel_inj/std_a.
- move/card_uniqP: (uniq_irange 0%uint63 (length a))=> ->.
  by rewrite size_irange subn0.
Qed.

Lemma rel_array_set_eq:
  (rel_array_set lt_T =~> rel_array_set lt_T =~> eq)
  (eq_array_rel (@eq_op _)) (@eq_op _).
Proof.
move=> a A aA b B bB; apply/idP/idP.
- case/eq_array_relP=> len_ab ab_eq; apply/eqP/setP=> i.
  case: aA=> _ ->; case: bB=> _ ->; rewrite -len_ab.
  apply/idP/idP; case/imsetP=> j; rewrite mem_irangeE le0x /= => j_len ->.
  + move/ab_eq: (j_len)=> /eqP ->; apply/imsetP; exists j=> //.
    by rewrite mem_irangeE le0x.
  + move/ab_eq: (j_len)=> /eqP <-; apply/imsetP; exists j=> //.
    by rewrite mem_irangeE le0x.
- move/eqP=> AB [:len_ab]; rewrite /eq_array_rel; apply/andP; split.
  + abstract:len_ab; apply/eqP/int_to_nat_inj.
    by rewrite -(rel_array_set_length aA) -(rel_array_set_length bB) AB.
  + rewrite /arr_all_pair.
    suff ->: (arr_to_seq a) = (arr_to_seq b) by
      elim: (arr_to_seq _)=> //= h t; rewrite eqxx.
    apply/irr_sorted_eq; [exact:tra_lt_T|exact:irr_lt_T|by case: aA|by case: bB| ].
    move=> x; case: aA bB=> _ /setP /(_ x) + [_ /setP/(_ x)].
    rewrite AB=> -> eq_h; apply/idP/idP.
    * case/mapP=> k k_mem x_eq; move: eq_h; rewrite x_eq imset_f //.
      by move/esym=> /imsetP [k'] ? ->; apply/map_f.
    * case/mapP=> k k_mem x_eq; move: eq_h; rewrite x_eq imset_f //.
      by move=> /imsetP [k'] ? ->; apply/map_f.
Qed.

End ArraySet.

Section ArrSetRel.

Context {t : Type} (T : finType) (r : t -> T -> Prop).
Context {lt_T : rel T}.

Definition rel_arr_set_r:=
  (rel_array r) |~ (@rel_array_set _ lt_T).

Lemma rel_arr_set_r_spec:
  rel_spec r eq->
  rel_spec rel_arr_set_r eq.
Proof.
move=> r_spec; apply:rel_spec_comp; first apply:(rel_spec_array r_spec).
- by move=> x X Y [_ ->] [_ ->].
- move=> x y Z [len_xy nth_xy] [st_x ->]; split.
  + rewrite (sorted_rel_equiv len_xy nth_xy (r2:=lt_T)) //.
    by move=> ???? -> ->.
  + rewrite -len_xy; apply/setP=> z; apply/idP/idP.
    * case/imsetP=> i; rewrite ?mem_irangeE ?le0x /= => ? ->.
      apply/imsetP; exists i; rewrite ?mem_irangeE ?le0x //.
      exact/esym/nth_xy.
    * case/imsetP=> i; rewrite ?mem_irangeE ?le0x /= => ? ->.
      apply/imsetP; exists i; rewrite ?mem_irangeE ?le0x //.
      exact/nth_xy.
Qed.

Lemma rel_arr_set_r_iall f F a A:
  (forall i V, (i < length a)%O -> r a.[i] V -> f i = F V) ->
  rel_arr_set_r a A ->
  iall f (length a) = [forall x, (x \in A) ==> F x].
Proof.
move=> fF aA.
case: aA=> a' aa' a'A; rewrite (rel_array_iall _ aa').
apply/(rel_array_set_iall _ a'A)=> i i_len; apply/fF.
- by rewrite (rel_array_length aa').
- by apply/(rel_array_r aa'); rewrite (rel_array_length aa').
Qed.

Hypothesis irr_lt_T : irreflexive lt_T.
Hypothesis tr_lt_T : transitive lt_T.

Lemma rel_arr_set_r_length:
  (rel_arr_set_r =~> rel_int) length (fun A=> #|A|).
Proof.
apply/rel_equiv_func; [exact:rel_equiv_refl|exact:rel_comp_eqL|].
apply/rel_comp_func; [exact:rel_array_length|exact:rel_array_set_length].
Qed.

Lemma rel_arr_set_r_eq eqt:
  (r =~> r =~> eq) eqt (@eq_op _)->
  (rel_arr_set_r =~> rel_arr_set_r =~> eq) (eq_array_rel eqt) (@eq_op _).
Proof.
move=> r_eq; apply/rel_equiv_func2;
  [exact:rel_equiv_refl|exact:rel_equiv_refl|exact:rel_comp_eqL|].
apply:rel_comp_func2; [|exact:rel_array_set_eq].
exact/rel_array_eq.
Qed.

End ArrSetRel.

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

Section Vector.

Context {R : realFieldType}.

Definition rel_cV (n : nat) (a : array R) (A : 'cV[R]_(n.+1)):=
  (n.+1 = length a) /\ (forall i : 'I_(n.+1), a.[nat_to_int i] = A i ord0).

Definition rel_rV (n : nat) (a : array R) (A : 'rV[R]_n.+1):=
  rel_cV a A^T.

Lemma rel_cV_length (n : nat) a A:
  @rel_cV n a A -> n.+1 = length a.
Proof. by case. Qed.

Lemma rel_cV_nth (n : nat) a A:
  @rel_cV n a A -> (forall i : 'I_n.+1, a.[nat_to_int i] = A i ord0).
Proof. by case. Qed.

Lemma rel_rV_nth (n : nat) a A:
  @rel_rV n a A -> (forall i : 'I_n.+1, a.[nat_to_int i] = A ord0 i).
Proof. by move/rel_cV_nth=> h i; rewrite h mxE. Qed.

Lemma rel_cV_tr (n : nat):
  (@rel_cV n =~> @rel_rV n) id trmx.
Proof. by move=> a A aA; rewrite /rel_rV trmxK. Qed.

Lemma rel_rV_tr (n : nat):
  (@rel_rV n =~> @rel_cV n) id trmx.
Proof. by []. Qed.

Lemma rel_cV_inj (n : nat):
  (@rel_cV n =~> @rel_cV n =~> eq)
    (eq_array_rel (@eq_op _)) (@eq_op _).
Proof.
move=> a A aA b B bB; apply/idP/idP.
- case/eq_array_relP=> len_ab ab_i; apply/eqP/matrixP=> i j.
  rewrite (ord1_eq0 j); move: (ab_i (nat_to_int i)).
  rewrite ltEint_nat -(rel_cV_length aA) nat_to_intK;
    first by (apply/(@int_threshold_length _ a); rewrite -(rel_cV_length aA)).
  by move/(_ (ltn_ord _))/eqP; rewrite (rel_cV_nth aA) (rel_cV_nth bB).
- move/eqP/matrixP=> AB; apply/eq_array_relP; split.
    by apply/int_to_nat_inj; rewrite -(rel_cV_length aA) -(rel_cV_length bB).
  move=> i; rewrite ltEint_nat -(rel_cV_length aA)=> i_n.
  move: (rel_cV_nth aA (Ordinal i_n)) (rel_cV_nth bB (Ordinal i_n)).
  rewrite int_to_natK => -> ->; exact/eqP/AB.
Qed.

Lemma rel_rV_inj (n : nat):
  (@rel_rV n =~> @rel_rV n =~> eq)
    (eq_array_rel (@eq_op _)) (@eq_op _).
Proof.
move=> a A /= /rel_rV_tr + b B /rel_rV_tr.
move/rel_cV_inj=> /[apply] ->; apply/idP/idP;
  [by move/eqP=> /trmx_inj ->|by move/eqP=> ->].
Qed.

Lemma rel_cV_scal (n : nat) (L : R):
  (@rel_cV n =~> @rel_cV n) (arr_map (fun x=> (L * x)%R)) (fun X=> (L *: X)%R).
Proof.
move=> a A aA; split; [by rewrite length_arr_map (rel_cV_length aA)| ].
by move=> i; rewrite arr_map_nth mxE (rel_cV_nth aA).
Qed.

Lemma rel_cV_big (n : nat) (f : R -> R -> R):
  (@rel_cV n =~> @rel_cV n =~> eq)
    (fun x y=> arr_fold_pair (fun elx ely a=> (a + (f elx ely))%R) x y 0%R)
    (fun X Y=> \big[+%R/0%R]_(i : 'I_n.+1) (f (X i ord0) (Y i ord0))).
Proof.
move=> x X xX y Y yY; rewrite /arr_fold_pair zip_arr_to_seq.
  by apply/int_to_nat_inj; rewrite -(rel_cV_length xX) -(rel_cV_length yY).
rewrite irange0_iota -(rel_cV_length xX).
under eq_bigr=> i _ do rewrite -(rel_cV_nth xX i) -(rel_cV_nth yY i) /=.
rewrite [RHS]/= -(big_mkord (fun _ => true) (fun i : nat => f x.[nat_to_int i] y.[nat_to_int i])).
rewrite /index_iota subn0.
elim: {1 2}n=> [|k Hk]; first by rewrite /= big_seq1 GRing.add0r.
by rewrite iotaS_rcons add0n !map_rcons foldl_rcons Hk big_rcons.
Qed.

Lemma rel_cV_dot (n : nat):
  (@rel_cV n =~> @rel_cV n =~> eq)
  (fun x y=> array_dot +%R *%R 0%R x y)
  (fun X Y=> vdot X Y).
Proof. exact/rel_cV_big. Qed.

Lemma rel_rV_lex (n : nat) (cmp : R -> R -> comparison):
  (forall x y, CompSpec (@eq R) (@Order.lt _ R) x y (cmp x y))->
  (@rel_rV n =~> @rel_rV n =~> eq)
  (lex_array_rel cmp) (fun x y=> (x <=lex y)%R).
Proof.
move=> cmpP x X xX y Y yY; rewrite /lex_array_rel.
have len_eq: (length x = length y) by
  apply/int_to_nat_inj; rewrite -(rel_cV_length xX) -(rel_cV_length yY).
rewrite len_eq eqxx /= /lex_array_rel_ lex_foo.
under eq_map=> i do rewrite -(rel_rV_nth xX).
under [X in ind_lexleq _ X]eq_map=> i do rewrite -(rel_rV_nth yY).
rewrite /arr_fold_pair zip_arr_to_seq // irange0_iota -(rel_cV_length xX).
rewrite -map_comp map_enum_ord_iota /=.
elim: (enum 'I_n.+1)=> [|a l IH] //=.
case: cmpP=> [->|->|];
    [rewrite eqxx ltxx; exact/IH |by elim: l {IH}|].
rewrite ltNge le_eqVlt negb_or=> /andP [/negPf -> /negPf ->].
by elim: l {IH}.
Qed.

End Vector.

Section Matrix.

Context {R : realFieldType}.

Definition rel_mx_col (m n : nat) (a : array (array R)) (A : 'M[R]_(m.+1,n.+1)):=
  (n.+1 = length a) /\ (forall i : 'I_n.+1, rel_cV a.[nat_to_int i] (col i A)).

Definition rel_mx_row (m n : nat) (a : array (array R)) (A : 'M[R]_(m.+1,n.+1)):=
  (m.+1 = length a) /\ (forall i : 'I_m.+1, rel_rV a.[nat_to_int i] (row i A)).

Lemma rel_mx_col_length (m n : nat):
  (@rel_mx_col m n =~> rel_int) (length) (fun A=> n.+1).
Proof. by move=> a A; case. Qed.

Lemma rel_mx_col_nth (m n : nat) a A:
  @rel_mx_col m n a A -> forall i : 'I_n.+1, rel_cV a.[nat_to_int i] (col i A).
Proof. by case. Qed.

Lemma rel_mx_row_nth (m n : nat) a A:
  @rel_mx_row m n a A -> forall i : 'I_m.+1, rel_rV a.[nat_to_int i] (row i A).
Proof. by case. Qed.

Lemma rel_mx_row_length (m n : nat):
  (@rel_mx_row m n =~> rel_int) (length) (fun A=> m.+1).
Proof. by move=> a A; case. Qed.

Lemma rel_mx_row_length_row (m n : nat):
  (@rel_mx_row m n =~> rel_int) (fun x=> length x.[0%uint63]) (fun A=> n.+1).
Proof. by move=> a A [_ /(_ ord0)] /rel_cV_length ->. Qed.

Lemma rel_mx_row_length_row_i (m n : nat) a A:
  @rel_mx_row m n a A -> forall i, (i < length a)%O ->
  n.+1 = length a.[i].
Proof.
move=> aA i; rewrite ltEint_nat -(rel_mx_row_length aA)=> i_m.
move: (rel_mx_row_nth aA (Ordinal i_m))=> /rel_cV_length ->.
by rewrite int_to_natK.
Qed.

Lemma rel_mx_col_map (m n : nat) (f : array R -> R) (F : 'cV[R]_m.+1 -> R):
  (@rel_cV R m =~> eq) f F ->
  (@rel_mx_col m n =~> @rel_rV R n)
  (fun x=> arr_map f x) (fun X=> ((\col_(i < n.+1) F (col i X))^T)%R).
Proof.
move=> fF x X xX; split; rewrite ?length_arr_map; first exact/(rel_mx_col_length xX).
move=> i; rewrite !mxE arr_map_nth; exact/fF/rel_mx_col_nth.
Qed.

Lemma rel_mx_row_bigsum (m n : nat) f F add_arr:
  (eq =~> @rel_rV R n =~> @rel_rV R n) f F ->
  (@rel_rV R n =~> @rel_rV R n =~> @rel_rV R n) add_arr (fun X Y=> (X + Y)%R) ->
  (@rel_rV R m =~> @rel_mx_row m n =~> @rel_rV R n)
  (fun v a=> arr_fold_pair (fun vi ai acc=> add_arr acc (f vi ai)) v a (make (length a.[0%uint63]) 0%R))
  (fun V A=> \big[+%R/0%R]_i F (V ord0 i) (row i A)).
Proof.
move=> fF addAdd v V vV a A aA.
rewrite /arr_fold_pair /arr_to_seq !irange0_iota.
rewrite -(rel_cV_length vV) -(rel_mx_row_length aA).
under eq_bigl=> x.
- move: (ltn_ord x) => <-; move: (mem_iota 0 m.+1 x).
  rewrite leq0n add0n [RHS]/= => <-.
  over.
move/mem_subseq: (subseq_refl (iota 0 m.+1)).
move: (iota_uniq 0 m.+1).
elim/last_ind: {-3}(iota _ _).
- move=> _ _ /=; under eq_bigl=> x do rewrite inE; rewrite big_pred0_eq.
  split; rewrite ?length_make ?leb_length ?(rel_mx_row_length_row aA) //.
  by move=> i; rewrite get_make !mxE.
- move=> t h IH; rewrite rcons_uniq.
  case/andP=> h_n_t uniq_t ht_iota; move: (ht_iota)=> /(_ h).
  rewrite mem_rcons inE eqxx=> /(_ isT); rewrite mem_iota leq0n add0n /= => h_m.
  rewrite (bigD1 (Ordinal h_m))=> /=; rewrite ?mem_rcons ?in_cons ?eqxx //=.
  rewrite !map_rcons !zip_rcons ?size_map // foldl_rcons /=.
  rewrite GRing.addrC.
  have rule: forall i : 'I_m.+1, (val i \in rcons t h) && (i != Ordinal h_m) = (val i \in t).
  + move=> i; rewrite mem_rcons inE.
    case/boolP: (i == Ordinal h_m)=> [/eqP -> /=|];
      rewrite ?eqxx /= ?(negPf h_n_t) //.
    rewrite andbT=> /eqP i_n_h; apply/orb_idl=> /eqP ih.
    by case: i_n_h; apply/val_inj.
  under eq_bigl => x do rewrite rule /=.
  apply/addAdd=> //; first apply/IH=> //;
    [by move=> x xt; apply/ht_iota; rewrite mem_rcons inE xt orbT|].
  apply/fF; first by move: (rel_rV_nth vV (Ordinal h_m)).
  by move: (rel_mx_row_nth aA (Ordinal h_m)).
Qed.

Lemma rel_mx_row_mul (m n : nat):
  (@rel_rV R m =~> @rel_mx_col m n =~> @rel_rV R n)
    (fun v a=> array_mul_row_mx +%R *%R 0%R v a)
    (fun V A=> (V *m A)%R).
Proof.
move=> v V vV a A aA; split.
- by rewrite length_arr_map; case: aA.
- move=> i; rewrite mxE -matrix_vdot row_id arr_map_nth.
  by apply/rel_cV_dot=> //; case: aA=> _ /(_ i).
Qed.

Lemma rel_mulmx (m n k : nat):
  (@rel_mx_row m n =~> @rel_mx_col n k =~> @rel_mx_row m k)
  (fun a b=> array_mulmx +%R *%R 0%R a b)
  (fun A B=> (A *m B)%R).
Proof.
move=> a A aA b B bB; split.
- by rewrite length_arr_map; case: aA.
- move=> i; rewrite arr_map_nth row_mul.
  by apply/rel_mx_row_mul=> //; case: aA=> _ /(_ i).
Qed.

End Matrix.

Section PointRel.

Context {t : Type} {R : realFieldType}.
Context (r : t -> R -> Prop).

Definition rel_point_cV (n : nat) := rel_array r |~ @rel_cV R n.
Definition rel_point_rV (n : nat) := rel_array r |~ @rel_rV R n.

Lemma rel_point_rV_tr (n : nat):
  (@rel_point_cV n =~> @rel_point_rV n) id (fun X => (X^T)%R).
Proof. apply/(rel_comp_func (g:=id))=> //; exact: rel_cV_tr. Qed.

Lemma rel_point_rV_eq (n : nat) (eq_t : rel t):
  (r =~> r =~> eq) eq_t (@eq_op _) ->
  (@rel_point_rV n =~> @rel_point_rV n =~> eq)
    (eq_array_rel eq_t) (@eq_op _).
Proof.
move=> r_eq; apply/rel_equiv_func2;
  [exact:rel_equiv_refl|exact:rel_equiv_refl|exact:rel_comp_eqL|].
apply/rel_comp_func2; [apply/rel_array_eq/r_eq|exact:rel_rV_inj].
Qed.

Lemma rel_point_cV_eq (n : nat) (eq_t : rel t):
  (r =~> r =~> eq) eq_t (@eq_op _) ->
  (@rel_point_cV n =~> @rel_point_cV n =~> eq)
    (eq_array_rel eq_t) (@eq_op _).
Proof.
move=> r_eq; apply/rel_equiv_func2;
  [exact:rel_equiv_refl|exact:rel_equiv_refl|exact:rel_comp_eqL|].
apply/rel_comp_func2; [apply/rel_array_eq/r_eq|exact:rel_cV_inj].
Qed.

Lemma rel_point_cV_scal (n : nat) (mul_t : t -> t -> t):
  (r =~> r =~> r) mul_t (fun x y=> (x * y)%R) ->
  (r =~> @rel_point_cV n =~> @rel_point_cV n) (fun l a=> arr_map (fun x=> mul_t l x) a) (fun L A=> (L *: A)%R).
Proof.
move=> mul_t_r.
apply/rel_equiv_func2; [exact:rel_comp_eqR|exact: rel_equiv_refl|exact: rel_equiv_refl|].
apply/rel_comp_func2; [|move=> l L ->; apply:rel_cV_scal].
by move=> /= l L lL; apply/rel_array_map/mul_t_r.
Qed.

Lemma rel_point_rV_iall (n : nat) f F:
  (@rel_int_ord n =~> r =~> eq) f F->
  (@rel_point_rV n =~> eq) (fun x=> iall (fun i=> f i x.[i]) (length x))
  (fun X=> [forall I, F I (X ord0 I)]).
Proof.
move=> fF x Y [X xX XY]; apply/idP/idP.
- move/allP=> h; apply/forallP=> I.
  move: (fF)=> /(_ (nat_to_int I) I) [:I_len].
  rewrite /rel_int_ord /rel_int nat_to_intK ?inE /=.
  + abstract: I_len.
    apply/(ltn_trans (ltn_ord _)); rewrite (rel_cV_length XY);
      exact:int_thresholdP.
  move/(_ (erefl _) (x.[nat_to_int I]) (Y ord0 I)).
  rewrite -(rel_rV_nth XY I)=> [:I_x] <-.
  + apply/(rel_array_r xX); rewrite ltEint_nat nat_to_intK ?inE //.
    abstract: I_x.
    by rewrite (rel_array_length xX) -(rel_cV_length XY).
  + by apply/h; rewrite mem_irangeE le0x ltEint_nat nat_to_intK ?inE ?I_x.
- move/forallP=> h; apply/allP=> i; rewrite mem_irangeE le0x /= => i_len.
  move: (i_len); rewrite ltEint_nat (rel_array_length xX) -(rel_cV_length XY).
  move=> i_n; move: (fF)=> /(_ i (Ordinal i_n)); rewrite /rel_int_ord /rel_int /=.
  move=> /(_ (erefl _) x.[i] (Y ord0 (Ordinal i_n))) ->; last exact/h.
  by rewrite -(rel_rV_nth XY) int_to_natK; apply/(rel_array_r xX).
Qed.

Definition rel_point_mx_col (m n: nat) := rel_array (rel_array r) |~ @rel_mx_col R m n.
Definition rel_point_mx_row (m n: nat) := rel_array (rel_array r) |~ @rel_mx_row R m n.

Lemma rel_point_mx_col_length (m n : nat):
  (@rel_point_mx_col m n =~> rel_int) length (fun _=> n.+1).
Proof.
apply/rel_equiv_func; [exact: rel_equiv_refl|exact:rel_comp_eqL|].
apply/rel_comp_func; [exact:rel_array_length|exact:rel_mx_col_length].
Qed.

Lemma rel_point_mx_col_spec (m n : nat):
  rel_spec r eq->
  rel_spec (@rel_point_mx_col m n) eq.
Proof.
move=> r_spec.
apply: rel_spec_comp; first try do 2? apply:rel_spec_array; first exact:r_spec.
- move=> x X Y /rel_mx_col_nth xX /rel_mx_col_nth xY.
  apply/matrixP=> p q; move: (xX q) (xY q).
  move=> /rel_cV_nth /(_ p) + /rel_cV_nth /(_ p).
  by rewrite !mxE=> <- <-.
- move=> /= x y M [len_xy] h [len_x x_nth]; split; rewrite ?len_xy //.
  move=> i; case: (x_nth i)=> len_xi xi_nth.
  move: (h (nat_to_int i)); rewrite ltEint_nat len_xy -len_x.
  rewrite nat_to_intK ?inE;
    first (apply/(ltn_trans (ltn_ord _)); rewrite len_x; exact/int_thresholdP).
  case/(_ (ltn_ord _))=> len_xyi xyi_nth; split; rewrite ?len_xyi //.
  move=> j; rewrite -(xi_nth j); apply/xyi_nth.
  rewrite ltEint_nat len_xyi -len_xi nat_to_intK //.
  rewrite inE; apply/(ltn_trans (ltn_ord _)); rewrite len_xi; exact:int_thresholdP.
Qed.

Lemma rel_point_mx_col_col0 (m n : nat):
  (@rel_point_mx_col m n =~> @rel_point_cV m) (fun x=> x.[0%uint63]) (col ord0).
Proof.
move=> x Y [X xX XY]; exists X.[0%uint63].
- move: (xX)=> /rel_array_r /(_ 0%uint63); apply.
  by rewrite (rel_array_length xX) ltEint_nat -(rel_mx_col_length XY).
- by move: XY=> /rel_mx_col_nth=> /(_ ord0).
Qed.

Lemma rel_point_mx_row_iall (m n : nat) f F:
  (@rel_int_ord m =~> @rel_point_rV n =~> eq) f F->
  (@rel_point_mx_row m n =~> eq)
    (fun x=> iall (fun i=> f i x.[i]) (length x)) (fun X=> [forall i, F i (row i X)]).
Proof.
move=> fF x Y [X xX XY]; apply/idP/idP.
- move/allP=> h; apply/forallP=> i.
  move: (fF)=> /(_ (nat_to_int i) i); rewrite /rel_int_ord /rel_int /=.
  move: (ltn_ord i). rewrite [X in (_ < X)](rel_mx_row_length XY)=> i_len.
  rewrite nat_to_intK; first exact/int_threshold_length/i_len.
  move=> /(_ (erefl _) x.[nat_to_int i] (row i Y)) <-;
    last (apply/h;
    rewrite mem_irangeE le0x ltEint_nat
    nat_to_intK ?(int_threshold_length i_len) ?(rel_array_length xX)//).
  exists X.[nat_to_int i]; [apply/(rel_array_r xX)|exact/rel_mx_row_nth].
  by rewrite (rel_array_length xX) ltEint_nat nat_to_intK // (int_threshold_length i_len).
- move/forallP=> h; apply/allP=> i; rewrite mem_irangeE le0x /= => i_len.
  move: (rel_mx_row_length XY); rewrite -(rel_array_length xX)=> len_x.
  move: (i_len); rewrite ltEint_nat -len_x=> i_m.
  move: fF=> /(_ i (Ordinal i_m)); rewrite /rel_int_ord /rel_int /=.
  move=> /(_ (erefl _) x.[i] (row (Ordinal i_m) Y)) ->; last exact:h.
  exists X.[i]; [exact/(rel_array_r xX)|].
  by move:(rel_mx_row_nth XY (Ordinal i_m))=> /=; rewrite int_to_natK.
Qed.

Lemma rel_point_dot (n : nat) addf mulf x0:
  (r =~> r =~> r) addf +%R->
  (r =~> r =~> r) mulf *%R->
  r x0 0%R->
  (@rel_point_cV n =~> @rel_point_cV n =~> r)
  (array_dot addf mulf x0) (fun X Y=> '[X,Y]%R).
Proof.
move=> addh mulh x0h.
apply/rel_equiv_func2;
  [exact:rel_equiv_refl|exact:rel_equiv_refl|exact:rel_comp_eqR|].
by apply/rel_comp_func2; [apply:rel_array_dot|apply:rel_cV_dot].
Qed.

Lemma rel_point_mul_row_mx (m n : nat) addf mulf x0:
  (r =~> r =~> r) addf +%R->
  (r =~> r =~> r) mulf *%R->
  r x0 0%R->
  (@rel_point_rV m =~> @rel_point_mx_col m n =~> @rel_point_rV n)
  (array_mul_row_mx addf mulf x0) (fun v M=> (v *m M)%R).
Proof.
move=> addh mulh x0h.
by apply/rel_comp_func2; [apply:rel_array_mul_row_mx|apply:rel_mx_row_mul].
Qed.

Lemma rel_point_mulmx (m n p: nat) addf mulf x0:
  (r =~> r =~> r) addf +%R->
  (r =~> r =~> r) mulf *%R->
  r x0 0%R->
  (@rel_point_mx_row m p =~> @rel_point_mx_col p n =~> @rel_point_mx_row m n)
  (array_mulmx addf mulf x0) (fun A B=> (A *m B)%R).
Proof.
move=> addh mulh x0h.
by apply/rel_comp_func2;
  [apply/rel_array_mulmx|apply/rel_mulmx].
Qed.

End PointRel.

Section PolyRel.

Context {t : Type} {R : realFieldType}.
Context {r : t -> R -> Prop}.

Definition rel_Po_r (m n : nat):=
  rel_couple (rel_array (rel_array r)) (rel_array r) |~
  rel_couple (@rel_mx_row R m n) (@rel_cV R m).

Lemma rel_Po_r_m (m n : nat):
  ((@rel_Po_r m n) =~> rel_int) (fun ab=> length ab.1) (fun _=> m.+1).
Proof.
apply/rel_equiv_func; [exact:rel_equiv_refl|exact:rel_comp_eqL|].
apply/rel_comp_func.
- apply: rel_couple_func_fst; exact: rel_array_length.
- case=> a b [A B] [/= + _]; move: a A; exact: rel_mx_row_length.
Qed.

Lemma rel_Po_r_n_temp (m n : nat):
  ((@rel_Po_r m n) =~> rel_int) (fun ab=> if (length ab.1 > 0)%O then length ab.1.[0%uint63] else 0%uint63) (fun _=> n.+1).
Proof.
pose g := fun x=> if (length x > 0)%O then length x.[0] else 0%uint63.
apply/rel_equiv_func; [exact:rel_equiv_refl|exact:rel_comp_eqL|].
apply/(@rel_comp_func _ _ _ _ _ _ _ _ _ _ _ (fun AB=> if (length AB.1 > 0)%O then length AB.1.[0%uint63] else 0%uint63)).
- apply:(@rel_couple_func_fst _ _ _ _ _ _ _ _ _ (@g t) (@g R)).
  apply:rel_func_if=> // [x X /rel_array_length -> //|].
  by move=> x X + len_x; move/rel_array_r=> /(_ _ len_x) /rel_array_length.
- case=> a b [A B] [/= + _]; move=> /[dup] /rel_mx_row_length.
  rewrite ltEint_nat=> <-; rewrite ltn0Sn; exact:rel_mx_row_length_row.
Qed.

Lemma rel_Po_r_n (m n : nat):
  ((@rel_Po_r m n) =~> rel_int) (fun ab=> length ab.1.[0%uint63]) (fun _=> n.+1).
Proof.
move=> ab AB /[dup] /rel_Po_r_m + /rel_Po_r_n_temp.
by rewrite ltEint_nat => <-; rewrite ltn0Sn.
Qed.

Lemma rel_Po_r_row_A (m n : nat):
  (@rel_Po_r m n =~> @rel_int_ord m =~> rel_array r |~ @rel_rV R n)
  (fun Po k=> Po.1.[k]) (fun Ab K=> row K Ab.1).
Proof.
move=> po [A b] [PO] [poPO _] [/= POA _] k K kK.
exists PO.1.[k].
- apply/(rel_array_r poPO); rewrite (rel_array_length poPO).
  rewrite ltEint_nat -(rel_mx_row_length POA) -kK; exact/ltn_ord.
- by case: POA=> _ /(_ K); rewrite kK int_to_natK.
Qed.

Lemma rel_Po_r_row_b (m n : nat):
  (@rel_Po_r m n =~> @rel_int_ord m =~> r)
  (fun Po k=> Po.2.[k]) (fun Ab K=> Ab.2 K ord0).
Proof.
move=> po [A b] [PO] [_ poPO] [_ POb] k K kK /=.
case: POb=> len_eq /(_ K); rewrite /= kK int_to_natK => <-.
apply/(rel_array_r poPO); rewrite (rel_array_length poPO).
rewrite ltEint_nat -len_eq -kK; exact:ltn_ord.
Qed.

Lemma rel_Po_r_all_row (m n : nat) (f : Uint63.int -> (array t) -> t -> bool ) (F : 'I_m.+1 -> 'rV[R]_n.+1 -> R -> bool):
  ((@rel_int_ord m) =~> (rel_array r |~ @rel_rV R n) =~> r =~> eq) f F ->
  ((@rel_Po_r m n) =~> eq)
    (fun ab=> iall (fun i=> f i ab.1.[i] ab.2.[i]) (length ab.1))
    (fun AB=> [forall i, F i (row i AB.1) (AB.2 i ord0)]).
Proof.
move=> fF Po Ab Po_Ab; apply/idP/idP.
- move/allP=> h; apply/forallP=> I.
  move: (rel_Po_r_row_A Po_Ab) (rel_Po_r_row_b Po_Ab).
  have iI: (rel_int_ord (nat_to_int I) I).
  + rewrite /rel_int_ord /rel_int nat_to_intK //.
    rewrite inE; apply/(ltn_trans (ltn_ord _)).
    rewrite (rel_Po_r_m Po_Ab); exact:int_thresholdP.
  move/(_ _ _ iI)=> AI /(_ _ _ iI) bI.
  move:(fF _ _ iI _ _ AI _ _ bI)=> <-; apply/h.
  rewrite mem_irangeE le0x /= ltEint_nat -iI -(rel_Po_r_m Po_Ab).
  exact:ltn_ord.
- move/forallP=> h; apply/allP=> i; rewrite mem_irangeE le0x /=.
  rewrite ltEint_nat -(rel_Po_r_m Po_Ab)=> i_m.
  have iI: rel_int_ord i (Ordinal i_m) by [].
  move: (rel_Po_r_row_A Po_Ab iI)=> AI.
  move: (rel_Po_r_row_b Po_Ab iI)=> bI.
  move: fF=> /(_ _ _ iI _ _ AI _ _ bI)=> ->; exact/h.
Qed.

End PolyRel.
(* ------------------------------------------------------------------------------------------------ *)

Section RelGraphStructure.

Definition precond_struct (g : graph.graph) := forall i, mem_vertex g i ->
  (lti_sorted (neighbours g i) /\ forall j, (j < nb_neighbours g i)%O -> mem_vertex g (neighbours g i).[j]).

Definition rel_structure g (G : graph [choiceType of Uint63.int]):=
  [/\
    precond_struct g,
    (forall i, mem_vertex g i = (i \in vertices G))&
    (forall i j, mem_vertex g i -> mem_edge g i j = edges G i j)
  ].

Lemma rel_struct_valid_nei g G : rel_structure g G -> forall i, mem_vertex g i ->
  forall j, (j < nb_neighbours g i)%O -> mem_vertex g (neighbours g i).[j].
Proof. by case=> + _ _ i ig; move=> /(_ i ig) []. Qed.

Lemma rel_struct_uniq_nei g G: rel_structure g G -> forall i, mem_vertex g i ->
  uniq (arr_to_seq (neighbours g i)).
Proof. by move=> gG i ig; case: gG=> /(_ _ ig) [/lti_sorted_uniq]. Qed.

Lemma rel_struct_nei_mem g G: rel_structure g G -> forall i, mem_vertex g i ->
  [seq j <- arr_to_seq (neighbours g i) | mem_vertex g j] =
  arr_to_seq (neighbours g i).
Proof.
move=> + i ig; move/rel_struct_valid_nei=> /(_ i ig) /= h.
apply/all_filterP/allP=> x /(nthP (default (neighbours g i))); rewrite size_arr_to_seq.
case=> [k k_nei <-]; rewrite nth_arr_to_seq //.
move: (h (nat_to_int k)); apply; rewrite ltEint_nat nat_to_intK //.
exact: (int_threshold_length k_nei).
Qed.

Lemma rel_struct_vtx g G:
  rel_structure g G -> (forall i, mem_vertex g i = (i \in vertices G)).
Proof. by case. Qed.

Lemma rel_struct_edge g G:
  rel_structure g G -> (forall i j, mem_vertex g i -> mem_edge g i j = edges G i j).
Proof. by case. Qed.

Lemma rel_struct_vtx_set g G: rel_structure g G -> vertices G = [fset i | i in irange0 (length g)].
Proof. by move=> gG; apply/fsetP=> z; rewrite !inE /= mem_irangeE le0x -(rel_struct_vtx gG). Qed.

Lemma rel_struct_card g G: rel_structure g G -> #|`vertices G| = length g.
Proof. by move=> gG; rewrite (rel_struct_vtx_set gG) card_imfset //= undup_id ?uniq_irange // size_irange subn0. Qed.

Lemma rel_struct_succ g G:
  rel_structure g G-> forall i, mem_vertex g i->
  successors G i = [fset j | j in arr_to_seq (neighbours g i)].
Proof.
move=> gG i ig; apply/fsetP=> j.
rewrite in_succE -(rel_struct_edge gG) // inE /=.
rewrite mem_edgeP // mem_filter.
apply/andb_idl=> /(nthP (default (neighbours g i))) [k].
rewrite size_arr_to_seq=> k_nei <-; rewrite nth_arr_to_seq //.
case: gG=> /(_ _ ig) [_ /(_ (nat_to_int k))] + _ _; apply.
rewrite ltEint_nat nat_to_intK //; exact/int_threshold_length/k_nei.
Qed.

Lemma rel_struct_nb_nei g G:
  rel_structure g G -> forall i, mem_vertex g i ->
  #|` successors G i| = nb_neighbours g i.
Proof.
move=> gG i ig; rewrite (rel_struct_succ gG) //.
rewrite card_imfset //= undup_id ?size_arr_to_seq //.
by apply/lti_sorted_uniq; case: gG=> /(_ i ig) [].
Qed.

Lemma rel_struct_all f:
  (rel_structure =~> eq) (fun g=> iall f (length g)) (fun G=> all f (vertices G)).
Proof.
move=> g G gG; apply/eq_all_r=> x.
by rewrite mem_irangeE le0x /= -(rel_struct_vtx gG).
Qed.

Lemma rel_struct_nei_all f g G: rel_structure g G -> forall i, mem_vertex g i ->
  neighbour_all f g i = all f (successors G i).
Proof.
move=> gG i ig; rewrite /neighbour_all.
under [LHS]eq_in_all=> x /mapP [y].
  rewrite mem_irangeE le0x /= => /(rel_struct_valid_nei gG ig) h ->; rewrite h.
over.
by apply/eq_all_r=> z; rewrite (rel_struct_succ gG ig) inE.
Qed.

Lemma rel_struct_nei_fold {T : Type} (f : Uint63.int -> T -> T) g G a: rel_structure g G ->
  (forall i j a, f i (f j a) = f j (f i a)) ->
  forall i, mem_vertex g i ->
  neighbour_fold f a g i = foldl (fun a i => f i a) a (successors G i).
Proof.
move=> gG fP i ig; rewrite neighbour_foldP //=.
apply/perm_foldl=> //; apply/uniq_perm; [exact/filter_uniq/(rel_struct_uniq_nei gG)|exact:fset_uniq|].
rewrite (rel_struct_succ gG) // => z; rewrite mem_filter !inE; apply/andb_idl.
move/nthP=> /(_ (default (neighbours g i))) [k]; rewrite size_arr_to_seq => k_nei <-.
rewrite nth_arr_to_seq //; move: (rel_struct_valid_nei gG ig)=> /(_ (nat_to_int k)).
apply; rewrite ltEint_nat nat_to_intK //; exact:(int_threshold_length k_nei).
Qed.

End RelGraphStructure.

Section RelGraph.

Context {t : Type} (T : choiceType).
Context {r : t -> T -> Prop}.

Definition precond_lbl_graph {t : Type} (gl : graph.graph * array t):=
  (length gl.1 = length gl.2).

Definition rel_lbl_graph gl GL := precond_lbl_graph gl /\ (rel_couple (rel_structure) (rel_array r)) gl GL.

Definition rel_final_graph (Gc : graph _ * array T) Gf :=
  gisof Gc.1 Gf (fun i=> Gc.2.[i]).

Definition rel_graph_r := rel_lbl_graph |~ rel_final_graph.

(* Lemma rel_lbl_graph_all gl GL f F:
  (forall i, mem_vertex gl.1 i -> f i = F i)->
  rel_lbl_graph gl GL -> iall (fun i=> f i) (length gl.1) = all (fun i=> F i) (vertices GL.1).
Proof.
move=> fF [gG lL]; apply/idP/idP.
- move/allP=> h; apply/allP=> i; rewrite -(rel_struct_vtx gG)=> i_g.
  by rewrite -(fF _ i_g); apply/h; rewrite mem_irangeE le0x.
- move/allP=> h; apply/allP=> i; rewrite mem_irangeE le0x /= => i_g.
  by rewrite fF //; apply/h; rewrite -(rel_struct_vtx gG).
Qed. *)

Lemma rel_final_graph_succ_card GL G:
  rel_final_graph GL G -> forall i, i \in vertices GL.1 -> #|` successors GL.1 i| = #|`successors G GL.2.[i]|.
Proof.
move=> GL_G i iG; rewrite (gisof_succ GL_G) // card_in_imfset //.
move=> x y /=; rewrite !in_succE=> /edge_vtxr + /edge_vtxr.
apply: (gisof_inj GL_G).
Qed.

(* Lemma rel_final_graph_all F GL G:
  rel_final_graph GL G-> all (fun i=> F GL.2.[i]) (vertices GL.1) = all F (vertices G).
Proof.
move=> GL_G.
rewrite -(gisof_vtx GL_G); apply/idP/idP.
- by move/allP=> h; apply/allP=> x /imfsetP [/= i /h ? ->].
- move/allP=> h; apply/allP=> i i_GL1; exact/h/in_imfset.
Qed. *)

Lemma rel_graph_r_spec gl GL G:
  rel_spec r eq ->
  rel_lbl_graph gl GL -> rel_final_graph GL G ->
  forall i V, mem_vertex gl.1 i -> V \in vertices G -> r gl.2.[i] V ->
  V = GL.2.[i].
Proof.
move=> r_injr [len_gl [/= gG lL] GL_G] i V ig VG iV.
move: VG; rewrite -(gisof_vtx GL_G)=> /imfsetP [/= j jG] V_eq.
move: iV; rewrite V_eq; apply/r_injr/(rel_array_r lL).
by rewrite -(len_gl).
Qed.

Lemma rel_graph_r_all f F gl G:
  (forall i V, mem_vertex gl.1 i -> V \in vertices G -> r gl.2.[i] V -> f i = F V) ->
  rel_graph_r gl G -> iall f (length gl.1) = all F (vertices G).
Proof.
move=> fF [GL [len_gG [gG lL]] GL_G]; rewrite -(gisof_vtx GL_G).
set S := [fset _ | _ in _].
have S_eq : S =i [seq GL.2.[i] | i <- irange0 (length gl.1)].
- move=> x; apply/idP/idP.
  + case/imfsetP=> /= i iG ->; apply/map_f; rewrite mem_irangeE le0x /=.
    by move: iG; rewrite -(rel_struct_vtx gG).
  + case/mapP=> i; rewrite mem_irangeE le0x /= => ig ->.
    by apply/in_imfset=> /=; rewrite -(rel_struct_vtx gG).
rewrite (eq_all_r S_eq) all_map /iall; apply/eq_in_all=> x /=.
rewrite mem_irangeE le0x /= => xg.
apply/fF/(rel_array_r lL)=> //; rewrite -?(gisof_vtx GL_G) -?(len_gG) //.
by apply/in_imfset=> /=; rewrite -(rel_struct_vtx gG).
Qed.

Lemma rel_graph_r_succ_card gl G:
  rel_spec r eq->
  rel_graph_r gl G -> forall i V, mem_vertex gl.1 i -> V \in vertices G -> r gl.2.[i] V ->
  #|` successors G V| = nb_neighbours gl.1 i.
Proof.
move=> r_injr [GL [len_gl [gG lL]] GL_G] i V ig VG iV.
rewrite -(rel_struct_nb_nei gG) // (rel_final_graph_succ_card GL_G) -?(rel_struct_vtx gG) //.
suff ->: V = GL.2.[i] by [].
by apply/(rel_graph_r_spec r_injr _ GL_G ig VG iV); split=> //.
Qed.

Lemma rel_graph_r_nei_all gl G f F:
  (rel_spec r eq)->
  (forall i V, mem_vertex gl.1 i -> V \in vertices G -> r gl.2.[i] V -> f i = F V)->
  rel_graph_r gl G -> forall i V, mem_vertex gl.1 i -> V \in vertices G -> r gl.2.[i] V ->
  neighbour_all f gl.1 i = all F (successors G V).
Proof.
move=> r_injr fF [GL [len_gl [gG lL]] GL_G] i V ig VG iV; rewrite /neighbour_all /arr_all.
have nei_eq: arr_to_seq gl.1.[i] =i [fset x | x in arr_to_seq gl.1.[i]] by move=> x; rewrite inE.
rewrite (eq_all_r nei_eq) -(rel_struct_succ gG) // (rel_graph_r_spec r_injr _ GL_G ig VG iV); first by split.
rewrite (gisof_succ GL_G) -?(rel_struct_vtx gG) //.
set S := [fset _ | _ in _]; have succ_eq: S =i [seq GL.2.[j] | j <- successors GL.1 i].
move=> x; apply/idP/idP; [case/imfsetP=> /= k ? ->; exact/map_f|case/mapP=> k ? ->; exact/in_imfset].
rewrite (eq_all_r succ_eq) all_map; apply/eq_in_all=> x /(fsubsetP (sub_succ _ _)) xG.
rewrite (rel_struct_vtx gG) xG; apply/fF=> //; rewrite ?(rel_struct_vtx gG) //.
- by rewrite -(gisof_vtx GL_G) in_imfset.
- by apply/(rel_array_r lL); rewrite -len_gl; move: xG; rewrite -(rel_struct_vtx gG).
Qed.

End RelGraph.

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

Section SpecFunc.

Definition spec_func {t T : Type} (r : t -> T -> Prop)
  (f : t -> T) (P : t -> Prop) := forall x, P x -> r x (f x).

Lemma spec_func_int: spec_func rel_int int_to_nat (fun _ => True).
Proof. by []. Qed.

Definition int_to_ord (m : nat) (x : Uint63.int) :=
  if @idP (x < m.+1)%nat is ReflectT h then Ordinal h else ord0.

Lemma spec_func_int_ord (m : nat):
  spec_func (@rel_int_ord m) (@int_to_ord m) (fun x=> (x < m.+1)%nat).
Proof. move=> x x_m; rewrite /int_to_ord; case: {-}_/idP=> //. Qed.

Lemma spec_func_comp {t T T' : Type}
  (r : t -> T -> Prop) (r' : T -> T' -> Prop)
  f g (P : t -> Prop) (Q : T -> Prop):
  (forall x, P x -> Q (f x)) ->
  spec_func r f P -> spec_func r' g Q ->
  spec_func (r |~ r') (g \o f) P.
Proof. move=> PQ spec_f spec_g x Px; exists (f x); [exact:spec_f|exact/spec_g/PQ]. Qed.

Lemma spec_func_comp_pre {t T T' : Type}
  (r : t -> T -> Prop) (r' : T -> T' -> Prop)
  f g (P P' : t -> Prop) (Q : T -> Prop):
  (forall x, P x -> P' x -> Q (f x))->
  spec_func r f P -> spec_func r' g Q->
  spec_func (r |~ r') (g \o f) (fun x=> P' x /\ P x).
Proof. move=> PQ spec_f spec_g x [Px P'x]; exists (f x); [exact:spec_f|exact/spec_g/PQ]. Qed.

Lemma spec_func_couple {t1 t2 T1 T2 : Type}
  (r1 : t1 -> T1 -> Prop) (r2 : t2 -> T2 -> Prop)
  f g (P : t1 -> Prop) (Q : t2 -> Prop):
  spec_func r1 f P -> spec_func r2 g Q ->
  spec_func (rel_couple r1 r2)
    (fun x=> (f x.1, g x.2)) (fun x=> P x.1 /\ Q x.2).
Proof. move=> spec_f spec_g x [Px1 Qx2]; split=> /=; [exact/spec_f|exact/spec_g]. Qed.

Definition precond_array {t : Type} (P : t -> Prop) (a : array t):=
  (forall i, (i < length a)%O -> P a.[i]).

Lemma spec_func_rel_array {t T : Type} (r : t -> T -> Prop)
  (f : t -> T) (P : t -> Prop):
  spec_func r f P->
  spec_func (rel_array r)
    (fun a=> arr_map f a) (precond_array P).
Proof.
move=> spec_f a Pa; split; rewrite ?length_arr_map //.
move=> i /Pa; rewrite arr_map_nth; exact:spec_f.
Qed.

Section Vector.

Definition precond_len (R : Type) (n : nat) (a : array R):=
  n.+1 = length a.

Definition arr_to_cV (R : realFieldType) (n : nat) (a : array R):=
  (\col_(i < n.+1) get a (nat_to_int i))%R.
Definition arr_to_rV (R : realFieldType) (n : nat) (a : array R):=
  (\row_(i < n.+1) get a (nat_to_int i))%R.

Lemma spec_func_to_cV (R : realFieldType) n:
  spec_func (@rel_cV R n) (@arr_to_cV R n) (@precond_len R n).
Proof. by move=> a a_len; split=> // i; rewrite mxE. Qed.

Lemma spec_func_to_rV R n:
  spec_func (@rel_rV R n) (@arr_to_rV R n) (@precond_len R n).
Proof. by move=> a a_len; split=> // i; rewrite !mxE. Qed.

Definition arr_to_mx_row (R : realFieldType)
  (m n : nat) (a : array (array R)):=
  (\matrix_(i < m.+1) (@arr_to_rV R n (get a (nat_to_int i))))%R.

Definition precond_mx (R : Type) (m n : nat)
  (a : array (array R)):=
  (m.+1 = length a) /\ (precond_array (@precond_len R n) a).

Definition arr_to_mx_col (R : realFieldType)
  (m n : nat) (a : array (array R)):=
  ((\matrix_(i < n.+1) (@arr_to_cV R m (get a (nat_to_int i)))^T)^T)%R.

Lemma spec_func_to_mx_row (R : realFieldType) (m n : nat):
  spec_func (@rel_mx_row R m n) (@arr_to_mx_row R m n)
    (@precond_mx R m n).
Proof.
move=> a [len_a len_row_a]; split=> // i.
rewrite rowK; apply/spec_func_to_rV/len_row_a.
rewrite ltEint_nat=> [:i_len].
rewrite nat_to_intK; last by (abstract:i_len; rewrite -len_a).
rewrite !inE; exact/(ltn_trans i_len)/int_thresholdP.
Qed.

Lemma spec_func_to_mx_col (R : realFieldType) (m n : nat):
  spec_func (@rel_mx_col R m n) (@arr_to_mx_col R m n)
    (@precond_mx R n m).
Proof.
move=> a [len_a len_row_a]; split=> // i.
rewrite -tr_row rowK trmxK; apply/spec_func_to_cV/len_row_a.
rewrite ltEint_nat=> [:i_len].
rewrite nat_to_intK; last by (abstract:i_len; rewrite -len_a).
rewrite !inE; exact/(ltn_trans i_len)/int_thresholdP.
Qed.

Definition arr_to_point_cV (t : Type) (R : realFieldType) (n : nat)
  (f : t -> R):= (@arr_to_cV R n) \o (arr_map f).

Definition arr_to_point_rV (t : Type) (R : realFieldType) (n : nat)
  (f : t -> R):= (@arr_to_rV R n) \o (arr_map f).

Lemma spec_func_to_point_cV (t : Type) (R : realFieldType) (n : nat)
  (r : t -> R -> Prop) (f : t -> R) (P : t -> Prop):
  spec_func r f P->
  spec_func (@rel_point_cV _ _ r n) (@arr_to_point_cV t R n f)
  (fun a=> @precond_len t n a /\ precond_array P a).
Proof.
move=> spec_f a /[dup] pre [len_a P_a].
apply/spec_func_comp_pre;
  [ |apply/spec_func_rel_array/spec_f|exact/spec_func_to_cV|exact/pre].
by move=> x _ len_x; rewrite /precond_len len_x length_arr_map.
Qed.

Lemma spec_func_to_point_rV (t : Type) (R : realFieldType) (n : nat)
  (r : t -> R -> Prop) (f : t -> R) (P : t -> Prop):
  spec_func r f P->
  spec_func (@rel_point_rV _ _ r n) (@arr_to_point_rV t R n f)
  (fun a=> @precond_len t n a /\ precond_array P a).
Proof.
move=> spec_f a /[dup] pre [len_a P_a].
apply/spec_func_comp_pre;
  [ |apply/spec_func_rel_array/spec_f|exact/spec_func_to_rV|exact/pre].
by move=> x _ len_x; rewrite /precond_len len_x length_arr_map.
Qed.

Definition arr_to_point_mx_row (t : Type) (R : realFieldType) (m n : nat)
  (f : t -> R):=
  (@arr_to_mx_row R m n) \o (arr_map (fun x => arr_map f x)).

Definition arr_to_point_mx_col (t : Type) (R : realFieldType) (m n : nat)
  (f : t -> R):=
  (@arr_to_mx_col R m n) \o (arr_map (fun x => arr_map f x)).

Lemma spec_func_to_point_mx_row (t : Type) (R : realFieldType) (m n : nat)
  (r : t -> R -> Prop) (f : t -> R) (P : t -> Prop):
  spec_func r f P->
  spec_func (@rel_point_mx_row _ _ r m n) (@arr_to_point_mx_row t R m n f)
  (fun a=> @precond_mx t m n a /\ precond_array (fun x=> precond_array P x) a).
Proof.
move=> spec_f; apply/spec_func_comp_pre;
  [|exact/spec_func_rel_array/spec_func_rel_array|exact/spec_func_to_mx_row].
move=> a _ [len_a pre_a]; split; rewrite ?length_arr_map //.
move=> i; rewrite length_arr_map=> /pre_a; rewrite /precond_len.
by rewrite arr_map_nth length_arr_map.
Qed.

Lemma spec_func_to_point_mx_col (t : Type) (R : realFieldType) (m n : nat)
  (r : t -> R -> Prop) (f : t -> R) (P : t -> Prop):
  spec_func r f P->
  spec_func (@rel_point_mx_col _ _ r m n)
    (@arr_to_point_mx_col t R m n f)
  (fun a=> @precond_mx t n m a /\ precond_array (fun x=> precond_array P x) a).
Proof.
move=> spec_f; apply/spec_func_comp_pre;
  [|exact/spec_func_rel_array/spec_func_rel_array|exact/spec_func_to_mx_col].
move=> a _ [len_a pre_a]; split; rewrite ?length_arr_map //.
move=> i; rewrite length_arr_map=> /pre_a; rewrite /precond_len.
by rewrite arr_map_nth length_arr_map.
Qed.

End Vector.

Section ArraySet.

Definition arr_to_set {T : finType} (a : array T):=
  [set a.[i] | i in irange0 (length a)].

Lemma spec_func_arr_to_set {T : finType} (op : rel T):
  spec_func (rel_array_set op) (@arr_to_set T)
  (fun a=> rel_sorted op a).
Proof. by move=> a sta; split. Qed.

Definition precond_array_set {t : Type} (op_t : rel t) (P : t -> Prop)
  (a : array t):=
  rel_sorted op_t a /\ precond_array P a.

Lemma spec_func_arr_to_set_r {t : Type} {T : finType}
  (op_t : rel t) (op_T : rel T)
  (r : t -> T -> Prop) (f : t -> T) (P : t -> Prop):
  (r =~> r =~> eq) op_t op_T ->
  spec_func r f P ->
  spec_func (@rel_arr_set_r _ _ r op_T) (arr_to_set \o (arr_map f))
  (precond_array_set op_t P).
Proof.
move=> op_tT spec_f; apply/spec_func_comp_pre;
  [|exact/spec_func_rel_array|exact/spec_func_arr_to_set].
move=> a Pa /=; apply/eq_imply/sorted_rel_equiv;
  [| |move=> ???? h1 h2; apply:op_tT; [exact:h1|exact:h2]].
- by rewrite length_arr_map.
- move=> i i_len; rewrite arr_map_nth; exact/spec_f/Pa.
Qed.

End ArraySet.

Section Graph.

Definition graph_to_high (g : graph.graph):=
  mk_graph ([fset i | i in irange0 (length g)])
  (fun i j=> mem_edge g i j).

Lemma spec_func_structure:
  spec_func rel_structure graph_to_high precond_struct.
Proof.
move=> g Pg; split=> // i; rewrite ?vtx_mk_graph ?inE ?mem_irangeE ?le0x //.
move=> j ig; apply/idP/idP.
- move: Pg=> /(_ i ig) [_ h].
  rewrite mem_edgeP // mem_filter => /andP [jg nei_j].
  rewrite edge_mk_graph ?mem_edgeP ?mem_filter
    ?jg ?nei_j ?inE ?mem_irangeE ?le0x //.
- move=> /[dup] /edge_vtxr; rewrite !vtx_mk_graph !inE !mem_irangeE !le0x /=.
  by move=> jg; rewrite edge_mk_graph // ?inE ?mem_irangeE ?le0x.
Qed.

Definition lbl_graph_to_high_lbl {t T: Type} (f : t -> T) gl:=
  (graph_to_high gl.1, arr_map f gl.2).

Lemma spec_func_lbl_graph {t : Type} {T : choiceType}
  (r : t -> T -> Prop) (f : t -> T) (P : t -> Prop):
  spec_func r f P ->
  spec_func (@rel_lbl_graph _ _ r) (lbl_graph_to_high_lbl f)
    (fun gl=> precond_lbl_graph gl /\ (precond_struct gl.1 /\ precond_array P gl.2)).
Proof.
move=> spec_f gl [pre_lbl pre_gr]; split=> //.
by apply:spec_func_couple;
  [apply:spec_func_structure|apply/spec_func_rel_array/spec_f|].
Qed.

Definition high_lbl_to_final {T : choiceType}
  (GL : high_graph.graph [choiceType of Uint63.int] * array T):=
  (fun x=> GL.2.[x]) @° GL.1.

Definition precond_high_to_final {T : choiceType}
  (GL : high_graph.graph [choiceType of Uint63.int] *
        array T):=
  (forall x, x \in vertices GL.1 = (x < length GL.2)%O) /\
  {in irange0 (length GL.2) &, injective (get GL.2)}.

Lemma spec_func_final_graph (T : choiceType):
  spec_func (@rel_final_graph T)
  (high_lbl_to_final) (precond_high_to_final).
Proof.
move=> GL [GL_len L_st] [:L_inj]; apply/gisofE; split.
- abstract: L_inj.
  by move=> x y; rewrite !GL_len=> ??; apply/L_st; rewrite ?mem_irangeE ?le0x.
- by rewrite vtx_img_graph.
- move=> x y xG yG; apply/idP/idP.
  + by move=> Gxy; apply/edge_img_graph; exists x,y; split.
  + case/edge_img_graph=> x' [y'] [++] /[dup] /edge_vtxlr [x'G y'G].
    by move/L_inj=> -> // /L_inj ->.
Qed.

Definition precond_graph {T : Type}
  (ltt : rel T) (P : T -> Prop)
  (gl : graph.graph * array T):=
  rel_sorted ltt gl.2 /\
  precond_lbl_graph gl /\
  (precond_struct gl.1 /\ precond_array P gl.2).

Lemma spec_func_rel_graph_r {t : Type} {T : choiceType}
  (r : t -> T -> Prop) f (P : t -> Prop)
  (ltt eqt: rel t):
  transitive ltt ->
  (forall x y, P x -> P y -> f x == f y -> eqt x y)->
  (forall x y : t, eqt x y -> ~~ ltt x y /\ ~~ ltt y x)->
  spec_func r f P->
  spec_func (@rel_graph_r _ _ r)
  (high_lbl_to_final \o (fun gl=> (graph_to_high gl.1, arr_map f gl.2)))
  (precond_graph ltt P).
Proof.
move=> tr_ltt f_inj eqt_spec spec_f.
apply: (spec_func_comp_pre);
  [|exact/spec_func_lbl_graph/spec_f|exact:spec_func_final_graph].
case=> g l [pre_lbl] [/= pre_struct pre_arr] pre_st.
split.
- move=> x /=; rewrite length_arr_map vtx_mk_graph inE /=.
  by rewrite pre_lbl /= mem_irangeE le0x.
- move=> i j /=; rewrite length_arr_map !arr_map_nth.
  rewrite !mem_irangeE ?le0x /= => i_l j_l /eqP.
  move/f_inj=> /(_ (pre_arr _ i_l) (pre_arr _ j_l)).
  move/(sorted_rel_inj_rel tr_ltt); exact.
Qed.

End Graph.
End SpecFunc.

Module PrecondComputation.

Definition pre_struct_computation (g : graph.graph) :=
  IFold.iall (fun i=>
    PArrayUtils.is_lti_sorted (GraphUtils.neighbours g i) &&
    PArrayUtils.all (fun j=> GraphUtils.mem_vertex g j) (GraphUtils.neighbours g i))
  (length g).

Definition pre_lbl_graph_computation {T : Type}
  (g : graph.graph) (l : array T):=
  (length g =? length l)%uint63.

Definition pre_array_computation {T : Type} (f : T -> bool) (a : array T):=
  PArrayUtils.all f a.

Definition pre_length_computation {T : Type} (a : array T) (n : Uint63.int):=
  (length a =? n)%uint63.

Definition pre_mx_computation {T : Type} (a : array (array T)) (m n : Uint63.int):=
  (length a =? m)%uint63 && PArrayUtils.all (fun x=> pre_length_computation x n) a.

Definition pre_ord_computation (x m : Uint63.int):=
  (x <? m)%uint63.

Definition pre_graph_computation {T : Type}
  (ltT : rel T) (f : T -> bool)
  (g : graph.graph) (l : array T) :=
  [&& PArrayUtils.is_sorted_rel ltT l,
      pre_lbl_graph_computation g l,
      pre_struct_computation g &
      pre_array_computation f l
  ].

Definition pre_arr_set_computation {T : Type} (op_t : rel T)
  (f : T -> bool) (a : array T):=
  PArrayUtils.is_sorted_rel op_t a && pre_array_computation f a.

End PrecondComputation.

Module PC := PrecondComputation.

Section PrecondEquiv.

Definition pre_struct_computation (g : graph.graph) :=
  iall (fun i=>
    is_lti_sorted (neighbours g i) &&
    arr_all (fun j=> mem_vertex g j) (neighbours g i))
  (length g).

Definition pre_lbl_graph_computation {T : Type}
  (g : graph.graph) (l : array T):=
  (length g == length l)%O.

Definition pre_array_computation {T : Type} (f : T -> bool) (a : array T):=
  arr_all f a.

Definition pre_length_computation {T : Type} (a : array T) (n : Uint63.int):=
  (length a == n)%O.

Definition pre_mx_computation {T : Type}
  (a : array (array T)) (m n : Uint63.int):=
  (length a == m)%O &&
  arr_all (fun x=> pre_length_computation x n) a.

Definition pre_ord_computation (x m : Uint63.int):=
  (x < m)%O.

Definition pre_graph_computation
  {T : Type} (ltT : rel T) (f : T -> bool)
  (g : graph.graph) (l : array T):=
  [&& is_sorted_rel ltT l,
      pre_lbl_graph_computation g l,
      pre_struct_computation g &
      pre_array_computation f l
  ].

Definition pre_arr_set_computation {T : Type} (op_t : rel T)
(f : T -> bool) (a : array T):=
  is_sorted_rel op_t a && pre_array_computation f a.

Lemma pre_struct_computationE g:
  PC.pre_struct_computation g = pre_struct_computation g.
Proof.
rewrite /PC.pre_struct_computation iallE; apply/eq_all=> i.
rewrite is_lti_sortedE arr_allE; congr andb.
Qed.

Lemma pre_lbl_graph_computationE {T : Type} g (l : array T):
  PC.pre_lbl_graph_computation g l = pre_lbl_graph_computation g l.
Proof. by rewrite /PC.pre_lbl_graph_computation eqEint. Qed.

Lemma pre_array_computationE {T : Type} (f : T -> bool) (a : array T):
  PC.pre_array_computation f a = pre_array_computation f a.
Proof. by rewrite /PC.pre_array_computation arr_allE. Qed.

Lemma pre_length_computationE {T : Type} (a : array T) n:
  PC.pre_length_computation a n = pre_length_computation a n.
Proof. by rewrite /PC.pre_length_computation eqEint. Qed.

Lemma pre_mx_computationE {T : Type} (a : array (array T)) m n:
  PC.pre_mx_computation a m n = pre_mx_computation a m n.
Proof.
rewrite /PC.pre_mx_computation eqEint; congr andb.
by rewrite arr_allE; apply/eq_all=> i; rewrite pre_length_computationE.
Qed.

Lemma pre_ord_computationE (x m : Uint63.int):
  PC.pre_ord_computation x m = pre_ord_computation x m.
Proof. by rewrite /PC.pre_ord_computation -ltEint. Qed.

Lemma pre_graph_computationE {T : Type}
  (ltT : rel T) (f : T -> bool)
  (g : graph.graph) (l : array T):
  PC.pre_graph_computation ltT f g l =
  pre_graph_computation ltT f g l.
Proof.
rewrite /PC.pre_graph_computation; repeat congr andb.
- by rewrite is_sorted_relE.
- by rewrite pre_lbl_graph_computationE.
- by rewrite pre_struct_computationE.
- by rewrite pre_array_computationE.
Qed.

Lemma pre_arr_set_computationE {T : Type}
  (ltt : rel T) (f : T -> bool) a:
  PC.pre_arr_set_computation ltt f a =
  pre_arr_set_computation ltt f a.
Proof. by rewrite /PC.pre_arr_set_computation is_sorted_relE pre_array_computationE. Qed.

End PrecondEquiv.

Section PrecondProofs.

Lemma precond_structP g: pre_struct_computation g ->
  precond_struct g.
Proof.
move/allP=> h i ig.
move/(_ i): h; rewrite mem_irangeE le0x=> /(_ ig).
case/andP=> nei_st nei_vtx; split.
- by rewrite -lti_sortedP.
- move=> j j_nei; move: nei_vtx.
  move/allP=> /(_ (neighbours g i).[j]).
  rewrite /arr_to_seq map_f ?mem_irangeE ?le0x ?j_nei //.
  exact.
Qed.

Lemma precond_lbl_graphP {T : Type} g (l : array T):
  pre_lbl_graph_computation g l ->
  precond_lbl_graph (g,l).
Proof. by move/eqP. Qed.

Lemma precond_arrayP {T : Type}
  (f : T -> bool) (P : T -> Prop) (a : array T):
  (forall x, f x -> P x)->
  pre_array_computation f a -> precond_array P a.
Proof. by move=> fP /all_arr hf i i_a; apply/fP/hf. Qed.

Lemma precond_lengthP {T : Type} (a : array T) (i : Uint63.int) (n : nat):
  n.+1 = i->
  pre_length_computation a i -> precond_len n a.
Proof. by rewrite /precond_len=> -> /eqP ->. Qed.

Lemma precond_mxP {T : Type} (a : array (array T))
  (i j : Uint63.int) (m n : nat):
  m.+1 = i -> n.+1 = j ->
  pre_mx_computation a i j -> precond_mx m n a.
Proof.
rewrite /precond_mx /precond_len => -> -> /andP [/eqP -> /all_arr] h.
by split=> // k k_a; move:h=> /(_ k k_a) /eqP ->.
Qed.

Lemma precond_graphP {T : Type} (ltt : rel T) (f : T -> bool)
  (P : T -> Prop) g l:
  (forall x, f x -> P x)->
  pre_graph_computation ltt f g l->
  precond_graph ltt P (g,l).
Proof.
move=> fP /and4P [l_st pre_lbl pre_stru pre_arr]; split=> /=.
- by rewrite -rel_sortedP.
- split=> /=. exact/precond_lbl_graphP.
- split=> /=. exact/precond_structP.
- exact/(precond_arrayP fP).
Qed.

Lemma precond_array_setP {T : Type} (ltt : rel T)
  (f : T -> bool) (P : T -> Prop) a:
  (forall x, f x -> P x)->
  pre_arr_set_computation ltt f a ->
  precond_array_set ltt P a.
Proof.
move=> fP /andP [st_a f_a]; split; rewrite -?rel_sortedP //.
exact/(precond_arrayP fP).
Qed.

End PrecondProofs.


Require Import Coq.Lists.List.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Util.Notations.

Create HintDb wf discriminated.

Ltac solve_wf_side_condition := solve [ eassumption | eauto 250 with wf ].

Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}.
  Local Notation exprf := (@exprf base_type_code op).
  Local Notation expr := (@expr base_type_code op).
  Local Notation Expr := (@Expr base_type_code op).

  Section with_var.
    Context {var1 var2 : base_type_code -> Type}.

    Local Notation eP2 := (fun t1t2 => var1 (fst t1t2) * var2 (snd t1t2))%type (only parsing).
    Local Notation eP := (fun t => var1 t * var2 t)%type (only parsing).
    Local Notation "x == y" := (existT eP _ (x, y)%core).
    Fixpoint flatten_binding_list2 {t1 t2} (x : interp_flat_type var1 t1) (y : interp_flat_type var2 t2) : list (sigT eP2)
      := (match t1, t2 return interp_flat_type var1 t1 -> interp_flat_type var2 t2 -> list _ with
          | Tbase t1, Tbase t2 => fun x y => existT eP2 (t1, t2)%core (x, y)%core :: nil
          | Unit, Unit => fun x y => nil
          | Prod t0 t1, Prod t0' t1'
            => fun x y => @flatten_binding_list2 _ _ (snd x) (snd y) ++ @flatten_binding_list2 _ _ (fst x) (fst y)
          | Tbase _, _
          | Unit, _
          | Prod _ _, _
            => fun _ _ => nil
          end x y)%list.
    Fixpoint flatten_binding_list {t} (x : interp_flat_type var1 t) (y : interp_flat_type var2 t) : list (sigT eP)
      := (match t return interp_flat_type var1 t -> interp_flat_type var2 t -> list _ with
          | Tbase _ => fun x y => (x == y) :: nil
          | Unit => fun x y => nil
          | Prod t0 t1 => fun x y => @flatten_binding_list _ (snd x) (snd y) ++ @flatten_binding_list _ (fst x) (fst y)
          end x y)%list.

    Inductive wff : list (sigT eP) -> forall {t}, @exprf var1 t -> @exprf var2 t -> Prop :=
    | WfTT : forall G, @wff G _ TT TT
    | WfVar : forall G (t : base_type_code) x x', List.In (x == x') G -> @wff G (Tbase t) (Var x) (Var x')
    | WfOp : forall G {t} {tR} (e : @exprf var1 t) (e' : @exprf var2 t) op,
        wff G e e'
        -> wff G (Op (tR := tR) op e) (Op (tR := tR) op e')
    | WfLetIn : forall G t1 t2 e1 e1' (e2 : interp_flat_type var1 t1 -> @exprf var1 t2) e2',
        wff G e1 e1'
        -> (forall x1 x2, wff (flatten_binding_list x1 x2 ++ G) (e2 x1) (e2' x2))
        -> wff G (LetIn e1 e2) (LetIn e1' e2')
    | WfPair : forall G {t1} {t2} (e1: @exprf var1 t1) (e2: @exprf var1 t2)
                      (e1': @exprf var2 t1) (e2': @exprf var2 t2),
        wff G e1 e1'
        -> wff G e2 e2'
        -> wff G (Pair e1 e2) (Pair e1' e2').
    Inductive wf : forall {t}, @expr var1 t -> @expr var2 t -> Prop :=
    | WfAbs : forall A B e e',
        (forall x x', @wff (flatten_binding_list x x') B (e x) (e' x'))
        -> @wf (Arrow A B) (Abs e) (Abs e').
  End with_var.

  Definition Wf {t} (E : @Expr t) := forall var1 var2, wf (E var1) (E var2).
End language.

Global Arguments wff {_ _ _ _} G {t} _ _.
Global Arguments wf {_ _ _ _ t} _ _.
Global Arguments Wf {_ _ t} _.

Hint Constructors wf wff : wf.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.
Require Export Category.Functor.Diagonal.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Corollary Diagonal_Unique `(C : Category) {D : Category} (d : D) :
Diagonal C d ≈[Cat] Const d ∘[Cat] one.
Proof. hammer_hook "Diagonal" "Diagonal.Diagonal_Unique". exists (fun _ => iso_id); simpl; intros; cat. Qed.