(**************************************************************************)
(*           *                                                            *)
(*     _     *   The Coccinelle Library / Evelyne Contejean               *)
(*    <o>    *          CNRS-LRI-Universite Paris Sud                     *)
(*  -/@|@\-  *                   A3PAT Project                            *)
(*  -@ | @-  *                                                            *)
(*  -\@|@/-  *      This file is distributed under the terms of the       *)
(*    -v-    *      CeCILL-C licence                                      *)
(*           *                                                            *)
(**************************************************************************)

From Coq Require Import Arith List.
From CoLoR Require Import more_list list_sort term_spec ac cf_eq_ac matching.

Module Type S.

Declare Module Import Matching : matching.S.
Import Cf_eq_ac.
Import Ac.
Import EqTh.
Import T.

Definition pb_weight pb :=
  list_size
    (fun t1_t2 : term * term =>
       match t1_t2 with | (t1,t2) => ac_size t1 + ac_size t2 end)
     (unsolved_part pb).
Parameter well_founded_solve :
  forall pb, well_formed_pb pb ->
  forall pb', In pb' (solve pb) -> pb_weight pb' < pb_weight pb.

End S.

Module Make (Matching1 : matching.S) : S with Module Matching := Matching1.

Module Matching := Matching1.
Import Matching1.
Import Cf_eq_ac.
Import Ac.
Import EqTh.
Import T.
Import F.
Import X.
Import Sort.
Import LPermut.

Lemma ac_size_build_eq :
  forall f l, arity f = AC ->
  ac_size (build f l) = (length l - 1) + list_size ac_size l.
Proof.
intros f l Af; unfold build; simpl; destruct l as [ | t1 l].
rewrite quicksort_equation; simpl; rewrite Af; trivial.
destruct l as [ | t2 l].
simpl; auto with arith.
rewrite ac_size_unfold; rewrite Af; rewrite length_quicksort;
apply (f_equal (fun n => length (t1 :: t2 :: l) -1 + n));
apply list_permut.permut_size with (@eq term).
intros; subst; trivial.
apply quick_permut_bis; auto.
Qed.

Lemma ac_size_build_lt_args :
  forall f l1 l2 t1, arity f = AC -> well_formed_cf (Term f (l1 ++ t1 :: l2)) ->
  ac_size (build f (l1 ++ l2)) + ac_size t1 < ac_size (Term f (l1 ++ t1 :: l2)).
Proof.
intros f l1 l2 t1 Ar W;
pattern (ac_size (Term f (l1 ++ t1 :: l2))); rewrite ac_size_unfold.
rewrite ac_size_build_eq; trivial.
do 2 rewrite length_app;
do 2 rewrite list_size_app; simpl; rewrite <- plus_assoc;
apply plus_lt_le_compat.
rewrite (plus_comm (length l1) (S (length l2))); simpl;
rewrite <- minus_n_O;
rewrite (plus_comm (length l2));
elim W; clear W; rewrite Ar;
intros _ W; elim W; clear W;
intros L _; rewrite length_app in L; simpl in L;
rewrite plus_comm in L; simpl in L;
rewrite plus_comm in L;
destruct (length l1 + length l2).
absurd (1 >= 2); trivial; unfold ge; auto with arith.
auto with arith.
rewrite <- plus_assoc; apply plus_le_compat_l;
rewrite plus_comm; auto with arith.
Qed.

Lemma ac_size_build_lt :
  forall f l1 l2 t1, arity f = AC -> well_formed_cf (Term f (l1 ++ t1 :: l2)) ->
  ac_size (build f (l1 ++ l2)) < ac_size (Term f (l1 ++ t1 :: l2)).
Proof.
intros f l1 l2 t1 Ar W.
apply lt_le_trans with (ac_size (build f (l1 ++ l2)) + ac_size t1).
rewrite (plus_n_O (ac_size (build f (l1 ++ l2))));
rewrite <- plus_assoc; apply plus_lt_compat_l;
simpl; unfold lt; apply ac_size_ge_one;
elim (well_formed_cf_unfold _ W); intros Wl _;
apply Wl; apply in_or_app; right; left; trivial.
apply lt_le_weak; apply ac_size_build_lt_args; trivial.
Qed.

Definition pb_weight pb :=
  list_size
    (fun t1_t2 : term * term =>
       match t1_t2 with | (t1,t2) => ac_size t1 + ac_size t2 end)
     (unsolved_part pb).

Theorem well_founded_solve :
  forall pb, well_formed_pb pb ->
  forall pb', In pb' (solve pb) -> pb_weight pb' < pb_weight pb.
Proof.
unfold pb_weight, solve, well_formed_pb;
 intros pb [W1 [W2 [W3 _]]] pb' In_pb';
destruct (unsolved_part pb) as [ | [[v1 | f1 l1] t2] l].
(* unsolved_part pb = nil *)
contradiction.
(* unsolved_part pb =  (v1,t2) :: _ *)
destruct (find X.eq_bool v1 (solved_part pb)) as [t1 | ].
(* v1 has already a plain value t1, and t1 is equal or not to t2 *)
destruct (T.eq_bool t1 t2); [idtac | contradiction];
inversion_clear In_pb' as [pb'_eq_ | ]; [idtac | contradiction];
subst; simpl; auto with arith.
generalize (W3 v1);
destruct (find X.eq_bool v1 (partly_solved_part pb)) as [ p1 |].
(* v1 has not a plain value, but it has a partial value p1 *)
(* the partial value p1 is compatible or not with t2 *)
destruct t2 as [ v2 | f2 l2].
contradiction.
revert In_pb'; generalize (F.Symb.eq_bool_ok (head_symb p1) f2);
case (F.Symb.eq_bool (head_symb p1) f2); [intros f1_eq_f2 In_pb' | contradiction].
rewrite f1_eq_f2; destruct_arity f2 n2 Af2; [ idtac | contradiction | contradiction].
intros _; assert (In_l2 := in_remove _ _ T.eq_bool_ok (closed_term p1) l2).
destruct (remove T.eq_bool (closed_term p1) l2) as [ l2''' | ]; [idtac | contradiction].
destruct In_l2 as [cp1 [l2' [l2'' [H [l2_eq l2'''_eq]]]]].
injection l2'''_eq; clear l2'''_eq; intro l2'''_eq; rewrite <- H in l2_eq; clear H; subst l2;
inversion_clear In_pb' as [pb'_eq_ | ]; [idtac | contradiction].
subst; simpl unsolved_part;
apply list_size_tl_compat; apply plus_le_lt_compat; auto with arith.
apply ac_size_build_lt;
[ rewrite Af2 | apply (proj2 (A:=well_formed_cf (Var v1))); apply W1; left] ; trivial.
inversion_clear In_pb' as [pb'_eq_ | ]; [idtac | contradiction].
(* v1 has no value at all, neither plain nor partial *)
intros _; subst; simpl unsolved_part; simpl; auto with arith.

(* unsolved_part pb = (Term f1 l1, t2) :: _ *)
(* t2 is compatible or not with (Term f1 l1) *)
destruct t2 as [ v2 | f2 l2 ].
contradiction.
revert In_pb';  generalize (F.Symb.eq_bool_ok f1 f2);
destruct (F.Symb.eq_bool f1 f2); [intros f1_eq_f2 In_pb'; subst f2 | contradiction].
destruct_arity f1 n1 Af1.
(* arity f1 = AC *)
destruct (le_gt_dec (length l1) (length l2)) as [_ | _]; [idtac | contradiction].
unfold ac_elementary_solve in In_pb'.
assert (W_t1 :  well_formed_cf (Term f1 l1)).
refine (proj1 _ (B:= (well_formed_cf (Term f1 l2)))); apply W1; left; trivial.
assert (W_t2 : well_formed_cf (Term f1 l2)).
apply (proj2 (A:= (well_formed_cf (Term f1 l1)))); apply W1; left; trivial.
destruct l1 as [ | t1 l1].
(* l1 = nil *)
absurd (2 <= @length term nil); auto with arith;
apply well_formed_cf_length with f1; trivial.
(* l1 = t1 :: _ *)
destruct t1 as [v1 | g1 ll1].
(* l1 = t1 :: _  and t1 is a variable v1 *)
generalize (W2 v1);
destruct (find X.eq_bool v1 (solved_part pb)) as [s1 | ].
(* l1 = t1 :: _, t1 is a variable v1  and v1 has a plain value s1 *)
intro W_s1; unfold ac_elementary_solve_term_var_with_val_term in *.
generalize (in_remove _ _ T.eq_bool_ok s1 l2);
destruct (remove T.eq_bool s1 l2) as [ l2''' |].
(* l1 = t1 :: _, t1 is a variable v1, v1 has a plain value s1 and s1 occurs in l2 *)
intros [cp1 [l2' [l2'' [ H [l2_eq l2'''_eq]]]]].
injection l2'''_eq; clear l2'''_eq; intro l2'''_eq; rewrite <- H in l2_eq; clear H; subst l2''';
inversion_clear In_pb' as [pb'_eq_ | ]; [idtac | contradiction].
generalize (W1 (Term f1 (Var v1 :: l1))  (Term f1 l2) (or_introl _ (eq_refl _)));
intros [Wt1 Wt2];  subst; unfold unsolved_part;
apply list_size_tl_compat; apply plus_lt_compat;
[replace (Var v1 :: l1) with (nil ++ Var v1 :: l1); trivial;
replace (build f1 l1) with (build f1 (nil ++ l1)); trivial |
idtac]; apply ac_size_build_lt; trivial.
(* l1 = t1 :: _, t1 is a variable v1, v1 has a plain value s1 and s1 does not occur in l2 *)
intros _; destruct s1 as [| g1 ll1].
contradiction.
revert In_pb';
generalize (F.Symb.eq_bool_ok f1 g1); case (F.Symb.eq_bool f1 g1); [intros f1_eq_g1 In_pb'; subst g1 | intros _; contradiction].
assert (S_ll1 := well_formed_cf_sorted Af1 W_s1).
assert (S_l2 := well_formed_cf_sorted Af1 W_t2).
generalize (in_remove_list S_ll1 S_l2);
destruct (remove_list ll1 l2) as [l2' | ]; [idtac | contradiction ].
unfold DOS.A in *;
destruct (le_gt_dec (length l1) (length l2')) as [L_l1_l2' |]; [idtac | contradiction].
inversion_clear In_pb' as [pb'_eq_ | ]; [idtac | contradiction].
intro P; subst; simpl unsolved_part;
apply list_size_tl_compat; apply plus_lt_le_compat.
replace (Var v1 :: l1) with (nil ++ Var v1 :: l1); trivial;
replace (build f1 l1) with (build f1 (nil ++ l1)); trivial;
apply ac_size_build_lt; trivial.
rewrite ac_size_build_eq; trivial;
rewrite ac_size_unfold; rewrite Af1; apply plus_le_compat.
generalize (list_permut.permut_length P); intro H;
unfold EDS.A, DOS.A in *; rewrite <- H; rewrite length_app;
destruct (length l2'); simpl; auto with arith;
rewrite plus_comm; simpl; do 2 rewrite <- minus_n_O; auto with arith.
assert (Dummy : forall a a' : term,
  In a (ll1 ++ l2') -> In a' l2 -> a = a' -> ac_size a = ac_size a').
intros; subst; trivial.
generalize (list_permut.permut_size ac_size ac_size Dummy P); intro H;
unfold EDS.A, DOS.A in *; rewrite <- H; rewrite list_size_app; auto with arith.
intros _; generalize (W3 v1);
destruct (find X.eq_bool v1 (partly_solved_part pb)) as [p1 | ].
(* l1 = t1 :: _, t1 is a variable v1 and v1 has a partial value p1 *)
unfold ac_elementary_solve_term_var_with_part_val_term in *.
revert In_pb'; generalize (F.Symb.eq_bool_ok f1 (head_symb p1));
case (F.Symb.eq_bool f1 (head_symb p1)); [intros f1_eq_hd_p1 In_pb'| intros f1_diff_hd_p1 In_pb'].
(* l1 = t1 :: _, t1 is a variable v1, v1 has a partial value p1 and the head of p1 is f1 *)
generalize (in_remove _ _ T.eq_bool_ok (closed_term p1) l2);
destruct (remove T.eq_bool (closed_term p1) l2) as [l2''' | ]; [idtac | contradiction].
destruct In_pb' as [pb'_eq_ | ]; [idtac | contradiction].
intros [cp1 [l2' [l2'' [ H [l2_eq l2'''_eq]]]]].
injection l2'''_eq; clear l2'''_eq; intro l2'''_eq; rewrite <- H in l2_eq; clear H;
subst; simpl unsolved_part; rewrite Af1; intros.
apply list_size_tl_compat; apply plus_le_lt_compat.
destruct l1 as [ | s1 l1]; [simpl; auto with arith | idtac].
do 2 rewrite ac_size_unfold; rewrite Af1; rewrite length_quicksort;
simpl; apply le_n_S; apply plus_le_compat_l.
assert (H'' := @list_permut.permut_size _ term (@eq term) ac_size ac_size (quicksort (Var (new_var p1) :: s1 :: l1))
  ((Var (new_var p1) :: s1 :: l1))).
unfold EDS.A, DOS.A in *; rewrite H''.
apply le_n.
intros; subst; trivial.
apply quick_permut_bis; reflexivity.
apply ac_size_build_lt; trivial.
(* l1 = t1 :: _, t1 is a variable v1, v1 has a partial value p1 and the head of p1 is NOT f1 *)
intros W3_v1;
pattern pb';
refine
(prop_map_without_repetition (B:=matching_problem) _ T.eq_bool_ok _ _ _ _ pb' In_pb');
clear pb' In_pb'; intros [ | g2 ll2] In_t2; trivial;
generalize (F.Symb.eq_bool_ok g2 (head_symb p1));
case (F.Symb.eq_bool g2 (head_symb p1)); [intros g2_eq_hd_p1 | intros g2_diff_hd_p1; trivial].
generalize (in_remove _ _ T.eq_bool_ok (closed_term p1) ll2);
destruct (remove T.eq_bool (closed_term p1) ll2) as [ll2''' | ]; trivial.
intros [cp1 [ll2' [ll2'' [ H [ll2_eq ll2'''_eq]]]]].
injection ll2'''_eq; clear ll2'''_eq; intro ll2'''_eq; subst cp1 ll2''';
generalize (in_remove _ _ T.eq_bool_ok (Term g2 ll2) l2);
destruct (remove T.eq_bool (Term g2 ll2) l2) as [l2''' | ]; trivial.
intros [cp1 [l2' [l2'' [ H [l2_eq l2'''_eq]]]]].
injection l2'''_eq; clear l2'''_eq; intro; subst l2''';
simpl unsolved_part; unfold list_size; rewrite plus_assoc; apply plus_lt_compat_r;
replace (ac_size (Var (new_var p1))) with (ac_size (Var v1)); trivial;
rewrite (plus_comm (ac_size (Var v1))); rewrite <- plus_assoc;
rewrite (plus_assoc (ac_size (Var v1))); rewrite plus_comm;
rewrite <- plus_assoc; apply plus_lt_compat.
rewrite plus_comm; replace (build f1 l1) with (build f1 (nil ++ l1)); trivial;
replace (Var v1 :: l1) with (nil ++ Var v1 :: l1); trivial;
apply ac_size_build_lt_args; trivial.
apply lt_trans with (ac_size (build f1 (l2' ++ l2'')) + ac_size (Term g2 ll2)).
apply plus_lt_compat_l; subst; apply ac_size_build_lt.
destruct (arity (head_symb p1)); [trivial | contradiction | contradiction].
apply (well_formed_cf_subterms W_t2); trivial.
subst; apply ac_size_build_lt_args; trivial.
(* l1 = t1 :: _, t1 is a variable v1, v1 has no value, neither plain nor partial *)
intros _; unfold ac_elementary_solve_term_var_without_val_term in *.
pattern pb';
refine
(prop_map12_without_repetition (B:=matching_problem) _ T.eq_bool_ok _ _ _ _ pb' In_pb');
clear pb' In_pb';
intros t2 In_t2; generalize (in_remove _ _ T.eq_bool_ok t2 l2);
destruct (remove T.eq_bool t2 l2) as [l2''' | ]; trivial;
intros [cp1 [l2' [l2'' [ H [l2_eq l2'''_eq]]]]].
injection l2'''_eq; clear l2'''_eq; intro; subst l2''';
assert (Common_ineq :
list_size
  (fun t1_t2 : term * term =>
   let (t1, t3) := t1_t2 in ac_size t1 + ac_size t3)
  (unsolved_part
     (mk_pb (existential_vars pb) ((build f1 l1, build f1 (l2' ++ l2'')) :: l)
        ((v1, t2) :: solved_part pb) (partly_solved_part pb))) <
list_size
  (fun t1_t2 : term * term =>
   let (t1, t3) := t1_t2 in ac_size t1 + ac_size t3)
  ((Term f1 (Var v1 :: l1), Term f1 l2) :: l)).
simpl unsolved_part; apply list_size_tl_compat; apply plus_le_lt_compat.
simpl; rewrite Af1; rewrite <- minus_n_O; rewrite (list_size_fold ac_size);
rewrite ac_size_build_eq; trivial; apply plus_le_compat; auto with arith; apply le_minus.
subst; apply ac_size_build_lt; trivial.
unfold EDS.A, DOS.A in *; destruct (le_gt_dec (length l2) (length l1 + 1)) as [_ | _]; trivial;
split; trivial; clear Common_ineq.
simpl unsolved_part; apply list_size_tl_compat; apply plus_le_lt_compat.
destruct l1 as [| t1' l1]; [simpl; auto with arith | idtac];
simpl; rewrite Af1; rewrite length_quicksort; simpl;
do 2 rewrite (list_size_fold ac_size); simpl;
assert (H' := @list_permut.permut_size _ term (@eq term) ac_size ac_size (Var (fresh_var pb) :: t1' :: l1)
(quicksort (Var (fresh_var pb) :: t1' :: l1))).
unfold EDS.A, DOS.A in *; rewrite <- H'.
simpl; apply le_n.
intros; subst; trivial.
apply quick_permut.
subst l2; apply ac_size_build_lt; trivial.
(* l1 = t1 :: _, t1 is a complex term (Term g1 ll1) *)
unfold ac_elementary_solve_term_term_term in *.
pattern pb';
refine
(prop_map_without_repetition (B:=matching_problem) _ T.eq_bool_ok _ _ _ _ pb' In_pb');
clear pb' In_pb'; intros [ | g2 ll2] In_t2; trivial;
destruct (F.Symb.eq_bool g1 g2); trivial.
generalize (in_remove _ _ T.eq_bool_ok (Term g2 ll2) l2);
destruct (remove T.eq_bool (Term g2 ll2) l2) as [l2''' | ]; trivial.
intros [cp1 [l2' [l2'' [ H [l2_eq l2'''_eq]]]]].
injection l2'''_eq; clear l2'''_eq; intro; subst l2''';
simpl unsolved_part; unfold list_size; do 2 rewrite plus_assoc; apply plus_lt_compat_r.
rewrite <- plus_assoc;
rewrite (plus_comm (ac_size (Term g1 ll1))); rewrite <- plus_assoc;
rewrite (plus_assoc (ac_size (Term g1 ll1))); rewrite plus_comm;
rewrite <- plus_assoc; apply plus_lt_compat.
rewrite plus_comm; replace (build f1 l1) with (build f1 (nil ++ l1)); trivial;
replace (Term g1 ll1 :: l1) with (nil ++ Term g1 ll1 :: l1); trivial;
apply ac_size_build_lt_args; trivial.
subst l2 cp1; apply ac_size_build_lt_args; trivial.

(* arity f1 = C *)
destruct l1 as [ | u1 [ | u2 [ | u3 l1]]]; [contradiction | contradiction | idtac | contradiction].
destruct l2 as [ | v1 [ | v2 [ | v3 l2]]]; [contradiction | contradiction | idtac | contradiction].
inversion_clear In_pb' as [pb'_eq_ | In_pb''];
[idtac | inversion_clear In_pb'' as [pb''_eq_ | ]; [idtac | contradiction]];
subst; simpl unsolved_part; simpl list_size;
rewrite Af1; do 2 rewrite plus_assoc; apply plus_lt_compat_r; do 2 rewrite plus_0_r.
do 2 rewrite plus_assoc; apply plus_lt_compat_r;
simpl; unfold lt; apply le_n_S; do 3 rewrite <- plus_assoc;
apply plus_le_compat_l; rewrite plus_comm; apply plus_le_compat_l;
simpl; apply le_S; apply le_n.
simpl; unfold lt; apply le_n_S; do 3 rewrite <- plus_assoc; apply plus_le_compat_l;
rewrite plus_comm;  rewrite <- plus_assoc; apply plus_le_compat_l;
apply le_S; apply le_n.

(* arity f1 = Free n1 *)
assert (L12 : length l1 = length l2).
apply trans_eq with n1; [idtac | apply sym_eq];
generalize (W1 (Term f1 l1) (Term f1 l2) (or_introl _ (eq_refl _)));
intros [[_ W_t1] [_ W_t2]]; [rewrite Af1 in W_t1 | rewrite Af1 in W_t2]; trivial.
generalize l l2 In_pb' L12; clear W1 W2 W3 l l2 In_pb' L12.
induction l1 as [ | t1 l1]; destruct l2 as [ | t2 l2].
intros [In_pb' | In_pb'] _; [idtac | contradiction];
subst pb'; simpl; rewrite Af1; rewrite <- plus_n_O; simpl; auto with arith.
intros _ L12; simpl in L12; discriminate.
intros _ L12; simpl in L12; discriminate.
intros In_pb' L12; simpl in L12; generalize (eq_add_S _ _ L12); clear L12; intro L12.
generalize (IHl1 _ _ In_pb' L12).
intro H; apply lt_le_trans with
(list_size
  (fun t1_t2 : term * term =>
   let (t1, t2) := t1_t2 in ac_size t1 + ac_size t2)
  ((Term f1 l1, Term f1 l2) :: (t1, t2) :: l)); trivial.
simpl; rewrite Af1; do 2 rewrite (list_size_fold ac_size); simpl; apply le_n_S.
rewrite plus_assoc; apply plus_le_compat_r.
rewrite plus_comm; do 2 rewrite <- plus_assoc; apply plus_le_compat_l.
rewrite plus_comm; rewrite <- plus_assoc; apply plus_le_compat_l.
simpl; rewrite plus_comm; trivial.

Qed.

End Make.


(*** Specs represented as dependent records ***)

Require Import List.
Import ListNotations.
Require Import String.

Add LoadPath "." as Specware.
Require Import Specware.Util.

(*** Fields and their operations ***)

(* Define the type of fields in one place, so we can change it later *)

Definition Field : Set := string.
Definition Field_dec : forall (f1 f2 : Field), {f1=f2} + {f1<>f2} := string_dec.

(* A FieldList is a list of fields with no duplicates *)
Definition FieldList : Set := { flds : list Field | NoDup flds }.

(* Helper constructors for FieldList *)
Definition FL_nil : FieldList := exist _ nil (NoDup_nil _).
Definition FL_cons (f : Field) (flds : FieldList) (n_in: ~ In f (projT1 flds))
: FieldList :=
  exist _ (f :: (projT1 flds)) (NoDup_cons f n_in (projT2 flds)).

(* Mapping a list and removing duplicates *)
Fixpoint map_NoDup (g : Field -> Field) (flds : list Field) : list Field :=
  match flds with
    | nil => nil
    | f :: flds' =>
      if in_dec Field_dec (g f) (map_NoDup g flds') then
        (map_NoDup g flds')
      else
        (g f) :: (map_NoDup g flds')
  end.

(* Proof that map_NoDup produces no duplicates *)
Lemma map_NoDup_NoDup (g : Field -> Field) (flds : list Field) :
  NoDup (map_NoDup g flds).
  induction flds;
  [ constructor
  | unfold map_NoDup; fold map_NoDup;
    destruct (in_dec _ _ _);
    [ | constructor ]; assumption
  ].
Qed.

(* Bundling together map_NoDup and its proof into an operation on FieldLists *)
Definition mapFields (g : Field -> Field) (flds : FieldList) : FieldList :=
  exist _ (map_NoDup g (projT1 flds)) (map_NoDup_NoDup g (projT1 flds)).

(*** Dependent record types ***)

(* Dependent record types, indexed by their fields *)
Inductive RecType : forall {flds : FieldList}, Type :=
| RecType_Nil : RecType (flds:=FL_nil)
| RecType_Cons f {flds} n_in A :
    (A -> RecType (flds:=flds)) -> RecType (flds:= FL_cons f flds n_in)
.

Fixpoint map_RecType (g : Field -> Field) {flds} (rectp : @RecType flds) :
  @RecType (mapFields g flds) :=
  match rectp in @RecType flds return @RecType (mapFields g flds) with
    | RecType_Nil =>
      RecType_Nil
    | RecType_Cons f _ A rectp' =>

      FIXME HERE: this is not going to work! Cannot remove a field
      from a RecType if it is a duplicate!

(* Elements of dependent record types (FIXME: unnecessary?) *)
(*
Inductive RecElem : forall {flds : list Field}, @RecType flds -> Type :=
| RecElem_Nil : RecElem RecType_Nil
| RecElem_Cons f A (a:A) {flds} (rectp: A -> @RecType flds)
               (rest: RecElem (rectp a)) :
    RecElem (RecType_Cons f A rectp)
.
*)

(* Dependent records, independent of record type *)
Inductive RecElem : forall {flds : list Field}, Type :=
| RecElem_Nil : @RecElem nil
| RecElem_Cons f A (a:A) {flds} (rest: @RecElem flds) :
    @RecElem (f :: flds)
.

(* Helper lemma for lists *)
Lemma In_inv_neq A (a b : A) l :
  In a (b :: l) -> b <> a -> In a l.
  intros in_ab neq; destruct (in_inv in_ab);
  [ elimtype False; apply (neq H) | assumption ].
Qed.

(* Projecting a field in a RecElem *)
Fixpoint RecElem_proj {flds} (elem: @RecElem flds) :
  {f:Field | In f flds} -> { A : Type & A } :=
  match elem in @RecElem flds return {f:Field | In f flds} -> { A : Type & A } with
    | RecElem_Nil =>
      (fun f => match in_nil (projT2 f) with end)
    | RecElem_Cons f' A a _ elem' =>
      (fun f =>
         match Field_dec f' (projT1 f) with
           | left _ => existT id A a
           | right neq_pf =>
             RecElem_proj elem' (existT _ (projT1 f)
                                        (In_inv_neq _ _ _ _ (projT2 f) neq_pf))
         end)
  end.

FIXME HERE:
* define the restriction of a RecElem to a particular FieldList
* loosen the IsElemOf to allow re-ordering and subsetting of fields
* define morphisms s1 >=> s2 as:
  forall models m of s2, applying a mapping to RecType s1 yields another s1'
  such that the model m IsElemOf s1'

(* When a RecElem is an element of a RecType *)
Inductive IsElemOf :
  forall {flds : list Field}, @RecType flds -> @RecElem flds -> Prop :=
| IsElemOf_Nil : IsElemOf RecType_Nil RecElem_Nil
| IsElemOf_Cons f A a {flds} (rest_tp: A -> @RecType flds)
                (rest_elem: @RecElem flds) :
    IsElemOf (rest_tp a) rest_elem ->
    IsElemOf (RecType_Cons f A rest_tp) (RecElem_Cons f A a rest_elem)
.

(* Bundling together RecElem with IsElemOf *)
Definition RecElemOf {flds} (rectp: @RecType flds) :=
  { elem: @RecElem flds | IsElemOf rectp elem }.

(* A Spec is a RecType with an arbitrary list of fields *)
Record Spec :=
  {
    spec_fields : list Field;
    spec_fields_nodups : NoDup spec_fields;
    spec_recType : @RecType spec_fields
  }.


From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat. Import Nat.
From Coq Require Import Strings.String.

(* Defining state *)

Definition state := string -> nat.

Definition empty_st : state :=
    fun _ => 0.

Definition update_st (st : state) (x : string) (n : nat) : state :=
    fun x' => if (string_dec x x') then n else st x'.

Notation "x '!->' n ';' st" := (update_st st x n)
    (at level 100, n at next level, right associativity).
Notation "x '!->' n" := (x !-> n ; empty_st)
    (at level 100).

Definition W : string := "W".
Definition X : string := "X".
Definition Y : string := "Y".
Definition Z : string := "Z".

(* Defining Syntax for expression *)

Inductive aexp : Type :=
    | ANum : nat -> aexp
    | AId : string -> aexp
    | APlus : aexp -> aexp -> aexp
    | AMinus : aexp -> aexp -> aexp
    | AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
    | BTrue : bexp
    | BFalse : bexp
    | BEq : aexp -> aexp -> bexp
    | BLe : aexp -> aexp -> bexp
    | BNot : bexp -> bexp
    | BAnd : bexp -> bexp -> bexp.

(* Defining Notation for expression *)

Coercion AId : string >-> aexp.
Coercion ANum : nat >-> aexp.
Declare Custom Entry com.
Declare Scope com_scope.
Notation "<{ e }>" := e (at level 0, e custom com at level 99) : com_scope.
Notation "( x )" := x (in custom com, x at level 99) : com_scope.
Notation "x" := x (in custom com at level 0, x constr at level 0) : com_scope.
Notation "f x .. y" := (.. (f x) .. y)
                  (in custom com at level 0, only parsing,
                  f constr at level 0, x constr at level 9,
                  y constr at level 9) : com_scope.
Notation "x + y" := (APlus x y) (in custom com at level 50, left associativity).
Notation "x - y" := (AMinus x y) (in custom com at level 50, left associativity).
Notation "x * y" := (AMult x y) (in custom com at level 40, left associativity).
Notation "'true'" := true (at level 1).
Notation "'true'" := BTrue (in custom com at level 0).
Notation "'false'" := false (at level 1).
Notation "'false'" := BFalse (in custom com at level 0).
Notation "x <= y" := (BLe x y) (in custom com at level 70, no associativity).
Notation "x = y" := (BEq x y) (in custom com at level 70, no associativity).
Notation "x && y" := (BAnd x y) (in custom com at level 80, left associativity).
Notation "'~' b" := (BNot b) (in custom com at level 75, right associativity).
Open Scope com_scope.

(* Defining evaluation for expression *)

Fixpoint aeval (st : state) (a : aexp) : nat :=
    match a with
    | ANum n => n
    | AId x => st x
    | <{a1 + a2}> => (aeval st a1) + (aeval st a2)
    | <{a1 - a2}> => (aeval st a1) - (aeval st a2)
    | <{a1 * a2}> => (aeval st a1) * (aeval st a2)
    end.

Fixpoint beval (st : state) (b : bexp) : bool :=
    match b with
    | <{true}> => true
    | <{false}> => false
    | <{a1 = a2}> => (aeval st a1) =? (aeval st a2)
    | <{a1 <= a2}> => (aeval st a1) <=? (aeval st a2)
    | <{~ b1}> => negb (beval st b1)
    | <{b1 && b2}> => andb (beval st b1) (beval st b2)
    end.

(* Defining Syntax for command *)

Inductive com : Type :=
    | CSkip : com
    | CAsgn : string -> aexp -> com
    | CSeq : com -> com -> com
    | CIf : bexp -> com -> com -> com
    | CWhile : bexp -> com -> com.

(* Defining Notation for command *)

Notation "'skip'" :=
        CSkip (in custom com at level 0) : com_scope.
Notation "x := y" :=
        (CAsgn x y)
           (in custom com at level 0, x constr at level 0,
            y at level 85, no associativity) : com_scope.
Notation "x ; y" :=
        (CSeq x y)
          (in custom com at level 90, right associativity) : com_scope.
Notation "'if' x 'then' y 'else' z 'end'" :=
        (CIf x y z)
          (in custom com at level 89, x at level 99,
           y at level 99, z at level 99) : com_scope.
Notation "'while' x 'do' y 'end'" :=
        (CWhile x y)
           (in custom com at level 89, x at level 99, y at level 99) : com_scope.

(* Defining evaluation for command as a relation *)

Reserved Notation
    "st '=[' c ']=>' st'"
    (at level 40, c custom com at level 99,
     st constr, st' constr at next level).

Inductive ceval : com -> state -> state -> Prop :=
     | E_Skip : forall st,
         st =[ skip ]=> st
     | E_Asgn : forall st a n x,
         aeval st a = n ->
         st =[ x := a ]=> (x !-> n ; st)
     | E_Seq : forall c1 c2 st st' st'',
         st =[ c1 ]=> st' ->
         st' =[ c2 ]=> st'' ->
         st =[ c1 ; c2 ]=> st''
     | E_IfTrue : forall st st' b c1 c2,
         beval st b = true ->
         st =[ c1 ]=> st' ->
         st =[ if b then c1 else c2 end]=> st'
     | E_IfFalse : forall st st' b c1 c2,
         beval st b = false ->
         st =[ c2 ]=> st' ->
         st =[ if b then c1 else c2 end]=> st'
     | E_WhileFalse : forall b st c,
         beval st b = false ->
         st =[ while b do c end ]=> st
     | E_WhileTrue : forall st st' st'' b c,
         beval st b = true ->
         st =[ c ]=> st' ->
         st' =[ while b do c end ]=> st'' ->
         st =[ while b do c end ]=> st''
     where "st =[ c ]=> st'" := (ceval c st st').

Example ceval_example1:
    empty_st
    =[
       X := 2;
       if (X <= 1)
         then Y := 3
         else Z := 4
       end
    ]=>
    (Z !-> 4 ; X !-> 2).
Proof.
    apply E_Seq with (X !-> 2).
    - apply E_Asgn. simpl. reflexivity.
    - apply E_IfFalse.
      + simpl. reflexivity.
      + apply E_Asgn. simpl. reflexivity.
Qed.


Inductive pbool : Prop := ptrue | pfalse.
(* Attempting to define this yields the error message *)
(* "Elimination of an inductive object of sort Prop is not allowed on a predicate in sort Set *)
(* because proofs can be eliminated only to build proofs." *)
(* Apparently something inherent to Coq is that you can't eliminate Props to make everything except for Props. Why? *)

Definition pbool_to_bool (p:pbool) : bool := match p with ptrue => true | pfalse => false end.

(* Here are some more examples of this: *)

(* This doesn't work: *)
Goal (1 <= 1) -> nat.
intro.
destruct H.

(* This works: *)
Goal (1 <= 1) -> forall (x : nat), x = x.
intro.
destruct H.

(* You can only do this in Prop, not in Set, because you would get universe inconsistency *)
Check (forall P : Prop, P /\ not P -> False) : Prop.
Definition X : Prop := (forall P : Prop, P /\ not P -> False).


(** **********************************************************

Benedikt Ahrens, Chris Kapulkin, Mike Shulman
january 2013

************************************************************)

(** **********************************************************

Contents :

		- Functors
                  - preserve isos, inverses

                  - fully faithful functors
                    - preserve isos, inverses, composition
                            backwards

                  - essentially surjective
                  - faithful
                  - full
                  - fully faithful is the same as full and faithful

                  - Image of a functor, full subcat specified
                                       by a functor

		- Natural transformations
                  - Equality is pointwise equality.

		- Functor (pre)category
                  - Isomorphisms in functor category are pointwise
                         isomorphisms

                - Isomorphic Functors are equal
                   if target precategory is category
                   [functor_eq_from_functor_iso]

                - Functor precategory is category if
                   target precategory is
                   [is_category_functor_category]

************************************************************)

Require Import Foundations.Generalities.uu0.
Require Import Foundations.hlevel1.hProp.
Require Import Foundations.hlevel2.hSet.

Require Import RezkCompletion.pathnotations.
Import RezkCompletion.pathnotations.PathNotations.

Require Import RezkCompletion.auxiliary_lemmas_HoTT.

Require Import RezkCompletion.precategories.

Local Notation "a --> b" := (precategory_morphisms a b)(at level 50).
Local Notation "f ;; g" := (compose f g)(at level 50).

Ltac pathvia b := (apply (@pathscomp0 _ _ b _ )).

(** * Functors : Morphisms of precategories *)

Definition functor_data (C C' : precategory_ob_mor) := total2 (
    fun F : ob C -> ob C' =>
             forall a b : ob C, a --> b -> F a --> F b).

Definition functor_on_objects {C C' : precategory_ob_mor}
     (F : functor_data C C') :  ob C -> ob C' := pr1 F.
Coercion functor_on_objects : functor_data >-> Funclass.

Definition functor_on_morphisms {C C' : precategory_ob_mor} (F : functor_data C C')
  { a b : ob C} :  a --> b -> F a --> F b := pr2 F a b.

Local Notation "# F" := (functor_on_morphisms F)(at level 3).

Definition is_functor {C C' : precategory_data} (F : functor_data C C') :=
     dirprod (forall a : ob C, #F (identity a) == identity (F a))
             (forall a b c : ob C, forall f : a --> b, forall g : b --> c,
                #F (f ;; g) == #F f ;; #F g).

Lemma isaprop_is_functor (C C' : precategory_data)
       (F : functor_data C C'): isaprop (is_functor F).
Proof.
  apply isofhleveldirprod.
  apply impred; intro a.
  apply (pr2 (_ --> _)).
  repeat (apply impred; intro).
  apply (pr2 (_ --> _)).
Qed.

Definition functor (C C' : precategory) := total2 (
   fun F : functor_data C C' => is_functor F).

Lemma functor_eq (C C' : precategory) (F F': functor C C'):
    pr1 F == pr1 F' -> F == F'.
Proof.
  intro H.
  apply (total2_paths H).
  apply proofirrelevance.
  apply isaprop_is_functor.
Defined.

Definition functor_data_from_functor (C C': precategory)
     (F : functor C C') : functor_data C C' := pr1 F.
Coercion functor_data_from_functor : functor >-> functor_data.

Definition functor_eq_eq_from_functor_ob_eq (C C' : precategory)
   (F G : functor C C') (p q : F == G)
   (H : base_paths _ _ (base_paths _ _  p) ==
         base_paths _ _ (base_paths _ _ q)) :
    p == q.
Proof.
  apply equal_equalities_between_pairs.
  simpl.
  assert (H' : base_paths _ _ p == base_paths _ _ q).
  apply equal_equalities_between_pairs.
  simpl.
  apply (@total2_paths2 _ (fun p : pr1 (pr1 F) == pr1 (pr1 G) =>
          transportf
            (fun x : ob C -> ob C' =>
            (fun x0 : ob C -> ob C' =>
            forall a b : ob C, a --> b -> x0 a --> x0 b) x)
            p (pr2 (pr1 F)) == pr2 (pr1 G)) _
   (fiber_path (base_paths F G p)) _ (fiber_path (base_paths F G q))  H).
   apply uip.
   change (isaset) with (isofhlevel 2).
   apply impred; intro a.
   apply impred; intro b.
   apply impred; intro f.
   apply (pr2 (_ --> _)).
   apply (@total2_paths2 (pr1 F == pr1 G)
    (fun x : pr1 F == pr1 G => transportf _ x (pr2 F) == pr2 G)
          (base_paths F G p) (fiber_path p) (base_paths F G q) (fiber_path q) H').
   apply uip.
   apply isasetaprop.
   apply isaprop_is_functor.
Defined.

Definition functor_id {C C' : precategory}(F : functor C C'):
       forall a : ob C, #F (identity a) == identity (F a) := pr1 (pr2 F).

Definition functor_comp {C C' : precategory}
      (F : functor C C'):
       forall a b c : ob C, forall f : a --> b,
                 forall g : b --> c,
                #F (f ;; g) == #F f ;; #F g := pr2 (pr2 F).

(** ** Functors preserve isomorphisms *)

Lemma is_inverse_functor_image (C C' : precategory) (F : functor C C')
    (a b : C) (f : iso a b):
   is_inverse_in_precat (#F f) (#F (inv_from_iso f)).
Proof.
  simpl; split; simpl.
  rewrite <- functor_comp.
  rewrite iso_inv_after_iso.
  apply functor_id.

  rewrite <- functor_comp.
  rewrite (iso_after_iso_inv _ _ _ f).
  apply functor_id.
Qed.

Lemma functor_on_iso_is_iso (C C' : precategory) (F : functor C C')
    (a b : ob C)(f : iso a b) : is_isomorphism (#F f).
Proof.
  exists (#F (inv_from_iso f)).
  simpl; apply is_inverse_functor_image.
Defined.

Definition functor_on_iso (C C' : precategory) (F : functor C C')
    (a b : ob C)(f : iso a b) : iso (F a) (F b).
Proof.
  exists (#F f).
  apply functor_on_iso_is_iso.
Defined.

Lemma functor_on_iso_inv (C C' : precategory) (F : functor C C')
    (a b : ob C) (f : iso a b) :
   functor_on_iso _ _ F _ _ (iso_inv_from_iso f) ==
       iso_inv_from_iso (functor_on_iso _ _ F _ _ f).
Proof.
  apply eq_iso.
  simpl.
  apply idpath.
Defined.

(** ** Functors preserve inverses *)

Lemma functor_on_inv_from_iso (C C' : precategory) (F : functor C C')
    (a b : ob C)(f : iso a b) :
      #F (inv_from_iso f) == inv_from_iso (functor_on_iso _ _ F _ _ f) .
Proof.
  apply idpath.
Qed.

(** ** Fully faithful functors *)

Definition fully_faithful {C D : precategory} (F : functor C D) :=
  forall a b : ob C,
    isweq (functor_on_morphisms F (a:=a) (b:=b)).

Lemma isaprop_fully_faithful (C D : precategory) (F : functor C D) :
   isaprop (fully_faithful F).
Proof.
  apply impred; intro a.
  apply impred; intro b.
  apply isapropisweq.
Qed.

Definition weq_from_fully_faithful {C D : precategory}{F : functor C D}
      (FF : fully_faithful F) (a b : ob C) :
   weq (a --> b) (F a --> F b).
Proof.
  exists (functor_on_morphisms F (a:=a) (b:=b)).
  exact (FF a b).
Defined.

Definition fully_faithful_inv_hom {C D : precategory}{F : functor C D}
      (FF : fully_faithful F) (a b : ob C) :
      F a --> F b -> a --> b :=
 invweq (weq_from_fully_faithful FF a b).

Local Notation "FF ^-1" := (fully_faithful_inv_hom FF _ _ ) (at level 20).

Lemma fully_faithful_inv_identity (C D : precategory) (F : functor C D)
      (FF : fully_faithful F) (a : ob C) :
         FF^-1 (identity (F a)) == identity _.
Proof.
  apply (equal_transport_along_weq _ _ (weq_from_fully_faithful FF a a)).
  unfold fully_faithful_inv_hom.
  set (HFaa:=homotweqinvweq (weq_from_fully_faithful FF a a)(identity _ )).
  simpl in *.
  rewrite HFaa.
  rewrite functor_id; apply idpath.
Qed.

Lemma fully_faithful_inv_comp (C D : precategory) (F : functor C D)
      (FF : fully_faithful F) (a b c : ob C)
      (f : F a --> F b) (g : F b --> F c) :
        FF^-1 (f ;; g) == FF^-1 f ;; FF^-1 g.
Proof.
  apply (equal_transport_along_weq _ _ (weq_from_fully_faithful FF a c)).
  set (HFFac := homotweqinvweq (weq_from_fully_faithful FF a c)
                 (f ;; g)).
  unfold fully_faithful_inv_hom.
  simpl in *.
  rewrite HFFac; clear HFFac.
  rewrite functor_comp.
  set (HFFab := homotweqinvweq (weq_from_fully_faithful FF a b) f).
  set (HFFbc := homotweqinvweq (weq_from_fully_faithful FF b c) g).
  simpl in *.
  rewrite HFFab; clear HFFab.
  rewrite HFFbc; clear HFFbc.
  apply idpath.
Qed.

(** *** Fully faithful functors reflect isos *)

Lemma inv_of_ff_inv_is_inv (C D : precategory) (F : functor C D)
   (FF : fully_faithful F) (a b : C) (f : iso (F a) (F b)) :
  is_inverse_in_precat ((FF ^-1) f) ((FF ^-1) (inv_from_iso f)).
Proof.
  unfold fully_faithful_inv_hom; simpl.
  split.
  apply (equal_transport_along_weq _ _ (weq_from_fully_faithful FF a a)).
  set (HFFab := homotweqinvweq (weq_from_fully_faithful FF a b)).
  set (HFFba := homotweqinvweq (weq_from_fully_faithful FF b a)).
  simpl in *.
  rewrite functor_comp.
  rewrite HFFab; clear HFFab.
  rewrite HFFba; clear HFFba.
  rewrite functor_id.
  apply iso_inv_after_iso.

  apply (equal_transport_along_weq _ _ (weq_from_fully_faithful FF b b)).
  set (HFFab := homotweqinvweq (weq_from_fully_faithful FF a b)).
  set (HFFba := homotweqinvweq (weq_from_fully_faithful FF b a)).
  simpl in *.
  rewrite functor_comp.
  rewrite HFFab.
  rewrite HFFba.
  rewrite functor_id.
  apply iso_after_iso_inv.
Qed.

Lemma fully_faithful_reflects_iso_proof (C D : precategory)(F : functor C D)
        (FF : fully_faithful F)
    (a b : ob C) (f : iso (F a) (F b)) :
     is_isomorphism (FF^-1 f).
Proof.
  exists (FF^-1 (inv_from_iso f)).
  simpl;
  apply inv_of_ff_inv_is_inv.
Defined.

Definition  iso_from_fully_faithful_reflection {C D : precategory}{F : functor C D}
        (HF : fully_faithful F)
    (a b : ob C) (f : iso (F a) (F b)) :
      iso a b.
Proof.
  exists (fully_faithful_inv_hom HF a b f).
  apply fully_faithful_reflects_iso_proof.
Defined.

Lemma functor_on_iso_iso_from_fully_faithful_reflection (C D : precategory)
      (F : functor C D) (HF : fully_faithful F) (a b : ob C)
   (f : iso (F a) (F b)) :
      functor_on_iso _ _  F a b
        (iso_from_fully_faithful_reflection HF a b f) == f.
Proof.
  apply eq_iso.
  simpl;
  apply (homotweqinvweq (weq_from_fully_faithful HF a b)).
Qed.

(** ** Essentially surjective functors *)

Definition essentially_surjective {C D : precategory} (F : functor C D) :=
  forall b, ishinh (total2 (fun a => iso (F a) b)).

(** ** Faithful functors *)

Definition faithful {C D : precategory} (F : functor C D) :=
  forall a b : ob C, forall f g : a --> b,
       #F f == #F g -> f == g.

Lemma isaprop_faithful (C D : precategory) (F : functor C D) :
   isaprop (faithful F).
Proof.
  repeat (apply impred; intro).
  apply (pr2 (_ --> _)).
Qed.

(** ** Full functors *)

Definition full {C D : precategory} (F : functor C D) :=
   forall a b (g : F a --> F b), ishinh (total2 (fun f : a --> b => #F f == g)).

(** ** Fully faithful is the same as full and faithful *)

Definition full_and_faithful {C D : precategory} (F : functor C D) :=
   dirprod (full F) (faithful F).

Lemma fully_faithful_implies_full_and_faithful (C D : precategory) (F : functor C D) :
   fully_faithful F -> full_and_faithful F.
Proof.
  intro H.
  split; simpl.
  unfold full.
  intros a b f.
  apply hinhpr.
  exists (fully_faithful_inv_hom H _ _ f).
  set (HFFaa := homotweqinvweq (weq_from_fully_faithful H a b)).
  simpl in HFFaa.
  apply HFFaa.

  unfold faithful.
  intros a b f g Heq.
  apply (equal_transport_along_weq _ _ (weq_from_fully_faithful H a b)).
  simpl. assumption.
Qed.

Lemma full_and_faithful_implies_fully_faithful (C D : precategory) (F : functor C D) :
   full_and_faithful F -> fully_faithful F.
Proof.
  intros [Hfull Hfaith].
  intros a b g.
  unfold full in Hfull.
  set (Hfull_f :=  Hfull a b g).
  assert (H : isaprop (iscontr (hfiber #F g))).
     apply isapropiscontr.
  apply (Hfull_f (hProppair (iscontr (hfiber #F g)) H)).
  simpl. intro X. exists X.
  unfold hfiber.
  intro t.
  unfold faithful in Hfaith.
  assert (HX : pr1 t == pr1 X).
  apply Hfaith.
  rewrite (pr2 t).
  set (H':= pr2 X).
  simpl in H'.
  rewrite H'. apply idpath.
  simpl in *.
  apply (total2_paths HX).
  apply proofirrelevance.
  apply (pr2 (F a --> F b)).
Qed.

Lemma isaprop_full_and_faithful (C D : precategory) (F : functor C D) :
   isaprop (full_and_faithful F).
Proof.
  apply isofhleveldirprod.
  apply impred; intro.
  apply impred; intro.
  apply impred; intro.
  simpl. repeat (apply impred; intro).
  apply isapropishinh.
  apply isaprop_faithful.
Qed.

Definition weq_fully_faithful_full_and_faithful (C D : precategory) (F : functor C D) :
   weq (fully_faithful F) (full_and_faithful F) :=
  weqimplimpl (fully_faithful_implies_full_and_faithful _ _ F)
              (full_and_faithful_implies_fully_faithful _ _ F)
              (isaprop_fully_faithful _ _ F)
              (isaprop_full_and_faithful _ _ F).

(** ** Image on objects of a functor  *)
(** is used later to define the full image subcategory of a category [D]
       defined by a functor [F : C -> D] *)

Definition is_in_img_functor {C D : precategory} (F : functor C D)
      (d : ob D) :=
  ishinh (
  total2 (fun c : ob C => iso (F c) d)).

Definition sub_img_functor {C D : precategory}(F : functor C D) :
    hsubtypes (ob D) :=
       fun d : ob D => is_in_img_functor F d.

(** ** Composition of Functors, Identity Functors *)

(** *** Composition *)
Lemma functor_composite_ob_mor {C C' C'' : precategory}
       (F : functor C C') (F' : functor C' C'') :
 is_functor
  (tpair (fun F : ob C -> ob C'' =>
             forall a b : ob C, a --> b -> F a --> F b)
    (fun a => F' (F a))
               (fun (a b : ob C) f => #F' (#F f))).
Proof.
  split; simpl.
  intro a.
  repeat rewrite functor_id.
  apply idpath.

  intros.
  repeat rewrite functor_comp.
  apply idpath.
Qed.

Definition functor_composite (C C' C'' : precategory)
       (F : functor C C') (F' : functor C' C'') :
  functor C C'' := tpair _ _ (functor_composite_ob_mor F F').

(** *** Identity functor *)

Lemma functor_identity_ob_mor (C : precategory) :
 is_functor
  (tpair (fun F : ob C -> ob C =>
             forall a b : ob C, a --> b -> F a --> F b)
    (fun a => a)
               (fun (a b : ob C) f => f)).
Proof.
  split; simpl.
  intros; apply idpath.
  intros; apply idpath.
Qed.

Definition functor_identity (C : precategory) :
     functor C  C.
Proof.
  exists (tpair (fun F : ob C -> ob C =>
             forall a b : ob C, a --> b -> F a --> F b)
    (fun a => a)
               (fun (a b : ob C) f => f)).
  apply  (functor_identity_ob_mor C).
Defined.

(** * Natural transformations *)

(** ** Definition of natural transformations *)

Definition is_nat_trans {C C' : precategory_data}
  (F F' : functor_data C C')
  (t : forall x : ob C, F x -->  F' x) :=
  forall (x x' : ob C)(f : x --> x'),
    #F f ;; t x' == t x ;; #F' f.

Lemma isaprop_is_nat_trans (C C' : precategory_data)
  (F F' : functor_data C C') (t : forall x : ob C, F x -->  F' x):
  isaprop (is_nat_trans F F' t).
Proof.
  repeat (apply impred; intro).
  apply (pr2 (_ --> _)).
Qed.

Definition nat_trans {C C' : precategory_data}
  (F F' : functor_data C C') := total2 (
   fun t : forall x : ob C, F x -->  F' x => is_nat_trans F F' t).

Lemma isaset_nat_trans {C C' : precategory_data}
  (F F' : functor_data C C') : isaset (nat_trans F F').
Proof.
  change isaset with (isofhlevel 2).
  apply isofhleveltotal2.
  apply impred.
  intro t. apply (pr2 (_ --> _)).
  intro x.
  apply isasetaprop.
  apply isaprop_is_nat_trans.
Qed.

Definition nat_trans_data {C C' : precategory_data}
 {F F' : functor_data C C'}(a : nat_trans F F') :
   forall x : ob C, F x --> F' x := pr1 a.
Coercion nat_trans_data : nat_trans >-> Funclass.

Definition nat_trans_ax {C C' : precategory_data}
  {F F' : functor_data C C'} (a : nat_trans F F') :
  forall (x x' : ob C)(f : x --> x'),
    #F f ;; a x' == a x ;; #F' f := pr2 a.

(** Equality between two natural transformations *)

Lemma nat_trans_eq {C C' : precategory_data}
  (F F' : functor_data C C')(a a' : nat_trans F F'):
  (forall x, a x == a' x) -> a == a'.
Proof.
  intro H.
  assert (H' : pr1 a == pr1 a').
  apply funextsec.
  assumption.
  apply (total2_paths H').
  apply proofirrelevance.
  apply isaprop_is_nat_trans.
Qed.

Definition nat_trans_eq_pointwise (C C' : precategory_data)
   (F F' : functor_data C C') (a a' : nat_trans F F'):
      a == a' -> forall x, a x == a' x.
Proof.
  intro h.
  apply toforallpaths.
  apply maponpaths.
  assumption.
Qed.

(** ** Functor category [[C, D]] *)

Definition functor_precategory_ob_mor (C C' : precategory):
  precategory_ob_mor := precategory_ob_mor_pair
   (functor C C') (fun F F' : functor C C' =>
                              hSetpair (nat_trans F F')
                                       (isaset_nat_trans F F')).

(** *** Identity natural transformation *)

Lemma is_nat_trans_id {C C' : precategory}
  (F : functor_data C C') : is_nat_trans F F
     (fun c : ob C => identity (F c)).
Proof.
  intros ? ? ? .
  rewrite id_left.
  rewrite id_right.
  apply idpath.
Qed.

Definition nat_trans_id {C C' : precategory}
  (F : functor_data C C') : nat_trans F F :=
    tpair _ _ (is_nat_trans_id F).

(** *** Composition of natural transformations *)

Lemma is_nat_trans_comp {C C' : precategory}
  {F G H : functor_data C C'}
  (a : nat_trans F G)
  (b : nat_trans G H): is_nat_trans F H
     (fun x : ob C => a x ;; b x).
Proof.
  intros ? ? ? .
  rewrite assoc.
  rewrite nat_trans_ax.
  rewrite <- assoc.
  rewrite nat_trans_ax.
  apply assoc.
Qed.

Definition nat_trans_comp {C C' : precategory}
  (F G H: functor_data C C')
  (a : nat_trans F G)
  (b : nat_trans G H): nat_trans F H :=
    tpair _ _ (is_nat_trans_comp a b).

(** *** The data of the functor precategory *)

Definition functor_precategory_data (C C' : precategory): precategory_data.
Proof.
  apply ( precategory_data_pair
        (functor_precategory_ob_mor C C')).
  intro a. simpl.
  apply (nat_trans_id (pr1 a)).
  intros a b c f g.
  apply (nat_trans_comp _ _ _ f g).
Defined.

(** *** Above data forms a precategory *)

Lemma is_precategory_functor_precategory_data (C C' : precategory) :
   is_precategory (functor_precategory_data C C').
Proof.
  repeat split; simpl; intros.
  unfold identity.
  simpl.
  apply nat_trans_eq.
  intro x; simpl.
  apply id_left.

  apply nat_trans_eq.
  intro x; simpl.
  apply id_right.

  apply nat_trans_eq.
  intro x; simpl.
  apply assoc.
Qed.

Definition functor_precategory (C C' : precategory): precategory :=
  tpair _ _ (is_precategory_functor_precategory_data C C').

Notation "[ C , D ]" := (functor_precategory C D).

Lemma nat_trans_comp_pointwise (C C' : precategory)
  (F G H : ob [C, C']) (A : F --> G) (A' : G --> H)
   (B : F --> H) : A ;; A' == B ->
        forall a, pr1 A a ;; pr1 A' a == pr1 B a.
Proof.
  intros H' a.
  pathvia (pr1 (A ;; A') a).
  apply idpath.
  destruct H'.
  apply idpath.
Defined.

(** Characterizing isomorphisms in the functor category *)

Lemma is_nat_trans_inv_from_pointwise_inv (C D : precategory)
  (F G : ob [C,D]) (A : F --> G)
  (H : forall a : ob C, is_isomorphism (pr1 A a)) :
  is_nat_trans _ _
     (fun a : ob C => inv_from_iso (tpair _ _ (H a))).
Proof.
  unfold is_nat_trans.
  intros x x' f.
  apply pathsinv0.
  apply iso_inv_on_right.
  rewrite assoc.
  apply iso_inv_on_left.
  set (HA:= pr2 A).
  simpl in *.
  unfold is_nat_trans in HA.
  rewrite HA.
  apply idpath.
Qed.

Definition nat_trans_inv_from_pointwise_inv (C D : precategory)
  (F G : ob [C,D]) (A : F --> G)
  (H : forall a : ob C, is_isomorphism (pr1 A a)) :
    G --> F := tpair _ _ (is_nat_trans_inv_from_pointwise_inv _ _ _ _ _ H).

Lemma is_inverse_nat_trans_inv_from_pointwise_inv (C C' : precategory)
    (F G : [C, C']) (A : F --> G)
   (H : forall a : C, is_isomorphism (pr1 A a)) :
  is_inverse_in_precat A (nat_trans_inv_from_pointwise_inv C C' F G A H).
Proof.
  simpl; split; simpl.
  apply nat_trans_eq.
  intro x; simpl.
  apply (pr2 (H _)).
  apply nat_trans_eq.
  intro x; simpl.
  apply (pr2 (pr2 (H _))).
Qed.

Lemma functor_iso_if_pointwise_iso (C C' : precategory)
 (F G : ob [C, C']) (A : F --> G) :
   (forall a : ob C, is_isomorphism (pr1 A a)) ->
           is_isomorphism A .
Proof.
  intro H.
  exists (nat_trans_inv_from_pointwise_inv _ _ _ _ _ H).
  simpl; apply is_inverse_nat_trans_inv_from_pointwise_inv.
Defined.

Definition functor_iso_from_pointwise_iso (C C' : precategory)
 (F G : ob [C, C']) (A : F --> G)
   (H : forall a : ob C, is_isomorphism (pr1 A a)) :
     iso F G :=
 tpair _ _ (functor_iso_if_pointwise_iso _ _ _ _ _  H).

Lemma is_functor_iso_pointwise_if_iso (C C' : precategory)
 (F G : ob [C, C']) (A : F --> G) :
  is_isomorphism A ->
       forall a : ob C, is_isomorphism (pr1 A a).
Proof.
  intros H a.
  simpl in *.
  set (R := pr1 H).
  simpl in *.
  exists (R a).
  unfold is_inverse_in_precat in *; simpl; split.
  set (H1' := nat_trans_eq_pointwise _ _ _ _ _ _ (pr1 (pr2 H))).
  simpl in H1'.
  apply H1'.
  apply (nat_trans_eq_pointwise _ _ _ _ _ _ (pr2 (pr2 H))).
Defined.

Definition functor_iso_pointwise_if_iso (C C' : precategory)
 (F G : ob [C, C']) (A : F --> G)
  (H : is_isomorphism A) :
     forall a : ob C,
       iso (pr1 F a) (pr1 G a) :=
  fun a => tpair _ _ (is_functor_iso_pointwise_if_iso C C' F G A H a).

Definition pr1_pr1_functor_eq_from_functor_iso (C D : precategory)
    (H : is_category D) (F G : ob [C , D]) :
   iso F G -> pr1 (pr1 F) == pr1 (pr1 G).
Proof.
  intro A.
  apply funextsec.
  intro t.
  apply isotoid.
  assumption.
  apply (functor_iso_pointwise_if_iso _ _ _ _ A).
  apply (pr2 A).
Defined.

Lemma transport_of_functor_map_is_pointwise (C D : precategory)
      (F0 G0 : ob C -> ob D)
    (F1 : forall a b : ob C, a --> b -> F0 a --> F0 b)
   (gamma : F0  == G0 )
    (a b : ob C) (f : a --> b) :
transportf (fun x : ob C -> ob D =>
            forall a0 b0 : ob  C, a0 --> b0 -> x a0 --> x b0)
           gamma  F1 a b f ==
transportf (fun TT : ob D => G0 a --> TT)
  (toforallpaths (fun _ : ob C => D) F0 G0 gamma b)
  (transportf (fun SS : ob D => SS --> F0 b)
     (toforallpaths (fun _ : ob C => D) F0 G0 gamma a) (F1 a b f)).
Proof.
  induction gamma.
  apply idpath.
Defined.

Lemma toforallpaths_funextsec : forall (T : UU) (P : T -> UU) (f g : forall t : T, P t)
          (h : forall t : T, f t == g t),
            toforallpaths _  _ _ (funextsec _ _ _ h) == h.
Proof.
  intros T P f g h.
  Opaque weqtoforallpaths.
  exact ((homotweqinvweq (weqtoforallpaths _ f g)) h : (pr1weq _ _ (tpair _ _ _) _) == _).
Qed.

Transparent weqtoforallpaths.

Definition pr1_functor_eq_from_functor_iso (C D : precategory)
    (H : is_category D) (F G : ob [C , D]) :
   iso F G -> pr1 F == pr1 G.
Proof.
  intro A.
  apply (total2_paths (pr1_pr1_functor_eq_from_functor_iso C D H F G A)).
  unfold pr1_pr1_functor_eq_from_functor_iso.
  apply funextsec; intro a.
  apply funextsec; intro b.
  apply funextsec; intro f.
  rewrite transport_of_functor_map_is_pointwise.
  rewrite toforallpaths_funextsec.
  pathvia ((inv_from_iso
        (idtoiso
           (isotoid D H
              (functor_iso_pointwise_if_iso C D F G A (pr2 A) a)));;
      pr2 (pr1 F) a b f);;
     idtoiso
       (isotoid D H
          (functor_iso_pointwise_if_iso C D F G A (pr2 A) b))).
    set (H':= double_transport_idtoiso D _ _ _ _
         (isotoid D H (functor_iso_pointwise_if_iso C D F G A (pr2 A) a))
         (isotoid D H (functor_iso_pointwise_if_iso C D F G A (pr2 A) b))
          (pr2 (pr1 F) a b f)).
      unfold double_transport in H'.
      apply H'; clear H'.
  rewrite idtoiso_isotoid.
  rewrite idtoiso_isotoid.
  destruct A as [A Aiso].
  simpl in *.
  pathvia
    (inv_from_iso (functor_iso_pointwise_if_iso C D F G A Aiso a) ;;
       (A a ;; #G f)).
  rewrite <- assoc.
  apply maponpaths.
  apply (nat_trans_ax A).
  rewrite assoc.

  unfold functor_iso_pointwise_if_iso.
  unfold inv_from_iso.
  simpl in *.

  destruct Aiso as [A' AH].
  simpl in *.
  destruct AH as [A1 A2].
  rewrite (nat_trans_comp_pointwise _ _ _ _ _ _ _ _ A2).
  simpl.
  rewrite id_left.
  apply idpath.
Defined.

Definition functor_eq_from_functor_iso {C D : precategory}
    (H : is_category D) (F G : ob [C , D])
    (H' : iso F G) : F == G.
Proof.
  apply (functor_eq _ _ F G).
  apply pr1_functor_eq_from_functor_iso;
  assumption.
Defined.

Lemma idtoiso_compute_pointwise (C D : precategory) (F G : ob [C, D])
     (p : F == G) (a : ob C) :
  functor_iso_pointwise_if_iso C D F G (idtoiso p) (pr2 (idtoiso p)) a ==
idtoiso
  (toforallpaths (fun _ : ob C => D) (pr1 (pr1 F)) (pr1 (pr1 G))
     (base_paths (pr1 F) (pr1 G) (base_paths F G p)) a).
Proof.
  induction p.
  apply eq_iso. apply idpath.
Qed.

Lemma functor_eq_from_functor_iso_idtoiso (C D : precategory)
    (H : is_category D)
    (F G : ob [C, D]) (p : F == G) :
  functor_eq_from_functor_iso H F G (idtoiso p) == p.
Proof.
  simpl; apply functor_eq_eq_from_functor_ob_eq.
  unfold functor_eq_from_functor_iso.
  unfold functor_eq.
  rewrite base_total_path.
  unfold pr1_functor_eq_from_functor_iso.
  rewrite base_total_path.
  unfold pr1_pr1_functor_eq_from_functor_iso.
  apply (equal_transport_along_weq _ _   (weqtoforallpaths _ _ _ )).
  simpl.
  rewrite toforallpaths_funextsec.
  apply funextsec; intro a.
  rewrite idtoiso_compute_pointwise.
  apply isotoid_idtoiso.
Qed.

Lemma idtoiso_functor_eq_from_functor_iso (C D : precategory)
    (H : is_category D)
    (F G : ob [C, D]) (gamma : iso F G) :
        idtoiso (functor_eq_from_functor_iso H F G gamma) == gamma.
Proof.
  apply eq_iso.
  simpl; apply nat_trans_eq; intro a.
  assert (H':= idtoiso_compute_pointwise C D F G (functor_eq_from_functor_iso H F G gamma) a).
  simpl in *.
  pathvia (pr1
       (idtoiso
          (toforallpaths (fun _ : ob C => D) (pr1 (pr1 F)) (pr1 (pr1 G))
             (base_paths (pr1 F) (pr1 G)
                (base_paths F G (functor_eq_from_functor_iso H F G gamma))) a))).
      assert (H2 := maponpaths (@pr1 _ _ ) H').
      simpl in H2. apply H2.
  unfold functor_eq_from_functor_iso.
  unfold functor_eq.
  rewrite base_total_path.
  unfold pr1_functor_eq_from_functor_iso.
  rewrite base_total_path.
  pathvia (pr1 (idtoiso
     (isotoid D H (functor_iso_pointwise_if_iso C D F G gamma (pr2 gamma) a)))).
  apply maponpaths.
  apply maponpaths.
  unfold pr1_pr1_functor_eq_from_functor_iso.
  rewrite toforallpaths_funextsec.
  apply idpath.
  rewrite idtoiso_isotoid.
  apply idpath.
Qed.

Lemma isweq_idtoiso_functorcat (C D : precategory) (H : is_category D)
    (F G : ob [C, D]) :
   isweq (@idtoiso _ F G).
Proof.
  apply (gradth _ (functor_eq_from_functor_iso H F G)).
  apply functor_eq_from_functor_iso_idtoiso.
  apply idtoiso_functor_eq_from_functor_iso.
Defined.

Lemma is_category_functor_category (C D : precategory) (H : is_category D) :
   is_category [C, D].
Proof.
  intros F G.
  apply isweq_idtoiso_functorcat.
  apply H.
Qed.


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

Require Import List Arith Lia Max.

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

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

From Undecidability.TRAKHTENBROT
  Require Import notations utils decidable
                 fol_ops fo_sig fo_terms fo_logic fo_sat.

Import fol_notations.

Set Implicit Arguments.

(* * Removal of function symbols from propositional signatures *)

Section Σ_Σ0.

  Variable (Σ  : fo_signature)
           (HΣ : forall r, ar_rels Σ r = 0).

  Definition Σ0 : fo_signature.
  Proof.
    exists Empty_set (rels Σ); exact (fun _ => 0).
  Defined.

  Fixpoint Σ_Σ0 (A : fol_form Σ) :=
    match A with
      |  ⊥            => ⊥
      | fol_atom r _  => @fol_atom Σ0 r vec_nil
      | fol_bin b A B => fol_bin b (Σ_Σ0 A) (Σ_Σ0 B)
      | fol_quant q A => fol_quant q (Σ_Σ0 A)
     end.

  Section soundness.

    Variable (X : Type) (M : fo_model Σ X).

    Let M' : fo_model Σ0 unit.
    Proof.
      split.
      + intros [].
      + intros r _; apply (fom_rels M r).
        rewrite HΣ; exact vec_nil.
    Defined.

    Local Fact Σ_Σ0_sound A φ ψ : fol_sem M φ A <-> fol_sem M' ψ (Σ_Σ0 A).
    Proof.
      revert φ ψ; induction A as [ | r v | b A HA B HB | [] A HA ]; intros φ ψ.
      + simpl; tauto.
      + simpl; fol equiv.
        revert v; rewrite (HΣ r); unfold eq_rect_r; simpl.
        intros v; vec nil v; auto.
      + apply fol_bin_sem_ext; auto.
      + simpl; split.
        * intros (? & H); exists tt; revert H; apply HA.
        * intros (? & H); exists (φ 0); revert H; apply HA.
      + simpl; split.
        * intros H x; generalize (H (φ 0)); apply HA.
        * intros H x; generalize (H tt); apply HA.
    Qed.

    Hypothesis (Mdec : fo_model_dec M)
               (phi : nat -> X)
               (A : fol_form Σ)
               (HA : fol_sem M phi A).

    Local Lemma Σ_Σ0_soundness : fo_form_fin_dec_SAT (Σ_Σ0 A).
    Proof.
      exists unit, M', finite_t_unit.
      exists. { intros r v; simpl; apply Mdec. }
      exists (fun _ => tt).
      revert HA; apply Σ_Σ0_sound.
    Qed.

  End soundness.

  Section completeness.

    Variable (X : Type) (M' : fo_model Σ0 X).

    Let M : fo_model Σ unit.
    Proof.
      split.
      + intros; exact tt.
      + intros r _; apply (fom_rels M' r vec_nil).
    Defined.

    Local Fact Σ_Σ0_complete A φ ψ : fol_sem M φ A <-> fol_sem M' ψ (Σ_Σ0 A).
    Proof.
      revert φ ψ; induction A as [ | r v | b A HA B HB | [] A HA ]; intros φ ψ.
      + simpl; tauto.
      + simpl; tauto.
      + apply fol_bin_sem_ext; auto.
      + simpl; split.
        * intros (? & H); exists (ψ 0); revert H; apply HA.
        * intros (? & H); exists (φ 0); revert H; apply HA.
      + simpl; split.
        * intros H x; generalize (H (φ 0)); apply HA.
        * intros H x; generalize (H (ψ 0)); apply HA.
    Qed.

    Hypothesis (M'dec : fo_model_dec M')
               (psi : nat -> X)
               (A : fol_form Σ)
               (HA : fol_sem M' psi (Σ_Σ0 A)).

    Local Lemma Σ_Σ0_completeness : fo_form_fin_dec_SAT A.
    Proof.
      exists unit, M, finite_t_unit.
      exists. { intros r v; simpl; apply M'dec. }
      exists (fun _ => tt).
      revert HA; apply Σ_Σ0_complete.
    Qed.

  End completeness.

  Theorem Σ_Σ0_correct A : fo_form_fin_dec_SAT A <-> fo_form_fin_dec_SAT (Σ_Σ0 A).
  Proof.
    split.
    + intros (X & M & _ & G2 & phi & G3).
      apply Σ_Σ0_soundness with X M phi; auto.
    + intros (X & M & _ & G2 & phi & G3).
      apply Σ_Σ0_completeness with X M phi; auto.
  Qed.

End Σ_Σ0.

Section Σ0_Σ.

  Variable (Σ  : fo_signature)
           (HΣ : forall r, ar_rels Σ r = 0).

  Fixpoint Σ0_Σ (A : fol_form (Σ0 Σ)) :=
    match A with
      |  ⊥            => ⊥
      | fol_atom r _  => @fol_atom Σ r (cast vec_nil (eq_sym (HΣ r)))
      | fol_bin b A B => fol_bin b (Σ0_Σ A) (Σ0_Σ B)
      | fol_quant q A => fol_quant q (Σ0_Σ A)
     end.

  Section soundness.

    Variable (X : Type) (M : fo_model (Σ0 Σ) X).

    Let M' : fo_model Σ unit.
    Proof.
      split.
      + intros; exact tt.
      + intros r _; apply (fom_rels M r vec_nil).
    Defined.

    Local Fact Σ0_Σ_sound A φ ψ : fol_sem M' ψ (Σ0_Σ A) <-> fol_sem M φ A.
    Proof.
      revert φ ψ; induction A as [ | r v | b A HA B HB | [] A HA ]; intros φ ψ.
      + simpl; tauto.
      + simpl in *; vec nil v; simpl; tauto.
      + apply fol_bin_sem_ext; auto.
      + simpl; split.
        * intros (? & H); exists (φ 0); revert H; apply HA.
        * intros (? & H); exists (ψ 0); revert H; apply HA.
      + simpl; split.
        * intros H x; generalize (H (ψ 0)); apply HA.
        * intros H x; generalize (H (φ 0)); apply HA.
    Qed.

    Hypothesis (Mdec : fo_model_dec M)
               (φ : nat -> X)
               (A : fol_form (Σ0 Σ))
               (HA : fol_sem M φ A).

    Local Lemma Σ0_Σ_soundness : fo_form_fin_dec_SAT (Σ0_Σ A).
    Proof.
      exists unit, M', finite_t_unit.
      exists. { intros r v; simpl; apply Mdec. }
      exists (fun _ => tt).
      revert HA; apply Σ0_Σ_sound.
    Qed.

  End soundness.

  Section completeness.

    Variable (X : Type) (M : fo_model Σ X).

    Let M' : fo_model (Σ0 Σ) unit.
    Proof.
      split.
      + intros [].
      + intros r _; apply (fom_rels M r).
        rewrite HΣ; exact vec_nil.
    Defined.

    Local Fact Σ0_Σ_complete A φ ψ : fol_sem M ψ (Σ0_Σ A) <-> fol_sem M' φ A.
    Proof.
      revert φ ψ; induction A as [ | r v | b A HA B HB | [] A HA ]; intros φ ψ.
      + simpl; tauto.
      + simpl; fol equiv.
        revert v; rewrite (HΣ r); unfold eq_rect_r; simpl; auto.
      + apply fol_bin_sem_ext; auto.
      + simpl; split.
        * intros (? & H); exists tt; revert H; apply HA.
        * intros (? & H); exists (ψ 0); revert H; apply HA.
      + simpl; split.
        * intros H x; generalize (H (ψ 0)); apply HA.
        * intros H x; generalize (H tt); apply HA.
    Qed.

    Hypothesis (Mdec : fo_model_dec M)
               (phi : nat -> X)
               (A : fol_form (Σ0 Σ))
               (HA : fol_sem M phi (Σ0_Σ A)).

    Local Lemma Σ0_Σ_completeness : fo_form_fin_dec_SAT A.
    Proof.
      exists unit, M', finite_t_unit.
      exists. { intros r v; simpl; apply Mdec. }
      exists (fun _ => tt).
      revert HA; apply Σ0_Σ_complete.
    Qed.

  End completeness.

  Theorem Σ0_Σ_correct A : fo_form_fin_dec_SAT A <-> fo_form_fin_dec_SAT (Σ0_Σ A).
  Proof.
    split.
    + intros (X & M & _ & G2 & phi & G3).
      apply Σ0_Σ_soundness with X M phi; auto.
    + intros (X & M & _ & G2 & phi & G3).
      apply Σ0_Σ_completeness with X M phi; auto.
  Qed.

End Σ0_Σ.


Module A.
Set Printing All.
Set Printing Universes.

Module M.
Section foo.
Universe i.
End foo.
End M.

Check Type@{M.i}.
(* Succeeds *)

Fail Check Type@{j}.
(* Error: Undeclared universe: j *)

Definition foo@{j} : Type@{M.i} := Type@{j}.
(* ok *)
End A.
Import A. Import M.
Set Universe Polymorphism.
Fail Universes j.
Monomorphic Universe j.
Section foo.
  Universes i.
  Constraint i < j.
  Definition foo : Type@{j} := Type@{i}.
  Definition foo' : Type@{j} := Type@{i}.
End foo.

Check eq_refl : foo@{i} = foo'@{i}.

Definition bar := foo.
Monomorphic Definition bar'@{k} := foo@{k}.

Fail Constraint j = j.
Monomorphic Constraint i = i.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Reflection.Z.Syntax.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.Relations.
Require Import Crypto.Util.Notations.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.Tactics.DestructHead.
Export Reflection.Syntax.Notations.

Local Notation eta x := (fst x, snd x).
Local Notation eta3 x := (eta (fst x), snd x).
Local Notation eta4 x := (eta3 (fst x), snd x).

Notation bounds := zrange.
Delimit Scope bounds_scope with bounds.
Local Open Scope Z_scope.

Module Import Bounds.
  Definition t := bounds.
  Bind Scope bounds_scope with t.
  Local Coercion Z.of_nat : nat >-> Z.
  Section with_bitwidth.
    Context (bit_width : option Z).
    Definition four_corners (f : Z -> Z -> Z) : t -> t -> t
      := fun x y
         => let (lx, ux) := x in
            let (ly, uy) := y in
            {| lower := Z.min (f lx ly) (Z.min (f lx uy) (Z.min (f ux ly) (f ux uy)));
               upper := Z.max (f lx ly) (Z.max (f lx uy) (Z.max (f ux ly) (f ux uy))) |}.
    Definition truncation_bounds (b : t)
      := match bit_width with
         | Some bit_width => if ((0 <=? lower b) && (upper b <? 2^bit_width))%bool
                             then b
                             else {| lower := 0 ; upper := 2^bit_width - 1 |}
         | None => b
         end.
    Definition BuildTruncated_bounds (l u : Z) : t
      := truncation_bounds {| lower := l ; upper := u |}.
    Definition t_map1 (f : bounds -> bounds) (x : t)
      := truncation_bounds (f x).
    Definition t_map2 (f : Z -> Z -> Z) : t -> t -> t
      := fun x y => truncation_bounds (four_corners f x y).
    Definition t_map4 (f : bounds -> bounds -> bounds -> bounds -> bounds) (x y z w : t)
      := truncation_bounds (f x y z w).
    Definition add : t -> t -> t := t_map2 Z.add.
    Definition sub : t -> t -> t := t_map2 Z.sub.
    Definition mul : t -> t -> t := t_map2 Z.mul.
    Definition shl : t -> t -> t := t_map2 Z.shiftl.
    Definition shr : t -> t -> t := t_map2 Z.shiftr.
    Definition extreme_lor_land_bounds (x y : t) : t
      := let (lx, ux) := x in
         let (ly, uy) := y in
         let lx := Z.abs lx in
         let ly := Z.abs ly in
         let ux := Z.abs ux in
         let uy := Z.abs uy in
         let max := Z.max (Z.max lx ly) (Z.max ux uy) in
         {| lower := -2^(1 + Z.log2_up max) ; upper := 2^(1 + Z.log2_up max) |}.
    Definition extermization_bounds (f : t -> t -> t) (x y : t) : t
      := truncation_bounds
           (let (lx, ux) := x in
            let (ly, uy) := y in
            if ((lx <? 0) || (ly <? 0))%Z%bool
            then extreme_lor_land_bounds x y
            else f x y).
    Definition land : t -> t -> t
      := extermization_bounds
           (fun x y
            => let (lx, ux) := x in
               let (ly, uy) := y in
               {| lower := Z.min 0 (Z.min lx ly) ; upper := Z.max 0 (Z.min ux uy) |}).
    Definition lor : t -> t -> t
      := extermization_bounds
           (fun x y
            => let (lx, ux) := x in
               let (ly, uy) := y in
               {| lower := Z.max lx ly;
                  upper := 2^(Z.max (Z.log2_up (ux+1)) (Z.log2_up (uy+1))) - 1 |}).
    Definition neg' (int_width : Z) : t -> t
      := fun v
         => let (lb, ub) := v in
            let might_be_one := ((lb <=? 1) && (1 <=? ub))%Z%bool in
            let must_be_one := ((lb =? 1) && (ub =? 1))%Z%bool in
            if must_be_one
            then {| lower := Z.ones int_width ; upper := Z.ones int_width |}
            else if might_be_one
                 then {| lower := Z.min 0 (Z.ones int_width) ; upper := Z.max 0 (Z.ones int_width) |}
                 else {| lower := 0 ; upper := 0 |}.
    Definition neg (int_width : Z) : t -> t
      := fun v
         => truncation_bounds (neg' int_width v).
    Definition cmovne' (r1 r2 : t) : t
      := let (lr1, ur1) := r1 in
         let (lr2, ur2) := r2 in
         {| lower := Z.min lr1 lr2 ; upper := Z.max ur1 ur2 |}.
    Definition cmovne (x y r1 r2 : t) : t
      := truncation_bounds (cmovne' r1 r2).
    Definition cmovle' (r1 r2 : t) : t
      := let (lr1, ur1) := r1 in
         let (lr2, ur2) := r2 in
         {| lower := Z.min lr1 lr2 ; upper := Z.max ur1 ur2 |}.
    Definition cmovle (x y r1 r2 : t) : t
      := truncation_bounds (cmovle' r1 r2).
  End with_bitwidth.

  Module Export Notations.
    Export Util.ZRange.Notations.
    Infix "+" := (add _) : bounds_scope.
    Infix "-" := (sub _) : bounds_scope.
    Infix "*" := (mul _) : bounds_scope.
    Infix "<<" := (shl _) : bounds_scope.
    Infix ">>" := (shr _) : bounds_scope.
    Infix "&'" := (land _) : bounds_scope.
  End Notations.

  Definition interp_base_type (ty : base_type) : Set := t.

  Definition bit_width_of_base_type ty : option Z
    := match ty with
       | TZ => None
       | TWord logsz => Some (2^Z.of_nat logsz)%Z
       end.

  Definition interp_op {src dst} (f : op src dst) : interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst
    := match f in op src dst return interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst with
       | OpConst T v => fun _ => BuildTruncated_bounds (bit_width_of_base_type T) v v
       | Add _ _ T => fun xy => add (bit_width_of_base_type T) (fst xy) (snd xy)
       | Sub _ _ T => fun xy => sub (bit_width_of_base_type T) (fst xy) (snd xy)
       | Mul _ _ T => fun xy => mul (bit_width_of_base_type T) (fst xy) (snd xy)
       | Shl _ _ T => fun xy => shl (bit_width_of_base_type T) (fst xy) (snd xy)
       | Shr _ _ T => fun xy => shr (bit_width_of_base_type T) (fst xy) (snd xy)
       | Land _ _ T => fun xy => land (bit_width_of_base_type T) (fst xy) (snd xy)
       | Lor _ _ T => fun xy => lor (bit_width_of_base_type T) (fst xy) (snd xy)
       | Neg _ T int_width => fun x => neg (bit_width_of_base_type T) int_width x
       | Cmovne _ _ _ _ T => fun xyzw => let '(x, y, z, w) := eta4 xyzw in cmovne (bit_width_of_base_type T) x y z w
       | Cmovle _ _ _ _ T => fun xyzw => let '(x, y, z, w) := eta4 xyzw in cmovle (bit_width_of_base_type T) x y z w
       end%bounds.

  Definition of_Z (z : Z) : t := ZToZRange z.

  Definition of_interp t (z : Syntax.interp_base_type t) : interp_base_type t
    := ZToZRange (interpToZ z).

  Definition bounds_to_base_type (b : t) : base_type
    := if (0 <=? lower b)%Z
       then TWord (Z.to_nat (Z.log2_up (Z.log2_up (1 + upper b))))
       else TZ.

  Definition ComputeBounds {t} (e : Expr base_type op t)
             (input_bounds : interp_flat_type interp_base_type (domain t))
    : interp_flat_type interp_base_type (codomain t)
    := Interp (@interp_op) e input_bounds.

  Definition is_tighter_thanb' {T} : interp_base_type T -> interp_base_type T -> bool
    := is_tighter_than_bool.

  Definition is_bounded_by' {T} : interp_base_type T -> Syntax.interp_base_type T -> Prop
    := fun bounds val => is_bounded_by' (bit_width_of_base_type T) bounds (interpToZ val).

  Definition is_tighter_thanb {T} : interp_flat_type interp_base_type T -> interp_flat_type interp_base_type T -> bool
    := interp_flat_type_relb_pointwise (@is_tighter_thanb').

  Definition is_bounded_by {T} : interp_flat_type interp_base_type T -> interp_flat_type Syntax.interp_base_type T -> Prop
    := interp_flat_type_rel_pointwise (@is_bounded_by').

  Local Arguments interp_base_type !_ / .
  Global Instance dec_eq_interp_flat_type {T} : DecidableRel (@eq (interp_flat_type interp_base_type T)) | 10.
  Proof.
    induction T; destruct_head base_type; simpl; exact _.
  Defined.
End Bounds.


Require Import ELRefine.Refinement.

(** Example of dependent refinement **)
Definition denote (b : bool) : Type :=
  match b with
    | true => nat
    | false => bool
  end.

Definition denote' (b : bool) : Type :=
  match b with
    | true => bool
    | false => nat
  end.

Inductive relD : hrelation bool bool :=
| relD_tf : relD true false
| relD_ft : relD false true.

Definition denoteD a b (pf : relD a b) : hrelation (denote a) (denote' b) :=
  match pf in relD a b return hrelation (denote a) (denote' b) with
    | relD_tf => eq
    | relD_ft => eq
  end.

Definition default (a : bool) : denote a :=
  match a as a return denote a with
    | true => 0
    | false => false
  end.

Definition default' (a : bool) : denote' a :=
  match a as a return denote' a with
    | true => false
    | false => 0
  end.

Theorem default_default' : hdrespectful _ denoteD default default'.
Proof.
  repeat red; intros.
  destruct pf; reflexivity.
Qed.


From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.
From mathcomp Require Import all_fingroup.
From mathcomp Require Import all_real_closed.
From CoqEAL Require Import binetcauchy ssrcomplements mxstructure minor.
From CoqEAL Require Import smith dvdring polydvd.
From CoqEAL Require Import similar perm_eq_image.

(**    This file is a complement of the file Smith.v of the CoqEAL library.
       We prove here the unicity of the Smith normal form of a matrix.

       The algorithm described in the file Smith.v takes a matrix M of
       type 'M_(m,n) and returns a triple (L,s,R) where s is the
       sequence such that diag_mx_seq m n s is the Smith normal
       form of M, and L and R are the transition matrices
       (i.e diag_mx_seq m n s = L * M * R). In this context we have
       the following definitions :

             Smith_seq M == The sequence s of the triple (L,s,R).
            Smith_form M == diag_mx_seq m n (Smith_seq M).

*)

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

Section Specification.

Import GRing.Theory.
Local Open Scope ring_scope.
Variable E : euclidDomainType.

Definition find1 m n (A : 'M[E]_(m.+1, n.+1)) (v : E) : option 'I_m :=
  pick [pred i | ~~(v %| A (lift 0 i) 0)].

Lemma find1P m n (A : 'M[E]_(m.+1, n.+1)) (v : E) :
  pick_spec [pred i | ~~(v %| A (lift 0 i) 0)] (find1 A v).
Proof. exact: pickP. Qed.

Definition find2 m n (A : 'M[E]_(m.+1, n.+1)) (v : E) :
    option ('I_m.+1 * 'I_n) :=
  pick [pred ij | ~~(v %| A ij.1 (lift 0 ij.2))] .

Lemma find2P m n (A : 'M[E]_(m.+1, n.+1)) v :
  pick_spec [pred ij | ~~(v %| A ij.1 (lift 0 ij.2))] (find2 A v).
Proof.  exact: pickP. Qed.

Definition find_pivot m n (A : 'M[E]_(m.+1, n.+1)) :
    option ('I_m.+1 * 'I_n.+1) :=
  pick [pred ij | A ij.1 ij.2 != 0].

Lemma find_pivotP m n (A : 'M[E]_(m.+1, n.+1)) :
  pick_spec [pred ij | A ij.1 ij.2 != 0] (find_pivot A).
Proof. exact: pickP. Qed.

Definition Smith_seq n m (M: 'M[E]_(n,m)) :=
  let: (L,d,R) := (Smith find1 find2 find_pivot M) in
  if d is a :: d' then (\det L)^-1 * (\det R)^-1 *a :: d' else nil.

Definition Smith_form n m (M: 'M[E]_(n,m)) :=
  diag_mx_seq n m (Smith_seq M).

Lemma equiv_Smith n m (M: 'M[E]_(n,m)) : equivalent M (Smith_form M).
Proof.
case: n m M=>[m M|n]; first exact: equiv0l.
case=>[M|m M]; first exact: equiv0r.
rewrite /Smith_form /Smith_seq.
case: (SmithP find1P find2P find_pivotP) => L0 d R0 H _ HL0 HR0; split=> //.
exists ((@block_mx _ 1 _ 1 _ ((\det L0)^-1 / \det R0)%:M 0 0 1%:M) *m L0).
exists R0; split=> //.
  rewrite unitmxE detM unitrM (@det_lblock _ 1 n) det_scalar1 det1 mulr1.
  by rewrite unitrM !unitrV -!unitmxE HL0 HR0.
rewrite conform_mx_id -!mulmxA (mulmxA L0) H.
case: d H =>[|a l _] ; first by rewrite !diag_mx_seq_nil mulmx0.
rewrite !diag_mx_seq_cons (@mulmx_block _ 1 _ 1 _ 1).
by rewrite !mulmx0 !mul0mx !add0r addr0 mul1mx -scalar_mxM.
Qed.

Lemma sorted_Smith n m (M: 'M[E]_(n,m)):
  sorted (@dvdr E) (Smith_seq M).
Proof.
rewrite /Smith_seq.
case: (SmithP find1P find2P find_pivotP) => L0 d R0 _ H HL0 HR0.
case: d H=> //= a l H.
have/allP Ha: all (%|%R a) l by exact: (order_path_min (@dvdr_trans _)).
rewrite path_min_sorted; [exact: (path_sorted H) | apply/allP=> x Hx].
apply/(dvdr_trans _ (Ha x Hx))/dvdrP; exists (\det R0 * \det L0).
by rewrite -invrM ?mulVKr // unitrM -!unitmxE HR0.
Qed.

Lemma det_Smith n (M: 'M[E]_n) : \det (Smith_form M) = \det M.
Proof.
rewrite /Smith_form /Smith_seq.
case: n M=>[M|n M]; first by rewrite !det_mx00.
case: (SmithP find1P find2P find_pivotP)=> L0 d R0 H _ HL0 HR0.
case: d H=>[|a l].
  rewrite !diag_mx_seq_nil -{1}(mul0mx _ R0)=> /(mulIr HR0).
  by rewrite -{1}(mulmx0 _ L0)=> /(mulrI HL0)=> ->.
rewrite !diag_mx_seq_cons (@det_ublock _ 1) scalar_mxM detM -mulrA.
rewrite -(det_ublock a%:M 0)=> <-.
rewrite !detM -invrM -?unitmxE // det_scalar1 (mulrC (\det L0)).
rewrite -mulrA mulrC -(mulrA (\det M)) (mulrC (\det L0)) mulrV ?mulr1 //.
by rewrite unitrM -!unitmxE HR0.
Qed.

Lemma size_Smith_seq n (M: 'M[E]_n) :
  \det M != 0 -> size (take n (Smith_seq M)) = n.
Proof.
move=> HdM0; rewrite size_take; apply: minn_idPl.
apply: contra_neqT HdM0=>/negbTE H.
by rewrite -det_Smith /Smith_form det_diag_mx_seq_truncated H.
Qed.

End Specification.

Section Preunicity.

Import GRing.Theory.
Import PolyPriField.

Variable E : euclidDomainType.
Variables (s : seq E) (m n k : nat) (A : 'M[E]_(m,n)).

Hypothesis (Hk : (k <= minn m n)%N) (Hs: sorted %|%R s).
Hypothesis (HAs : equivalent A (diag_mx_seq m n s)).

Let widen_minl i := widen_ord (geq_minl m n) i.
Let widen_minr i := widen_ord (geq_minr m n) i.

Lemma minor_diag_mx_seq :
  let l := minn m n in
  forall (f g : 'I_k -> 'I_l),
  let f' i := widen_minl (f i) in
  let g' i := widen_minr (g i) in
  injective f -> injective g -> {subset codom f <= codom g} ->
  minor f' g' (diag_mx_seq m n s) %= \prod_i s`_(f i).
Proof.
rewrite /minor.
elim: k=>[f g|j IHj f g Hf Hg Hfg]; first by rewrite det_mx00 big_ord0.
have := perm_eq_image Hf Hg Hfg.
have Ht : size (codom g) == j.+1 by rewrite size_codom card_ord.
have -> : image g (ordinal_finType j.+1) = Tuple Ht by [].
case/tuple_permP=> p Hp.
have Hfg0 i : g (p i) = f i.
  have He: (i < #|'I_j.+1|)%N by rewrite card_ord.
  have {2}->: i = enum_val (Ordinal He) by rewrite enum_val_ord; apply: ord_inj.
  rewrite -(nth_image (f ord0)) Hp -tnth_nth tnth_mktuple (tnth_nth (f ord0)).
  by rewrite /= codomE (nth_map ord0) ?nth_ord_enum // size_enum_ord.
rewrite (expand_det_row _ ((p^-1)%g ord0)) big_ord_recl big1=>[|i _].
  rewrite /cofactor !mxE.
  set B := diag_mx_seq _ _ _.
  set M := row' _ _.
  pose f2 x :=  f (lift ((p^-1)%g ord0) x).
  pose g2 x :=  g (lift ord0 x).
  have Hf2: injective f2.
   by apply/(inj_comp Hf)/lift_inj.
  have Hg2: injective g2.
   by apply/(inj_comp Hg)/lift_inj.
  pose f' i := widen_ord (geq_minl m n) (f2 i).
  pose g' i := widen_ord (geq_minr m n) (g2 i).
  have ->: M = submatrix f' g' B.
    by apply/matrixP=> r t; rewrite !mxE.
  have Hfg2: {subset codom f2 <= codom g2}.
    move=> x /codomP [y ->].
    rewrite codomE /f2 /g2 -Hfg0 map_comp (mem_map Hg).
    set i := p _.
    have:= mem_ord_enum i.
    rewrite -enum_ord_enum enum_ordS in_cons -(permKV p ord0).
    by rewrite /i (inj_eq (@perm_inj _ _)) eq_sym (negbTE (neq_lift _ _)).
  rewrite addr0 (bigD1 ((p^-1)%g ord0)) //= -Hfg0 permKV eqxx eqd_mull //.
  rewrite -[X in _ %= X]mul1r eqd_mul ?eqd1 ?unitrX ?unitrN ?unitr1 //.
  rewrite (eq_bigl (fun i => (p^-1)%g ord0 != i)) ?big_lift_ord /=; last first.
    by move=> i /=; rewrite eq_sym.
  exact: (IHj _ _ Hf2 Hg2 Hfg2).
rewrite !mxE /= (inj_eq (@ord_inj _)) -Hfg0 (inj_eq Hg) permKV.
by rewrite (negbTE (neq_lift _ _)) mul0r.
Qed.

Lemma prod_minor_seq :
  \prod_(i < k) s`_i  =
   minor [ffun x : 'I_k => widen_minl (widen_ord Hk x)]
   [ffun x : 'I_k => widen_minr (widen_ord Hk x)] (diag_mx_seq m n s).
Proof.
rewrite /minor /submatrix.
elim: k Hk=>[H|j /= IHj Hj]; first by rewrite det_mx00 big_ord0.
have IH:= ltnW Hj.
apply: esym; rewrite (expand_det_row _ ord_max) big_ord_recr /= big1 ?add0r.
  rewrite /cofactor  /col' /row' !mxE !ffunE !matrix_comp.
  rewrite eqxx exprD -expr2 sqrr_sign mul1r.
  set M := matrix_of_fun _ _.
  have ->: M =
         (\matrix_(i, j) (diag_mx_seq m n s)
                           ([ffun x => widen_minl (widen_ord IH x)] i)
                           ([ffun x => widen_minr (widen_ord IH x)] j)).
    apply/matrixP=> i l; rewrite !mxE !ffunE.
    have Hr: forall p, widen_ord Hj (lift ord_max p) = widen_ord IH p.
      by move=> p; apply: ord_inj=> /=; rewrite /bump leqNgt (ltn_ord p) add0n.
    by rewrite !Hr.
  by rewrite -(IHj IH) big_ord_recr /= mulrC.
move=> i _; rewrite !mxE !ffunE /=.
by rewrite eqn_leq leqNgt (ltn_ord i) andFb mul0r.
Qed.

Lemma minor_eq0l (R : comRingType) k1 m1 n1  (s1 : seq R) x :
  forall (f : 'I_k1 -> 'I_m1) g, (n1 <= f x)%N ->
  minor f g (diag_mx_seq m1 n1 s1) = 0.
Proof.
move=> f g H.
rewrite /minor (expand_det_row _ x) big1 // => i _.
by rewrite !mxE gtn_eqF ?mul0r // (leq_trans _ H).
Qed.

Lemma minor_eq0r (R : comRingType) k1 m1 n1  (s1 : seq R) x :
  forall f (g : 'I_k1 -> 'I_n1) , (m1 <= g x)%N ->
  minor f g (diag_mx_seq m1 n1 s1) = 0.
Proof.
move=> f g H.
rewrite /minor (expand_det_col _ x) big1 // => i _.
by rewrite !mxE ltn_eqF ?mul0r // (leq_trans _ H).
Qed.

Lemma eqd_seq_gcdr :
  \prod_(i < k) s`_i %=
  \big[(@gcdr E)/0]_(f : {ffun 'I_k -> 'I_m})
  (\big[(@gcdr E)/0]_(g : {ffun 'I_k -> 'I_n}) minor f g (diag_mx_seq m n s)).
Proof.
apply/andP; split; last first.
  rewrite prod_minor_seq; set j := [ffun _ => _].
  by apply/(dvdr_trans (big_dvdr_gcdr _ j))/big_dvdr_gcdr.
apply: big_gcdrP=> f; apply: big_gcdrP=> g.
case: (injectiveb f) /injectiveP=> Hinjf; last first.
  by rewrite (minor_f_not_injective _ _ Hinjf) dvdr0.
case: (injectiveb g) /injectiveP=> Hinjg; last first.
  by rewrite (minor_g_not_injective _ _ Hinjg) dvdr0.
have Hmin k1 i m1 n1 (h : 'I_k1 -> 'I_m1) : (minn m1 n1 <= h i -> n1 <= h i)%N.
  move=> Hhi; have := (leq_ltn_trans Hhi (ltn_ord (h i))).
  by rewrite gtn_min ltnn=> /ltnW/minn_idPr <-.
case: (altP (@forallP _ (fun i => f i < minn m n)%N))=>[Hwf|]; last first.
  rewrite negb_forall=> /existsP [x]; rewrite -leqNgt=> /Hmin Hx.
  by rewrite (minor_eq0l _ _ Hx) dvdr0.
case: (altP (@forallP _ (fun i => g i < minn m n)%N))=>[Hwg|]; last first.
  rewrite negb_forall=> /existsP [x]; rewrite -leqNgt minnC=> /Hmin Hx.
  by rewrite (minor_eq0r _ _ Hx) dvdr0.
pose f1 i := Ordinal (Hwf i).
pose g1 i := Ordinal (Hwg i).
have Hinjf1 : injective f1.
  by move=> x y /eqP; rewrite -(inj_eq (@ord_inj _)) /= => /eqP/ord_inj/Hinjf.
have Hinjg1 : injective g1.
  by move=> x y /eqP; rewrite -(inj_eq (@ord_inj _)) /= => /eqP/ord_inj/Hinjg.
case/boolP: (codom f1 \subset codom g1); last first.
  case/subsetPn => x /codomP [y Hy] Habs.
  rewrite /minor (expand_det_row _ y).
  rewrite [\sum_(_ <_) _](big1 _ xpredT) ?dvdr0 // => j _.
  rewrite !mxE -[(g j : nat)]/(g1 j : nat) -[(f y : nat)]/(f1 y : nat).
  suff /negbTE->: (f1 y != g1 j :> nat) by rewrite mul0r.
  by apply: contraNneq Habs =>/ord_inj H; rewrite Hy H codom_f.
move/subsetP => Hcfg.
pose f' i := widen_minl (f1 i).
pose g' i := widen_minr (g1 i).
have ->: minor f g (diag_mx_seq m n s) =
           minor f' g' (diag_mx_seq m n s).
  by apply: minor_eq=> i; apply: ord_inj.
rewrite (eqd_dvdr _ (minor_diag_mx_seq Hinjf1 Hinjg1 Hcfg)) //.
move: Hinjf1; clear -Hs; move: f1; clear -Hs.
elim: k =>[?|j /= IHj g Hg]; first by rewrite big_ord0 dvd1r.
rewrite big_ord_recr /=.
pose max:= \max_i (g i).
have [l Hl]: {j | max = g j} by apply: eq_bigmax; rewrite card_ord.
pose p := tperm l ord_max.
set B := \prod_(_ < _) _.
rewrite (reindex_inj (@perm_inj _ p)) /= big_ord_recr /= dvdr_mul //.
  pose f := g \o p \o (widen_ord (leqnSn j)).
  have Hf: injective f.
    apply: inj_comp=> [|x y /eqP].
      by apply: inj_comp=> //; exact: perm_inj.
    by rewrite -(inj_eq (@ord_inj _)) /= => H; apply/ord_inj/eqP.
  have Hi: injective (finfun f).
    by move=> x e; rewrite !ffunE; exact: Hf.
  set C := \prod_(_ < _) _.
  suff ->: C = \prod_i s`_(finfun f i) by apply: IHj.
  by apply: eq_bigr=> i _; rewrite ffunE.
have jleg : (j <= g (p ord_max))%N.
  rewrite /= tpermR; case: ltngtP => // Hgm.
  have Habs: forall i, (g i < j)%N.
    move=> i; apply: (leq_ltn_trans _ Hgm).
    by rewrite -Hl /k; exact: (leq_bigmax i).
  pose f := fun x => Ordinal (Habs x).
  have Hf: injective f.
    move=> x y /eqP; rewrite -(inj_eq (@ord_inj _)) /= => /eqP Hxy.
    by apply/Hg/ord_inj.
  have: (#|'I_j.+1| <= #|'I_j|)%N.
    by rewrite -(card_codom Hf); exact: max_card.
  by rewrite !card_ord ltnn.
have [glts | sleg] := ltnP (g (p ord_max)) (size s); last first.
  by rewrite (nth_default 0 sleg); exact: dvdr0.
apply: sorted_leq_nth=>//; first exact: dvdr_trans.
by rewrite inE; apply/leq_ltn_trans/glts.
Qed.

Lemma Smith_gcdr_spec :
  \prod_(i < k) s`_i  %=
  \big[(@gcdr E)/0]_(f : {ffun 'I_k -> 'I_m})
   (\big[(@gcdr E)/0]_(g : {ffun 'I_k -> 'I_n}) minor f g A) .
Proof.
rewrite (eqd_ltrans eqd_seq_gcdr).
have [ _ _ [M [N [_ _ Heqs]]]]:= HAs.
have [ _ _ [P [Q [_ _ Hseq]]]]:= (equiv_sym HAs).
rewrite conform_mx_id in Heqs.
rewrite conform_mx_id in Hseq.
have HdivmA p q k1 (B C : 'M[E]_(p,q)) (M1 : 'M_p) (N1 : 'M_q) :
   forall (H : M1 *m C *m N1 = B),
   forall (f : 'I_k1 -> 'I_p) (g : 'I_k1 -> 'I_q),
   \big[(@gcdr E)/0]_(f0 : {ffun 'I_k1 -> _})
    \big[(@gcdr E)/0]_(g0 : {ffun 'I_k1 -> _}) minor f0 g0 C
    %| minor f g B.
  move=> H f g.
  have HBC: minor f g B =  \sum_(f0 : {ffun _ -> _ } | strictf f0)
                 ((\sum_(g0 : {ffun _ -> _ } | strictf g0)
                  (minor id g0 (submatrix f id M1) * minor g0 f0 C)) *
                   minor f0 id (submatrix id g N1)).
    rewrite -H /minor submatrix_mul BinetCauchy.
    apply: eq_bigr=> i _; congr GRing.mul; rewrite /minor.
    rewrite sub_submatrix submatrix_mul BinetCauchy.
    by apply: eq_bigr=> j _; rewrite /minor !sub_submatrix.
  rewrite HBC; apply: big_dvdr=> h; rewrite dvdr_mulr //.
  apply: big_dvdr=> j; rewrite dvdr_mull //.
  by apply: (dvdr_trans (big_dvdr_gcdr _ j)); apply: big_dvdr_gcdr.
apply/andP; split; apply: big_gcdrP=> f; apply: big_gcdrP=> g.
  exact: (HdivmA _ _ _ _ _ _ _ Hseq).
exact: (HdivmA _ _ _ _ _ _ _ Heqs).
Qed.

End Preunicity.

Section Unicity.

Import GRing.Theory.
Import PolyPriField.
Variable E : euclidDomainType.

Lemma Smith_unicity n (A : 'M[E]_n) (s : seq E) :
  sorted %|%R s -> equivalent A (diag_mx_seq n n s) ->
  forall i, (i < n)%N -> s`_i %= (Smith_seq A)`_i.
Proof.
move=> Hs HAs i.
have Hsmt := sorted_Smith A.
have HAsmt := equiv_Smith A.
elim: i {-2}i (leqnn i)=>[i|i IHi j Hji].
  rewrite leqn0 -[X in (i < X)%N]minnn=> /eqP -> Hi.
  move: (Smith_gcdr_spec Hi Hs HAs).
  move: (Smith_gcdr_spec Hi Hsmt HAsmt).
  rewrite !big_ord_recl !big_ord0 !mulr1 eqd_sym => H1 H2.
  exact: (eqd_trans H2 H1).
rewrite -[X in (j < X)%N]minnn=> Hj.
move: (Smith_gcdr_spec Hj Hs HAs).
move: (Smith_gcdr_spec Hj Hsmt HAsmt).
rewrite !big_ord_recr /= eqd_sym => H1 H2.
have {H1 H2} H3:= eqd_trans H2 H1.
have H1: \prod_(i < j) s`_i %= \prod_(i < j) (Smith_seq A)`_i.
  rewrite minnn in Hj.
  apply: eqd_big_mul=> k _; apply: IHi.
    exact: (leq_trans (ltn_ord k) Hji).
  exact: (ltn_trans _ Hj).
case: (eqVneq (\prod_(i < j) s`_i) 0) => H0; last first.
  by rewrite -(eqd_mul2l _ _ H0) (eqd_rtrans (eqd_mulr _ H1)).
have/prodf_eq0 [k _ /eqP Hk]: (\prod_(i < j) (Smith_seq A)`_i == 0).
  by rewrite H0 eqd0r in H1.
case/eqP/prodf_eq0: H0 => l _ /eqP Hl.
have sj0 : s`_j == 0.
  have [ jlts | slej ] := ltnP j (size s); last first.
    by rewrite (nth_default 0 slej).
  rewrite -dvd0r -{1}Hl.
  apply: sorted_leq_nth => //.
  + exact: dvdr_trans.
  + by rewrite inE (ltn_trans _ jlts).
  + exact: ltnW.
have smsj0 : (Smith_seq A)`_j == 0.
  have [ jlts | slej ] := ltnP j (size (Smith_seq A)); last first.
    by rewrite (nth_default 0 slej).
  rewrite -dvd0r -{1}Hk.
  apply: sorted_leq_nth => //.
  + exact: dvdr_trans.
  + by rewrite inE (ltn_trans _ jlts).
  + exact: ltnW.
by rewrite (eqP sj0) (eqP smsj0).
Qed.

End Unicity.


Require Import Eqdep_dec.
Require Import Coq.Logic.JMeq.
Require Import Program.Tactics.
Require Import ProofIrrelevance.
Require Import Coq.Bool.Bool.
Require Import Fin.

Definition EqDecType T := forall x y: T, {x=y}+{x<>y}.

Class EqDec {T: Type} := {
  eqDom: Type := T;
  eq_dec: EqDecType eqDom
}.
Coercion eqDom: EqDec >-> Sortclass.

Fixpoint assoc `{T1: EqDec} {T2} (x: T1) (l: list (T1*T2)) : option T2 :=
  match l with
    nil => None
  | cons (y1, y2) l' => if eq_dec x y1 then Some y2 else assoc x l'
  end.

Class Decidable := {
  dcPred: Prop;
  dc_dec: {dcPred }+{not dcPred}
}.
Coercion dcPred: Decidable >-> Sortclass.

Definition TrueDec: Decidable := {|
  dcPred := True;
  dc_dec := left I
|}.

Definition FalseDec: Decidable := {|
  dcPred := False;
  dc_dec := right (fun h:False => match h with end)
|}.

Program Definition NotDec (P: Decidable): Decidable := {|
  dcPred := not P
|}.
Next Obligation.
  destruct (@dc_dec P); simpl.
  right.
  intro.
  apply (H d).
  left.
  apply n.
Defined.

Program Definition AndDec (P Q: Decidable) : Decidable := {|
  dcPred := P /\ Q;
|}.
Next Obligation.
  destruct (@dc_dec P).
  destruct (@dc_dec Q); [left; auto | right; intro; tauto].
  right; intro; tauto.
Defined.

Program Definition OrDec (P Q: Decidable) : Decidable := {|
  dcPred := P \/ Q;
|}.
Next Obligation.
  destruct (@dc_dec P).
  left; left; tauto.
  destruct (@dc_dec Q); [left; right; auto | right; intro; tauto].
Defined.

Program Definition ImpDec (P Q: Decidable) : Decidable := {|
  dcPred := P -> Q;
|}.
Next Obligation.
  destruct (@dc_dec P).
  destruct (@dc_dec Q).
  left; intro; tauto.
  right; intro; tauto.
  left; intro; tauto.
Defined.

Program Definition IffDec (P Q: Decidable) : Decidable := {|
  dcPred := P <-> Q;
|}.
Next Obligation.
  destruct (@dc_dec P).
  destruct (@dc_dec Q).
  left; intros; tauto.
  right; intros; tauto.
  destruct (@dc_dec Q).
  right; intros; tauto.
  left; intros; tauto.
Defined.

Program Definition AndThenDec (P: Decidable) (Q: P -> Decidable): Decidable := {|
  dcPred := exists p: P, Q p;
|}.
Next Obligation.
  destruct (@dc_dec P).
  destruct (@dc_dec (Q d)); [left | right].
  exists d; auto.
  intro.
  destruct H as [p h].
  rewrite (proof_irrelevance _ p d) in h.
  apply (n h).
  right; intro.
  destruct H as [p _].
  apply (n p).
Defined.

Instance isEq `{T: EqDec} (x y:T) : Decidable := {
  dcPred := x=y;
  dc_dec := eq_dec x y
}.

Instance isNEq `{T: EqDec} (x y:T) : Decidable := {
  dcPred := x<>y;
  dc_dec := match eq_dec x y with left e => right (fun h => h e) | right n => left n end
}.

Instance isEqF (T1: Type) `{T2: EqDec} (f: T1->T2) (x: T2) (y:T1) : Decidable := {
  dcPred := x=f y;
  dc_dec := eq_dec x (f y)
}.

Lemma inj_pairT1
     : forall {U : Type} {P : U -> Type} {p q x y},
       existT P p x = existT P q y -> p = q.
Proof.
  intros.
  injection H; intros; auto.
Qed.

Program Instance isEq2 `{T1: EqDec} {T2: T1->Type} {U: forall t, @EqDec (T2 t)} (x1:T1) (y1: U x1) (x2:T1) (y2: U x2) : Decidable := {
  dcPred := existT U x1 y1 = existT U x2 y2;
  dc_dec := _
}.
Next Obligation.
  intros.
  destruct (eq_dec x1 x2).
  subst x2.
  destruct (eq_dec y1 y2).
  subst y2.
  left; easy.
  right; intro.
  apply n; clear n.
  apply inj_pair2_eq_dec in H; auto.
  intros; apply eq_dec.

  right; intro.
  inversion H.
  apply (n H1).
Qed.

Lemma isEq2_sym: forall `{T1: EqDec} {T2: T1->Type} x1 x2 y1 y2,
  isEq2 x1 x2 y1 y2 -> isEq2 y1 y2 x1 x2.
Proof.
  intros.
  inversion H; intros; subst.
  constructor.
Qed.

Program Instance uptoDec n: @EqDec (Fin.t n) := {| eq_dec := Fin.eq_dec |}.

Program Instance DepPairDec `(T1: EqDec) {T2: T1->Type} (U: forall t, @EqDec (T2 t)): @EqDec {x:T1 & U x} := {| eq_dec := _ |}.
Next Obligation.
  repeat intro.
  destruct x; destruct y.
  apply isEq2.
Defined.

Program Instance PairDec `(T1: EqDec) `(T2: EqDec) : @EqDec (T1*T2) := {| eq_dec := _ |}.
Next Obligation.
  repeat intro.
  destruct x; destruct y.
  destruct (eq_dec e e1); subst.
  destruct (eq_dec e0 e2); subst.
  left; reflexivity.
  right; intro H; apply n; clear n; injection H; intros; auto.
  right; intro H; apply n; clear n; injection H; intros; auto.
Defined.

Program Definition SumDec `(T1: EqDec) `(T2: EqDec) : @EqDec (T1+T2) := {|
  eq_dec := _;
|}.
Next Obligation.
  repeat intro; decide equality; apply eq_dec.
Defined.

Inductive IncType T :=
  New: IncType T
| Old: T -> IncType T.

Program Definition IncDec `(T: EqDec) : @EqDec (IncType T) := {| eq_dec := _ |}.
Next Obligation.
  repeat intro; decide equality; apply eq_dec.
Qed.

Definition eProduct `(T1: EqDec) `(T2: EqDec): @EqDec (T1*T2).
  Proof.
    split; repeat intro.
    destruct x as [x1 x2].
    destruct y as [y1 y2].
    destruct (eq_dec x1 y1).
    destruct (eq_dec x2 y2).
    left.
    rewrite e,e0; reflexivity.
    right; intro.
    injection H; clear H; intros.
    apply (n H).
    right; intro.
    injection H; clear H; intros.
    apply (n H0).
  Defined.

  Inductive Empty: Type := .

  Program Definition EmptyDec: @EqDec Empty := {| eq_dec x y := _ |}.
  Next Obligation.
   destruct x.
  Defined.

  Inductive One: Type := one: One.

  Definition OneDec: @EqDec One := {|
    eq_dec x y := left (match x,y with one,one => eq_refl end)
  |}.

  Definition TwoDec: @EqDec bool := {| eq_dec := Bool.bool_dec |}.


Section Inv.

Context {T T' : finType} {A : {set T}} {B : {set T'}} (f : A ⟶ B).
Hypotheses Hbi : bij f.

Theorem inv_map_mixin :
    map_mixinp (range f) A  (inv f).
Proof.
    inductionM f Gf Hfm domA imA F Hf_ Hf.
    split.
    +   setE b.
        -   move /domainP => [a].
            rewrite in_set => /=.
            move /Hf; case => //=.
        -   move => Hb.
            apply /domainP.
    move : Hbi => [surjf injf].
    move /bij_inv : Hbi => [H' Hf'] => //.
    apply /map_mixinP => //.
Qed.

Definition Inv  :=
    mkMap (inv f) (map_mixin_intro inv_map_mixin).

Theorem compKl :
    Inv ○ f = id A.
Proof.
    move : Hbi; rewrite /bij /inj /surj; move => [Hs Hi].
    move /bij_inv : Hbi => [axiom' [ Hs' Hi']].
    apply map_extension; apply extension; apply /subsetP => u /=; induction u as [a a'].
    +   induction f as [Γ axiom_].
        move : (map_mixin_elim axiom_) => axiom.
        move /comp_setP => /= [b [Hf /inv_setP /= Hf']].
        move : (in_graph _ _ Hf) => /= [Ha Hb].
        move : (in_graph _ _ Hf') => /= [Ha' _].
        move : (axiom _ Ha) => [b0 ima].
        move : (axiom _ Ha') => [b0' ima'].
        move /imageP : Hf; rewrite ima; move /set1P => bb; subst b0.
        move /imageP : Hf'; rewrite ima'; move /set1P => bb; subst b0'.
        suff : a = a'.
            move ->; apply /id_setP; split => //.
            apply /setXP => //.
        apply Hi => //=.
        rewrite ima ima' => //.
    +   move /id_setP => /= [/setXP [Ha _] aa]; subst a'.
        rewrite -Hs' in Ha.
        move /rangeP : Ha => /= [b /inv_setP /= Hab].
        apply /comp_setP => /=.
        exists b; split => //.
        apply /inv_setP => //.
Qed.

Theorem compkr :
    f ○ Inv = id B.
Proof.
    move : Hbi; rewrite /bij /inj /surj; move => [Hs Hi].
    move /bij_inv : Hbi => [axiom'_ [ Hs' Hi']].
    move : (map_mixin_elim axiom'_) => axiom'.
    apply map_extension; apply extension; apply /subsetP => u /=; induction u as [b b'].
    +   induction f as [Γ axiom_].
        move : (map_mixin_elim axiom_) => axiom.
        move /comp_setP => /= [a [/inv_setP /= Hf Hf']].
        move : (in_graph _ _ Hf) => /= [Ha Hb].
        move : (in_graph _ _ Hf') => /= [_ Hb'].
        move : (axiom' _ Hb) => /= [a0 imb].
        move : (axiom' _ Hb') => /= [a0' imb'].
        move /imageP : Hf; rewrite -in_inv imb; move /set1P => aa; subst a0.
        move /imageP : Hf' ; rewrite -in_inv imb'; move /set1P => aa; subst a0'.
        suff : b = b'.
            move ->; apply /id_setP; split => //.
            apply /setXP => //.
        apply Hi' => //=.
        rewrite imb imb' => //.
    +   move /id_setP => /= [/setXP [Hb _] bb]; subst b'.
        rewrite -Hs in Hb.
        move /rangeP : Hb => /= [a  Hab].
        apply /comp_setP => /=.
        exists a; split => //.
        apply /inv_setP => //.
Qed.

End Inv.