(* NIZK Proof System - Useful functions by Remi Bazin *)

(* Imports *)
Require Import Arith.
Require Import NPeano.
Require Import Le.
Require Import List.

(* Various utils *)
Fixpoint repeat_fn (n:nat) (A:Type) (f:A -> A) (s:A) : A :=
  match n with
    | O => s
    | S m => repeat_fn m A f (f s)
  end
.

Lemma mod_S : forall (n p:nat), 2<=p -> ((S n) mod p=S (n mod p)) \/ ((S n) mod p=O).
Proof.
  admit. (* TODO *)
Qed.

Lemma rm_notin (A:Type) (l1 l2:list A) (x:A) (p:forall x y:A, {x = y} + {x <> y}) :
  (~In x l1) -> ((remove p x (l1++l2)) = l1++(remove p x l2)).
Proof.
  elim l1.
  (* Case l1=nil *)
    intro useless.
    rewrite (app_nil_l l2).
    rewrite (app_nil_l (remove p x l2)).
    reflexivity.
  (* Case l1 --> a::l1 *)
    intros a l Hrec xnotinal.
    assert (subg : ~ In x l).
    intro Hwrong.
    case (xnotinal (in_cons a x l Hwrong)).
    rewrite <- (app_comm_cons l l2 a).
    rewrite <- (app_comm_cons l (remove p x l2) a).
    rewrite <- (Hrec subg).
    unfold remove at 1.
    fold (remove p x (l++l2)).
    case (p x a).
    intro xisa.
    rewrite xisa in xnotinal.
    case (xnotinal (in_eq a l)).
    intro xisnota.
    reflexivity.
Qed.

Lemma nodup_rm (A:Type) (l:list A) (x:A) (p:forall x y:A, {x = y} + {x <> y}) :
  (NoDup l) -> ({~In x l} + {In x l /\ exists (l1 l2:list A),
    (l = l1++x::l2 /\ ~In x l1 /\ ~In x l2 /\ (remove p x l=l1++l2))}).
Proof.
  intros lnodup.
  case (in_dec p x l).
  (* Case In x l *)
    intro xinl.
    refine (right (conj xinl _)).
    destruct (in_split x l xinl).
    destruct H.
    refine (ex_intro _ x0 _).
    refine (ex_intro _ x1 _).
    rewrite H in lnodup.
    pose (subg := (NoDup_remove_2 x0 x1 x lnodup)).
    assert (xnotinx0 : ~In x x0).
    intro abs1.
    case (subg (in_or_app x0 x1 x (or_introl abs1))).
    assert (xnotinx1 : ~In x x1).
    intro abs2.
    case (subg (in_or_app x0 x1 x (or_intror abs2))).
    refine (conj H (conj xnotinx0 (conj xnotinx1 _))).
    rewrite H.
    rewrite (rm_notin A x0 (x::x1) x p xnotinx0).
    unfold remove.
    case (p x x).
    intro useless.
    fold (remove p x x1).
    rewrite <- (app_nil_r x1) at 1.
    rewrite (rm_notin A x1 nil x p xnotinx1).
    unfold remove.
    rewrite (app_assoc _ _ _).
    exact (app_nil_r _).
    intro Hwrong.
    case (Hwrong (eq_refl x)).
  (* Case ~In x l *)
    intro xnotinl.
    exact (left xnotinl).
Qed.

Lemma notin_rm (A:Type) (l:list A) (x:A) (p:forall x y:A, {x = y} + {x <> y}) :
  (~In x l) -> (remove p x l=l).
Proof.
  elim l.
  (* Case l=nil *)
    intro useless.
    unfold remove.
    reflexivity.
  (* Case l --> a::l *)
    intros.
    unfold remove.
    case (p x a).
    intro xisa.
    admit.
    intro xisnota.
    case (in_dec p x l0).
    intro xinl0.
    case (H0 (in_cons a x l0 xinl0)).
    intro xnotinl0.
    rewrite <- (H xnotinl0) at 2.
    reflexivity.
Qed.

(* Prime integer definition and properties *)
Definition Is_prime (n:nat) : Prop :=
  (2 <= n)
  /\
  (forall k:nat, (0<k<n) -> (NPeano.gcd k n = 1))
.

(* See https://www.eecs.northwestern.edu/~robby/courses/395-495-2013-fall/genrec_hw.v
   to prove the end of the recursion.
Print well_founded.
Print Acc.
Fixpoint mygcd (n m:nat) :=
  match le_lt_dec n m with
    | left _ => match n with
      | O => m
      | S O => 1
      | _ => mygcd n (m mod n)
    end
    | right _ => match m with
      | O => n
      | S O => 1
      | _ => mygcd (n mod m) m
    end
  end
.
*)

Lemma gcd_mult : forall (m n p:nat), m>0 -> n>0 -> p>0 ->
  gcd (m*n) p <= (gcd m p) * (gcd n p).
Proof.
  admit. (* TODO *)
Qed.

(* Mathematical structure properties *)
Definition Is_zero (G:Type) (add:G->G->G) (e:G) : Prop :=
  forall a:G, (add e a) = a
.
Definition Is_associative (G:Type) (add:G->G->G) : Prop :=
  forall (a b c:G), (add a (add b c)) = (add (add a b) c)
.
Definition Is_commutative (G:Type) (add:G->G->G) : Prop :=
  forall (a b:G), (add a b) = (add b a)
.
Definition Has_inverse (G:Type) (add:G->G->G) (e:G) : Prop :=
  (Is_zero G add e)
  /\
  (forall a:G, exists (b:G), (add a b) = e)
.
Definition Order_atmost_p (G:Type) (add:G->G->G) (e:G) (p:nat) : Prop :=
  (Is_zero G add e)
  /\
  (forall a:G, (repeat_fn p G (fun x => add x a) e) = e)
.

Definition Order_atleast_p (G:Type) (add:G->G->G) (e:G) (p:nat) : Prop :=
  (Is_zero G add e)
  /\
  (forall (a:G) (k:nat), 0<k<p -> a<>e -> (repeat_fn k G (fun x => add x a) e) <> e)
.

Definition Has_card (G:Type) (p:nat) : Prop :=
  (* At least p *)
  (exists l1:list G, ((length l1)=p) /\ (NoDup l1))
  /\
  (* At most p *)
  (~(exists l2:list G, ((length l2)>p) /\ (NoDup l2)))
.

(* Definition of an abelian group that is isomorphic to Fp *)
Definition Is_Fp_isomorphic (G:Type) (add:G->G->G) (p:nat) : Prop :=
  exists (e:G), (
    (* Note: Closure comes from the type of add. *)
    (* Associativity *)
    (Is_associative G add)
    /\
    (* Commutativity *)
    (Is_commutative G add)
    /\
    (* Identity element *)
    (Is_zero G add e)
    /\
    (* Inverse element *)
    (Has_inverse G add e)
    /\
    (* Prime order *)
    (Is_prime p)
    /\
    (* Order at most p *)
    (Order_atmost_p G add e p)
    /\
    (* Order at least p *)
    (Order_atleast_p G add e p)
    /\
    (* Cardinal check *)
    (Has_card G p)
  )
.


Require Import Coq.Strings.String.
Require Import GDTC.
Require Import CaseStudy.Names.
Require Import CaseStudy.PNames.
Require Import CaseStudy.Arith.
Require Import CaseStudy.Bool.
Require Import CaseStudy.Lambda.
Require Import CaseStudy.Arith_Lambda.
Require Import CaseStudy.Bool_Lambda.

Open Scope string_scope.

Section Type_Test_Section.
  (* Type Testing, of course. *)
  Definition D := AType :+: LType :+: BType.

  Global Instance Container_D : Container D :=
    PolynomialContainer D.

  Definition tex2 : DType D := tnat _.
  Definition tex3 : DType D := tarrow _ tex2 tex2. (* Nat -> Nat *)
  Definition tex4 : DType D := tarrow _ (tbool _) tex2. (* Bool -> Nat *)

  Eval compute in ("Evaluating 'tnat == tnat -> tnat' as an 'TNat :+: TArrow :+: TBool'.").
  Eval compute in (eq_DType D tex2 tex3).
  Eval compute in ("Evaluating 'tnat == tnat' as an 'TNat :+: TArrow :+: TBool'.").
  Eval compute in (eq_DType D tex2 tex2).
  Eval compute in ("Evaluating 'tnat -> tnat == tnat' as an 'TNat :+: TArrow :+: TBool'.").
  Eval compute in (eq_DType D tex3 tex2).
  Eval compute in ("Evaluating 'tnat -> tnat == tnat -> tnat' as an 'TNat :+: TArrow :+: TBool'.").
  Eval compute in (eq_DType D tex3 (tarrow _ tex2 tex2)).
  Eval compute in ("Evaluating 'tbool -> tnat == tnat -> tnat' as an 'TNat :+: TArrow :+: TBool'.").
  Eval compute in (eq_DType D tex4 (tarrow _ tex2 tex2)).

  Eval compute in ("Evaluating 'tbool == tnat' as an 'TNat :+: TArrow :+: TBool'.").
  Eval compute in (eq_DType D (tbool _) (tnat _)).

End Type_Test_Section.

Section Test_Section.

  Definition E (A: Set) := Arith :+: (Lambda D A) :+: Bool.

  Global Instance Container_E : forall (A : Set), Container (E A).
    eauto with typeclass_instances.
  Defined.

  Definition ex_3 A : Exp E A := (lit _ 1). (* ex_3 := 1 *)

  (* Definition ex_1 (A : Set) t1 t2 : Names.Exp (E A) := (* ex_1 := (\x : t1. x) (\y : t2 . y) *) *)
  (*   app D E (lam D E t1 (fun e : A => var D E e)) (lam D E t2 (fun e : A => var D E e)). *)
  (* Definition ex_4 A : Names.Exp (E A) := (* ex_4 := \x : tnat . x + x*) *)
  (*   lam D E (tnat _) (fun x => add (E A) (var D _ x) (var D _ x)). *)
  (* Example ex_id A : Names.Exp (E A) :=  (* ex_id := \x. x *) *)
  (*   lam D _ (tnat _) (fun x => (var D _ x)). *)
  (* Example ex_5 A : Names.Exp (E A) := (* ex_5 := \x. (x (\y. y)) 1*) *)
  (*   lam D _ (tnat _ ) (fun x => app D _ (app D _ (var D _ x) (ex_id _)) (ex_3 _)). *)
  (* Example ex_6 A : Names.Exp (E A) := (* ex_6 := \x. \y. x y*) *)
  (*   lam D _ (tnat _) (fun x => lam D _ (tnat _) (fun y => app D _ (var D _ x) (var D _ y))). *)
  (* Example ex_7 A : Names.Exp (E A):= (* ex_7 := (\x. (x (\y. y)) 1) (\x. \y. x y)*) *)
  (*   (app D _ (ex_5 _) (ex_6 _)). *)

  Instance D_typeof T : FAlgebra TypeofName T (typeofR D) (E (typeofR D)).
    eauto with typeclass_instances.
  Defined.

  Definition test_typeof e :=
    match (typeof D (E _) e) with
      | Some t1 => DTypePrint _ t1
      | None => "Type Error"
    end.

  (* Eval compute in ("The type of '(\x:tnat->tnat. x) (\y:tnat.y)' should be tnat->tnat"). *)
  (* Eval compute in (test_typeof (ex_1 _ tex3 tex2)). *)
  (* Eval compute in ("The type of '1' as a 'Arith :+: Lambda' should be tnat"). *)
  (* Eval compute in (test_typeof (ex_3 _)). *)
  (* Eval compute in ("The type of '\x.x+x' as a 'Arith :+: Lambda' should be 'tnat -> tnat"). *)
  (* Eval compute in (test_typeof (ex_4 _)). *)

  (* Eval compute in (ExpPrint _ (ex_1 _ tex3 tex2)). *)
  (* Eval compute in (ExpPrint _ (ex_3 _)). *)
  (* Eval compute in (ExpPrint _ (ex_4 _)). *)
  (* Eval compute in (ExpPrint _ (ex_7 _)). *)

  Definition V := StuckValue :+: BotValue :+: NatValue :+: (ClosValue E) :+: (BoolValue).

  Global Instance Container_V : Container V.
    eauto with typeclass_instances.
  Defined.

  Instance V_eval : FAlgebra EvalName (Exp E nat) (evalR V) (E nat).
    eauto 150 with typeclass_instances.
  Defined.

  (* Eval compute in ("Evaluating '(\x:tnat->tnat. x) (\y:tnat.y)'"). *)
  (* Eval compute in (ValuePrint V (proj1_sig (beval V _ 3 (ex_1 _ tex3' tex2') nil))). *)
  (* Eval compute in ("Evaluating '((\x:tnat->tnat. x) (\y:tnat.y)) 1'"). *)
  (* Eval compute in (ValuePrint V (proj1_sig (beval V _ 3 (app D E (ex_1 _ tex3' tex2') (lit' _ 1)) nil))). *)
  (* Eval compute in ("Evaluating '\x.x+x'"). *)
  (* Eval compute in (ValuePrint V (proj1_sig (beval V _ 2 (ex_4 _) nil))). *)
  (* Eval compute in ("Evaluating '(\x.x+x) 1'"). *)
  (* Eval compute in (ValuePrint V (proj1_sig (beval V _ 4 (app D E (ex_4 _) (lit' _ 1)) nil))). *)
  (* Eval compute in ("Evaluating '(\x.x+x) 3'"). *)
  (* Eval compute in (ValuePrint V (proj1_sig (beval V _ 4 (app D E (ex_4 _) (lit' _ 3)) nil))). *)
  (* Eval compute in ("Evaluating '(\x. (x (\y. y)) 1) (\x. \y. x y)'"). *)
  (* Eval compute in (ValuePrint V (proj1_sig (beval V _ 5 (ex_7 _) nil))). *)
  (* Eval compute in ("Evaluating '\x. x'"). *)
  (* Eval compute in (ValuePrint V (proj1_sig (beval V _ 5 (ex_id _) nil))). *)

  Definition SV := (SubValue_refl V) ::+:: (SubValue_Bot V) ::+:: (SubValue_Clos E V).

  Global Instance Container_SV : IContainer SV.
    eauto with typeclass_instances.
  Defined.

  Global Instance EV_Alg :
    FPAlgebra (eval_continuous_Exp_P V (E nat) SV) (inject (E nat) (E nat)).
  Proof.
    repeat apply FPAlgebra_Plus_cont_inject; eauto 200 with typeclass_instances.
    - pose proof (Lambda_eval_continuous_Exp D E).
      eauto 200 with typeclass_instances.
  Qed.

  Lemma eval_continuous : forall m,
    forall (e : Exp E nat) (gamma gamma' : Env _),
      forall n (Sub_G_G' : Sub_Environment V SV gamma gamma'),
        m <= n ->
        SubValueC _ SV (beval _ _ m e gamma) (beval _ _ n e gamma').
    eapply beval_continuous; eauto 250 with typeclass_instances.
  Qed.

  Eval compute in ("Continuity of Evaluation Proven!").

  Definition Eqv (A B : Set) :=
    (NP_Functor_eqv E Arith A B) ::+:: (NP_Functor_eqv E Bool A B) ::+::
    (Lambda_eqv D E A B).
  Global Instance Container_Eqv : forall (A B : Set), IContainer (Eqv A B).
    eauto with typeclass_instances.
  Defined.

  Definition WFV := (WFValue_Clos D E V Eqv (typeof _ _)) ::+:: (WFValue_Bot D V) ::+::
    (WFValue_VI D V) ::+:: (WFValue_VB D V).

  Global Instance Container_WFV : IContainer WFV.
    eauto with typeclass_instances.
  Defined.

  Instance Eval_Soundness_alg (eval_rec : Exp E nat -> evalR V) :
    iPAlgebra soundness_XName
              (soundness_X'_P D V E Eqv WFV
                              (typeof D (E (typeofR D))) eval_rec
                              (f_algebra TypeofName) (f_algebra EvalName))
              (Eqv (typeofR D) nat).
  Proof with eauto 200 with typeclass_instances.
    repeat apply iPAlgebra_Plus...
    - apply Lift_soundness_X_alg...
      apply eqv_eval_Soundness...
    - apply Lift_soundness_X_alg...
      apply eqv_eval_Soundness...
    - pose proof (Lambda_eqv_eval_soundness_alg D E)...
  Qed.

  Theorem soundness : forall n gamma gamma' gamma'' e' e'',
    E_eqvC _ Eqv gamma gamma' e' e'' ->
    forall (WF_gamma : forall n b, lookup gamma' n = Some b ->
      exists T, lookup gamma b = Some T)
    (WF_gamma2 : List.length gamma = List.length gamma')
    (WF_gamma' : forall n b, lookup gamma' n = Some b -> b = n)
    (WF_gamma'' : WF_Environment _ _ WFV gamma'' gamma) T,
    typeof D (E _) e' = Some T -> WFValueC _ _ WFV (beval _ _ n e'' gamma'') T.
  Proof.
    eapply soundness_X; eauto 350 with typeclass_instances.
  Qed.

  Eval compute in ("Type Soundness for Arith :+: Lambda :+: Boolean Proven!").

End Test_Section.


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This file collects common properties of pre-orders and semi lattices. This
theory will mainly be used for the theory on collections and finite maps. *)

From stdpp Require Export prelude.
Require Export base.

#[global] Instance preorder_equiv `{SubsetEq A} : Equiv A | 100 := λ X Y, X ⊆ Y ∧ Y ⊆ X.

(** * Partial orders *)
Section partial_order.
  Context `{SubsetEq A, !PartialOrder (@subseteq A _)}.
  Global Instance: LeibnizEquiv A.
  Proof. unfold LeibnizEquiv. intros * [? ?]. by apply (anti_symm (⊆)). Qed.
End partial_order.

Section join_semi_lattice.
  Context `{Empty A, JoinSemiLattice A, !EmptySpec A}.
  Implicit Types X Y : A.
  Implicit Types Xs Ys : list A.

  Local Instance: @Equivalence A (≡@{A}).
  Proof.
    split.
    * done.
    * by intros ?? [??].
    * by intros X Y Z [??] [??]; split; transitivity Y.
  Qed.

  Local Instance: Proper ((≡@{A}) ==> (≡@{A}) ==> (iff)) (⊆@{A}).
  Proof.
    unfold equiv, preorder_equiv. intros X1 Y1 ? X2 Y2 ?. split; intro.
    * transitivity X1. tauto. transitivity X2; tauto.
    * transitivity Y1. tauto. transitivity Y2; tauto.
  Qed.

  Local Hint Resolve subseteq_empty union_subseteq_l union_subseteq_r union_least: core.
  Lemma union_subseteq_l_transitive X1 X2 Y : X1 ⊆ X2 → X1 ⊆ X2 ∪ Y.
  Proof. intros. transitivity X2; auto. Qed.
  Lemma union_subseteq_r_transitive X1 X2 Y : X1 ⊆ X2 → X1 ⊆ Y ∪ X2.
  Proof. intros. transitivity X2; auto. Qed.
  Local Hint Resolve union_subseteq_l_transitive union_subseteq_r_transitive: core.
  Lemma union_preserving_l X Y1 Y2 : Y1 ⊆ Y2 → X ∪ Y1 ⊆ X ∪ Y2.
  Proof. auto. Qed.
  Lemma union_preserving_r X1 X2 Y : X1 ⊆ X2 → X1 ∪ Y ⊆ X2 ∪ Y.
  Proof. auto. Qed.
  Lemma union_preserving X1 X2 Y1 Y2 : X1 ⊆ X2 → Y1 ⊆ Y2 → X1 ∪ Y1 ⊆ X2 ∪ Y2.
  Proof. auto. Qed.
  Lemma union_empty X : X ∪ ∅ ⊆ X.
  Proof. by apply union_least. Qed.
  Global Instance union_proper : Proper ((≡@{A}) ==> (≡@{A}) ==> (≡@{A})) (∪).
  Proof.
    unfold equiv, preorder_equiv.
    split; apply union_preserving; simpl in *; tauto.
  Qed.
  Global Instance: IdemP (≡@{A}) (∪).
  Proof. split; eauto. Qed.
  Global Instance: LeftId (≡@{A}) ∅ (∪).
  Proof. split; eauto. Qed.
  Global Instance: RightId (≡@{A}) ∅ (∪).
  Proof. split; eauto. Qed.
  Global Instance: Comm (≡@{A}) (∪).
  Proof. split; auto. Qed.
  Global Instance: Assoc (≡@{A}) (∪).
  Proof. split; auto. Qed.
  Lemma subseteq_union X Y : X ⊆ Y ↔ X ∪ Y ≡ Y.
  Proof. repeat split; eauto. intros HXY. rewrite <-HXY. auto. Qed.
  Lemma subseteq_union_1 X Y : X ⊆ Y → X ∪ Y ≡ Y.
  Proof. apply subseteq_union. Qed.
  Lemma subseteq_union_2 X Y : X ∪ Y ≡ Y → X ⊆ Y.
  Proof. apply subseteq_union. Qed.
  Lemma equiv_empty X : X ⊆ ∅ → X ≡ ∅.
  Proof. split; eauto. Qed.
  Global Instance union_list_proper: Proper (Forall2 (≡@{A}) ==> (≡@{A})) union_list.
  Proof. induction 1; simpl. done. by apply union_proper. Qed.
  Lemma union_list_nil : ⋃ @nil A = ∅.
  Proof. done. Qed.
  Lemma union_list_cons X Xs : ⋃ (X :: Xs) = X ∪ ⋃ Xs.
  Proof. done. Qed.
  Lemma union_list_singleton X : ⋃ [X] ≡ X.
  Proof. simpl. by rewrite (right_id ∅ _). Qed.
  Lemma union_list_app Xs1 Xs2 : ⋃ (Xs1 ++ Xs2) ≡ ⋃ Xs1 ∪ ⋃ Xs2.
  Proof.
    induction Xs1 as [|X Xs1 IH]; simpl; [by rewrite (left_id ∅ _)|].
    by rewrite IH, (assoc _).
  Qed.
  Lemma union_list_reverse Xs : ⋃ (reverse Xs) ≡ ⋃ Xs.
  Proof.
    induction Xs as [|X Xs IH]; simpl; [done |].
    by rewrite reverse_cons, union_list_app,
      union_list_singleton, (comm _), IH.
  Qed.
  Lemma union_list_preserving Xs Ys : Xs ⊆* Ys → ⋃ Xs ⊆ ⋃ Ys.
  Proof. induction 1; simpl; auto using union_preserving. Qed.
  Lemma empty_union X Y : X ∪ Y ≡ ∅ ↔ X ≡ ∅ ∧ Y ≡ ∅.
  Proof.
    split.
    * intros HXY. split; apply equiv_empty;
        by transitivity (X ∪ Y); [auto | rewrite HXY].
    * intros [HX HY]. by rewrite HX, HY, (left_id _ _).
  Qed.
  Lemma empty_union_list Xs : ⋃ Xs ≡ ∅ ↔ Forall (.≡ ∅) Xs.
  Proof.
    split.
    * induction Xs; simpl; rewrite ?empty_union; intuition.
    * induction 1 as [|?? E1 ? E2]; simpl. done. by apply empty_union.
  Qed.

  Section leibniz.
    Context `{!LeibnizEquiv A}.
    Global Instance: IdemP (=@{A}) (∪).
    Proof. intros ?. unfold_leibniz. apply (idemp _). Qed.
    Global Instance: LeftId (=@{A}) ∅ (∪).
    Proof. intros ?. unfold_leibniz. apply (left_id _ _). Qed.
    Global Instance: RightId (=@{A}) ∅ (∪).
    Proof. intros ?. unfold_leibniz. apply (right_id _ _). Qed.
    Global Instance: Comm (=@{A}) (∪).
    Proof. intros ??. unfold_leibniz. apply (comm _). Qed.
    Global Instance: Assoc (=@{A}) (∪).
    Proof. intros ???. unfold_leibniz. apply (assoc _). Qed.
    Lemma subseteq_union_L X Y : X ⊆ Y ↔ X ∪ Y = Y.
    Proof. unfold_leibniz. apply subseteq_union. Qed.
    Lemma subseteq_union_1_L X Y : X ⊆ Y → X ∪ Y = Y.
    Proof. unfold_leibniz. apply subseteq_union_1. Qed.
    Lemma subseteq_union_2_L X Y : X ∪ Y = Y → X ⊆ Y.
    Proof. unfold_leibniz. apply subseteq_union_2. Qed.
    Lemma equiv_empty_L X : X ⊆ ∅ → X = ∅.
    Proof. unfold_leibniz. apply equiv_empty. Qed.
    Lemma union_list_singleton_L (X : A) : ⋃ [X] = X.
    Proof. unfold_leibniz. apply union_list_singleton. Qed.
    Lemma union_list_app_L (Xs1 Xs2 : list A) : ⋃ (Xs1 ++ Xs2) = ⋃ Xs1 ∪ ⋃ Xs2.
    Proof. unfold_leibniz. apply union_list_app. Qed.
    Lemma union_list_reverse_L (Xs : list A) : ⋃ (reverse Xs) = ⋃ Xs.
    Proof. unfold_leibniz. apply union_list_reverse. Qed.
    Lemma empty_union_L X Y : X ∪ Y = ∅ ↔ X = ∅ ∧ Y = ∅.
    Proof. unfold_leibniz. apply empty_union. Qed.
    Lemma empty_union_list_L Xs : ⋃ Xs = ∅ ↔ Forall (.= ∅) Xs.
    Proof. unfold_leibniz. by rewrite empty_union_list. Qed.
  End leibniz.

  Section dec.
    Context `{∀ X Y : A, Decision (X ⊆ Y)}.
    Lemma non_empty_union X Y : X ∪ Y ≢ ∅ ↔ X ≢ ∅ ∨ Y ≢ ∅.
    Proof. rewrite empty_union. destruct (decide (X ≡ ∅)); intuition. Qed.
    Lemma non_empty_union_list Xs : ⋃ Xs ≢ ∅ → Exists (.≢ ∅) Xs.
    Proof. rewrite empty_union_list. apply (not_Forall_Exists _). Qed.
    Context `{!LeibnizEquiv A}.
    Lemma non_empty_union_L X Y : X ∪ Y ≠ ∅ ↔ X ≠ ∅ ∨ Y ≠ ∅.
    Proof. unfold_leibniz. apply non_empty_union. Qed.
    Lemma non_empty_union_list_L Xs : ⋃ Xs ≠ ∅ → Exists (.≠ ∅) Xs.
    Proof. unfold_leibniz. apply non_empty_union_list. Qed.
  End dec.
End join_semi_lattice.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e416m2e208m1_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e322m2e161m1_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e130m5_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)

(*****************************************************************************)
(*  some doc here                                                            *)
(*****************************************************************************)

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrbool ssrfun eqtype ssrnat seq choice fintype finfun fingroup perm.
From mathcomp
Require Import div tuple bigop ssralg poly polydiv mxpoly ring_quotient.
From mathcomp
Require Import binomial bigop ssralg finalg zmodp matrix mxalgebra polyXY.
From mathcomp
Require Import generic_quotient.

From Newtonsums Require Import auxresults fraction truncpowerseries.

Import FracField.

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

Import GRing.Theory.
Local Open Scope ring_scope.
Local Open Scope quotient_scope.

Section ExpansibleFracpoly.

Variable K : fieldType.

Definition fracpoly_of of phant K := {fracpoly K}.
Notation "{ 'fracpoly' K }" := (fracpoly_of (Phant K)).

Definition devs : pred_class := fun f : {fracpoly K} => (~~ (0.-fppole) f).

Lemma devs_invf (p : {poly K}) : p != 0 -> (0.-fppole) p%:F^-1 = (p`_0 == 0).
Proof. by move => p_neq0; rewrite fpoleV -horner_coef0 froot_tofrac. Qed.

Lemma devs_inv1subCX (a : K) : devs (1 - a *: 'X)%:F^-1.
Proof.
by rewrite /devs devs_invf ?p_neq0 //; [rewrite -horner_coef0| exists 0];
rewrite -horner_evalE rmorphB /= !horner_evalE -mul_polyC hornerCM hornerX
                                                   mulr0 hornerC subr0 oner_neq0.
Qed.

Lemma devs_frac (p q : {poly K}) : (0.-fppole)(p // q) -> q`_0 == 0.
Proof. by move => ppq; rewrite -horner_coef0 -horner_evalE (den_fpole_eq0 ppq). Qed.

Lemma devsD (x y : {fracpoly K}) : devs x -> devs y -> devs (x + y).
Proof.
move: (fracpolyE x) => [[a b] /= Hx] /andP [b_neq0 coprime_a_b].
move: (fracpolyE y) => [[c d] /= Hy] /andP [d_neq0 coprime_c_d].
rewrite Hx Hy addf_div ?raddf_eq0 //; last 2 first.
+ exact: tofrac_inj.
+ exact: tofrac_inj.
rewrite /devs !coprimep_fpole // !horner_coef0 => b0_neq0 d0_neq0.
rewrite -!rmorphM -rmorphD /=.
have: (b * d)`_0 != 0 by rewrite coef0M mulf_neq0 // -horner_coef0.
by apply/contra; apply: devs_frac.
Qed.

Lemma devsM (x y : {fracpoly K}) : devs x -> devs y -> devs (x * y).
Proof.
move: (fracpolyE x) => [[a b] /= Hx] /andP [b_neq0 coprime_a_b].
move: (fracpolyE y) => [[c d] /= Hy] /andP [d_neq0 coprime_c_d].
rewrite Hx Hy mulf_div -!rmorphM /=.
rewrite /devs coprimep_fpole // coprimep_fpole // !horner_coef0 => b0_neq0 d0_neq0.
have: (b * d)`_0 != 0 by rewrite coef0M mulf_neq0 // -horner_coef0.
by apply/contra; apply: devs_frac.
Qed.

Lemma devsN (x : {fracpoly K}) : devs x -> devs (-x).
Proof. by rewrite /devs fpoleN. Qed.

Lemma devsB (x y : {fracpoly K}) : devs x -> devs y -> devs (x - y).
Proof. by move => dx dy; rewrite devsD // devsN. Qed.

Variable n : nat.

Definition Tfpsfp (x : {fracpoly K}) :=
  if (0.-fppole) x then 0
  else let (x1, x2) := projT1 (fracpolyE x) in (Tfpsp n x1) / (Tfpsp n x2).

Lemma Tfpsfp0 : Tfpsfp 0 = 0.
Proof.
rewrite /Tfpsfp ; case: ((0.-fppole) 0) => //=.
move: (fracpolyE (0 : {fracpoly K}))
                                   => [[u v] /= Hx] /andP [v_neq0 coprime_u_v].
move/eqP: Hx ; rewrite eq_sym mulf_eq0 invr_eq0 !raddf_eq0; last 2 first.
+ exact: tofrac_inj.
+ exact: tofrac_inj.
move/negbTE: v_neq0 -> ; rewrite orbF => /eqP ->.
by rewrite rmorph0 mul0r.
Qed.

Lemma Tfpsfp_frac (p q : {poly K}) :
     q`_0 != 0 -> Tfpsfp (p // q) = (Tfpsp n p) / (Tfpsp n q).
Proof.
move => q0_neq0 ; rewrite /Tfpsfp.
have -> : (0.-fppole) (p // q) = false.
  apply/negbTE; move: q0_neq0; apply/contra.
  exact: devs_frac.
have q_neq0 : q != 0 by apply: p_neq0; exists 0; rewrite horner_coef0.
move: (fracpolyE (p // q)) => [[u v] /= Hx] /andP [v_neq0 coprime_u_v].
have v0_neq0 : v`_0 != 0.
  rewrite -horner_coef0 -(@coprimep_fpole K _ _ _ v_neq0 coprime_u_v) -Hx.
  have -> : (0.-fppole) (p // q) = false.
    apply/negbTE; move: q0_neq0; apply/contra.
    exact: devs_frac.
  by [].
apply/eqP ; rewrite eq_divr ?Tfpsp_is_unit // -!rmorphM.
apply/eqP ; apply: (congr1 _) ; apply/eqP.
apply/eqP/tofrac_inj/eqP.
rewrite !rmorphM /= -eq_divf ?raddf_eq0 //; last 2 first.
+ exact: tofrac_inj.
+ exact: tofrac_inj.
by apply/eqP ; symmetry.
Qed.

Fact Tfpsfp1 : Tfpsfp 1 = 1.
Proof.
rewrite /Tfpsfp.
move: (fracpolyE (1 : {fracpoly K}))=> [[u v] /= Hx] /andP [v_neq0 cop_u_v].
have: exists (c : K), (u == c%:P) && (v == c%:P) && (c != 0).
  move/eqP: Hx ; rewrite eq_sym.
  move/eqP/(congr1 (fun x => x*v%:F)).
  rewrite mul1r mulrAC -mulrA divff ?mulr1; last first.
    by rewrite raddf_eq0 //; apply: tofrac_inj.
  move/tofrac_inj => u_eq_v.
  move: cop_u_v ; rewrite u_eq_v coprimepp.
  move/size_poly1P => [c c_neq0 v_eq_cP] ; exists c.
  by rewrite c_neq0 andbb andbT v_eq_cP.
move => [c /andP [/andP [/eqP -> /eqP ->] c_neq0]].
by rewrite -tofrac1 fpole_tofrac divrr // Tfpsp_is_unit coefC eqxx.
Qed.

Lemma Tfpsfp_tofrac (p : {poly K}) : Tfpsfp p %:F = Tfpsp n p.
Proof.
rewrite -[p%:F]divr1 -tofrac1 Tfpsfp_frac.
+ by rewrite rmorph1 divr1.
+ by rewrite -horner_coef0 hornerC oner_neq0.
Qed.

Lemma Tfpsfp_inv_tofrac (p : {poly K}) :
                  p`_0 != 0 -> Tfpsfp ((p %:F) ^-1) = (Tfpsp n p) ^-1.
Proof.
move => p0_neq0.
rewrite -[p%:F^-1]mul1r -tofrac1 Tfpsfp_frac //.
  by rewrite rmorph1 mul1r.
Qed.

Lemma TfpsfpM : {in devs &, {morph Tfpsfp: x y  / x * y}}.
Proof.
move => x y.
move: (fracpolyE x) => [[a b] /= Hx] /andP [b_neq0 coprime_a_b].
move: (fracpolyE y) => [[c d] /= Hy] /andP [d_neq0 coprime_c_d].
rewrite /devs -!topredE /= Hx Hy !coprimep_fpole // !horner_coef0 => b0_neq0 d0_neq0.
rewrite mulf_div -!rmorphM /= [LHS]Tfpsfp_frac ; last first.
  by rewrite coef0M mulf_neq0.
rewrite !Tfpsfp_frac // !rmorphM /=.
by rewrite mulr_div ?Tfpsp_is_unit.
Qed.

Lemma TfpsfpD : {in devs &, {morph Tfpsfp: x y  / x + y}}.
Proof.
move => x y ; rewrite -!topredE.
move: (fracpolyE x) => [[a b] /= Hx] /andP [b_neq0 coprime_a_b].
move: (fracpolyE y) => [[c d] /= Hy] /andP [d_neq0 coprime_c_d].
rewrite /devs Hx Hy !coprimep_fpole // !horner_coef0 => b0_neq0 d0_neq0.
rewrite addf_div ?raddf_eq0 //; last 2 first.
+ exact: tofrac_inj.
+ exact: tofrac_inj.
rewrite -!rmorphM -rmorphD [LHS]Tfpsfp_frac; last first.
  by rewrite coef0M mulf_neq0.
rewrite rmorphD !rmorphM /= !Tfpsfp_frac //.
by rewrite addr_div ?Tfpsp_is_unit.
Qed.

Lemma TfpsfpN : {in devs, {morph Tfpsfp: x / - x >-> - x}}.
Proof.
move => x ; rewrite -topredE.
move: (fracpolyE x) => [[a b] /= Hx] /andP [b_neq0 coprime_a_b].
rewrite /devs Hx !coprimep_fpole // => b0_neq0.
rewrite -mulNr -rmorphN [LHS]Tfpsfp_frac -?horner_coef0 //.
by rewrite Tfpsfp_frac -?horner_coef0 // rmorphN mulNr.
Qed.

Lemma TfpsfpB : {in devs &, {morph Tfpsfp: x y  / x - y}}.
Proof.
move => x y xd yd.
by rewrite -TfpsfpN // -TfpsfpD // /devs -topredE /= fpoleN.
Qed.

Lemma Tfpsfp_eq0 (u v : {poly K}) : v`_0 = 0 -> coprimep u v ->
  Tfpsfp (u // v) = 0.
Proof.
move => /eqP v0_eq0 coprime_u_v.
have [-> | v_neq0] := eqVneq v 0 ;
                          first by rewrite rmorph0 invr0 mulr0 Tfpsfp0.
by rewrite /Tfpsfp coprimep_fpole // horner_coef0 v0_eq0.
Qed.

Fact devs_subring_closed : GRing.subring_closed devs.
Proof.
split; first by rewrite /devs -topredE /= fpole1.
+ by move => f g; rewrite -!topredE; apply: devsB.
+ by move => f g; rewrite -!topredE; apply: devsM.
Qed.

Fact devs_key : pred_key devs. Proof. by []. Qed.

Canonical devs_keyed := KeyedPred devs_key.
Canonical devs_opprPred := OpprPred devs_subring_closed.
Canonical devs_addrPred := AddrPred devs_subring_closed.
Canonical devs_zmodPred := ZmodPred devs_subring_closed.
Canonical devs_mulrPred := MulrPred devs_subring_closed.
Canonical devs_subringPred := SubringPred devs_subring_closed.

(* tests *)
Fact devs0 : devs 0.
Proof. by rewrite -unfold_in rpred0. Qed.

End ExpansibleFracpoly.

Local Notation "f ^ g" := (map_tfps g f).
Local Notation "p ^^^ f" := (map_frac (map_poly f) p)
                              (f at next level, at level 30).

(* Variables (K L : fieldType) (iota : {injmorphism K -> L}). *)

Lemma map_Tfpsfp (K L : fieldType) (iota : {injmorphism K -> L}) (n : nat) (x : {fracpoly K}) :
    map_tfps iota (Tfpsfp n x) = Tfpsfp n (x ^^^ iota).
Proof.
move: (fracpolyE x) => [ [u v] /= Hx ] /andP [ v_neq0 coprime_u_v ].
rewrite Hx fmorph_div /= !map_fracE /=.
have [ v0_eq0 | v0_neq0 ] := eqVneq v`_0 0; last first.
+ rewrite Tfpsfp_frac // Tfpsfp_frac; last first.
    by rewrite coef_map raddf_eq0 //; apply: fmorph_inj.
+ by rewrite rmorph_div /= ?Tfpsp_is_unit // !Tfps_map_poly.
by rewrite !Tfpsfp_eq0 // ?coef_map ?v0_eq0 /= ?rmorph0 // coprimep_map.
Qed.


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

(** ** FRACTRAN reduces to Diophantine logic *)

Require Import List Arith Omega.

Require Import ILL.Definitions.

Require Import utils_tac pos vec.
Require Import fractran_defs MM_FRACTRAN.
Require Import dio_logic fractran_dio dio_elem dio_single.

Set Implicit Arguments.

(** A diophantine logic satisfiability question is given
    a diophantine logic formula f and a valuation for the
    parameters. Is the formula valid ? *)

Definition DIO_LOGIC_PROBLEM := (dio_formula * (nat -> nat))%type.

Definition DIO_LOGIC_SAT : DIO_LOGIC_PROBLEM -> Prop.
Proof.
  intros (A,v).
  exact (df_pred A v).
Defined.

Section FRACTRAN_HALTING_DIO_LOGIC_SAT.

  Let f : FRACTRAN_PROBLEM -> DIO_LOGIC_PROBLEM.
  Proof.
    intros (l & x).
    destruct FRACTRAN_HALTING_on_diophantine with (ll := l) (x := fun _ : nat -> nat => x)
      as (A & HA).
    + auto.
    + exact (A, fun _ => 0).
  Defined.

  Opaque FRACTRAN_HALTING_on_diophantine.

  Theorem FRACTRAN_HALTING_DIO_LOGIC_SAT : FRACTRAN_HALTING ⪯ DIO_LOGIC_SAT.
  Proof.
    exists f.
    intros (l & x); simpl.
    destruct FRACTRAN_HALTING_on_diophantine with (ll := l) as (A & HA); simpl.
    unfold DIO_LOGIC_SAT; rewrite HA; tauto.
  Qed.

End FRACTRAN_HALTING_DIO_LOGIC_SAT.

(** An elementary diophantine problem is a list of elementary diophantine
    constraints and a valuation for the parameters. The question is whether
    there exists a valuation for the variables that satisfies all the constraints
    simultaneously *)

Definition DIO_ELEM_PROBLEM := (list dio_constraint * (nat -> nat))%type.

Definition DIO_ELEM_SAT : DIO_ELEM_PROBLEM -> Prop.
Proof.
  intros (l,v).
  exact (exists φ, Forall (dc_eval φ v) l).
Defined.

Section DIO_LOGIC_ELEM_SAT.

  Let f : DIO_LOGIC_PROBLEM -> DIO_ELEM_PROBLEM.
  Proof.
    intros (A,v).
    destruct (dio_formula_elem A) as (l & _ & _ & H3).
    exact (l,v).
  Defined.

  Theorem DIO_LOGIC_ELEM_SAT : DIO_LOGIC_SAT ⪯  DIO_ELEM_SAT.
  Proof.
    exists f; intros (A,v); unfold DIO_LOGIC_SAT, DIO_ELEM_SAT, f.
    destruct (dio_formula_elem A) as (l & _ & _ & H3); simpl; auto.
  Qed.

End DIO_LOGIC_ELEM_SAT.

Definition DIO_SINGLE_PROBLEM := (dio_single nat nat * (nat -> nat))%type.

Definition DIO_SINGLE_SAT : DIO_SINGLE_PROBLEM -> Prop.
Proof.
  intros (e,v).
  apply (dio_single_pred e v).
Defined.

Section DIO_ELEM_SINGLE_SAT.

  Let f : DIO_ELEM_PROBLEM -> DIO_SINGLE_PROBLEM.
  Proof.
    intros (l,v).
    destruct (dio_elem_equation l) as (e & _ & H1).
    exact (e,v).
  Defined.

  Theorem DIO_ELEM_SINGLE_SAT : DIO_ELEM_SAT ⪯ DIO_SINGLE_SAT.
  Proof.
    exists f; intros (l,v).
    unfold DIO_ELEM_SAT, DIO_SINGLE_SAT, f.
    destruct (dio_elem_equation l) as (e & _ & H1).
    rewrite H1; tauto.
  Qed.

End DIO_ELEM_SINGLE_SAT.


(*
Copyright 2010 IMDEA Software Institute
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)

(******************************************************************************)
(* This file defines heaps as possibly undefined finite maps from pointer     *)
(* type to dynamic type.                                                      *)
(* Heaps are a special case of Partial Commutative Monoids (pcm)              *)
(******************************************************************************)

From Coq Require Import ssreflect ssrbool ssrfun Eqdep.
From mathcomp Require Import ssrnat eqtype seq path.
From fcsl Require Import axioms ordtype pcm finmap unionmap.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(*************)
(* Locations *)
(*************)

Inductive ptr := ptr_nat of nat.

Definition null := ptr_nat 0.

Definition nat_ptr (x : ptr) := let: ptr_nat y := x in y.

Definition eq_ptr (x y : ptr) : bool :=
  match x, y with ptr_nat m, ptr_nat n => m == n end.

Lemma eq_ptrP : Equality.axiom eq_ptr.
Proof. by case=>x [y] /=; case: eqP=>[->|*]; constructor=>//; case. Qed.

Definition ptr_eqMixin := EqMixin eq_ptrP.
Canonical ptr_eqType := EqType ptr ptr_eqMixin.

(* some pointer arithmetic: offsetting from a base *)

Definition ptr_offset x i := ptr_nat (nat_ptr x + i).

Notation "x .+ i" := (ptr_offset x i)
  (at level 3, format "x .+ i").

Lemma ptrE x y : (x == y) = (nat_ptr x == nat_ptr y).
Proof. by move: x y=>[x][y]. Qed.

Lemma ptr0 x : x.+0 = x.
Proof. by case: x=>x; rewrite /ptr_offset addn0. Qed.

Lemma ptrA x i j : x.+i.+j = x.+(i+j).
Proof. by case: x=>x; rewrite /ptr_offset addnA. Qed.

Lemma ptrK x i j : (x.+i == x.+j) = (i == j).
Proof. by case: x=>x; rewrite ptrE eqn_add2l. Qed.

Lemma ptr_null x m : (x.+m == null) = (x == null) && (m == 0).
Proof. by case: x=>x; rewrite !ptrE addn_eq0. Qed.

Lemma ptrT x y : {m : nat | (x == y.+m) || (y == x.+m)}.
Proof.
case: x y=>x [y]; exists (if x <= y then (y - x) else (x - y)).
rewrite !ptrE leq_eqVlt /=.
by case: (ltngtP x y)=>/= E; rewrite subnKC ?(ltnW E) ?eq_refl ?orbT // E.
Qed.

Definition ltn_ptr (x y : ptr) :=
  match x, y with ptr_nat m, ptr_nat n => m < n end.

Lemma ltn_ptr_irr : irreflexive ltn_ptr.
Proof. by case=>x /=; rewrite ltnn. Qed.

Lemma ltn_ptr_trans : transitive ltn_ptr.
Proof. by case=>x [y][z]; apply: ltn_trans. Qed.

Lemma ltn_ptr_total : forall x y : ptr, [|| ltn_ptr x y, x == y | ltn_ptr y x].
Proof. by case=>x [y]; rewrite ptrE /=; case: ltngtP. Qed.

Definition ptr_ordMixin := OrdMixin ltn_ptr_irr ltn_ptr_trans ltn_ptr_total.
Canonical ptr_ordType := OrdType ptr ptr_ordMixin.

(*********)
(* Heaps *)
(*********)

Module Heap.

Inductive heap :=
  Undef | Def (finmap : {finMap ptr -> dynamic id}) of
               null \notin supp finmap.

Section NullLemmas.
Variables (f g : {finMap ptr -> dynamic id}) (x : ptr) (v : dynamic id).

Lemma upd_nullP :
        x != null -> null \notin supp f -> null \notin supp (ins x v f).
Proof. by move=>H1 H2; rewrite supp_ins negb_or /= inE /= eq_sym H1. Qed.

Lemma free_nullP : null \notin supp f -> null \notin supp (rem x f).
Proof. by move=>H; rewrite supp_rem negb_and /= H orbT. Qed.

Lemma un_nullP :
        null \notin supp f -> null \notin supp g ->
          null \notin supp (fcat f g).
Proof. by move=>H1 H2; rewrite supp_fcat negb_or H1 H2. Qed.

Lemma filt_nullP (q : pred ptr) :
        null \notin supp f -> null \notin supp (kfilter q f).
Proof. by move=>H; rewrite supp_kfilt mem_filter negb_and H orbT. Qed.

Lemma heap_base : null \notin supp f -> all (fun k => k != null) (supp f).
Proof. by move=>H; apply/allP=>k; case: eqP H=>// -> /negbTE ->. Qed.

Lemma base_heap : all (fun k => k != null) (supp f) -> null \notin supp f.
Proof. by move/allP=>H; apply: (introN idP); move/H. Qed.

Lemma heapE (h1 h2 : heap) :
        h1 = h2 <->
        match h1, h2 with
          Def f' pf, Def g' pg => f' = g'
        | Undef, Undef => true
        | _, _ => false
        end.
Proof.
split; first by move=>->; case: h2.
case: h1; case: h2=>// f1 pf1 f2 pf2 E.
rewrite {f2}E in pf1 pf2 *.
by congr Def; apply: bool_irrelevance.
Qed.

End NullLemmas.

(* methods *)

Definition def h := if h is Def _ _ then true else false.

Definition empty := @Def (finmap.nil _ _) is_true_true.

Definition upd k v h :=
  if h is Def hs ns then
    if decP (@idP (k != null)) is left pf then
      Def (@upd_nullP _ _ v pf ns)
    else Undef
  else Undef.

Definition dom h : seq ptr :=
  if h is Def f _ then supp f else [::].

Definition dom_eq h1 h2 :=
  match h1, h2 with
    Def f1 _, Def f2 _ => supp f1 == supp f2
  | Undef, Undef => true
  | _, _ => false
  end.

Definition free x h :=
  if h is Def hs ns then Def (free_nullP x ns) else Undef.

Definition find (x : ptr) h :=
  if h is Def hs _ then fnd x hs else None.

Definition union h1 h2 :=
  if (h1, h2) is (Def hs1 ns1, Def hs2 ns2) then
    if disj hs1 hs2 then
       Def (@un_nullP _ _ ns1 ns2)
    else Undef
  else Undef.

Definition um_filter q f :=
  if f is Def fs pf then Def (@filt_nullP fs q pf) else Undef.

Definition pts (x : ptr) v := upd x v empty.

Definition empb h := if h is Def hs _ then supp hs == [::] else false.

Definition undefb h := if h is Undef then true else false.

Definition keys_of h : seq ptr :=
  if h is Def f _ then supp f else [::].

Local Notation base :=
  (@UM.base ptr_ordType (dynamic id) (fun k => k != null)).

Definition from (f : heap) : base :=
  if f is Def hs ns then UM.Def (heap_base ns) else UM.Undef _ _.

Definition to (b : base) : heap :=
  if b is UM.Def hs ns then Def (base_heap ns) else Undef.

Lemma ftE b : from (to b) = b.
Proof. by case: b=>// f H; rewrite UM.umapE. Qed.

Lemma tfE f : to (from f) = f.
Proof. by case: f=>// f H; rewrite heapE. Qed.

Lemma undefE : Undef = to (@UM.Undef _ _ _).
Proof. by []. Qed.

Lemma defE f : def f = UM.valid (from f).
Proof. by case: f. Qed.

Lemma emptyE : empty = to (@UM.empty _ _ _).
Proof. by rewrite heapE. Qed.

Lemma updE k v f : upd k v f = to (UM.upd k v (from f)).
Proof. by case: f=>[|f H] //=; case: decP=>// H1; rewrite heapE. Qed.

Lemma domE f : dom f = UM.dom (from f).
Proof. by case: f. Qed.

Lemma dom_eqE f1 f2 : dom_eq f1 f2 = UM.dom_eq (from f1) (from f2).
Proof. by case: f1 f2=>[|f1 H1][|f2 H2]. Qed.

Lemma freeE k f : free k f = to (UM.free k (from f)).
Proof. by case: f=>[|f H] //; rewrite heapE. Qed.

Lemma findE k f : find k f = UM.find k (from f).
Proof. by case: f. Qed.

Lemma unionE f1 f2 : union f1 f2 = to (UM.union (from f1) (from f2)).
Proof.
case: f1 f2=>[|f1 H1][|f2 H2] //; rewrite /union /UM.union /=.
by case: ifP=>D //; rewrite heapE.
Qed.

Lemma umfiltE q f : um_filter q f = to (UM.um_filter q (from f)).
Proof. by case: f=>[|f H] //; rewrite heapE. Qed.

Lemma empbE f : empb f = UM.empb (from f).
Proof. by case: f. Qed.

Lemma undefbE f : undefb f = UM.undefb (from f).
Proof. by case: f. Qed.

Lemma ptsE k (v : dynamic id) : pts k v = to (@UM.pts _ _ _ k v).
Proof.
by rewrite /pts /UM.pts /UM.upd /=; case: decP=>// H; rewrite heapE.
Qed.

Module Exports.

(* the inheritance from PCMs *)

Definition heapUMCMix :=
  UMCMixin ftE tfE defE undefE emptyE updE domE dom_eqE freeE
           findE unionE umfiltE empbE undefbE ptsE.
Canonical heapUMC := Eval hnf in UMC heap heapUMCMix.

Definition heapPCMMix := union_map_classPCMMix heapUMC.
Canonical heapPCM := Eval hnf in PCM heap heapPCMMix.

Definition heapCPCMMix := union_map_classCPCMMix heapUMC.
Canonical heapCPCM := Eval hnf in CPCM heap heapCPCMMix.

Definition heapTPCMMix := union_map_classTPCMMix heapUMC.
Canonical heapTPCM := Eval hnf in TPCM heap heapTPCMMix.

End Exports.

End Heap.

Export Heap.Exports.

Notation heap := Heap.heap.

Definition heap_pts A (x : ptr) (v : A) :=
  @UMC.pts _ _ heapUMC x (idyn v).

Notation "x :-> v" := (@heap_pts _ x v) (at level 30).

(*****************************)
(* Specific points-to lemmas *)
(*****************************)

Section HeapPointsToLemmas.
Implicit Types (x : ptr) (h : heap).

Lemma hcancelPtT A1 A2 x (v1 : A1) (v2 : A2) :
        valid (x :-> v1) -> x :-> v1 = x :-> v2 -> A1 = A2.
Proof. by move=>V /(cancelPt V)/dyn_injT. Qed.

Lemma hcancelPtT2 A1 A2 x1 x2 (v1 : A1) (v2 : A2) :
        valid (x1 :-> v1) -> x1 :-> v1 = x2 :-> v2 -> (x1, A1) = (x2, A2).
Proof. by move=>V; case/(cancelPt2 V)=>-> E _; rewrite E. Qed.

Lemma hcancelPtV A x (v1 v2 : A) :
        valid (x :-> v1) -> x :-> v1 = x :-> v2 -> v1 = v2.
Proof. by move=>V; move/(cancelPt V)/dyn_inj. Qed.

Lemma hcancelPtV2 A x1 x2 (v1 v2 : A) :
        valid (x1 :-> v1) -> x1 :-> v1 = x2 :-> v2 -> (x1, v1) = (x2, v2).
Proof. by move=>V /(cancelPt2 V) [->] /dyn_inj ->. Qed.

Lemma heap_eta x h :
        x \in dom h -> exists A (v : A),
        find x h = Some (idyn v) /\ h = x :-> v \+ free x h.
Proof. by case/um_eta; case=>A v H; exists A, v. Qed.

Lemma heap_eta2 A x h (v : A) :
        find x h = Some (idyn v) -> h = x :-> v \+ free x h.
Proof.
move=>E; case: (heap_eta (find_some E))=>B [w][].
rewrite {}E; case=>E; rewrite -E in w *.
by move/(@inj_pair2 _ _ _ _ _)=>->.
Qed.

Lemma hcancelT A1 A2 x (v1 : A1) (v2 : A2) h1 h2 :
        valid (x :-> v1 \+ h1) ->
        x :-> v1 \+ h1 = x :-> v2 \+ h2 -> A1 = A2.
Proof. by move=>V; case/(cancel V); move/dyn_injT. Qed.

Lemma hcancelV A x (v1 v2 : A) h1 h2 :
        valid (x :-> v1 \+ h1) ->
        x :-> v1 \+ h1 = x :-> v2 \+ h2 -> [/\ v1 = v2, valid h1 & h1 = h2].
Proof. by move=>V; case/(cancel V); move/dyn_inj. Qed.

Lemma hcancel2V A x1 x2 (v1 v2 : A) h1 h2 :
        valid (x1 :-> v1 \+ h1) ->
        x1 :-> v1 \+ h1 = x2 :-> v2 \+ h2 ->
        if x1 == x2 then v1 = v2 /\ h1 = h2
        else [/\ free x1 h2 = free x2 h1,
                 h1 = x2 :-> v2 \+ free x1 h2 &
                 h2 = x1 :-> v1 \+ free x2 h1].
Proof. by move=>V /(cancel2 V); case: ifP=>// _ [/dyn_inj]. Qed.

End HeapPointsToLemmas.

Prenex Implicits heap_eta2.

(******************************************)
(* additional stuff, on top of union maps *)
(* mostly random stuff, kept for legacy   *)
(* should be removed/redone eventually    *)
(******************************************)

Definition fresh (h : heap) :=
  (if h is Heap.Def hs _ then last null (supp hs) else null) .+ 1.

Definition pick (h : heap) :=
  if h is Heap.Def hs _ then head null (supp hs) else null.

(*********)
(* fresh *)
(*********)

Lemma path_last_nat n s x : path ord x s -> ord x (last x s).+(n+1).
Proof.
move: n s x.
suff L: forall s x, path ord x s -> ord x (last x s).+(1).
- elim=>[|n IH] // s x; move/IH=>E; apply: trans E _.
  by case: (last x s)=>m; rewrite /ord /= addSn (addnS m).
elim=>[|y s IH x] /=; first by case=>x; rewrite /ord /= addn1.
by case/andP=>H1; move/IH; apply: trans H1.
Qed.

Lemma path_filter (A : ordType) (s : seq A) (p : pred A) x :
        path ord x s -> path ord x (filter p s).
Proof.
elim: s x=>[|y s IH] x //=.
case/andP=>H1 H2.
case: ifP=>E; first by rewrite /= H1 IH.
apply: IH; elim: s H2=>[|z s IH] //=.
by case/andP=>H2 H3; rewrite (@trans _ y).
Qed.

Lemma dom_fresh h n : (fresh h).+n \notin dom h.
Proof.
suff L2: forall h x, x \in dom h -> ord x (fresh h).
- by apply: (contra (L2 _ _)); rewrite -leqNgt leq_addr.
case=>[|[s H1]] //; rewrite /supp => /= H2 x.
rewrite /dom /fresh /supp /=.
elim: s H1 null H2 x=>[|[y d] s IH] //= H1 x.
rewrite inE negb_or; case/andP=>H3 H4 z; rewrite inE.
case/orP; first by move/eqP=>->{z}; apply: (path_last_nat 0).
by apply: IH; [apply: path_sorted H1 | apply: notin_path H1].
Qed.

Lemma fresh_null h : fresh h != null.
Proof. by rewrite -lt0n addn1. Qed.

Opaque fresh.

Hint Resolve dom_fresh fresh_null : core.

(********)
(* pick *)
(********)

Lemma emp_pick (h : heap) : (pick h == null) = (~~ valid h || empb h).
Proof.
rewrite /empb; case: h=>[|h] //=; case: (supp h)=>[|x xs] //=.
by rewrite inE negb_or eq_sym; case/andP; move/negbTE=>->.
Qed.

Lemma pickP h : valid h && ~~ empb h = (pick h \in dom h).
Proof.
rewrite /dom /empb; case: h=>[|h] //=.
by case: (supp h)=>// *; rewrite inE eq_refl.
Qed.

(***********************)
(* Some derived lemmas *)
(***********************)

Lemma domPtUnX A (v : A) x i : valid (x :-> v \+ i) -> x \in dom (x :-> v \+ i).
Proof. by move=>D; rewrite domPtUn inE /= D eq_refl. Qed.

Lemma domPtX A (v : A) x : valid (x :-> v) -> x \in dom (x :-> v).
Proof. by move=>D; rewrite -(unitR (x :-> v)) domPtUnX // unitR. Qed.

(*******************************************)
(* Block update for reasoning about arrays *)
(*******************************************)

Section BlockUpdate.
Variable (A : Type).

Fixpoint updi x (vs : seq A) {struct vs} : heap :=
  if vs is v'::vs' then x :-> v' \+ updi (x .+ 1) vs' else Unit.

Lemma updiS x v vs : updi x (v :: vs) = x :-> v \+ updi (x .+ 1) vs.
Proof. by []. Qed.

Lemma updi_last x v vs :
        updi x (rcons vs v) = updi x vs \+ x.+(size vs) :-> v.
Proof.
elim: vs x v=>[|w vs IH] x v /=.
- by rewrite ptr0 unitR unitL.
by rewrite -(addn1 (size vs)) addnC -ptrA IH joinA.
Qed.

Lemma updi_cat x vs1 vs2 :
        updi x (vs1 ++ vs2) = updi x vs1 \+ updi x.+(size vs1) vs2.
Proof.
elim: vs1 x vs2=>[|v vs1 IH] x vs2 /=.
- by rewrite ptr0 unitL.
by rewrite -(addn1 (size vs1)) addnC -ptrA IH joinA.
Qed.

Lemma updi_catI x y vs1 vs2 :
        y = x.+(size vs1) -> updi x vs1 \+ updi y vs2 = updi x (vs1 ++ vs2).
Proof. by move=>->; rewrite updi_cat. Qed.

(* helper lemma *)
Lemma updiVm' x m xs : m > 0 -> x \notin dom (updi x.+m xs).
Proof.
elim: xs x m=>[|v vs IH] x m //= H.
rewrite ptrA domPtUn inE /= negb_and negb_or -{4}(ptr0 x) ptrK -lt0n H /=.
by rewrite orbC IH // addn1.
Qed.

Lemma updiD x xs : valid (updi x xs) = (x != null) || (size xs == 0).
Proof.
elim: xs x=>[|v xs IH] x //=; first by rewrite orbC.
by rewrite validPtUn updiVm' // orbF IH ptr_null andbF andbC.
Qed.

Lemma updiVm x m xs :
        x \in dom (updi x.+m xs) = [&& x != null, m == 0 & size xs > 0].
Proof.
case: m=>[|m] /=; last first.
- by rewrite andbF; apply/negbTE/updiVm'.
case: xs=>[|v xs]; rewrite ptr0 ?andbF ?andbT //=.
by rewrite domPtUn inE /= eq_refl -updiS updiD orbF andbT /=.
Qed.

Lemma updimV x m xs :
        x.+m \in dom (updi x xs) = (x != null) && (m < size xs).
Proof.
case H: (x == null)=>/=.
- by case: xs=>// a s; rewrite (eqP H).
elim: xs x m H=>[|v vs IH] x m H //; case: m=>[|m].
- by rewrite ptr0 /= domPtUn inE /= eq_refl andbT -updiS updiD H.
rewrite -addn1 addnC -ptrA updiS domPtUn inE /= IH; last first.
- by rewrite ptrE /= addn1.
by rewrite -updiS updiD H /= -{1}(ptr0 x) ptrA ptrK.
Qed.

Lemma updiP x y xs :
        reflect (y != null /\ exists m, x = y.+m /\ m < size xs)
                (x \in dom (updi y xs)).
Proof.
case H: (y == null)=>/=.
- by rewrite (eqP H); elim: xs=>[|z xs IH] //=; constructor; case.
case E: (x \in _); constructor; last first.
- by move=>[_][m][H1] H2; rewrite H1 updimV H2 H in E.
case: (ptrT x y) E=>m; case/orP; move/eqP=>->.
- by rewrite updimV H /= => H1; split=>//; exists m.
rewrite updiVm; case/and3P=>H1; move/eqP=>-> H2.
by split=>//; exists 0; rewrite ptrA addn0 ptr0.
Qed.

(* Invertibility *)
Lemma updi_inv x xs1 xs2 :
        valid (updi x xs1) -> updi x xs1 = updi x xs2 -> xs1 = xs2.
Proof.
elim: xs1 x xs2 =>[|v1 xs1 IH] x /=; case=>[|v2 xs2] //= D;
[move/esym| |]; try by rewrite empbE empbUn empbPt.
by case/(hcancelV D)=><- {D} D /(IH _ _ D) <-.
Qed.

Lemma updi_iinv x xs1 xs2 h1 h2 :
        size xs1 = size xs2 -> valid (updi x xs1 \+ h1) ->
        updi x xs1 \+ h1 = updi x xs2 \+ h2 -> xs1 = xs2 /\ h1 = h2.
Proof.
elim: xs1 x xs2 h1 h2=>[|v1 xs1 IH] x /=; case=>[|v2 xs2] //= h1 h2.
- by rewrite !unitL.
move=>[E]; rewrite -!joinA=>D; case/(hcancelV D)=><- {D} D.
by case/(IH _ _ _ _ E D)=>->->.
Qed.

End BlockUpdate.

Lemma domeqUP A1 A2 x (xs1 : seq A1) (xs2 : seq A2) :
        size xs1 = size xs2 -> dom_eq (updi x xs1) (updi x xs2).
Proof.
move=>E; apply/domeqP; split; first by rewrite !updiD E.
move=>z; case: updiP=>[[H][m][->]|X]; first by rewrite updimV H E.
by case: updiP=>// [[H]][m][Ez S]; elim: X; split=>//; exists m; rewrite Ez E.
Qed.

(*************************************)
(* the automation of the PtUn lemmas *)
(*************************************)

(* First, the mechanism for search-and-replace for the overloaded lemas, *)
(* pattern-matching on heap expressions.                                 *)

Structure tagged_heap := Tag {untag :> heap}.

Definition right_tag := Tag.
Definition left_tag := right_tag.
Canonical found_tag i := left_tag i.

Definition partition_axiom k r (h : tagged_heap) := untag h = k \+ r.

Structure partition (k r : heap) :=
  Partition {heap_of :> tagged_heap;
             _ : partition_axiom k r heap_of}.

Lemma partitionE r k (f : partition k r) : untag f = k \+ r.
Proof. by case: f=>[[j]] /=; rewrite /partition_axiom /= => ->. Qed.

Lemma found_pf k : partition_axiom k Unit (found_tag k).
Proof. by rewrite /partition_axiom unitR. Qed.

Canonical found_struct k := Partition (found_pf k).

Lemma left_pf h r (f : forall k, partition k r) k :
        partition_axiom k (r \+ h) (left_tag (untag (f k) \+ h)).
Proof. by rewrite partitionE /partition_axiom /= joinA. Qed.

Canonical left_struct h r (f : forall k, partition k r) k :=
  Partition (left_pf h f k).

Lemma right_pf h r (f : forall k, partition k r) k :
        partition_axiom k (h \+ r) (right_tag (h \+ f k)).
Proof. by rewrite partitionE /partition_axiom /= joinCA. Qed.

Canonical right_struct h r (f : forall k, partition k r) k :=
  Partition (right_pf h f k).

(* now the actual lemmas *)

Lemma defPtUnO A h x (v : A) (f : partition (x :-> v) h) :
        valid (untag f) = [&& x != null, valid h & x \notin dom h].
Proof. by rewrite partitionE validPtUn. Qed.

Arguments defPtUnO [A][h] x [v][f].

Lemma defPt_nullO A h x (v : A) (f : partition (x :-> v) h) :
        valid (untag f) -> x != null.
Proof. by rewrite partitionE; apply: validPtUn_cond. Qed.

Arguments defPt_nullO [A h x v f] _.

Lemma defPt_defO A h x (v : A) (f : partition (x :-> v) h) :
        valid (untag f) -> valid h.
Proof. by rewrite partitionE; apply: validPtUnV. Qed.

Arguments defPt_defO [A][h] x [v][f] _.

Lemma defPt_domO A h x (v : A) (f : partition (x :-> v) h) :
        valid (untag f) -> x \notin dom h.
Proof. by rewrite partitionE; apply: validPtUnD. Qed.

Arguments defPt_domO [A][h] x [v][f] _.

Lemma domPtUnO A h x (v : A) (f : partition (x :-> v) h) :
        dom (untag f) =i
        [pred y | valid (untag f) & (x == y) || (y \in dom h)].
Proof. by rewrite partitionE; apply: domPtUn. Qed.

Arguments domPtUnO [A][h] x [v][f] _.

Lemma lookPtUnO A h x (v : A) (f : partition (x :-> v) h) :
        valid (untag f) -> find x (untag f) = Some (idyn v).
Proof. by rewrite partitionE; apply: findPtUn. Qed.

Arguments lookPtUnO [A h x v f] _.

Lemma freePtUnO A h x (v : A) (f : partition (x :-> v) h) :
        valid (untag f) -> free x (untag f) = h.
Proof. by rewrite partitionE; apply: freePtUn. Qed.

Arguments freePtUnO [A h x v f] _.

Lemma updPtUnO A1 A2 x i (v1 : A1) (v2 : A2)
               (f : forall k, partition k i) :
        upd x (idyn v2) (untag (f (x :-> v1))) = f (x :-> v2).
Proof. by rewrite !partitionE; apply: updPtUn. Qed.

Arguments updPtUnO [A1 A2 x i v1 v2] f.

Lemma cancelTO A1 A2 h1 h2 x (v1 : A1) (v2 : A2)
               (f1 : partition (x :-> v1) h1)
               (f2 : partition (x :-> v2) h2) :
        valid (untag f1) -> f1 = f2 :> heap -> A1 = A2.
Proof. by rewrite !partitionE; apply: hcancelT. Qed.

Arguments cancelTO [A1 A2 h1 h2] x [v1 v2 f1 f2] _ _.

Lemma cancelO A h1 h2 x (v1 v2 : A)
              (f1 : partition (x :-> v1) h1)
              (f2 : partition (x :-> v2) h2) :
        valid (untag f1) -> f1 = f2 :> heap ->
        [/\ v1 = v2, valid h1 & h1 = h2].
Proof. by rewrite !partitionE; apply: hcancelV. Qed.

Arguments cancelO [A h1 h2] x [v1 v2 f1 f2] _ _.

Lemma domPtUnXO A (v : A) x i (f : partition (x :-> v) i) :
        valid (untag f) -> x \in dom (untag f).
Proof. by rewrite partitionE; apply: domPtUnX. Qed.

(*******************************************************)
(*******************************************************)
(* Custom lemmas about singly-linked lists in the heap *)
(*******************************************************)
(*******************************************************)

Fixpoint llist A p (xs : seq A) {struct xs} :=
  if xs is x::xt then
    fun h => exists r h', h = p :-> (x, r) \+ h' /\ llist r xt h'
  else fun h : heap => p = null /\ h = Unit.

Lemma llist_prec A p (l1 l2 : seq A) h1 h2 g1 g2 :
        valid (h1 \+ g1) ->
        llist p l1 h1 -> llist p l2 h2 ->
        h1 \+ g1 = h2 \+ g2 ->
        [/\ l1 = l2, h1 = h2 & g1 = g2].
Proof.
move=>V H1 H2 E; elim: l1 l2 h1 h2 p H1 H2 E V=>[|a1 l1 IH].
- case=>[|a2 l2] h1 h2 p /= [->->].
  - by case=>_ ->; rewrite !unitL.
  by case=>r [h'][-> _ ->] /validL /validPtUn_cond.
case=>[|a2 l2] h1 h2 p /= [p1][k1][-> H1].
- by case=>->-> _ /validL /validPtUn_cond.
case=>p2 [k2][-> H2]; rewrite -!joinA => E V.
case: {E V} (hcancelV V E) H1 H2; case=>->-> V E H1 H2.
by case: (IH _ _ _ _ H1 H2 E V)=>->->->.
Qed.

Lemma first_exists A p h (ls : seq A) :
        p != null -> llist p ls h ->
        exists x r h',
          [/\ ls = x :: behead ls, h = p :-> (x, r) \+ h' &
              llist r (behead ls) h'].
Proof.
case: ls=>[|a ls] /= H []; first by case: eqP H.
by move=>r [h'][-> H1]; eexists a, r, h'.
Qed.

Lemma llist_null A (xs : seq A) h :
        valid h -> llist null xs h -> xs = [::] /\ h = Unit.
Proof.
case: xs=>[|x xs] /= V H; first by case: H.
by case: H V=>p [h'][-> _] /validPtUn_cond.
Qed.

(******************************)
(******************************)
(* Custom lemmas about arrays *)
(******************************)
(******************************)

From mathcomp Require Import fintype tuple finfun.

Definition indx {I : finType} (x : I) := index x (enum I).

Prenex Implicits indx.

(***********************************)
(* Arrays indexed by a finite type *)
(***********************************)

Section Array.
Variables (p : ptr) (I : finType).

(* helper lemmas *)

Lemma enum_split k :
        enum I = take (indx k) (enum I) ++ k :: drop (indx k).+1 (enum I).
Proof.
rewrite -{2}(@nth_index I k k (enum I)) ?mem_enum //.
by rewrite -drop_nth ?index_mem ?mem_enum // cat_take_drop.
Qed.

Lemma updi_split T k (f : {ffun I -> T}) :
        updi p (fgraph f) = updi p (take (indx k) (fgraph f)) \+
                            p.+(indx k) :-> f k \+
                            updi (p.+(indx k).+1) (drop (indx k).+1 (fgraph f)).
Proof.
rewrite fgraph_codom /= codomE {1}(enum_split k) map_cat updi_cat /=.
rewrite map_take map_drop size_takel ?joinA ?ptrA ?addn1 //.
by rewrite size_map index_size.
Qed.

Lemma takeord T k x (f : {ffun I -> T}) :
        take (indx k) (fgraph [ffun y => [eta f with k |-> x] y]) =
        take (indx k) (fgraph f).
Proof.
set f' := (finfun _).
suff E: {in take (indx k) (enum I), f =1 f'}.
- by rewrite !fgraph_codom /= !codomE -2!map_take; move/eq_in_map: E.
move: (enum_uniq I); rewrite {1}(enum_split k) cat_uniq /= =>H4.
move=>y H5; rewrite /f' /= !ffunE /=; case: eqP H5 H4=>// -> ->.
by rewrite andbF.
Qed.

Lemma dropord T k x (f : {ffun I -> T}) :
        drop (indx k).+1 (fgraph [ffun y => [eta f with k |->x] y]) =
        drop (indx k).+1 (fgraph f).
Proof.
set f' := (finfun _).
suff E: {in drop (indx k).+1 (enum I), f =1 f'}.
- by rewrite !fgraph_codom /= !codomE -2!map_drop; move/eq_in_map: E.
move: (enum_uniq I); rewrite {1}(enum_split k) cat_uniq /= => H4.
move=>y H5; rewrite /f' /= !ffunE /=; case: eqP H5 H4=>// -> ->.
by rewrite !andbF.
Qed.

Lemma size_fgraph T1 T2 (r1 : {ffun I -> T1}) (r2 : {ffun I -> T2}) :
        size (fgraph r1) = size (fgraph r2).
Proof. by rewrite !fgraph_codom /= !codomE !size_map. Qed.

Lemma fgraphE T (r1 r2 : {ffun I -> T}) :
        fgraph r1 = fgraph r2 -> r1 = r2.
Proof. by case: r1; case=>r1 H1; case: r2; case=>r2 H2 /= ->. Qed.

End Array.


From sgdt Require Import preamble category functor adjunction.

Set Universe Polymorphism.

(** Easier than activating -impredicative-set. *)
#[bypass_check(universes = yes)]
Definition All {A : Type} (B : A -> Set) : Set :=
  forall x : A, B x.

Notation "'⋀' x .. y , p" := (All (fun x => .. (All (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' '⋀' '/ ' x .. y , '/ ' p ']'")
  : type_scope.

Module Reflection.
  Section Defs.
    Context (A : Type).

    Definition pre : Set :=
      ⋀ X : Set, (⋀ _ : A, X) -> X.

    Definition ok (α : pre) : Prop :=
      forall (X Y : Set) (f : X -> Y) (h : A -> X),
        α Y ((fun g x => f (g x)) h) = f (α X h).

    Definition T : Set :=
      {α : pre | ok α}.
  End Defs.

  Section Unit.
    Context {A : Type}.

    Definition unit_pre : A -> pre A.
    Proof. by move=> a X; apply. Defined.

    Lemma unit_pre_ok (x : A) : ok _ (unit_pre x).
    Proof. by []. Qed.

    Definition unit : A -> T A.
    Proof. by move=> a; exists (unit_pre a); apply: unit_pre_ok. Defined.
  End Unit.

  Section Map.
    Context {A B : Type} (f : A -> B).

    Definition map_pre : pre A -> pre B.
    Proof. by move=> α X h; apply: α=>/f/h. Defined.

    Definition map_pre_ok : forall α : pre A, ok A α -> ok B (map_pre α).
    Proof. by move=> α hα X Y g h; rewrite -hα. Qed.

    Definition map : T A -> T B.
    Proof.
      move=> x.
      exists (map_pre (pi1 x)).
      apply: map_pre_ok.
      by apply pi2.
    Defined.

    Definition map_beta : forall x, map (unit x) = unit (f x).
    Proof. by move=> ?; apply: subE. Qed.
  End Map.

  Section Alg.
    Context {A : Set}.

    Definition alg : T A -> A.
    Proof. by move=> /pi1 α; apply: (α A). Defined.

    Definition alg_beta : forall x : A, alg (unit x) = x.
    Proof. by []. Qed.

    Definition alg_eta : forall x : T A, x = unit (alg x).
    Proof.
      move=> α.
      apply: subE =>//=.
      apply: dfunE => X.
      apply: funE => ?.
      by rewrite /unit_pre /alg -(pi2 α).
    Qed.
  End Alg.

  Section Ext.
    Context {A : Type} {B : Set} (f : A -> B).

    Definition ext : T A -> B.
    Proof. by move=> x; apply: alg; apply: map f x. Defined.

    Lemma ext_beta : forall x, ext (unit x) = f x.
    Proof. by move=> ?; rewrite /ext map_beta alg_beta. Qed.
  End Ext.

  Section ExtEta.
    Context {A : Type} {B : Set}.

    (* Argument due to Awodey, Frey, Speight *)
    Lemma ext_eta : forall h : T A -> B, ext (h \o unit) = h.
    Proof.
      move=> h.
      apply: funE=> α.
      rewrite /ext /alg /map /map_pre //= (pi2 α).
      congr h.
      apply: subE=>//=.
      apply: dfunE=> X.
      apply: funE=> f.
      rewrite
        (_ : (pi1 (pi1 α (T A) unit) X f) = ext f (pi1 α _ unit)) //=
        /ext -(pi2 α _ _ (map f))
        (_ : (fun x : A => map f (unit x)) = (fun x => unit (f x))).
      - by apply: funE=> ?; apply: map_beta.
      - by rewrite (pi2 α) alg_beta.
    Qed.

    Context (f : A -> B).

    Definition is_univ_map (h : T A -> B) := forall x, h (unit x) = f x.

    Lemma univ_map_uniq h1 h2 : is_univ_map h1 -> is_univ_map h2 -> h1 = h2.
    Proof.
      move=> hh1 hh2.
      rewrite -(ext_eta h1) -(ext_eta h2).
      congr ext.
      apply: funE=>?//=.
      by rewrite hh1 hh2.
    Qed.
  End ExtEta.

  Definition ind {A : Type} (C : T A -> Set) (H : forall x : A, C (unit x)) : forall x : T A, C x.
  Proof.
    suff Q: {f : T A -> {x : T A & C x} | forall x : T A, pi1 (f x) = x}.
    - move=> x.
      rewrite (_ : x = pi1 (pi1 Q x)).
      + by rewrite (pi2 Q x).
      + by apply: (pi2 (pi1 Q x)).
    - build.
      + apply: ext=> x.
        by [exists (unit x); apply: H].
      + abstract by apply: unfunE; unshelve apply: univ_map_uniq; first by apply: unit.
  Defined.

  Lemma map_id {A : Type} : map (id : A -> A) = id.
  Proof.
    apply: funE; apply: ind=> x.
    by rewrite map_beta.
  Qed.

  Lemma map_cmp {A B C : Type} (f : A -> B) (g : B -> C) : map (fun x => g (f x)) = map g \o map f.
  Proof.
    apply: funE; apply: ind=> x //=.
    by rewrite ? map_beta.
  Qed.
End Reflection.

Definition Ex {A : Type} (B : A -> Set) : Set :=
  Reflection.T {x : A & B x}.

Notation "'⋁' x .. y , p" := (Ex (fun x => .. (Ex (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' '⋁' '/ ' x .. y , '/ ' p ']'")
  : type_scope.

Section PackUnpack.
  Context {A : Type} {B : A -> Set}.

  Definition pack (a : A) (b : B a) : ⋁ x : A, B x.
  Proof.
    apply: Reflection.unit.
    exists a; exact: b.
  Defined.

  Definition unpack {C : Set} (f : forall x : A, B x -> C) (u : ⋁ x : A, B x) : C.
    move: u.
    apply Reflection.ext; case.
    apply: f.
  Defined.
End PackUnpack.

Local Open Scope category_scope.

Module SetToType.
  Definition prefunctor@{u v w} : Prefunctor.type SET.cat@{w} TYPE.cat@{u v}.
  Proof.
    build.
    - by move=> A; exact: (A : Type).
    - by build.
  Defined.

  Definition functor_mixin@{u v w} : Functor.mixin_of SET.cat@{w} TYPE.cat@{u v} prefunctor@{u v w}.
  Proof.
    constructor.
    - build.
    - build.
  Defined.

  Canonical functor@{u v w} : Functor.type SET.cat@{w} TYPE.cat@{u v}.
  Proof. by esplit; apply: functor_mixin. Defined.
End SetToType.

Module TypeToSet.
  Definition prefunctor@{u v w} : Prefunctor.type TYPE.cat@{u v} SET.cat@{w}.
  Proof.
    build.
    - by apply: Reflection.T.
    - by build=> A B; apply: Reflection.map.
  Defined.

  Definition functor_mixin@{u v w} : Functor.mixin_of TYPE.cat@{u v} SET.cat@{w} prefunctor@{u v w}.
  Proof.
    build.
    - move=> A.
      apply: funE.
      apply: Reflection.ind=> x.
      by cbn; rewrite Reflection.map_beta.
    - move=> A B C f g.
      apply: funE.
      apply: Reflection.ind=> x.
      by cbn; rewrite ?Reflection.map_beta.
  Qed.

  Canonical functor@{u v w} : Functor.type TYPE.cat@{u v} SET.cat@{w}.
  Proof. by esplit; apply: functor_mixin. Defined.
End TypeToSet.

Module TypeSetAdjunction.

  Definition transp_fwd_fam : forall U, LeftOblique.functor TypeToSet.functor U -> RightOblique.functor SetToType.functor U.
  Proof.
    case=> A X f a.
    apply: f.
    by apply: Reflection.unit a.
  Defined.

  Definition transp_bwd_fam : forall U, RightOblique.functor SetToType.functor U -> LeftOblique.functor TypeToSet.functor U.
  Proof.
    case=> A X f.
    by cbn in *; apply: Reflection.ext f.
  Defined.

  Definition transp_fwd_mixin : NatTrans.mixin_of (LeftOblique.functor TypeToSet.functor) (RightOblique.functor SetToType.functor) transp_fwd_fam.
  Proof.
    build; case=> A1 X1; case=> A2 X2; case=> f g.
    apply: funE=> h //=.
    apply: funE=> x.
    by cbn; rewrite Reflection.map_beta.
  Qed.

  Definition transp_bwd_mixin : NatTrans.mixin_of (RightOblique.functor SetToType.functor) (LeftOblique.functor TypeToSet.functor)  transp_bwd_fam.
  Proof.
    build; case=> A1 X1; case=> A2 X2; case=> f g.
    apply: funE=> h //=.
    by apply: funE; apply: Reflection.ind.
  Qed.

  Canonical transp_fwd : LeftOblique.functor TypeToSet.functor ~> RightOblique.functor SetToType.functor.
  Proof. by esplit; apply: transp_fwd_mixin. Defined.

  Canonical transp_bwd : RightOblique.functor SetToType.functor ~> LeftOblique.functor TypeToSet.functor.
  Proof. by esplit; apply: transp_bwd_mixin. Defined.

  Definition preadj : Preadjunction.type TypeToSet.functor SetToType.functor.
  Proof.
    build.
    - by apply: transp_fwd.
    - by apply: transp_bwd.
  Defined.

  Definition adj_mixin : Adjunction.mixin_of _ _ preadj.
  Proof.
    build; case=> A B.
    rewrite /LeftOblique.ob /TypeToSet.functor //=.
    move=> f.
    rewrite /transp_fwd_fam /transp_bwd_fam //=.
    apply: Reflection.ext_eta.
  Qed.

  Definition adj : TypeToSet.functor ⊣ SetToType.functor.
  Proof. by esplit; apply: adj_mixin. Defined.

End TypeSetAdjunction.

Global Opaque Reflection.unit.
Global Opaque Reflection.ext.


From Hammer Require Import Hammer.

From Fermat4 Require Export Descent.
From Fermat4 Require Export Pythagorean.

Lemma multiple4_2: forall u v : Z,
Zodd v -> Zodd u -> v <= u -> rel_prime u v -> 1 < u -> 1 < v ->
exists two : Z * Z,
let (s, w) := two in
(u - v = 4 * s /\ u + v = 2 * w \/
u - v = 2 * w /\ u + v = 4 * s) /\ 0 < s /\ 0 < w /\ rel_prime s w.
Proof. hammer_hook "Diophantus20" "Diophantus20.multiple4_2".
intros; elim (Zodd_mult u v H0 H); intros; elim H5; clear H5; intros;
elim_hyps; split with (x,x0); intuition; cut (u <> 1); auto with zarith;
intro; cut (u <> -1); auto with zarith; intro.
apply (Zmult_lt_0_reg_r 4 x); auto with zarith; rewrite Zmult_comm;
rewrite <- H5; generalize (relp_neq _ _ H7 H8 H2); auto with zarith.
apply (gcd2_rel_prime (u - v) (u + v) x x0); auto; apply gcd2_relp_odd; auto.
apply (Zmult_lt_0_reg_r 2 x0); auto with zarith; rewrite Zmult_comm;
rewrite <- H5; generalize (relp_neq _ _ H7 H8 H2); auto with zarith.
apply (gcd2_rel_prime (u + v) (u - v) x x0); auto; apply Zis_gcd_sym;
apply gcd2_relp_odd; auto.
Qed.

Lemma for_exists_ab : forall u v m n : Z,
v <= u -> u * u = m * m + n * n -> v * v = n * n - m * m -> 1 < u -> 1 < v ->
Zodd v -> Zodd u -> rel_prime u v ->
exists two : Z * Z,
let (a, b) := two in
(u - v = 4 * (a * a) /\ u + v = 2 * (b * b) \/
u - v = 2 * (b * b) /\ u + v = 4 * (a * a)) /\ 0 < a /\ 0 < b.
Proof. hammer_hook "Diophantus20" "Diophantus20.for_exists_ab".
intros u v m n Huv H H0 H1 H2 H3 H4 H5;
elim (multiple4_2 u v H3 H4 Huv H5 H1 H2); intro; elim x; intros;
elim_hyps; (cut (is_sqr (a * b));
[ intro Hab; elim (prop4 a b (Zlt_le_weak 0 a H7) (Zlt_le_weak 0 b H8) H9
Hab); intros; elim H11; intros Ha H11'; elim H11'; clear H11';
intros a0 H11'; elim H11'; clear H11'; intros H11' Ha0; elim H12;
intros Hb H12'; elim H12'; clear H12'; intros b0 H12'; elim H12';
clear H12'; intros H12' Hb0; split with (a0,b0); intuition;
[ rewrite <- H11' in H7; generalize (sqr_poss a0 H7); intro;
auto with zarith
| rewrite <- H12' in H8; generalize (sqr_poss b0 H8); intro;
auto with zarith ]
| apply (is_sqr_compat 2); try discriminate;
replace (2 * 2 * (a * b)) with (m * m);
[ apply is_sqr_sqr
| apply (Zmult_eq_reg_l 2); try discriminate;
replace (2 * (m * m)) with ((u * u) - (v * v));
[ replace (u * u - v * v) with ((u - v) * (u + v));
[ rewrite H6; rewrite H10; ring | ring ]
| replace (2 * (m * m)) with ((m * m + n * n) - (n * n - m * m));
[ rewrite H; rewrite H0; ring | ring ] ] ] ]).
Qed.

Lemma for_mba_pytha1: forall m n u v a b : Z,
u * u = m * m + n * n -> v * v = n * n - m * m -> u - v = 4 * (a * a) ->
u + v = 2 * (b * b) -> b * b * (b * b) + 2 * (a * a) * (2 * (a * a)) = n * n.
Proof. hammer_hook "Diophantus20" "Diophantus20.for_mba_pytha1".
intros; cut (2 * n * n = u * u + v * v).
intro; cut (u = 2 * a * a + b * b).
intro; cut (v = b * b - 2 * a * a).
intro; rewrite H4 in H3; rewrite H5 in H3; symmetry;
apply (Zmult_eq_reg_l 2).
replace (2 * (n * n)) with (2 * n * n); [ rewrite H3; ring | ring ].
discriminate.
apply (Zmult_eq_reg_l 2).
replace (2 * v) with (u + v - (u - v));
[ rewrite H2; rewrite H1; ring | ring ].
discriminate.
apply (Zmult_eq_reg_l 2).
replace (2 * u) with (u + v + (u - v));
[ rewrite H2; rewrite H1; ring | ring ].
discriminate.
replace (2 * n * n) with (m * m + n * n + (n * n - m * m));
[ rewrite H; rewrite H0; ring | ring ].
Qed.

Lemma for_mba_pytha2: forall m n u v a b : Z,
u * u = m * m + n * n -> v * v = n * n - m * m -> u - v = 2 * (b * b) ->
u + v = 4 * (a * a) -> b * b * (b * b) + 2 * (a * a) * (2 * (a * a)) = n * n.
Proof. hammer_hook "Diophantus20" "Diophantus20.for_mba_pytha2".
intros; cut (2 * n * n = u * u + v * v).
intro; cut (u = 2 * a * a + b * b).
intro; cut (v = 2 * a * a - b * b).
intro; rewrite H4 in H3; rewrite H5 in H3; symmetry;
apply (Zmult_eq_reg_l 2).
replace (2 * (n * n)) with (2 * n * n); [ rewrite H3; ring | ring ].
discriminate.
apply (Zmult_eq_reg_l 2).
replace (2 * v) with (u + v - (u - v));
[ rewrite H2; rewrite H1; ring | ring ].
discriminate.
apply (Zmult_eq_reg_l 2).
replace (2 * u) with (u + v + (u - v));
[ rewrite H2; rewrite H1; ring | ring ].
discriminate.
replace (2 * n * n) with (m * m + n * n + (n * n - m * m));
[ rewrite H; rewrite H0; ring | ring ].
Qed.


(* =================================================================================== *)
(** * Signatures and their models.

    Content:
    - Definition of signature (aka arity).
    - Definition of model of a signature.
    - Forgetful functor to the category of modules over a given monad R.                *)
(* =================================================================================== *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.categories.HSET.All.
Require Import UniMath.CategoryTheory.Epis.
Require Import UniMath.CategoryTheory.EpiFacts.

Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.

Require Import Modules.Prelims.lib.
Require Import Modules.Prelims.LModulesFibration.
Require Import Modules.Prelims.LModulesComplements.

Set Automatic Introduction.
Delimit Scope signature_scope with ar.

Section Signatures.

Context {C : category}.

Local Notation MONAD := (Monad C).
Local Notation PRE_MONAD := (category_Monad C).
Local Notation BMOD := (bmod_disp C C).

(* ----------------------------------------------------------------------------------- *)
(** ** Definition of signature.                                                        *)
(* ----------------------------------------------------------------------------------- *)

Definition signature_data :=
  ∑ F : (∏ R : MONAD, LModule R C),
        ∏ (R S : MONAD) (f : Monad_Mor R S), LModule_Mor _ (F R) (pb_LModule f (F S)).
(* :(F R : bmod_disp C C R) -->[f] F S. *)

Definition signature_on_objects (a : signature_data) : ∏ R, LModule R C
  := pr1 a.

Coercion signature_on_objects : signature_data >-> Funclass.

Definition signature_on_morphisms  (F : signature_data) {R S : MONAD}
  : ∏ (f: Monad_Mor R S), LModule_Mor _ (F R) (pb_LModule f (F S))
  := pr2 F R S.

Notation "# F" := (signature_on_morphisms F) (at level 3) : signature_scope.

(* ----------------------------------------------------------------------------------- *)
(** In classical terms, signatures are sections of a functor.  Here the same fact is
    expressed in the language of displayed cateteories with the following two
    property.                                                                          *)
(* ----------------------------------------------------------------------------------- *)

Definition signature_idax  (F : signature_data) :=
  ∏ (R : MONAD), ∏ x ,
  (# F (identity (C:= PRE_MONAD) R))%ar x  = identity  _.

Definition signature_compax  (F : signature_data) :=
  ∏ (R S T : MONAD) (f : PRE_MONAD ⟦R, S⟧) (g : PRE_MONAD ⟦S, T⟧),
  (#F  (f · g))%ar
  =
  (((# F f)%ar :(F R : bmod_disp C C R) -->[f] F S) ;; (#F g)%ar)%mor_disp.

Definition is_signature  (F : signature_data) : UU := signature_idax F × signature_compax F.

Lemma isaprop_is_signature (F : signature_data) : isaprop (is_signature F).
Proof.
  apply isofhleveldirprod.
  - repeat (apply impred; intro).
    apply homset_property.
  - repeat (apply impred; intro).
    apply (homset_property (category_LModule _ _)).
Qed.

Definition signature : UU := ∑ F : signature_data, is_signature F.

Definition signature_data_from_signature (F : signature) : signature_data := pr1 F.
Coercion signature_data_from_signature : signature >-> signature_data.

Notation Θ := tautological_LModule.

Definition tautological_signature_on_objects : ∏ (R : Monad C), LModule R C := Θ.
Definition tautological_signature_on_morphisms :
  ∏ (R S : Monad C) (f : Monad_Mor R S), LModule_Mor _ (Θ R) (pb_LModule f (Θ S)) :=
  @monad_mor_to_lmodule C.

Definition tautological_signature_data : signature_data  :=
  tautological_signature_on_objects ,, tautological_signature_on_morphisms.

Lemma tautological_signature_is_signature :  is_signature tautological_signature_data.
Proof.
  split.
  - intros R x.
    apply idpath.
  - intros R S T f g.
    apply LModule_Mor_equiv.
    + apply homset_property.
    + apply nat_trans_eq.
      * apply homset_property.
      * intro x.
        cbn.
        rewrite id_right.
        apply idpath.
Qed.

Definition tautological_signature : signature := _ ,, tautological_signature_is_signature.

Definition signature_id (F : signature) :
  ∏ (R : MONAD), ∏ x ,
  ((# F (identity (C:= PRE_MONAD) R)))%ar x  = identity  _
  := pr1 (pr2 F).
(* ((# F (identity (C:= PRE_MONAD) R): LModule_Mor _ _ _ ))%ar x  = identity  _ *)

Definition signature_comp (F : signature) {R S T : MONAD}
           (f : PRE_MONAD ⟦R,S⟧) (g : PRE_MONAD⟦S,T⟧)
  : (#F  (f · g))%ar
    =
    ((# F f : (F R : bmod_disp C C R) -->[f] F S) %ar ;; (#F g)%ar)%mor_disp
  := pr2 (pr2 F) _ _ _ _ _ .

(* Demander la version pointwise plutôt ? *)
Definition is_signature_Mor (F F' : signature_data)
           (t : ∏ R : MONAD, LModule_Mor R (F R)  (F' R))
  :=
    ∏ (R S : MONAD)(f : Monad_Mor R S),
    (((# F)%ar f :   nat_trans _ _) : [_,_]⟦_,_⟧) ·
                                                  (t S : nat_trans _ _)
    =
    ((t R : nat_trans _ _) : [_,_]⟦_,_⟧) · ((#F')%ar f : nat_trans _ _).

  (* ((((# F)%ar f : LModule_Mor _ _ _) : nat_trans _ _) : [_,_]⟦_,_⟧) · *)
  (*                                                                   (t S : nat_trans _ _) = *)
  (* ((t R : nat_trans _ _) : [_,_]⟦_,_⟧) · (((#F')%ar f:LModule_Mor _ _ _) : nat_trans _ _). *)

Lemma isaprop_is_signature_Mor (F F' : signature_data) t :
  isaprop (is_signature_Mor F F' t).
Proof.
  repeat (apply impred; intro).
  apply homset_property.
Qed.

Definition signature_Mor  (F F' : signature_data) : UU := ∑ X, is_signature_Mor F F' X.

Local Notation "F ⟹ G" := (signature_Mor F G) (at level 39) : signature_scope.

Lemma isaset_signature_Mor (F F' : signature) : isaset (signature_Mor F F').
Proof.
  apply (isofhleveltotal2 2).
  + apply impred ; intro t; apply (homset_property (category_LModule _ _)).
  + intro x; apply isasetaprop, isaprop_is_signature_Mor.
Qed.

Definition signature_Mor_data
 {F F' : signature_data}(a : signature_Mor F F') := pr1 a.
Coercion signature_Mor_data : signature_Mor >-> Funclass.

Definition signature_Mor_ax {F F' : signature} (a : signature_Mor F F')
  : ∏ {R S : MONAD}(f : Monad_Mor R S),
    (((# F)%ar f :   nat_trans _ _) : [_,_]⟦_,_⟧) ·
                                                  (a S : nat_trans _ _)
    =
    ((a R : nat_trans _ _) : [_,_]⟦_,_⟧) · ((#F')%ar f : nat_trans _ _)
  := pr2 a.

Lemma signature_Mor_ax_pw {F F' : signature} (a : signature_Mor F F')
  : ∏ {R S : Monad C}(f : Monad_Mor R S) x,
    (((# F)%ar f :   nat_trans _ _) x) ·
                                       ((a S : nat_trans _ _) x)
    =
    ((a R : nat_trans _ _)  x) · (((#F')%ar f : nat_trans _ _) x).
Proof.
  intros.
  assert (h := signature_Mor_ax a f).
  eapply nat_trans_eq_pointwise in h.
  apply h.
Qed.

(** Equality between two signature morphisms *)

Lemma signature_Mor_eq (F F' : signature)(a a' : signature_Mor F F'):
  (∏ x, a x = a' x) -> a = a'.
Proof.
  intro H.
  assert (H' : pr1 a = pr1 a').
  { apply funextsec. intro; apply H. }
  apply (total2_paths_f H'), proofirrelevance, isaprop_is_signature_Mor.
Qed.

Lemma is_signature_Mor_comp {F G H : signature} (a : signature_Mor F G) (b : signature_Mor G H)
  : is_signature_Mor F H (fun R  => (a R : category_LModule _ _ ⟦_,_⟧ ) · b R).
Proof.
  intros ? ? ?.
  etrans.
  apply (assoc (C:= [_,_])).
  etrans.
  apply ( cancel_postcomposition (C:= [_,_])).
  apply (signature_Mor_ax (F:=F) (F':=G) a f).
  rewrite <- (assoc (C:=[_,_])).
  etrans.
  apply (cancel_precomposition ([_,_])).
  apply signature_Mor_ax.
  rewrite assoc.
  apply idpath.
Qed.

Definition signature_precategory_ob_mor  : precategory_ob_mor := make_precategory_ob_mor
   signature (fun F F' => signature_Mor F F').

Lemma is_signature_Mor_id (F : signature_data) : is_signature_Mor F F
     (fun R => identity (C:=category_LModule _ _) _).
Proof.
  intros ? ? ? .
  rewrite id_left, id_right.
  apply idpath.
Qed.

Definition signature_Mor_id (F : signature_data) : signature_Mor F F :=
    tpair _ _ (is_signature_Mor_id F).

Definition signature_Mor_comp {F G H : signature} (a : signature_Mor F G) (b : signature_Mor G H)
  : signature_Mor F H
  := tpair _ _ (is_signature_Mor_comp a b).

Definition signature_precategory_data : precategory_data.
Proof.
  apply (make_precategory_data (signature_precategory_ob_mor )).
  + intro a; simpl.
    apply (signature_Mor_id (pr1 a)).
  + intros a b c f g.
    apply (signature_Mor_comp f g).
Defined.

Lemma is_precategory_signature_precategory_data :
   is_precategory signature_precategory_data.
Proof.
  apply make_is_precategory_one_assoc; simpl; intros.
  - unfold identity.
    simpl.
    apply signature_Mor_eq.
    intro x; simpl.
    apply (id_left (C:=category_LModule _ _)).
  - apply signature_Mor_eq.
    intro x; simpl.
    apply (id_right (C:=category_LModule _ _)).
  - apply signature_Mor_eq.
    intro x; simpl.
    apply (assoc (C:=category_LModule _ _)).
Qed.

Definition signature_precategory : precategory :=
  tpair (fun C => is_precategory C)
        (signature_precategory_data)
        (is_precategory_signature_precategory_data).

Lemma signature_category_has_homsets : has_homsets signature_precategory.
Proof.
  intros F G.
  apply isaset_signature_Mor.
Qed.

Definition signature_category : category.
Proof.
  exists (signature_precategory).
  apply signature_category_has_homsets.
Defined.

End Signatures.

Arguments signature _ : clear implicits.

Notation "# F" := (signature_on_morphisms F) (at level 3) : signature_scope.

Section ForgetSigFunctor.
  Context {C : category} (R : Monad C) .
  Local Notation MOD := (category_LModule R C).
  Local Notation HAR := (signature_category (C:=C)).

  Definition forget_Sig_data : functor_data HAR MOD :=
    make_functor_data (C := HAR) (C' := MOD)
                    (fun X => ((X : signature C) R))
                    (fun a b f => ((f : signature_Mor _ _ ) R)).

  Definition forget_Sig_is_functor : is_functor forget_Sig_data :=
    (( fun x => idpath _) : functor_idax forget_Sig_data)
      ,, ((fun a b c f g => idpath _) : functor_compax forget_Sig_data).

  Definition forget_Sig: functor HAR MOD  :=
    make_functor forget_Sig_data forget_Sig_is_functor.
End ForgetSigFunctor.

(* large category of model defined as a display category

Not that contrary to the large category of modules, we do not construct the category of
models of a specific signature

This is an attempt to use directly the display category construction.
The category of represenations of a specific signature can be retrieved as a fiber category.

Let us recall what it the category of models of a signature B.
It is a pair (R,m) where R is monad and m a module morphism (on R) m : B(R) -> R.

Now, any morphism of signature F : A -> B induces a functor F* : Rep(B) -> Rep(A) defined by
F*(R,m) = (R, m o (F R))

That's how the large category of models is built.

*)

Section LargeCatRep.

Context {C : category}.

Local Notation MONAD := (Monad C).
Local Notation PRE_MONAD := (category_Monad C).
Local Notation BMOD := (bmod_disp C C).

(* Signatures are display functors over the identity *)
Local Notation PRECAT_SIGNATURE  := (@signature_category C).

Notation signature  := (@signature C).
Local Notation SIGNATURE := signature.

Goal signature = ob PRECAT_SIGNATURE.
  reflexivity.
Abort.

Local Notation Θ := tautological_LModule.

  (* We define the displayed category of models of a signature
We could also define it as a displayed category over the monads
and we have no idea what that would look like *)

(** A model is a monad with a module morphisme from its image by the signature
 to itself *)
Definition model (ar : SIGNATURE) :=
  ∑ R : MONAD, LModule_Mor R (ar R) (Θ R).

Coercion Monad_from_rep_ar (ar : SIGNATURE) (X : model ar) : MONAD := pr1 X.

Definition model_τ {ar : signature} (X : model ar) := pr2 X.

Definition model_mor_law {a b : signature} (M : model a) (N : model b)
           (f : signature_Mor a b) (g : Monad_Mor M N)
  := ∏ c : C, model_τ M c · g c = ((#a g)%ar:nat_trans _ _) c · f N c · model_τ N c .

Lemma isaprop_model_mor_law {a b : SIGNATURE} (M : model a) (N : model b)
      (f : signature_Mor a b) (g : Monad_Mor M N)
  : isaprop (model_mor_law M N f g).
Proof.
  intros.
  apply impred; intro c.
  apply homset_property.
Qed.

Definition model_mor_mor (a b : SIGNATURE) (M : model a) (N : model b) f :=
  ∑ g:Monad_Mor M N, model_mor_law  M N f g.

Lemma isaset_model_mor_mor (a b : SIGNATURE) (M : model a) (N : model b) f :
  isaset (model_mor_mor a b M N f).
Proof.
  intros.
  apply isaset_total2 .
  - apply has_homsets_Monad.
  - intros.
    apply isasetaprop.
    apply isaprop_model_mor_law.
Qed.

Coercion monad_morphism_from_model_mor_mor {a b : SIGNATURE} {M : model a} {N : model b}
         {f} (h : model_mor_mor a b M N f) : Monad_Mor M N
  := pr1 h.

Definition model_mor_ax {a b : SIGNATURE} {M : model a} {N : model b}
           {f} (h:model_mor_mor a b M N f) :
  ∏ c, model_τ M c · h c = (#a h)%ar c · f N c · model_τ N c
  := pr2 h.

Definition rep_disp_ob_mor : disp_cat_ob_mor PRECAT_SIGNATURE :=
  (model,, model_mor_mor).

Lemma rep_id_law (a : SIGNATURE) (RM : rep_disp_ob_mor a) :
  model_mor_law RM RM (identity (C:=PRECAT_SIGNATURE) _) (Monad_identity _).
Proof.
  intro c.
  apply pathsinv0.
  etrans.
    { apply cancel_postcomposition, id_right. }
  etrans.
    { apply cancel_postcomposition, (signature_id a (pr1 RM) c). }
  etrans; [  apply id_left |].
  apply pathsinv0.
  apply id_right.
Qed.

Definition rep_id  (a : SIGNATURE) (RM : rep_disp_ob_mor a) :
  RM -->[ identity (C:=PRECAT_SIGNATURE) a] RM.
Proof.
  intros.
  exists (Monad_identity _).
  apply rep_id_law.
Defined.

Lemma transport_signature_mor (x y : SIGNATURE) (f g : signature_Mor x y)
      (e : f = g)
      (xx : rep_disp_ob_mor x)
      (yy : rep_disp_ob_mor y)
      (ff : xx -->[ f] yy)
      (c : C) :
  pr1 (pr1 (transportf (mor_disp xx yy) e ff)) c = pr1 (pr1 ff) c.
Proof.
  induction e.
  apply idpath.
Qed.

(** type de ff ; b (pr1 R) tt -->[ identity (pr1 R) ;; pr1 α] c (pr1 S) tt *)
Lemma model_mor_mor_equiv (a b : SIGNATURE) (R:rep_disp_ob_mor a)
      (S:rep_disp_ob_mor b) (f:signature_Mor a b)
      (u v: R -->[ f] S) :
  (∏ c, pr1 (pr1 u) c = pr1 (pr1 v) c) -> u = v.
Proof.
  intros.
  use (invmap (subtypeInjectivity _ _ _ _  )).
  - intro g.
    apply isaprop_model_mor_law.
  - use (invmap (Monad_Mor_equiv _ _  _  )).
     +  apply nat_trans_eq.
        apply homset_property.
        assumption.
Qed.

(** Defining the composition in rep *)

Lemma rep_comp_law  (a b c : SIGNATURE) (f : signature_Mor a b) (g : signature_Mor b c)
      (R : rep_disp_ob_mor a) (S : rep_disp_ob_mor b)    (T : rep_disp_ob_mor c)
      (α:R -->[ f ] S) (β:S -->[g]  T) :
  (model_mor_law R T (compose (C:=PRECAT_SIGNATURE) f g)
                  (compose (C:=PRE_MONAD) (monad_morphism_from_model_mor_mor α)
                           ( monad_morphism_from_model_mor_mor  β))).
Proof.
  intro x.
  cbn.
  rewrite assoc.
  etrans.
  { apply cancel_postcomposition.
    use model_mor_ax. }

  etrans.
  { rewrite <- assoc.
    apply cancel_precomposition.
    use model_mor_ax. }

  (* Cf diagramme à ce point *)

  symmetry.
  repeat rewrite assoc.
  apply cancel_postcomposition.
  apply cancel_postcomposition.
  etrans.
  {
    apply cancel_postcomposition.
    assert (h:= (signature_comp a (pr1 α) (pr1 β))).
    apply LModule_Mor_equiv in h.
    eapply nat_trans_eq_pointwise in h.
    apply h.
    apply homset_property.
  }
  cbn.
  rewrite id_right.
  repeat rewrite <- assoc.
  apply cancel_precomposition.
  assert (h:=signature_Mor_ax f (pr1 β)).
  eapply nat_trans_eq_pointwise in h.
  apply h.
Qed.

Definition rep_comp (a b c : SIGNATURE) f g
           (RMa : rep_disp_ob_mor a)
           (RMb : rep_disp_ob_mor b)
           (RMc : rep_disp_ob_mor c)
           (mab : RMa -->[ f ] RMb)
           (mbc:RMb -->[g]  RMc)
  : RMa -->[f·g] RMc.
Proof.
  intros.
  exists (compose (C:=PRE_MONAD) (pr1 mab) (pr1 mbc)).
  apply rep_comp_law.
Defined.

Definition rep_id_comp : disp_cat_id_comp _ rep_disp_ob_mor.
Proof.
  split.
  - apply rep_id.
  - apply rep_comp.
Defined.

Definition rep_data : disp_cat_data _ := (rep_disp_ob_mor ,, rep_id_comp).

Lemma rep_axioms : disp_cat_axioms signature_category rep_data.
Proof.
  repeat apply tpair; intros; try apply homset_property.
  - apply model_mor_mor_equiv.
    intros c.
    etrans. apply id_left.
    symmetry.
    apply transport_signature_mor.
  - apply model_mor_mor_equiv.
    intro c.
    etrans. apply id_right.
    symmetry.
    apply transport_signature_mor.
  - set (heqf:= assoc f g h).
    apply model_mor_mor_equiv.
    intros c.
    etrans. Focus 2.
      symmetry.
      apply transport_signature_mor.
      cbn.
      rewrite assoc.
      apply idpath.
  - apply isaset_model_mor_mor.
Qed.

Definition rep_disp : disp_cat signature_category := rep_data ,, rep_axioms.

Definition pb_rep {a a' : signature} (f : signature_Mor a a') (R : model a') : model a :=
  ((R : MONAD) ,, ((f R : category_LModule _ _ ⟦_, _⟧) · model_τ R)).

Lemma pb_rep_to_law {a a'} (f : signature_category ⟦ a, a' ⟧) (R : model a') :
  model_mor_law (pb_rep f R) R f (identity ((R : MONAD) : PRE_MONAD)).
Proof.
  intros.
  intro c.
  cbn.
  rewrite id_right.
  apply cancel_postcomposition.
  apply pathsinv0.
  etrans; [| apply id_left].
  apply cancel_postcomposition.
  apply signature_id.
Qed.

(** ** Now the cleaving *)

Definition pb_rep_to {a a'} (f : signature_category ⟦ a, a' ⟧) (R : model a') :
  (pb_rep f R : rep_disp a) -->[f] R :=
  (identity (C:=PRE_MONAD) (R:MONAD),, pb_rep_to_law f R).

Lemma rep_mor_law_pb {a a' b} (f : signature_category ⟦ a, a' ⟧) (g : signature_category ⟦ b, a ⟧)
      (S : model b) (R : model a') (hh : (S : rep_disp _) -->[g·f] R) :
  model_mor_law S (pb_rep f R) g (hh : model_mor_mor _ _ _ _ _ ).
Proof.
  intros.
  destruct hh as [hh h].
  intro c.
  etrans; [apply h|].
  cbn.
  repeat rewrite assoc.
  apply idpath.
Qed.

Lemma rep_mor_pb {a a' b} (f : signature_category ⟦ a, a' ⟧) (g : signature_category ⟦ b, a ⟧)
      (S : model b) (R : model a') (hh : (S : rep_disp _) -->[g·f] R) :
   (S : rep_disp _) -->[ g] pb_rep f R.
Proof.
    use tpair.
    + apply hh.
    + apply rep_mor_law_pb.
Defined.

Definition pb_rep_to_cartesian {a a'} (f : signature_category ⟦ a, a' ⟧)
           (R : model a') : is_cartesian ((pb_rep_to f R) :
                                             (pb_rep f R : rep_disp a) -->[_] R).
Proof.
  intros.
  intro b.
  intros g S hh.
  unshelve eapply unique_exists.
  - apply rep_mor_pb.
    exact hh.
  - abstract (apply model_mor_mor_equiv;
    intro c;
    apply id_right).
  - intro u.
    apply isaset_model_mor_mor.
  - abstract (intros u h;
    apply model_mor_mor_equiv;
    intro c;
    cbn;
    rewrite <- h;
    apply pathsinv0;
    apply id_right).
Defined.
           (* (pb_rep f R) R f *)
Lemma rep_cleaving : cleaving rep_disp.
Proof.
  intros a a' f R.
  red.
  use tpair;[ |use tpair].
  - apply (pb_rep f R).
  - apply pb_rep_to.
  - apply pb_rep_to_cartesian.
Defined.

End LargeCatRep.

Arguments rep_disp _ : clear implicits.
Arguments rep_cleaving : clear implicits.

(*
Lemma transport_disp_mor {C} {d:disp_cat C} {x y : C} {f g : C ⟦ x, y ⟧}
        (e : f = g)
        {xx : d x}     {yy : d y}
        (ff : xx -->[ f] yy)
        (Q : UU)
        (P : ∏ (z:C ⟦ x, y ⟧) ,xx -->[ z] yy -> Q)
    :
      (P _ (transportf (mor_disp xx yy) e ff))  = P _ ff.
  Proof.
    destruct e.
    intros.
    apply idpath.
  Qed.
*)

  (*
Lemma rep_ar_mor_mor_equiv_inv {a b : SIGNATURE} {R:rep_disp_ob_mor a}
      {S:rep_disp_ob_mor b} {f:signature_Mor  a b}
      (u v: R -->[ f] S)
  : u = v -> (∏ c, pr1 (pr1 u) c = pr1 (pr1 v) c).
Proof.
  intros.
  now induction X.
Qed.
   *)

  (*
 Lemma transport_signature_mor' (x y : SIGNATURE) f g
        (e : f = g)
        (ff : disp_nat_trans f x y)
        (R:MONAD)
        (c : C) :
    pr1 (pr1 (transportf (mor_disp (D:=GEN_SIGNATURE) x y) e ff) R tt) c
    = pr1 (pr1 ff R tt) c.
  Proof.
    now induction e.
  Qed.
*)

  (*
  Lemma eq_ar_pointwise  (a b c : SIGNATURE)  (f:PRECAT_SIGNATURE⟦ a,b⟧)
        (g:PRECAT_SIGNATURE⟦ b,c⟧) (R:MONAD) x :
    ( (f ;; g) `` R) x = ( f`` R) x ;; ( g`` R) x .
  Proof.
    intros.
    etrans.
    use (transport_signature_mor' a c _ ).
    cbn.
    now rewrite  id_right.
  Qed.
*)

  (*
  Lemma rep_transport (x y : SIGNATURE)
        (R S:MONAD)
        (f g : Monad_Mor R S )
        (e : f = g)
        (ff : pr1 x R (tt) -->[ f] pr1 y S (tt))
        (c : C) :
    pr1 (transportf _ e ff) c  = pr1 ff c .
  Proof.
    intros.
    simpl.
    now induction e.
  Qed.
*)

  (* Notation "# F" := (ar_mor F) (at level 3) : signature_scope. *)

  (*
  Definition ar_mor_pw {a b : SIGNATURE} (f:signature_Mor a b) (R:MONAD) :
    LModule_Mor _  (a ` R)
                (pb_LModule ((nat_trans_id (functor_identity PRE_MONAD)) R)
                            (b ` R))
    := (f : signature_mor (a:signature) (b:signature)) R.
*)

  (* Infix "``" := ar_mor_pw (at level 25) : signature_scope . *)


(*|
########################################################################################
All-quantified type variable in (value) constructor cannot be explicitly typed as wanted
########################################################################################

:Link: https://stackoverflow.com/q/41104527
|*)

(*|
Question
********

I have the following GADT.
|*)

Inductive GADT : Type -> Type :=
| A : forall A, GADT A
| B : GADT bool.

(*|
And the following data type that has one constructor with an
all-qualified type variable.
|*)

Inductive Wrap A :=
| wrap : GADT A -> Wrap A
| unwrap : forall X, GADT X -> (X -> Wrap A) -> Wrap A.

(*|
Then I want to define a recursive function that uses the function
within ``unwrap``.
|*)

Fail Fixpoint wrappedGADT {A} (xs : Wrap A) : option (GADT A) :=
  match xs with
  | wrap _ x => Some x
  | unwrap _ _ fx k => match fx with
                       | A _ => None
                       | B => wrappedGADT (k true)
                       end
  end. (* .unfold *)

(*|
I was assuming that when I inspect ``fx`` and get case ``B``, the
parameter ``fx`` has type ``GADT bool``, thus, the all-quantified type
variable ``X`` is ``bool`` as well. Is this assumption wrong?

Next, I tried to explicitly type ``unwrap`` as follows.
|*)

Fail Fixpoint wrappedGADT {A} (xs : Wrap A) : option (GADT A) :=
  match xs with
  | wrap _ x => Some x
  | @unwrap _ bool fx k => match fx with
                           | A _ => None
                           | B => wrappedGADT (k true)
                           end
  end. (* .unfold *)

(*| Can anybody give any pointers to the origin of this problem? |*)

(*|
Answer (Daniel Schepler)
************************

Unfortunately, raw match statements in Coq aren't always very smart
about the kind of reasoning you're applying here. The "convoy pattern"
(see CPDT for more information about it) is usually the answer for
resolving this type of problem. The immediate application here would
look something like:
|*)

Fixpoint wrappedGADT {A} (xs : Wrap A) {struct xs} : option (GADT A) :=
  match xs with
  | wrap _ x => Some x
  | unwrap _ _ fx k => match fx in (GADT T)
                             return ((T -> Wrap A) -> option (GADT A)) with
                       | A _ => fun k0 => None
                       | B => fun k0 => wrappedGADT (k0 true)
                       end k
  end.

(*|
However, this runs into another issue, that Coq isn't able to verify
the termination condition after passing the function through the
"convoy". It seems that to work around that, it suffices to first
define the function of recursive calls on values of ``k`` and then
convoy that instead:
|*)

Reset wrappedGADT. (* .none *)
Fixpoint wrappedGADT {A} (xs : Wrap A) {struct xs} : option (GADT A) :=
  match xs with
  | wrap _ x => Some x
  | unwrap _ _ fx k =>
      let r := fun x => wrappedGADT (k x) in
      match fx in (GADT T)
            return ((T -> option (GADT A)) -> option (GADT A)) with
      | A _ => fun _ => None
      | B => fun r' => r' true
      end r
  end.

(*|
For your second code attempt, you're creating a local variable
``bool`` to hold the type called ``X`` in the ``unwrap`` constructor,
which is then shadowing the ``Datatypes.bool`` definition. In general,
there's no way to match only on one specific type in the Coq kernel
language (although typeclasses provide a way to simulate that,
somewhat).
|*)

(*|
Answer (Anton Trunov)
*********************

Here is an alternative implementation, which constructs
``wrappedGADT``'s body using tactics. It has one advantage that it
doesn't require manual ``return`` annotations from the user. The
overall structure closely resembles your original code with the
``match`` expression.

It is crucial to use ``induction xs`` as opposed to ``destruct xs``
here, because the ``Wrap`` type is recursive.
|*)

Fixpoint wrappedGADT' {A} (xs : Wrap A) : option (GADT A).
  induction xs as [x | ? fx k r].
  - exact (Some x).
  - destruct fx as [T | ].
    + exact None.
    + exact (r true).
Defined.

(*|
Here is a proof that the two implementations are extensionally equal.
|*)

Goal forall (A : Type) (xs : Wrap A),
    wrappedGADT xs = wrappedGADT' xs.
Proof with auto.
  intros A xs.
  induction xs...
  destruct g...
  simpl; rewrite H; destruct (w true)...
Qed.

(*|
----

If we look at the term generated for ``wrappedGADT'`` (using ``Print
wrappedGADT'.``), we'll be able to construct one more solution using
the ``Wrap_rect`` induction principle generated for the ``Wrap``
datatype (I just removed unused variable ``k`` from the ``match``
expression in ``wrappedGADT'``):
|*)

Definition wrappedGADT'' {A} (xs : Wrap A) : option (GADT A) :=
  Wrap_rect _
            _
            (fun t => Some t)
            (fun _ fx k r =>
               match fx in (GADT T)
                     return ((T -> option (GADT A)) -> option (GADT A)) with
               | A _ => fun _ => None
               | B => fun r' => r' true
               end r)
            xs.

(*|
This solution can then lead to a solution a-la `Daniel's
<https://stackoverflow.com/a/41111181/2747511>`__, if we unfold
``Wrap_rect``, implemented as ``Fixpoint`` itself.
|*)


From mathcomp Require Import ssreflect.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Classes.SetoidClass.
Require Import Coq.Relations.Relation_Definitions.
From Category.Base Require Import Logic Category Functor NatTran.
From Category.Instances Require Import Univ.FunctorComp Univ.NatTranComp.

Set Universe Polymorphism.

Program Definition FunctorCategory (C D : Category) : Category :=
  {|
    Obj := Functor C D;
    Hom := fun (F1 F2 : Functor C D) => NatTran F1 F2;
    Hom_Id := fun (F1 : Functor C D) => NatTran_Id F1;
    Hom_comp := fun (F1 F2 F3 : Functor C D) => fun (N1 : NatTran F2 F3) (N2 : NatTran F1 F2) => NatTran_Vertical_Comp N1 N2
  |}.
Next Obligation.
Proof.
  exact: NatTran_Vertical_Comp_assoc.
Qed.
Next Obligation.
  exact: NatTran_Vertical_Comp_IdL.
Qed.
Next Obligation.
  exact: NatTran_Vertical_Comp_IdR.
Qed.

Section NaturalEquivalence.

  Context {C D : Category}.
  Context {F1 F2 : Functor C D}.

  Definition NaturalEquivalence (N1 : NatTran F1 F2) := @isomorphism (FunctorCategory C D) _ _ N1.

  Lemma ToNaturalEquivalence : forall N1,
      (forall X, isomorphism (NApp N1 X)) -> NaturalEquivalence N1.
  Proof.
    move => N1 cond.
    have: (forall (X : Obj C), exists! (h : Hom (FApp F2 X) (FApp F1 X)), isomorphism_pair (NApp N1 X) h).
    {
      move => X.
      move: (cond X).
      case.
      move => h pair_Nx.
      exists h.
      split.
      {
        destruct pair_Nx.
        by split.
      } {
        move => h' pair_Nh'.
        apply: (isomorphism_pair_unqR (NApp N1 X)).
        by split.
      }
    }
    move => Cond.
    apply (dependent_unique_choice (Obj C) (fun X => Hom (FApp F2 X) (FApp F1 X))) in Cond.
    move: Cond.
    case.
    move => NApp2 ispair.
    have: (forall (X Y : Obj C) (f : Hom X Y), FAppH F1 f \o (NApp2 X) = (NApp2 Y) \o FAppH F2 f).
    {
      move => X Y f.
      move: (NatTran_rectangle _ _ N1 _ _ f).
      move => HH.
      apply (f_equal (fun N => N \o (NApp2 X))) in HH.
      rewrite (Hom_assoc (FAppH F2 f) (NApp N1 X) (NApp2 X)) in HH.
      rewrite (proj2 (ispair X)) in HH.
      rewrite (Hom_IdR) in HH.
      move: HH =>->.
      rewrite <- (Hom_assoc (NApp2 Y) _ (NApp2 X)).
      rewrite <- (Hom_assoc (NApp2 Y) (NApp N1 Y)).
      rewrite (proj1 (ispair Y)).
      rewrite Hom_IdL.
      reflexivity.
    }
    move => NApp2_cond.
    set (Build_NatTran _ _ _ _ NApp2 NApp2_cond) as N2.
    exists N2.
    split; rewrite /=; apply ToNatTranEq; unfold NatTran_Vertical_Comp; rewrite /=; apply: functional_extensionality_dep; move => X; move: (ispair X); case; by [].
  Qed.

  Lemma OfNaturalEquivalence : forall N1,
      NaturalEquivalence N1 -> (forall X, isomorphism (NApp N1 X)).
  Proof.
    unfold NaturalEquivalence.
    move => N1.
    move => [N2 [eqN21 eqN12]].
    move => X.
    exists (NApp N2 X).
    split.
    {
      move: eqN21.
      rewrite /=.
      by apply/ (f_equal (fun N => NApp N X)).
    } {
      move: eqN12.
      rewrite /=.
      by apply/ (f_equal (fun N => NApp N X)).
    }
  Qed.

End NaturalEquivalence.

Lemma NApp_HomId'_eq {C D : Category} {F1 F2: Functor C D} (eqF : F1 = F2) X (eqFX : FApp F1 X = FApp F2 X) :
  NApp (@HomId' (FunctorCategory C D) _ _ eqF) X = HomId' eqFX.
Proof.
  subst.
  repeat rewrite HomId'_id.
  rewrite /=.
  reflexivity.
Qed.

Program Definition ToConstFunctor (C D : Category) : Functor D (FunctorCategory C D) :=
  {|
    FApp := fun (X : Obj D) => ConstFunctor C X;
    FAppH := fun X1 X2 => fun f =>
                            {|
                              NApp := fun Y => f
                            |}
  |}.
Next Obligation.
  rewrite Hom_IdL.
  rewrite Hom_IdR.
  reflexivity.
Qed.
Next Obligation.
  apply: ToNatTranEq.
  rewrite /=.
  reflexivity.
Qed.
Next Obligation.
  apply: ToNatTranEq.
  rewrite /=.
  reflexivity.
Qed.