Require Import QArith_base Qcanon.
Require Import Reals.
Require Import RPolS.
Require Import PolSBase.
Require Import PolFBase.
Require Import PolAux.
Require Import PolAuxList.
Require Import RSignTac.

Definition Qcgcd x y := (Qcdiv x y).

Definition Rfactor :=
  factor Qc Qcplus Qcmult Qcopp 0 1 is_Qc1 is_Qc0 is_Qcpos is_Qcdiv Qcdiv Qcgcd.

Definition Rfactor_minus :=
  factor_sub Qc Qcplus Qcmult Qcopp 0 1 is_Qc1 is_Qc0 is_Qcpos is_Qcdiv Qcdiv Qcgcd.

Ltac Rfactor_term term1 term2 :=
  let term := constr:(Rminus term1 term2) in
  let rfv := FV RCst Rplus Rmult Rminus Ropp term (@nil R) in
  let fv := Trev rfv in
  let expr1 := mkPolexpr Qc RCst Rplus Rmult Rminus Ropp term1 fv in
  let expr2 := mkPolexpr Qc RCst Rplus Rmult Rminus Ropp term2 fv in
  let re := (eval vm_compute in (Rfactor_minus (PEsub expr1 expr2))) in
  let factor := match re with (PEmul ?X1 _) => X1 end in
  let expr3 := match re with (PEmul _ (PEsub ?X1 _)) => X1 end in
  let expr4 := match re with (PEmul _ (PEsub _ ?X1 )) => X1 end in
  let re1' :=
      (eval
         unfold
        Rconvert_back, convert_back, pos_nth, jump,
       hd, tl, Qc2R_can, Qcanon.this, Q2Qc, Qreduction.Qred,
       Z.eqb, Qden, Qnum, Z2R, P2R,
       Pos.eqb, Z.ggcd, Z.abs, snd, Z.to_pos, Z.sgn,
       Pos.ggcd, Pos.size_nat, Nat.add, Pos.ggcdn
       in (Rconvert_back (PEmul factor expr3) fv)) in
  let re1'' := (eval lazy beta in re1')
  in
  let re2' :=
      (eval
         unfold
        Rconvert_back, convert_back, pos_nth, jump,
       hd, tl, Qc2R_can, Qcanon.this, Q2Qc, Qreduction.Qred,
      Z.eqb, Qden, Qnum, Z2R, P2R,
       Pos.eqb, Z.ggcd, Z.abs, snd, Z.to_pos, Z.sgn,
       Pos.ggcd, Pos.size_nat, Nat.add, Pos.ggcdn
      in (Rconvert_back (PEmul factor expr4) fv)) in
  let re2'' := (eval lazy beta in re2')
  in
  replace2_tac term1 term2 re1'' re2''; [idtac | ring | ring].

Ltac rpolf :=
  progress
    (try match goal with
         | |- (?X1 = ?X2)%R => Rfactor_term X1 X2
         | |- (?X1 <> ?X2)%R => Rfactor_term X1 X2
         | |- Rlt ?X1 ?X2 => Rfactor_term X1 X2
         | |- Rgt ?X1 ?X2 => Rfactor_term X1 X2
         | |- Rle ?X1 ?X2 => Rfactor_term X1 X2
         | |- Rge ?X1 ?X2 => Rfactor_term X1 X2
         | _ => fail end);
  try rsign_tac; try repeat (rewrite Rmult_1_l || rewrite Rmult_1_r).

Ltac hyp_rpolf H :=
  progress
    (generalize H;
     try match type of H with
         | (?X1 = ?X2)%R => Rfactor_term X1 X2
         | (?X1 <> ?X2)%R => Rfactor_term X1 X2
         | Rlt ?X1 ?X2 => Rfactor_term X1 X2
         | Rgt ?X1 ?X2 => Rfactor_term X1 X2
         | Rle ?X1 ?X2 => Rfactor_term X1 X2
         | Rge ?X1 ?X2 => Rfactor_term X1 X2
         | _ => fail end);
  clear H; intros H;
  try hyp_rsign_tac H; try repeat rewrite Rmult_1_l in H.


(** * Classification of the [×] Type *)
(** In this file, we classify the basic structure of [×] types ([prod]
    in Coq).  In particular, we classify equalities of non-dependent
    pairs (inhabitants of [×] types), so that when we have an equality
    between two such pairs, or when we want such an equality, we have
    a systematic way of reducing such equalities to equalities at
    simpler types. *)
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Bool.Bool.
Require Import Rewriter.Util.IffT.
Require Import Rewriter.Util.Equality.
Require Import Rewriter.Util.GlobalSettings.

Local Arguments fst {_ _} _.
Local Arguments snd {_ _} _.
Local Arguments f_equal {_ _} _ {_ _} _.

Scheme Equality for prod.

Definition prod_beq_hetero {A1 B1 A2 B2} (A_beq_hetero : A1 -> A2 -> bool) (B_beq_hetero : B1 -> B2 -> bool)
           (x : A1 * B1) (y : A2 * B2) : bool
  := (A_beq_hetero (fst x) (fst y) && B_beq_hetero (snd x) (snd y))%bool.

Arguments prod_beq_hetero {_ _ _ _} _ _ x y / .

Lemma prod_bl_hetero {A1 B1 A2 B2}
      {A_beq_hetero : A1 -> A2 -> bool} {A_R : A1 -> A2 -> Prop}
      {B_beq_hetero : B1 -> B2 -> bool} {B_R : B1 -> B2 -> Prop}
      (A_bl : forall x y, A_beq_hetero x y = true -> A_R x y)
      (B_bl : forall x y, B_beq_hetero x y = true -> B_R x y)
      {x y}
  : prod_beq_hetero A_beq_hetero B_beq_hetero x y = true -> A_R (fst x) (fst y) /\ B_R (snd x) (snd y).
Proof using Type.
  destruct x, y; cbn in *; rewrite ?Bool.andb_true_iff; intuition auto.
Qed.

Lemma prod_lb_hetero {A1 B1 A2 B2}
      {A_beq_hetero : A1 -> A2 -> bool} {A_R : A1 -> A2 -> Prop}
      {B_beq_hetero : B1 -> B2 -> bool} {B_R : B1 -> B2 -> Prop}
      (A_lb : forall x y, A_R x y -> A_beq_hetero x y = true)
      (B_lb : forall x y, B_R x y -> B_beq_hetero x y = true)
      {x y}
  : A_R (fst x) (fst y) /\ B_R (snd x) (snd y) -> prod_beq_hetero A_beq_hetero B_beq_hetero x y = true.
Proof using Type.
  destruct x, y; cbn in *; rewrite ?Bool.andb_true_iff; intuition auto.
Qed.

Lemma prod_beq_hetero_uniform {A B : Type} A_beq B_beq {x y}
  : prod_beq_hetero A_beq B_beq x y = @prod_beq A B A_beq B_beq x y.
Proof. destruct x, y; reflexivity. Qed.

Lemma prod_bl_hetero_eq {A B}
      {A_beq : A -> A -> bool}
      {B_beq : B -> B -> bool}
      (A_bl : forall x y, A_beq x y = true -> x = y)
      (B_bl : forall x y, B_beq x y = true -> x = y)
      {x y}
  : prod_beq_hetero A_beq B_beq x y = true -> x = y.
Proof using Type. rewrite prod_beq_hetero_uniform; now apply internal_prod_dec_bl. Qed.

Lemma prod_lb_hetero_eq {A B}
      {A_beq : A -> A -> bool}
      {B_beq : B -> B -> bool}
      (A_lb : forall x y, x = y -> A_beq x y = true)
      (B_lb : forall x y, x = y -> B_beq x y = true)
      {x y}
  : x = y -> prod_beq_hetero A_beq B_beq x y = true.
Proof using Type. rewrite prod_beq_hetero_uniform; now apply internal_prod_dec_lb. Qed.

(* We would use [Scheme Minimality for prod Sort Type.], but we want
   [prod_rect_nodep] to unfold directly to [prod_rect] so that
   unification doesn't have a hard time unifying [prod_rect] and
   [prod_rect_nodep] on large arguments. *)
Definition prod_rect_nodep {A B P} : (A -> B -> P) -> A * B -> P
  := @prod_rect A B (fun _ => P).
(** Strongly prefer unfolding this version of [prod_rect] to the
    underlying [prod_rect] principle.  Possibly -1 would suffice rather
    than expand, but I don't think there's harm in [expand] because
    [prod_rect] ought not be much more complicated than any of these *)
Global Strategy expand [prod_rect_nodep].

Definition fst_pair {A B} (a:A) (b:B) : fst (a,b) = a := eq_refl.
Definition snd_pair {A B} (a:A) (b:B) : snd (a,b) = b := eq_refl.
Create HintDb cancel_pair discriminated. #[global] Hint Rewrite @fst_pair @snd_pair : cancel_pair.

(** ** Equality for [prod] *)
Section prod.
  (** *** Projecting an equality of a pair to equality of the first components *)
  Definition fst_path {A B} {u v : prod A B} (p : u = v)
  : fst u = fst v
    := f_equal fst p.

  (** *** Projecting an equality of a pair to equality of the second components *)
  Definition snd_path {A B} {u v : prod A B} (p : u = v)
  : snd u = snd v
    := f_equal snd p.

  (** *** Equality of [prod] is itself a [prod] *)
  Definition path_prod_uncurried {A B : Type} (u v : prod A B)
             (pq : prod (fst u = fst v) (snd u = snd v))
    : u = v.
  Proof.
    destruct u as [u1 u2], v as [v1 v2]; simpl in *.
    destruct pq as [p q].
    destruct p, q; simpl in *.
    reflexivity.
  Defined.

  (** *** Equality of [pair]s is itself a [prod] *)
  Definition path_pair_uncurried {A B : Type} (a1 a2 : A) (b1 b2 : B)
             (pq : prod (a1 = a2) (b1 = b2))
    : (a1, b1) = (a2, b2)
    := path_prod_uncurried (_, _) (_, _) pq.

  (** *** Curried version of proving equality of prod types *)
  Definition path_prod {A B : Type} (u v : prod A B)
             (p : fst u = fst v) (q : snd u = snd v)
    : u = v
    := path_prod_uncurried u v (pair p q).

  (** *** Curried version of proving equality of prod types *)
  Definition path_pair {A B : Type} (a1 a2 : A) (b1 b2 : B)
             (p : a1 = a2) (q : b1 = b2)
    : (a1, b1) = (a2, b2)
    := path_pair_uncurried _ _ _ _ (pair p q).

  (** *** Equivalence of equality of [prod] with a [prod] of equality *)
  (** We could actually use [IsIso] here, but for simplicity, we
      don't.  If we wanted to deal with proofs of equality of × types
      in dependent positions, we'd need it. *)
  Definition path_prod_uncurried_iff {A B}
             (u v : @prod A B)
    : u = v <-> (prod (fst u = fst v) (snd u = snd v)).
  Proof.
    split; [ intro; subst; split; reflexivity | apply path_prod_uncurried ].
  Defined.

  Definition path_pair_uncurried_iff {A B}
             (a1 a2 : A) (b1 b2 : B)
    : (a1, b1) = (a2, b2) <-> (prod (a1 = a2) (b1 = b2))
    := path_prod_uncurried_iff (_, _) (_, _).

  (** *** Eta-expansion of [@eq (prod _ _)] *)
  Definition path_prod_eta {A B} {u v : @prod A B} (p : u = v)
    : p = path_prod_uncurried u v (fst_path p, snd_path p).
  Proof. destruct u, p; reflexivity. Defined.

  (** *** Induction principle for [@eq (prod _ _)] *)
  Definition path_prod_rect {A B} {u v : @prod A B} (P : u = v -> Type)
             (f : forall p q, P (path_prod_uncurried u v (p, q)))
    : forall p, P p.
  Proof. intro p; specialize (f (fst_path p) (snd_path p)); destruct u, p; exact f. Defined.
  Definition path_prod_rec {A B u v} (P : u = v :> @prod A B -> Set) := path_prod_rect P.
  Definition path_prod_ind {A B u v} (P : u = v :> @prod A B -> Prop) := path_prod_rec P.

  Definition path_pair_rect {A B} {a1 a2 : A} {b1 b2 : B} (P : (a1, b1) = (a2, b2) -> Type)
             (f : forall p q, P (path_pair_uncurried _ _ _ _ (p, q)))
    : forall p, P p
    := path_prod_rect P f.
  Definition path_pair_rec {A B a1 a2 b1 b2} (P : (a1, b1) = (a2, b2) :> @prod A B -> Set) := path_pair_rect P.
  Definition path_pair_ind {A B a1 a2 b1 b2} (P : (a1, b1) = (a2, b2) :> @prod A B -> Prop) := path_pair_rec P.
End prod.

Lemma prod_iff_and (A B : Prop) : (A /\ B) <-> (A * B).
Proof. repeat (intros [? ?] || intro || split); assumption. Defined.

Global Instance iff_prod_Proper
  : Proper (iff ==> iff ==> iff) (fun A B => prod A B).
Proof. repeat intro; tauto. Defined.
Global Instance iff_iffTp_prod_Proper
  : Proper (iff ==> iffTp ==> iffTp) (fun A B => prod A B) | 1.
Proof.
  intros ?? [?] ?? [?]; constructor; tauto.
Defined.
Global Instance iffTp_iff_prod_Proper
  : Proper (iffTp ==> iff ==> iffTp) (fun A B => prod A B) | 1.
Proof.
  intros ?? [?] ?? [?]; constructor; tauto.
Defined.
Global Instance iffTp_iffTp_prod_Proper
  : Proper (iffTp ==> iffTp ==> iffTp) (fun A B => prod A B) | 1.
Proof.
  intros ?? [?] ?? [?]; constructor; tauto.
Defined.
Global Hint Extern 2 (Proper _ prod) => apply iffTp_iffTp_prod_Proper : typeclass_instances.
Global Hint Extern 2 (Proper _ (fun A => prod A)) => refine iff_iffTp_prod_Proper : typeclass_instances.
Global Hint Extern 2 (Proper _ (fun A B => prod A B)) => refine iff_prod_Proper : typeclass_instances.

(** ** Useful Tactics *)
(** *** [inversion_prod] *)
Ltac simpl_proj_pair_in H :=
  repeat match type of H with
         | context G[fst (pair ?x ?p)]
           => let G' := context G[x] in change G' in H
         | context G[snd (pair ?x ?p)]
           => let G' := context G[p] in change G' in H
         end.
Ltac induction_path_prod H :=
  let H0 := fresh H in
  let H1 := fresh H in
  induction H as [H0 H1] using path_prod_rect;
  simpl_proj_pair_in H0;
  simpl_proj_pair_in H1.
Ltac inversion_prod_step :=
  match goal with
  | [ H : _ = pair _ _ |- _ ]
    => induction_path_prod H
  | [ H : pair _ _ = _ |- _ ]
    => induction_path_prod H
  end.
Ltac inversion_prod := repeat inversion_prod_step.

(** *** [inversion_pair] *)
(** A version of [inversion_prod] that occurs only when there are pairs on both sides *)
Ltac induction_path_pair H :=
  let H0 := fresh H in
  let H1 := fresh H in
  induction H as [H0 H1] using path_pair_rect.
Ltac inversion_pair_step :=
  match goal with
  | [ H : pair _ _ = pair _ _ |- _ ]
    => induction_path_pair H
  | [ H : pair _ _ = pair _ _ |- _ ]
    => induction_path_pair H
  end.
Ltac inversion_pair := repeat inversion_pair_step.

(** This turns a goal like [x = let v := p in let '(x, y) := f v in x
    + y)] into a goal like [x = fst (f p) + snd (f p)].  Note that it
    inlines [let ... in ...] as well as destructuring lets. *)
Ltac only_eta_expand_and_contract_step :=
  match goal with
  | [ |- context[let '(x, y) := ?e in _] ]
    => rewrite (surjective_pairing e)
  | [ H : context[let '(x, y) := ?e in _] |- _ ]
    => rewrite (surjective_pairing e) in H
  | _ => rewrite <- !surjective_pairing
  | [ H : context[(fst ?e, snd ?e)] |- _ ]
    => rewrite <- !surjective_pairing in H
  end.
Ltac only_eta_expand_and_contract := repeat only_eta_expand_and_contract_step.
Ltac eta_expand :=
  repeat first [ progress cbv beta iota zeta
               | only_eta_expand_and_contract_step ].

(** *** [subst_prod] *)
(** The tactic [subst_prod] is like [subst], but it works on equations
    of the form [_ = (x, y)] and [(x, y) = _] for [x] and [y]
    identifiers (or recursively pairs of identitifers). *)
Ltac on_pair_vars tac x :=
  lazymatch x with
  | pair ?x ?y => on_pair_vars tac x; on_pair_vars tac y
  | _ => tac x
  end.
Ltac is_pair_var x := on_pair_vars is_var x.
Ltac do_subst_prod v :=
  lazymatch v with
  | @pair ?A ?B ?x ?y
    => let H := fresh in
       let xy := fresh v in
       remember v as xy eqn:H;
       assert (fst xy = x) by (subst xy; reflexivity);
       assert (snd xy = y) by (subst xy; reflexivity);
       clear H;
       do_subst_prod x; do_subst_prod y;
       try subst xy
  | _ => subst v
  end.
Ltac subst_prod_step :=
  first [ inversion_pair_step
        | match goal with
          | [ H : _ = ?v |- _ ] => is_pair_var v; do_subst_prod v
          | [ H : ?v = _ |- _ ] => is_pair_var v; do_subst_prod v
          end ].
Ltac subst_prod := repeat subst_prod_step.


Require Import Coq.Unicode.Utf8.

 Infix "≡" := (x=y) (at level 70, no associativity).
(*
Theorem thn (A : Type)
  (i : nat)
  (index_f : nat → nat)
  (n : nat)
  (ip : n < i)
  (partial_index_f : nat → option nat)
  (L : (partial_index_f (index_f n)) = Some n)
  (V : ∀ i0 : nat, i0 < i → option A)
  (l : ∀ z : nat, partial_index_f (index_f n) = Some z → z < i)
  :
   V n ip
   ≡ match
       partial_index_f (index_f n) as fn
       return (partial_index_f (index_f n) = fn → option A)
     with
     | Some z => λ p : partial_index_f (index_f n) = Some z, V z (l z p)
     | None => λ _ : partial_index_f (index_f n) = None, None
     end eq_refl.
*)


Add LoadPath "D:\sfsol".
Require Export Stlc.

Module STLCExtendedRecords.

Module FirstTry.

Definition alist (X : Type) := list (id * X).

Inductive ty : Type :=
  | TBase : id -> ty
  | TArrow : ty -> ty -> ty
  | TRcd : (alist ty) -> ty.

End FirstTry.

Inductive ty : Type :=
  | TBase : id -> ty
  | TArrow : ty -> ty -> ty
  | TRNil : ty
  | TRCons : id -> ty -> ty -> ty.

Tactic Notation "T_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "TBase" | Case_aux c "TArrow"
  | Case_aux c "TRNil" | Case_aux c "TRCons" ].

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | tproj : tm -> id -> tm
  | trnil : tm
  | trcons : id -> tm -> tm -> tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp" | Case_aux c "tabs"
  | Case_aux c "tproj" | Case_aux c "trnil" | Case_aux c "trcons" ].

Notation a := (Id 0).
Notation f := (Id 1).
Notation g := (Id 2).
Notation l := (Id 3).
Notation A := (TBase (Id 4)).
Notation B := (TBase (Id 5)).
Notation k := (Id 6).
Notation i1 := (Id 7).
Notation i2 := (Id 8).

Inductive record_ty : ty -> Prop :=
  | RTnil :
        record_ty TRNil
  | RTcons : forall i T1 T2,
        record_ty (TRCons i T1 T2).

Inductive record_tm : tm -> Prop :=
  | rtnil :
        record_tm trnil
  | rtcons : forall i t1 t2,
        record_tm (trcons i t1 t2).

Inductive well_formed_ty : ty -> Prop :=
  | wfTBase : forall i,
        well_formed_ty (TBase i)
  | wfTArrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty (TArrow T1 T2)
  | wfTRNil :
        well_formed_ty TRNil
  | wfTRCons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty (TRCons i T1 T2).

Hint Constructors record_ty record_tm well_formed_ty.

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar y => if eq_id_dec x y then s else t
  | tabs y T t1 => tabs y T (if eq_id_dec x y then t1 else (subst x s t1))
  | tapp t1 t2 => tapp (subst x s t1) (subst x s t2)
  | tproj t1 i => tproj (subst x s t1) i
  | trnil => trnil
  | trcons i t1 tr1 => trcons i (subst x s t1) (subst x s tr1)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

Inductive value : tm -> Prop :=
  | v_abs : forall x T11 t12,
      value (tabs x T11 t12)
  | v_rnil : value trnil
  | v_rcons : forall i v1 vr,
      value v1 ->
      value vr ->
      value (trcons i v1 vr).

Hint Constructors value.

Fixpoint Tlookup (i:id) (Tr:ty) : option ty :=
  match Tr with
  | TRCons i' T Tr' => if eq_id_dec i i' then Some T else Tlookup i Tr'
  | _ => None
  end.

Fixpoint tlookup (i:id) (tr:tm) : option tm :=
  match tr with
  | trcons i' t tr' => if eq_id_dec i i' then Some t else tlookup i tr'
  | _ => None
  end.

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T11 t12 v2,
         value v2 ->
         (tapp (tabs x T11 t12) v2) ==> ([x:=v2]t12)
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         (tapp t1 t2) ==> (tapp t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         (tapp v1 t2) ==> (tapp v1 t2')
  | ST_Proj1 : forall t1 t1' i,
        t1 ==> t1' ->
        (tproj t1 i) ==> (tproj t1' i)
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tlookup i tr = Some vi ->
        (tproj tr i) ==> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 ==> t1' ->
        (trcons i t1 tr2) ==> (trcons i t1' tr2)
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 ==> tr2' ->
        (trcons i v1 tr2) ==> (trcons i v1 tr2')

where "t1 '==>' t2" := (step t1 t2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1" | Case_aux c "ST_App2"
  | Case_aux c "ST_Proj1" | Case_aux c "ST_ProjRcd"
  | Case_aux c "ST_Rcd_Head" | Case_aux c "ST_Rcd_Tail" ].

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Hint Constructors step.

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      well_formed_ty T ->
      Gamma |- (tvar x) \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      well_formed_ty T11 ->
      (extend Gamma x T11) |- t12 \in T12 ->
      Gamma |- (tabs x T11 t12) \in (TArrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in (TArrow T1 T2) ->
      Gamma |- t2 \in T1 ->
      Gamma |- (tapp t1 t2) \in T2
  | T_Proj : forall Gamma i t Ti Tr,
      Gamma |- t \in Tr ->
      Tlookup i Tr = Some Ti ->
      Gamma |- (tproj t i) \in Ti
  | T_RNil : forall Gamma,
      Gamma |- trnil \in TRNil
  | T_RCons : forall Gamma i t T tr Tr,
      Gamma |- t \in T ->
      Gamma |- tr \in Tr ->
      record_ty Tr ->
      record_tm tr ->
      Gamma |- (trcons i t tr) \in (TRCons i T Tr)

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs" | Case_aux c "T_App"
  | Case_aux c "T_Proj" | Case_aux c "T_RNil" | Case_aux c "T_RCons" ].

Lemma typing_example_2 :
  empty |-
    (tapp (tabs a (TRCons i1 (TArrow A A)
                      (TRCons i2 (TArrow B B)
                       TRNil))
              (tproj (tvar a) i2))
            (trcons i1 (tabs a A (tvar a))
            (trcons i2 (tabs a B (tvar a))
             trnil))) \in
    (TArrow B B).
Proof with eauto.
  econstructor... econstructor...
  econstructor... apply T_Var.
  unfold extend. rewrite eq_id...
  eauto. unfold Tlookup...
  econstructor...
  Qed.

Example typing_nonexample :
  ~ exists T,
      (extend empty a (TRCons i2 (TArrow A A)
                                TRNil)) |-
               (trcons i1 (tabs a B (tvar a)) (tvar a)) \in
               T.
Proof.
  intros contra. inversion contra.
  inversion H; subst.
  inversion H8. Qed.

Example typing_nonexample_2 : forall y,
  ~ exists T,
    (extend empty y A) |-
           (tapp (tabs a (TRCons i1 A TRNil)
                     (tproj (tvar a) i1))
                   (trcons i1 (tvar y) (trcons i2 (tvar y) trnil))) \in
           T.
Proof.
  intros y contra.
  inversion contra; clear contra; inversion H; clear H; subst.
  inversion H3; subst; clear H3... inversion H8; subst; clear H8...
  inversion H3; subst... unfold extend in H0. rewrite eq_id in H0.
  inversion H0; subst; clear H0... inversion H5; subst; clear H5.
  inversion H11; subst; clear  H11.
  Qed.

Lemma wf_rcd_lookup : forall i T Ti,
  well_formed_ty T ->
  Tlookup i T = Some Ti ->
  well_formed_ty Ti.
Proof with eauto.
  intros i T.
  T_cases (induction T) Case; intros; try solve by inversion.
  Case "TRCons".
    inversion H. subst. unfold Tlookup in H0.
    destruct (eq_id_dec i i0)...
    inversion H0. subst... Qed.

Lemma step_preserves_record_tm : forall tr tr',
  record_tm tr ->
  tr ==> tr' ->
  record_tm tr'.
Proof.
  intros tr tr' Hrt Hstp.
  inversion Hrt; subst; inversion Hstp; subst; auto.
Qed.

Lemma has_type__wf : forall Gamma t T,
  Gamma |- t \in T -> well_formed_ty T.
Proof with eauto.
  intros Gamma t T Htyp.
  has_type_cases (induction Htyp) Case...
  Case "T_App".
    inversion IHHtyp1...
  Case "T_Proj".
    eapply wf_rcd_lookup...
Qed.

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  empty |- v \in T ->
  Tlookup i T = Some Ti ->
  exists ti, tlookup i v = Some ti /\ empty |- ti \in Ti.
Proof with eauto.
  intros v T i Ti Hval Htyp Hget.
  remember (@empty ty) as Gamma.
  has_type_cases (induction Htyp) Case; subst; try solve by inversion...
  Case "T_RCons".
    simpl in Hget. simpl. destruct (eq_id_dec i i0).
    SCase "i is first".
      simpl. inversion Hget. subst.
      exists t...
    SCase "get tail".
      destruct IHHtyp2 as [vi [Hgeti Htypi]]...
      inversion Hval... Qed.

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.
Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  generalize dependent HeqGamma.
  has_type_cases (induction Ht) Case; intros HeqGamma; subst.
  Case "T_Var".
    inversion H.
  Case "T_Abs".
    left...
  Case "T_App".
    right.
    destruct IHHt1; subst...
    SCase "t1 is a value".
      destruct IHHt2; subst...
      SSCase "t2 is a value".
        inversion H; subst; try (solve by inversion).
        exists ([x:=t2]t12)...
      SSCase "t2 steps".
        destruct H0 as [t2' Hstp]. exists (tapp t1 t2')...
    SCase "t1 steps".
      destruct H as [t1' Hstp]. exists (tapp t1' t2)...
  Case "T_Proj".
    right. destruct IHHt...
    SCase "rcd is value".
      destruct (lookup_field_in_value _ _ _ _ H0 Ht H) as [ti [Hlkup _]].
      exists ti...
    SCase "rcd_steps".
      destruct H0 as [t' Hstp]. exists (tproj t' i)...
  Case "T_RNil".
    left...
  Case "T_RCons".
    destruct IHHt1...
    SCase "head is a value".
      destruct IHHt2; try reflexivity.
      SSCase "tail is a value".
        left...
      SSCase "tail steps".
        right. destruct H2 as [tr' Hstp].
        exists (trcons i t tr')...
    SCase "head steps".
      right. destruct H1 as [t' Hstp].
      exists (trcons i t' tr)... Qed.

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x ->
        appears_free_in x t12 ->
        appears_free_in x (tabs y T11 t12)
  | afi_proj : forall x t i,
     appears_free_in x t ->
     appears_free_in x (tproj t i)
  | afi_rhead : forall x i ti tr,
      appears_free_in x ti ->
      appears_free_in x (trcons i ti tr)
  | afi_rtail : forall x i ti tr,
      appears_free_in x tr ->
      appears_free_in x (trcons i ti tr).

Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
     Gamma |- t \in S ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     Gamma' |- t \in S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  has_type_cases (induction H) Case;
    intros Gamma' Heqv...
  Case "T_Var".
    apply T_Var... rewrite <- Heqv...
  Case "T_Abs".
    apply T_Abs... apply IHhas_type. intros y Hafi.
    unfold extend. destruct (eq_id_dec x y)...
  Case "T_App".
    apply T_App with T1...
  Case "T_RCons".
    apply T_RCons... Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  has_type_cases (induction Htyp) Case; inversion Hafi; subst...
  Case "T_Abs".
    destruct IHHtyp as [T' Hctx]... exists T'.
    unfold extend in Hctx.
    rewrite neq_id in Hctx...
Qed.

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     (extend Gamma x U) |- t \in S ->
     empty |- v \in U ->
     Gamma |- ([x:=v]t) \in S.
Proof with eauto.
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent Gamma. generalize dependent S.
  t_cases (induction t) Case;
    intros S Gamma Htypt; simpl; inversion Htypt; subst...
  Case "tvar".
    simpl. rename i into y.
    destruct (eq_id_dec x y).
    SCase "x=y".
      subst.
      unfold extend in H0. rewrite eq_id in H0.
      inversion H0; subst. clear H0.
      eapply context_invariance...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    SCase "x<>y".
      apply T_Var... unfold extend in H0. rewrite neq_id in H0...
  Case "tabs".
    rename i into y. rename t into T11.
    apply T_Abs...
    destruct (eq_id_dec x y).
    SCase "x=y".
      eapply context_invariance...
      subst.
      intros x Hafi. unfold extend.
      destruct (eq_id_dec y x)...
    SCase "x<>y".
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold extend.
      destruct (eq_id_dec y z)...
      subst. rewrite neq_id...
  Case "trcons".
    apply T_RCons... inversion H7; subst; simpl...
Qed.

Theorem preservation : forall t t' T,
     empty |- t \in T ->
     t ==> t' ->
     empty |- t' \in T.
Proof with eauto.
  intros t t' T HT.
  remember (@empty ty) as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  has_type_cases (induction HT) Case;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  Case "T_App".
    inversion HE; subst...
    SCase "ST_AppAbs".
      apply substitution_preserves_typing with T1...
      inversion HT1...
  Case "T_Proj".
    destruct (lookup_field_in_value _ _ _ _ H2 HT H)
      as [vi [Hget Htyp]].
    rewrite H4 in Hget. inversion Hget. subst...
  Case "T_RCons".
    apply T_RCons... eapply step_preserves_record_tm...
Qed.

End STLCExtendedRecords.


(* $Id: MoreIntervals.v,v 1.17 2003/03/11 13:36:07 lcf Exp $ *)

Require Export NthDerivative.

Opaque Min Max.

Section Intervals.

(* Tex_Prose
\chapter{Generalized Intervals}

At this stage we have enough material to begin generalizing our concepts in preparation for the fundamental theorem of calculus and the definition of the main (non-polynomial) functions of analysis.

In order to define functions via power series (or any other kind of series!)\ we need to formalize a notion of convergence more general than the one we already have on compact intervals.  This is necessary for practical reasons: we want to define a single exponential function with domain \RR, not several exponential functions defined on compact intervals which we prove to be the same wherever their domains overlap.  In a similar way, we want to define indefinite integrals on infinite domains and not only on compact intervals.

Unfortunately, proceeding in a way analogous to how we defined the concept of global continuity will lead us nowhere; the concept turns out to be to general, and the behaviour on too small domains (typically intervals $[a,a']$ where $a=a'$ is neither provably true nor provably false) will be unsatisfactory.

There is a special family of sets, however, where this problems can be avoided: intervals.  Intervals have some nice properties that allow us to prove good results, namely the facts that if $a$ and $b$ are elements of an interval $I$ then so are $\min(a,b)$ and $\max(a,b)$ (which is in general not true) and also the compact interval $[a,b]$ is included in $I$.  Furthermore, all intervals are characterized by simple, well defined predicates, and the nonempty and proper concepts become very easy to define.

\section{Definitions and Basic Results}

We define an inductive type of intervals\footnote{The compact interval which we will define here is obviously the same that we have been working with all the way through; why, then, the different formulation?  The reason is simple: if we had worked with intervals from the beginning we would have had case definitions at every spot, and our lemmas and proofs would have been very awkward.  Also, it seems more natural to characterize a compact interval by two real numbers [and a proof] than as a particular case of a more general concept which doesn't have an intuitive interpretation.  Finally, the definitions we will make here will have the elegant consequence that from this point on we can work with \emph{any} kind of intervals in exactly the same way.} with nine constructors, corresponding to the nine basic types of intervals\footnote{The reason why so many constructors are needed is that we do not have a notion of real line, for many reasons which we will not discuss here.  Also it seems simple to directly define finite intervals than to define then later as intersections of infinite intervals, as it would only mess things up.}.
*)

(* Begin_Tex_Verb *)
Inductive interval : Set :=
  realline : interval
  | openl : IR->interval
  | openr : IR->interval
  | closel : IR->interval
  | closer : IR->interval
  | olor : IR->IR->interval
  | olcr : IR->IR->interval
  | clor : IR->IR->interval
  | clcr : IR->IR->interval.
(* End_Tex_Verb *)

(* Tex_Prose
To each interval a predicate (set) is assigned by the following map:
*)

(* Begin_Tex_Verb *)
Definition iprop [I:interval] : IR->CProp := [x:IR] Cases I of
  realline     => CTrue
  | (openr b)  => x[<]b
  | (openl a)  => a[<]x
  | (closer b) => (toCProp x[<=]b)
  | (closel a) => (toCProp a[<=]x)
  | (olor a b) => (a[<]x)*(x[<]b)
  | (olcr a b) => (a[<]x)*{x[<=]b}
  | (clor a b) => {a[<=]x}*(x[<]b)
  | (clcr a b) => {a[<=]x}*{x[<=]b}
  end.
(* End_Tex_Verb *)

(* Tex_Prose
We now define what it means for an interval to be nonvoid, proper, finite and compact in the obvious way.
*)

(* Begin_Tex_Verb *)
Definition nonvoid [I:interval] : CProp := Cases I of
  realline     => CTrue
  | (openr b)  => CTrue
  | (openl a)  => CTrue
  | (closer b) => CTrue
  | (closel a) => CTrue
  | (olor a b) => a[<]b
  | (olcr a b) => a[<]b
  | (clor a b) => a[<]b
  | (clcr a b) => (toCProp a[<=]b)
  end.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition proper [I:interval] : CProp := Cases I of
  realline     => CTrue
  | (openr b)  => CTrue
  | (openl a)  => CTrue
  | (closer b) => CTrue
  | (closel a) => CTrue
  | (olor a b) => a[<]b
  | (olcr a b) => a[<]b
  | (clor a b) => a[<]b
  | (clcr a b) => a[<]b
  end.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition finite [I:interval] : CProp := Cases I of
  realline     => CFalse
  | (openr b)  => CFalse
  | (openl a)  => CFalse
  | (closer b) => CFalse
  | (closel a) => CFalse
  | (olor a b) => CTrue
  | (olcr a b) => CTrue
  | (clor a b) => CTrue
  | (clcr a b) => CTrue
  end.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition compact_ [I:interval] : CProp := Cases I of
  realline     => CFalse
  | (openr b)  => CFalse
  | (openl a)  => CFalse
  | (closer b) => CFalse
  | (closel a) => CFalse
  | (olor a b) => CFalse
  | (olcr a b) => CFalse
  | (clor a b) => CFalse
  | (clcr a b) => (toCProp a[<=]b)
  end.
(* End_Tex_Verb *)

(* Tex_Prose
Finite intervals have a left end and a right end.
*)

(* Begin_Tex_Verb *)
Definition left_end [I:interval] : (finite I)->IR.
(* End_Tex_Verb *)
Intro.
Elim I; Intros.
Inversion H.
Inversion H.
Inversion H.
Inversion H.
Inversion H.
Apply c.
Apply c.
Apply c.
Apply c.
Defined.

(* Begin_Tex_Verb *)
Definition right_end [I:interval] : (finite I)->IR.
(* End_Tex_Verb *)
Intro.
Elim I; Intros.
Inversion H.
Inversion H.
Inversion H.
Inversion H.
Inversion H.
Apply c0.
Apply c0.
Apply c0.
Apply c0.
Defined.

(* Tex_Prose
Some trivia: compact intervals are finite; proper intervals are nonvoid; an interval is nonvoid iff it contains some point.
*)

(* Begin_Tex_Verb *)
Lemma compact_finite : (I:interval)(compact_ I)->(finite I).
(* End_Tex_Verb *)
Intros; Induction I; Simpl; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma proper_nonvoid : (I:interval)(proper I)->(nonvoid I).
(* End_Tex_Verb *)
Intro.
Elim I; Simpl; Intros; Auto.
Apply ts; Apply less_leEq; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma nonvoid_point : (I:interval)(nonvoid I)->{x:IR & (iprop I x)}.
(* End_Tex_Verb *)
Intro.
Elim I; Simpl; Intros.
Exists (Zero::IR); Auto.
Exists c[+]One; Apply less_plusOne.
Exists c[-]One; Apply shift_minus_less; Apply less_plusOne.
Exists c; Apply ts; Apply leEq_reflexive.
Exists c; Apply ts; Apply leEq_reflexive.
Exists c[+](c0[-]c)[/]TwoNZ; Split.
Step c[+]Zero; Apply plus_resp_less_lft.
Apply div_resp_pos.
Apply pos_two.
Apply shift_less_minus; Step c; Auto.
RStepr c[+](c0[-]c).
Apply plus_resp_less_lft.
Apply pos_div_two'.
Apply shift_less_minus; Step c; Auto.
Exists c0; Split; Auto; Apply leEq_reflexive.
Exists c; Split; Auto; Apply leEq_reflexive.
Exists c; Split; [Apply leEq_reflexive | Inversion H; Auto].
Qed.

(* Begin_Tex_Verb *)
Lemma nonvoid_char : (I:interval)(x:IR)(iprop I x)->(nonvoid I).
(* End_Tex_Verb *)
Intro; Elim I; Simpl; Intros; Auto; Inversion_clear H.
Apply less_transitive_unfolded with x; Auto.
Apply less_leEq_trans with x; Auto.
Apply leEq_less_trans with x; Auto.
Apply ts; Apply leEq_transitive with x; Auto.
Qed.

(* Tex_Prose
For practical reasons it helps to define left end and right end of compact intervals.
*)

(* Begin_Tex_Verb *)
Definition Lend [I:interval][H:(compact_ I)] :=
  (left_end I (compact_finite I H)).
Definition Rend [I:interval][H:(compact_ I)] :=
  (right_end I (compact_finite I H)).
(* End_Tex_Verb *)

(* Tex_Prose
In a compact interval, the left end is always less than or equal to the right end.
*)

(* Begin_Tex_Verb *)
Lemma Lend_leEq_Rend :
  (I:interval)(cI:(compact_ I))(Lend ? cI)[<=](Rend ? cI).
(* End_Tex_Verb *)
Intro; Elim I; Simpl; Intros; Try Inversion cI; Auto.
Qed.

(* Tex_Prose
Some nice characterizations of inclusion:
*)

(* Begin_Tex_Verb *)
Lemma compact_included : (a,b,Hab,I:?)(iprop I a)->(iprop I b)->
  (included (compact a b Hab) (iprop I)).
(* End_Tex_Verb *)
Induction I; Red; Simpl; Intros; Try Inversion_clear H; Try Inversion_clear H0; Try Inversion_clear H1; Try Apply ts.
Auto.
Apply less_leEq_trans with a; Auto.
Apply leEq_less_trans with b; Auto.
Apply leEq_transitive with a; Auto.
Apply leEq_transitive with b; Auto.
Split; [Apply less_leEq_trans with a| Apply leEq_less_trans with b]; Auto.
Split; [Apply less_leEq_trans with a| Apply leEq_transitive with b]; Auto.
Split; [Apply leEq_transitive with a| Apply leEq_less_trans with b]; Auto.
Split; [Apply leEq_transitive with a| Apply leEq_transitive with b]; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma included_interval' : (I,x,y,z,w:?)
  (iprop I x)->(iprop I y)->(iprop I z)->(iprop I w)->
  (H:?)(included (compact (Min x z) (Max y w) H) (iprop I)).
(* End_Tex_Verb *)
Intro I; Elim I; Simpl; Intros; Red; Intros t Ht; Inversion_clear Ht; Simpl;
  Try Inversion_clear H; Try Inversion_clear H0; Try Inversion_clear H1; Try Inversion_clear H2; Try Split.
Apply less_leEq_trans with (Min x z); Try Apply less_Min; Auto.
Apply leEq_less_trans with (Max y w); Try Apply Max_less; Auto.
Apply leEq_transitive with (Min x z); Try Apply leEq_Min; Auto.
Apply leEq_transitive with (Max y w); Try Apply Max_leEq; Auto.
Apply less_leEq_trans with (Min x z); Try Apply less_Min; Auto.
Apply leEq_less_trans with (Max y w); Try Apply Max_less; Auto.
Apply less_leEq_trans with (Min x z); Try Apply less_Min; Auto.
Apply leEq_transitive with (Max y w); Try Apply Max_leEq; Auto.
Apply leEq_transitive with (Min x z); Try Apply leEq_Min; Auto.
Apply leEq_less_trans with (Max y w); Try Apply Max_less; Auto.
Apply leEq_transitive with (Min x z); Try Apply leEq_Min; Auto.
Apply leEq_transitive with (Max y w); Try Apply Max_leEq; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma included_interval : (I,x,y:?)(iprop I x)->(iprop I y)->
  (H:?)(included (compact (Min x y) (Max x y) H) (iprop I)).
(* End_Tex_Verb *)
Intros; Apply included_interval'; Auto.
Qed.

(* Tex_Prose
A weirder inclusion result.
*)

(* Begin_Tex_Verb *)
Lemma included3_interval : (I:?)(x,y,z:IR)(Hxyz:?)
  (iprop I x)->(iprop I y)->(iprop I z)->
  (included (compact (Min (Min x y) z) (Max (Max x y) z) Hxyz)
            (iprop I)).
(* End_Tex_Verb *)
Intros.
Apply included_interval'; Auto.
Apply (included_interval I x y H H0 (Min_leEq_Max ??)).
Apply compact_inc_lft.
Apply (included_interval I x y H H0 (Min_leEq_Max ??)).
Apply compact_inc_rht.
Qed.

(* Tex_Prose
Finally, all intervals are characterized by well defined predicates.
*)

(* Begin_Tex_Verb *)
Lemma iprop_wd : (I:interval)(pred_well_def ? (iprop I)).
(* End_Tex_Verb *)
Intro; Elim I; Unfold iprop; Red; Intros; Try Inversion_clear H; Try Inversion H0; Try Inversion H1; Try Apply ts.
Auto.
Stepr x; Auto.
Step x; Auto.
Stepr x; Auto.
Step x; Auto.
Split.
Stepr x; Auto.
Step x; Auto.
Split.
Stepr x; Auto.
Step x; Auto.
Split.
Stepr x; Auto.
Step x; Auto.
Split.
Stepr x; Auto.
Step x; Auto.
Qed.

End Intervals.

Implicits Lend [1].
Implicits Rend [1].

Section Compact_Constructions.

Section Single_Compact_Interval.

(* Tex_Prose
\section{Constructions with Compact Intervals}

Several important constructions are now discussed.

We begin by defining the compact interval $[x,x]$.

\begin{convention} Let \verb!P:IR->CProp! be well defined, and \verb!x:IR! such that $P(x)$ holds.
\end{convention}
*)

Variable P:IR->CProp.
Hypothesis wdP : (pred_well_def IR P).
Variable x:IR.

Hypothesis Hx : (P x).

(* Begin_Tex_Verb *)
Definition compact_single := (Compact (leEq_reflexive ? x)).
(* End_Tex_Verb *)

(* Tex_Prose
This interval contains $x$ and only (elements equal to) $x$; furthermore, for every (well-defined) $P$, if $x\in P$ then $[x,x]\subseteq P$.
*)

(* Begin_Tex_Verb *)
Lemma compact_single_prop : (compact_single x).
(* End_Tex_Verb *)
Split; Apply leEq_reflexive.
Qed.

(* Begin_Tex_Verb *)
Lemma compact_single_pt : (y:IR)(compact_single y)->x[=]y.
(* End_Tex_Verb *)
Intros.
Inversion_clear H; Apply leEq_imp_eq; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma compact_single_inc : (included compact_single P).
(* End_Tex_Verb *)
Red; Intros.
Apply wdP with x.
Auto.
Apply compact_single_pt; Auto.
Qed.

End Single_Compact_Interval.

(* Tex_Prose
The special case of intervals is worth singling out, as one of the hypothesis becomes a theorem.
*)

(* Begin_Tex_Verb *)
Definition compact_single_iprop [I:interval] :=
  (compact_single_inc (iprop I) (iprop_wd I)).
(* End_Tex_Verb *)

(* Tex_Prose
Now for more interesting and important results.

Let $I$ be a proper interval and $x$ be a point of $I$.  Then there is a proper compact interval $[a,b]$ such that $x\in[a,b]\subseteq I$.
*)

Section Proper_Compact_with_One_or_Two_Points.

Local cip1' : (c,x:IR)(c[<=]x)->(x[-](x[-]c)[/]TwoNZ)[<=]x.
Intros.
Stepr x[-]Zero.
Unfold 1 3 cg_minus; Apply plus_resp_leEq_lft.
Apply inv_resp_leEq; Apply shift_leEq_div.
Apply pos_two.
Apply shift_leEq_minus; RStep c; Auto.
Qed.

Local cip1'' : (c,x:IR)(c[<]x)->(x[-](x[-]c)[/]TwoNZ)[<]x.
Intros.
Stepr x[-]Zero.
Unfold 1 3 cg_minus; Apply plus_resp_less_lft.
Apply inv_resp_less; Apply shift_less_div.
Apply pos_two.
Apply shift_less_minus; RStep c; Auto.
Qed.

Local cip1''' : (c0,x:IR)(x[<=]c0)->x[<=](x[+](c0[-]x)[/]TwoNZ).
Intros.
Step x[+]Zero.
Apply plus_resp_leEq_lft.
Apply shift_leEq_div.
Apply pos_two.
Apply shift_leEq_minus; RStep x; Auto.
Qed.

Local cip1'''' : (c0,x:IR)(x[<]c0)->x[<](x[+](c0[-]x)[/]TwoNZ).
Intros.
Step x[+]Zero.
Apply plus_resp_less_lft.
Apply shift_less_div.
Apply pos_two.
Apply shift_less_minus; RStep x; Auto.
Qed.

Local cip2 : (c,x,x0:IR)(c[<=]x)->((x[-](x[-]c)[/]TwoNZ)[<=]x0)->(c[<=]x0).
Intros.
Apply leEq_transitive with c[+](x[-]c)[/]TwoNZ.
Step c[+]Zero; Apply plus_resp_leEq_lft.
Apply shift_leEq_div.
Apply pos_two.
Apply shift_leEq_minus; RStep c; Auto.
EApply leEq_wdl.
Apply H0.
Rational.
Qed.

Local cip2' : (c,x,x0:IR)(c[<]x)->((x[-](x[-]c)[/]TwoNZ)[<=]x0)->(c[<]x0).
Intros.
Apply less_leEq_trans with c[+](x[-]c)[/]TwoNZ.
Step c[+]Zero; Apply plus_resp_less_lft.
Apply shift_less_div.
Apply pos_two.
Apply shift_less_minus; RStep c; Auto.
EApply leEq_wdl.
Apply H0.
Rational.
Qed.

Local cip2'' : (c,x,x0:IR)(c[<=]x)->((x[-](x[-]c)[/]TwoNZ)[<]x0)->(c[<]x0).
Intros.
Apply leEq_less_trans with c[+](x[-]c)[/]TwoNZ.
Step c[+]Zero; Apply plus_resp_leEq_lft.
Apply shift_leEq_div.
Apply pos_two.
Apply shift_leEq_minus; RStep c; Auto.
EApply less_wdl.
Apply H0.
Rational.
Qed.

Local cip2''' : (c,x,x0:IR)(c[<]x)->((x[-](x[-]c)[/]TwoNZ)[<]x0)->(c[<]x0).
Intros.
Apply cip2'' with x.
Apply less_leEq; Auto.
Auto.
Qed.

Local cip3 : (c0,x,x0:IR)(x[<=]c0)->(x0[<=](x[+](c0[-]x)[/]TwoNZ))->(x0[<=]c0).
Intros.
EApply leEq_transitive.
Apply H0.
RStep c0[-](c0[-]x)[/]TwoNZ.
Stepr c0[-]Zero; Unfold 1 3 cg_minus; Apply plus_resp_leEq_lft.
Apply inv_resp_leEq.
Apply shift_leEq_div.
Apply pos_two.
Apply shift_leEq_minus; RStep x; Auto.
Qed.

Local cip3' : (c0,x,x0:IR)(x[<]c0)->(x0[<=](x[+](c0[-]x)[/]TwoNZ))->(x0[<]c0).
Intros.
EApply leEq_less_trans.
Apply H0.
RStep c0[-](c0[-]x)[/]TwoNZ.
Stepr c0[-]Zero; Unfold 1 3 cg_minus; Apply plus_resp_less_lft.
Apply inv_resp_less.
Apply shift_less_div.
Apply pos_two.
Apply shift_less_minus; RStep x; Auto.
Qed.

Local cip3'' : (c0,x,x0:IR)(x[<=]c0)->(x0[<](x[+](c0[-]x)[/]TwoNZ))->(x0[<]c0).
Intros.
EApply less_leEq_trans.
Apply H0.
RStep c0[-](c0[-]x)[/]TwoNZ.
Stepr c0[-]Zero; Unfold 1 3 cg_minus; Apply plus_resp_leEq_lft.
Apply inv_resp_leEq.
Apply shift_leEq_div.
Apply pos_two.
Apply shift_leEq_minus; RStep x; Auto.
Qed.

Local cip3''' : (c0,x,x0:IR)(x[<]c0)->(x0[<](x[+](c0[-]x)[/]TwoNZ))->(x0[<]c0).
Intros.
Apply cip3'' with x; Try Apply less_leEq; Auto.
Qed.

(* Begin_Tex_Verb *)
Definition compact_in_interval
  [I:interval][pI:(proper I)][x:IR][Hx:(iprop I x)] : interval.
(* End_Tex_Verb *)
Intros; Elim I; Intros.
Apply (clcr x x[+]One).
Apply (clcr x x[+]One).
Apply (clcr x[-]One x).
Apply (clcr x x[+]One).
Apply (clcr x[-]One x).
Apply (clcr x[-](x[-]c)[/]TwoNZ x[+](c0[-]x)[/]TwoNZ).
Apply (clcr x[-](x[-]c)[/]TwoNZ x[+](c0[-]x)[/]TwoNZ).
Apply (clcr x[-](x[-]c)[/]TwoNZ x[+](c0[-]x)[/]TwoNZ).
Apply (clcr c c0).
Defined.

(* Begin_Tex_Verb *)
Lemma compact_compact_in_interval : (I,pI,x,Hx:?)
  (compact_ (compact_in_interval I pI x Hx)).
(* End_Tex_Verb *)
Intro.
Elim I; Simpl; Intros; Try Inversion_clear Hx; Try Apply ts; Apply less_leEq.
Apply less_plusOne.
Apply less_plusOne.
Apply shift_minus_less; Apply less_plusOne.
Apply less_plusOne.
Apply shift_minus_less; Apply less_plusOne.
EApply less_transitive_unfolded; [Apply cip1'' | Apply cip1'''']; Auto.
EApply less_leEq_trans; [Apply cip1'' | Apply cip1''']; Auto.
EApply leEq_less_trans; [Apply cip1' | Apply cip1'''']; Auto.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma proper_compact_in_interval : (I,pI,x,Hx:?)
  (proper (compact_in_interval I pI x Hx)).
(* End_Tex_Verb *)
Intro.
Elim I; Simpl; Intros; Try Inversion_clear Hx.
Apply less_plusOne.
Apply less_plusOne.
Apply shift_minus_less; Apply less_plusOne.
Apply less_plusOne.
Apply shift_minus_less; Apply less_plusOne.
EApply less_transitive_unfolded; [Apply cip1'' | Apply cip1'''']; Auto.
EApply less_leEq_trans; [Apply cip1'' | Apply cip1''']; Auto.
EApply leEq_less_trans; [Apply cip1' | Apply cip1'''']; Auto.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma proper_compact_in_interval' :
  (I,pI,x,Hx,H:?)(!Lend (compact_in_interval I pI x Hx) H)[<]
                 (!Rend (compact_in_interval I pI x Hx) H).
(* End_Tex_Verb *)
Do 4 Intro.
Cut (proper (compact_in_interval I pI x Hx)).
2: Apply proper_compact_in_interval.
Elim (compact_in_interval I pI x Hx); Intros; Try Inversion H0.
Simpl; Simpl in H; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma included_compact_in_interval : (I,pI,x,Hx:?)
  (included (iprop (compact_in_interval I pI x Hx)) (iprop I)).
(* End_Tex_Verb *)
Intro.
Elim I; Simpl; Intros;
  Try Inversion_clear Hx; Red; Simpl; Intros;
  Try Inversion_clear H; Try Inversion_clear H0; Try Inversion_clear H1; Try Inversion H2; Try Inversion H3; Try Apply ts; Auto.
Apply less_leEq_trans with x; Auto.
Apply leEq_less_trans with x; Auto.
Apply leEq_transitive with x; Auto.
Apply leEq_transitive with x; Auto.
Split.
Apply cip2' with x; Auto.
Apply cip3' with x; Auto.
Split.
Apply cip2' with x; Auto.
Apply cip3 with x; Auto.
Split.
Apply cip2 with x; Auto.
Apply cip3' with x; Auto.
Split; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma iprop_compact_in_interval :
  (I,pI,x,Hx:?)(iprop (compact_in_interval I pI x Hx) x).
(* End_Tex_Verb *)
Intro.
Elim I; Simpl; Intros; Try Inversion_clear Hx; Split; Auto; Try Apply leEq_reflexive.
Apply less_leEq; Apply less_plusOne.
Apply less_leEq; Apply less_plusOne.
Apply less_leEq; Apply shift_minus_less; Apply less_plusOne.
Apply less_leEq; Apply less_plusOne.
Apply less_leEq; Apply shift_minus_less; Apply less_plusOne.
Apply less_leEq; Apply cip1''; Auto.
Apply less_leEq; Apply cip1''''; Auto.
Apply less_leEq; Apply cip1''; Auto.
Apply less_leEq; Apply cip1''''; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma iprop_compact_in_interval' : (I,pI,x,Hx,H,H':?)
  (compact (!Lend (compact_in_interval I pI x Hx) H)
           (!Rend (compact_in_interval I pI x Hx) H) H' x).
(* End_Tex_Verb *)
Do 4 Intro.
Cut (iprop (compact_in_interval I pI x Hx) x).
2: Apply iprop_compact_in_interval.
Elim (compact_in_interval I pI x Hx); Intros; Try Inversion H0.
Simpl; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma iprop_compact_in_interval_inc1 : (I,pI,x,Hx,H,H':?)
  (included (compact (!Lend (compact_in_interval I pI x Hx) H)
                     (!Rend (compact_in_interval I pI x Hx) H) H')
    (iprop (compact_in_interval I pI x Hx))).
(* End_Tex_Verb *)
Do 4 Intro.
Elim (compact_in_interval I pI x Hx); Intros; Try Inversion H.
Unfold compact; Unfold iprop; Simpl; Included.
Qed.

(* Begin_Tex_Verb *)
Lemma iprop_compact_in_interval_inc2 : (I,pI,x,Hx,H,H':?)
  (included
    (iprop (compact_in_interval I pI x Hx))
    (compact (!Lend (compact_in_interval I pI x Hx) H)
             (!Rend (compact_in_interval I pI x Hx) H) H')).
(* End_Tex_Verb *)
Do 4 Intro.
Elim (compact_in_interval I pI x Hx); Intros; Try Inversion H.
Unfold compact; Unfold iprop; Simpl; Included.
Qed.

(* Tex_Prose
If $x=y$ then the construction yields the same interval whether we use $x$ or $y$ in its definition\footnote{This property is required at some stage, which is why we formalized this result as a functional definition rather than as an existential formula.}.
*)

(* Begin_Tex_Verb *)
Lemma compact_in_interval_wd1 : (I,pI,x,Hx,y,Hy,H,H':?)(x[=]y)->
  (!Lend (compact_in_interval I pI x Hx) H)[=]
    (!Lend (compact_in_interval I pI y Hy) H').
(* End_Tex_Verb *)
Intro I; Elim I; Simpl; Intros; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma compact_in_interval_wd2 : (I,pI,x,Hx,y,Hy,H,H':?)(x[=]y)->
  (!Rend (compact_in_interval I pI x Hx) H)[=]
    (!Rend (compact_in_interval I pI y Hy) H').
(* End_Tex_Verb *)
Intro I; Elim I; Simpl; Intros; Algebra.
Qed.

(* Tex_Prose
We can make an analogous construction for two points.
*)

(* Begin_Tex_Verb *)
Definition compact_in_interval2 [I:interval][pI:(proper I)]
  [x,y:IR][Hx:(iprop I x)][Hy:(iprop I y)] : interval.
(* End_Tex_Verb *)
Intros.
LetTac z1:=(Min x y).
LetTac z2:=(Max x y).
Elim I; Intros.
Apply (clcr z1 z2[+]One).
Apply (clcr z1 z2[+]One).
Apply (clcr z1[-]One z2).
Apply (clcr z1 z2[+]One).
Apply (clcr z1[-]One z2).
Apply (clcr z1[-](z1[-]c)[/]TwoNZ z2[+](c0[-]z2)[/]TwoNZ).
Apply (clcr z1[-](z1[-]c)[/]TwoNZ z2[+](c0[-]z2)[/]TwoNZ).
Apply (clcr z1[-](z1[-]c)[/]TwoNZ z2[+](c0[-]z2)[/]TwoNZ).
Apply (clcr c c0).
Defined.

(* Begin_Tex_Verb *)
Lemma compact_compact_in_interval2 : (I,pI,x,y,Hx,Hy:?)
  (compact_ (compact_in_interval2 I pI x y Hx Hy)).
(* End_Tex_Verb *)
Intro.
Elim I; Simpl; Intros; Try Inversion_clear Hx; Try Inversion_clear Hy; Try Apply ts; Apply less_leEq.
Apply leEq_less_trans with (Max x y); [Apply Min_leEq_Max | Apply less_plusOne].
Apply leEq_less_trans with (Max x y); [Apply Min_leEq_Max | Apply less_plusOne].
Apply shift_minus_less; Apply leEq_less_trans with (Max x y); [Apply Min_leEq_Max | Apply less_plusOne].
Apply leEq_less_trans with (Max x y); [Apply Min_leEq_Max | Apply less_plusOne].
Apply shift_minus_less; Apply leEq_less_trans with (Max x y); [Apply Min_leEq_Max | Apply less_plusOne].
EApply less_transitive_unfolded; [Apply cip1'' | EApply leEq_less_trans; [Apply Min_leEq_Max | Apply cip1'''']];
  Try Apply less_Min; Try Apply Max_less; Auto.
EApply less_leEq_trans; [Apply cip1'' | EApply leEq_transitive; [Apply Min_leEq_Max | Apply cip1''']];
  Try Apply less_Min; Try Apply Max_leEq; Auto.
EApply leEq_less_trans; [Apply cip1' | EApply leEq_less_trans; [Apply Min_leEq_Max | Apply cip1'''']];
  Try Apply leEq_Min; Try Apply Max_less; Auto.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma proper_compact_in_interval2 : (I,pI,x,y,Hx,Hy:?)
  (proper (compact_in_interval2 I pI x y Hx Hy)).
(* End_Tex_Verb *)
Intro.
Elim I; Simpl; Intros; Try Inversion_clear Hx; Try Inversion_clear Hy.
Apply leEq_less_trans with (Max x y); [Apply Min_leEq_Max | Apply less_plusOne].
Apply leEq_less_trans with (Max x y); [Apply Min_leEq_Max | Apply less_plusOne].
Apply shift_minus_less; Apply leEq_less_trans with (Max x y); [Apply Min_leEq_Max | Apply less_plusOne].
Apply leEq_less_trans with (Max x y); [Apply Min_leEq_Max | Apply less_plusOne].
Apply shift_minus_less; Apply leEq_less_trans with (Max x y); [Apply Min_leEq_Max | Apply less_plusOne].
EApply less_transitive_unfolded; [Apply cip1'' | EApply leEq_less_trans; [Apply Min_leEq_Max | Apply cip1'''']];
  Try Apply less_Min; Try Apply Max_less; Auto.
EApply less_leEq_trans; [Apply cip1'' | EApply leEq_transitive; [Apply Min_leEq_Max | Apply cip1''']];
  Try Apply less_Min; Try Apply Max_leEq; Auto.
EApply leEq_less_trans; [Apply cip1' | EApply leEq_less_trans; [Apply Min_leEq_Max | Apply cip1'''']];
  Try Apply leEq_Min; Try Apply Max_less; Auto.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma proper_compact_in_interval2' : (I,pI,x,y,Hx,Hy,H:?)
  (!Lend (compact_in_interval2 I pI x y Hx Hy) H)[<]
    (!Rend (compact_in_interval2 I pI x y Hx Hy) H).
(* End_Tex_Verb *)
Do 6 Intro.
Cut (proper (compact_in_interval2 I pI x y Hx Hy)).
2: Apply proper_compact_in_interval2.
Elim (compact_in_interval2 I pI x y Hx Hy); Intros; Try Inversion H0.
Simpl; Simpl in H; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma included_compact_in_interval2 : (I,pI,x,y,Hx,Hy:?)
  (included (iprop (compact_in_interval2 I pI x y Hx Hy))
            (iprop I)).
(* End_Tex_Verb *)
Intro.
Elim I; Simpl; Intros; Try Inversion_clear Hx; Try Inversion_clear Hy; Red; Simpl; Intros;
  Try Inversion_clear H; Try Inversion_clear H1; Try Inversion_clear H3; Try Apply ts; Auto.
Apply less_leEq_trans with (Min x y); Try Apply less_Min; Auto.
Apply leEq_less_trans with (Max x y); Try Apply Max_less; Auto.
Apply leEq_transitive with (Min x y); Try Apply leEq_Min; Auto.
Apply leEq_transitive with (Max x y); Try Apply Max_leEq; Auto.
Split.
Apply cip2' with (Min x y); Try Apply less_Min; Auto.
Apply cip3' with (Max x y); Try Apply Max_less; Auto.
Split.
Apply cip2' with (Min x y); Try Apply less_Min; Auto.
Apply cip3 with (Max x y); Try Apply Max_leEq; Auto.
Split.
Apply cip2 with (Min x y); Try Apply leEq_Min; Auto.
Apply cip3' with (Max x y); Try Apply Max_less; Auto.
Split; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma iprop_compact_in_interval2x : (I,pI,x,y,Hx,Hy:?)
  (iprop (compact_in_interval2 I pI x y Hx Hy) x).
(* End_Tex_Verb *)
Intro.
Elim I; Simpl; Intros; Try Inversion_clear Hx; Try Inversion_clear Hy; Split; Auto; Try Apply Min_leEq_lft; Try Apply lft_leEq_Max.
Apply less_leEq; Apply leEq_less_trans with (Max x y); [Apply lft_leEq_Max | Apply less_plusOne].
Apply less_leEq; Apply leEq_less_trans with (Max x y); [Apply lft_leEq_Max | Apply less_plusOne].
Apply less_leEq; Apply shift_minus_less; Apply leEq_less_trans with x; [Apply Min_leEq_lft | Apply less_plusOne].
Apply less_leEq; Apply leEq_less_trans with (Max x y); [Apply lft_leEq_Max | Apply less_plusOne].
Apply less_leEq; Apply shift_minus_less; Apply leEq_less_trans with x; [Apply Min_leEq_lft | Apply less_plusOne].
Apply less_leEq; EApply less_leEq_trans; [Apply cip1'' | Apply Min_leEq_lft]; Try Apply less_Min; Auto.
Apply less_leEq; Apply leEq_less_trans with (Max x y); [Apply lft_leEq_Max | Apply cip1'''']; Try Apply Max_less; Auto.
Apply less_leEq; EApply less_leEq_trans; [Apply cip1'' | Apply Min_leEq_lft]; Try Apply less_Min; Auto.
Apply leEq_transitive with (Max x y); [Apply lft_leEq_Max | Apply cip1''']; Try Apply Max_leEq; Auto.
EApply leEq_transitive; [Apply cip1' | Apply Min_leEq_lft]; Try Apply leEq_Min; Auto.
Apply less_leEq; Apply leEq_less_trans with (Max x y); [Apply lft_leEq_Max | Apply cip1'''']; Try Apply Max_less; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma iprop_compact_in_interval2y : (I,pI,x,y,Hx,Hy:?)
  (iprop (compact_in_interval2 I pI x y Hx Hy) y).
(* End_Tex_Verb *)
Intro.
Elim I; Simpl; Intros; Try Inversion_clear Hx; Try Inversion_clear Hy; Split; Auto; Try Apply Min_leEq_rht; Try Apply rht_leEq_Max.
Apply less_leEq; Apply leEq_less_trans with (Max x y); [Apply rht_leEq_Max | Apply less_plusOne].
Apply less_leEq; Apply leEq_less_trans with (Max x y); [Apply rht_leEq_Max | Apply less_plusOne].
Apply less_leEq; Apply shift_minus_less; Apply leEq_less_trans with y; [Apply Min_leEq_rht | Apply less_plusOne].
Apply less_leEq; Apply leEq_less_trans with (Max x y); [Apply rht_leEq_Max | Apply less_plusOne].
Apply less_leEq; Apply shift_minus_less; Apply leEq_less_trans with y; [Apply Min_leEq_rht | Apply less_plusOne].
Apply less_leEq; EApply less_leEq_trans; [Apply cip1'' | Apply Min_leEq_rht]; Try Apply less_Min; Auto.
Apply less_leEq; Apply leEq_less_trans with (Max x y); [Apply rht_leEq_Max | Apply cip1'''']; Try Apply Max_less; Auto.
Apply less_leEq; EApply less_leEq_trans; [Apply cip1'' | Apply Min_leEq_rht]; Try Apply less_Min; Auto.
Apply leEq_transitive with (Max x y); [Apply rht_leEq_Max | Apply cip1''']; Try Apply Max_leEq; Auto.
EApply leEq_transitive; [Apply cip1' | Apply Min_leEq_rht]; Try Apply leEq_Min; Auto.
Apply less_leEq; Apply leEq_less_trans with (Max x y); [Apply rht_leEq_Max | Apply cip1'''']; Try Apply Max_less; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma iprop_compact_in_interval2x' : (I,pI,x,y,Hx,Hy,H,H':?)
  (compact (!Lend (compact_in_interval2 I pI x y Hx Hy) H)
           (!Rend (compact_in_interval2 I pI x y Hx Hy) H) H' x).
(* End_Tex_Verb *)
Do 6 Intro.
Cut (iprop (compact_in_interval2 I pI x y Hx Hy) x).
2: Apply iprop_compact_in_interval2x.
Elim (compact_in_interval2 I pI x y Hx Hy); Intros; Try Inversion H0.
Simpl; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma iprop_compact_in_interval2y' : (I,pI,x,y,Hx,Hy,H,H':?)
  (compact (!Lend (compact_in_interval2 I pI x y Hx Hy) H)
           (!Rend (compact_in_interval2 I pI x y Hx Hy) H) H' y).
(* End_Tex_Verb *)
Do 6 Intro.
Cut (iprop (compact_in_interval2 I pI x y Hx Hy) y).
2: Apply iprop_compact_in_interval2y.
Elim (compact_in_interval2 I pI x y Hx Hy); Intros; Try Inversion H0.
Simpl; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma iprop_compact_in_interval2_inc1 : (I,pI,x,y,Hx,Hy,H,H':?)
  (included
    (compact (!Lend (compact_in_interval2 I pI x y Hx Hy) H)
             (!Rend (compact_in_interval2 I pI x y Hx Hy) H) H')
    (iprop (compact_in_interval2 I pI x y Hx Hy))).
(* End_Tex_Verb *)
Do 6 Intro.
Elim (compact_in_interval2 I pI x y Hx Hy); Intros; Try Inversion H.
Unfold compact; Unfold iprop; Simpl; Included.
Qed.

(* Begin_Tex_Verb *)
Lemma iprop_compact_in_interval2_inc2 : (I,pI,x,y,Hx,Hy,H,H':?)
  (included
    (iprop (compact_in_interval2 I pI x y Hx Hy))
    (compact (!Lend (compact_in_interval2 I pI x y Hx Hy) H)
             (!Rend (compact_in_interval2 I pI x y Hx Hy) H) H')).
(* End_Tex_Verb *)
Do 6 Intro.
Elim (compact_in_interval2 I pI x y Hx Hy); Intros; Try Inversion H.
Unfold compact; Unfold iprop; Simpl; Included.
Qed.

(* Begin_Tex_Verb *)
Lemma compact_in_interval_x_lft : (I,pI,x,y,Hx,Hy,H,H':?)
  (!Lend (compact_in_interval2 I pI x y Hx Hy) H)[<=]
    (!Lend (compact_in_interval I pI x Hx) H').
(* End_Tex_Verb *)
Intro I; Elim I; Simpl; Intros; Try Apply minus_resp_leEq; Try Apply Min_leEq_lft; Try Apply leEq_reflexive;
  (RStep c[+]((Min x y)[-]c)[/]TwoNZ; RStepr c[+](x[-]c)[/]TwoNZ; Apply plus_resp_leEq_lft;
  Apply div_resp_leEq; [Apply pos_two | Apply minus_resp_leEq; Apply Min_leEq_lft]).
Qed.

(* Begin_Tex_Verb *)
Lemma compact_in_interval_y_lft : (I,pI,x,y,Hx,Hy,H,H':?)
  (!Lend (compact_in_interval2 I pI x y Hx Hy) H)[<=]
    (!Lend (compact_in_interval I pI y Hy) H').
(* End_Tex_Verb *)
Intro I; Elim I; Simpl; Intros; Try Apply minus_resp_leEq; Try Apply Min_leEq_rht; Try Apply leEq_reflexive;
  (RStep c[+]((Min x y)[-]c)[/]TwoNZ; RStepr c[+](y[-]c)[/]TwoNZ; Apply plus_resp_leEq_lft;
  Apply div_resp_leEq; [Apply pos_two | Apply minus_resp_leEq; Apply Min_leEq_rht]).
Qed.

(* Begin_Tex_Verb *)
Lemma compact_in_interval_x_rht : (I,pI,x,y,Hx,Hy,H,H':?)
  (!Rend (compact_in_interval I pI x Hx) H)[<=]
    (!Rend (compact_in_interval2 I pI x y Hx Hy) H').
(* End_Tex_Verb *)
Intro I; Elim I; Simpl; Intros; Try Apply plus_resp_leEq; Try Apply lft_leEq_Max; Try Apply leEq_reflexive;
  (RStep c0[-](c0[-]x)[/]TwoNZ; RStepr c0[-](c0[-](Max x y))[/]TwoNZ;
  Unfold cg_minus; Apply plus_resp_leEq_lft; Apply inv_resp_leEq; Apply div_resp_leEq;
  [Apply pos_two | Apply plus_resp_leEq_lft; Apply inv_resp_leEq; Apply lft_leEq_Max]).
Qed.

(* Begin_Tex_Verb *)
Lemma compact_in_interval_y_rht : (I,pI,x,y,Hx,Hy,H,H':?)
  (!Rend (compact_in_interval I pI y Hy) H)[<=]
    (!Rend (compact_in_interval2 I pI x y Hx Hy) H').
(* End_Tex_Verb *)
Intro I; Elim I; Simpl; Intros; Try Apply plus_resp_leEq; Try Apply rht_leEq_Max; Try Apply leEq_reflexive;
  (RStep c0[-](c0[-]y)[/]TwoNZ; RStepr c0[-](c0[-](Max x y))[/]TwoNZ;
  Unfold cg_minus; Apply plus_resp_leEq_lft; Apply inv_resp_leEq; Apply div_resp_leEq;
  [Apply pos_two | Apply plus_resp_leEq_lft; Apply inv_resp_leEq; Apply rht_leEq_Max]).
Qed.

End Proper_Compact_with_One_or_Two_Points.

(* Tex_Prose
Compact intervals are exactly\ldots\ compact intervals.
*)

(* Begin_Tex_Verb *)
Lemma interval_compact_inc : (I:interval)(cI:(compact_ I))
  (H:?)(included (iprop I) (compact (Lend cI) (Rend cI) H)).
(* End_Tex_Verb *)
Intro.
Elim I; Intros; Try Inversion cI.
Generalize c c0 cI H; Clear H0 H cI c0 c.
Simpl; Intros a b Hab Hab'.
Red; Intros.
Simpl in H.
Inversion_clear H; Split; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma compact_interval_inc : (I:interval)(cI:(compact_ I))
  (H:?)(included (compact (Lend cI) (Rend cI) H) (iprop I)).
(* End_Tex_Verb *)
Intro.
Elim I; Intros; Try Inversion cI.
Generalize c c0 cI H; Clear H0 H cI c0 c.
Simpl; Intros a b Hab.
Red; Intros.
Inversion_clear H0; Split; Auto.
Qed.

(* Tex_Prose
A generalization of the previous results: if $[a,b]\subseteq J$ and $J$ is proper, then we can find a proper interval $[a',b']$ such that $[a,b]\subseteq[a',b']\subseteq J$.
*)

(* Begin_Tex_Verb *)
Lemma compact_proper_in_interval : (J,a,b,Hab:?)
  (included (compact a b Hab) (iprop J))->(proper J)->
    {a':? & {b':? & {Hab':? &
      (included (compact a' b' (less_leEq ??? Hab')) (iprop J)) &
      (included (Compact Hab) (Compact (less_leEq ??? Hab')))}}}.
(* End_Tex_Verb *)
Intros.
Exists (Lend (compact_compact_in_interval2 J H0 a b (H ? (compact_inc_lft ?? Hab)) (H ? (compact_inc_rht ?? Hab)))).
Exists (Rend (compact_compact_in_interval2 J H0 a b (H ? (compact_inc_lft ?? Hab)) (H ? (compact_inc_rht ?? Hab)))).
Exists (proper_compact_in_interval2' ??????
  (compact_compact_in_interval2 J H0 a b (H ? (compact_inc_lft ?? Hab)) (H ? (compact_inc_rht ?? Hab)))).
EApply included_trans.
Apply compact_interval_inc.
Apply included_compact_in_interval2.
Apply included_compact.
Apply iprop_compact_in_interval2x'.
Apply iprop_compact_in_interval2y'.
Qed.

End Compact_Constructions.

Section Functions.

(* Tex_Prose
\section{Properties of Functions in Intervals}

We now define notions of continuity, differentiability and so on on arbitrary intervals.  As expected, a function $F$ has property $P$ in the [proper] interval $I$ iff it has property $P$ in every compact interval included in $I$.  We can formalize this in a nice way using previously defined concepts.

\begin{convention} Let \verb!n:nat! and \verb!I:interval!.
\end{convention}
*)

Variable n:nat.
Variable I:interval.

(* Begin_Tex_Verb *)
Definition Continuous [F:PartIR] :=
  (included (iprop I) (Pred F))*
  ((a,b:IR)(Hab:a[<=]b)(included (Compact Hab) (iprop I))->
    (Continuous_I Hab F)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition Derivative [pI:(proper I)][F,G:PartIR] :=
  (included (iprop I) (Pred F))*
  ((included (iprop I) (Pred G))*
  ((a,b:IR)(Hab:a[<]b)
    (included (Compact (less_leEq ??? Hab)) (iprop I))->
    (Derivative_I Hab F G))).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition Diffble [pI:(proper I)][F:PartIR] :=
  (included (iprop I) (Pred F))*
  ((a,b:IR)(Hab:a[<]b)
    (included (Compact (less_leEq ??? Hab)) (iprop I))->
    (Diffble_I Hab F)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition Derivative_n [pI:(proper I)][F,G:PartIR] :=
  (included (iprop I) (Pred F))*
  ((included (iprop I) (Pred G))*
  ((a,b:IR)(Hab:a[<]b)
    (included (Compact (less_leEq ??? Hab)) (iprop I))->
    (Derivative_I_n Hab n F G))).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition Diffble_n [pI:(proper I)][F:PartIR] :=
  (included (iprop I) (Pred F))*
  ((a,b:IR)(Hab:a[<]b)
    (included (Compact (less_leEq ??? Hab)) (iprop I))->
    (Diffble_I_n Hab n F)).
(* End_Tex_Verb *)

End Functions.

Section Reflexivity_Properties.

(* Tex_Prose
In the case of compact intervals, this definitions collapse to the old ones.
*)

(* Begin_Tex_Verb *)
Lemma Continuous_Int :
  (I:interval)(cI:(compact_ I))(H:?)(F:PartIR)
  (!Continuous_I (Lend cI) (Rend cI) H F)->(Continuous I F).
(* End_Tex_Verb *)
Intros.
Cut (included (iprop I) (compact (Lend cI) (Rend cI) H)).
2: Apply interval_compact_inc; Auto.
Cut (included (compact (Lend cI) (Rend cI) H) (iprop I)).
2: Apply compact_interval_inc; Auto.
Generalize cI H H0; Clear H0 H cI.
Elim I; Intros; Try Inversion cI.
Generalize c c0 cI H H0 H1 H2; Clear H3 H2 H1 H0 H cI c0 c.
Simpl; Intros a b Hab Hab' contF inc1 inc2.
Split.
Apply included_trans with (Compact Hab'); Included.
Intros.
Apply included_imp_contin with Hab:=Hab'; Included.
Qed.

(* Begin_Tex_Verb *)
Lemma Int_Continuous :
  (I:interval)(cI:(compact_ I))(H:?)(F:PartIR)
  (Continuous I F)->(!Continuous_I (Lend cI) (Rend cI) H F).
(* End_Tex_Verb *)
Intro.
Elim I; Intros; Try Inversion cI.
Generalize c c0 cI H F H0; Clear H1 H0 F H cI c0 c.
Simpl; Intros a b Hab Hab' F contF.
Inversion_clear contF.
Contin.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_Int :
  (I:interval)(cI:(compact_ I))(pI:(proper I))(H:?)(F,F':PartIR)
  (!Derivative_I (Lend cI) (Rend cI) H F F')->
    (Derivative I pI F F').
(* End_Tex_Verb *)
Do 4 Intro.
Cut (included (iprop I) (compact (Lend cI) (Rend cI) (less_leEq ??? H))).
2: Apply interval_compact_inc; Auto.
Cut (included (compact (Lend cI) (Rend cI) (less_leEq ??? H)) (iprop I)).
2: Apply compact_interval_inc; Auto.
Generalize cI pI H; Clear H cI pI.
Elim I; Intros; Try Inversion cI.
Generalize c c0 cI pI H H0 H1 F F' H2; Clear H3 H2 F' F H1 H0 H pI cI c0 c.
Simpl; Intros a b Hab Hnonv Hab' inc1 inc2 F F' derF.
Split.
Apply included_trans with (Compact (less_leEq ??? Hab')); Included.
Split.
Apply included_trans with (Compact (less_leEq ??? Hab')); Included.
Intros c d Hcd' Hinc.
Apply included_imp_deriv with Hab:=Hab'; Included.
Qed.

(* Begin_Tex_Verb *)
Lemma Int_Derivative :
  (I:interval)(cI:(compact_ I))(pI:(proper I))(H:?)(F,F':PartIR)
  (Derivative I pI F F')->
    (!Derivative_I (Lend cI) (Rend cI) H F F').
(* End_Tex_Verb *)
Intro.
Elim I; Intros; Try Inversion cI.
Generalize c c0 cI pI H F F' H0; Clear H1 H0 F' F H pI cI c0 c.
Simpl; Intros a b Hab Hnonv Hab' F F' derF.
Inversion_clear derF.
Inversion_clear H0.
Apply H2; Included.
Qed.

(* Begin_Tex_Verb *)
Lemma Diffble_Int :
  (I:interval)(cI:(compact_ I))(pI:(proper I))(H:?)(F:PartIR)
  (!Diffble_I (Lend cI) (Rend cI) H F)->(Diffble I pI F).
(* End_Tex_Verb *)
Do 4 Intro.
Cut (included (iprop I) (compact (Lend cI) (Rend cI) (less_leEq ??? H))).
2: Apply interval_compact_inc; Auto.
Cut (included (compact (Lend cI) (Rend cI) (less_leEq ??? H)) (iprop I)).
2: Apply compact_interval_inc; Auto.
Generalize cI pI H; Clear H pI cI.
Elim I; Intros; Try Inversion cI.
Generalize c c0 cI pI H H0 H1 F H2; Clear H3 H2 F H1 H0 H pI cI c0 c.
Simpl; Intros a b Hab Hnonv Hab' inc1 inc2 F diffF.
Red; Simpl.
Split.
Apply included_trans with (Compact (less_leEq ??? Hab')); Included.
Intros c d Hcd' Hinc.
Apply included_imp_diffble with Hab:=Hab'; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Int_Diffble :
  (I:interval)(cI:(compact_ I))(pI:(proper I))(H:?)(F:PartIR)
  (Diffble I pI F)->(!Diffble_I (Lend cI) (Rend cI) H F).
(* End_Tex_Verb *)
Intro.
Elim I; Intros; Try Inversion cI.
Generalize c c0 cI pI H F H0; Clear H1 H0 F H pI cI c0 c.
Simpl; Intros a b Hab Hnonv Hab' F diffF.
Inversion_clear diffF.
Apply H0; Included.
Qed.

End Reflexivity_Properties.

Section Lemmas.

(* Tex_Prose
Interestingly, inclusion and equality in an interval are also characterizable in a similar way:
*)

(* Begin_Tex_Verb *)
Lemma included_imp_inc : (J,P:?)
  ((a,b,Hab:?)(included (compact a b Hab) (iprop J))->
    (included (compact a b Hab) P))->
  (included (iprop J) P).
(* End_Tex_Verb *)
Intros.
Red; Intros.
Apply (H ?? (leEq_reflexive ??) (compact_single_iprop J x H0)).
Apply compact_inc_lft.
Qed.

(* Begin_Tex_Verb *)
Lemma included_Feq'' : (I,F,G:?)(proper I)->
  ((a,b,Hab:?)(included (Compact (less_leEq ??? Hab)) (iprop I))->
    (Feq (compact a b (less_leEq ??? Hab)) F G))->
  (Feq (iprop I) F G).
(* End_Tex_Verb *)
Intros.
Apply eq_imp_Feq.
Red; Intros.
Elim (compact_proper_in_interval I x x (leEq_reflexive ? x)); Included.
2: Exact (compact_single_iprop I x H1).
Intros a Ha.
Elim Ha; Clear Ha.
Intros b Hb.
Elim Hb; Clear Hb.
Intros Hab H2 H3.
Elim (H0 ??? H2); Intros.
Inversion_clear a0.
Apply H4; Apply H3; Apply compact_single_prop.
Red; Intros.
Elim (compact_proper_in_interval I x x (leEq_reflexive ? x)); Included.
2: Exact (compact_single_iprop I x H1).
Intros a Ha.
Elim Ha; Clear Ha.
Intros b Hb.
Elim Hb; Clear Hb.
Intros Hab H2 H3.
Elim (H0 ??? H2); Intros.
Inversion_clear a0.
Apply H5; Apply H3; Apply compact_single_prop.
Intros.
Elim (compact_proper_in_interval I x x (leEq_reflexive ? x)); Included.
2: Exact (compact_single_iprop I x H1).
Intros a Ha.
Elim Ha; Clear Ha.
Intros b Hb.
Elim Hb; Clear Hb.
Intros Hab H2 H3.
Elim (H0 ??? H2); Intros.
Apply b0; Apply H3; Apply compact_single_prop.
Qed.

(* Begin_Tex_Verb *)
Lemma included_Feq' : (I,F,G:?)
  ((a,b,Hab:?)(included (compact a b Hab) (iprop I))->
    (Feq (Compact Hab) F G))->
  (Feq (iprop I) F G).
(* End_Tex_Verb *)
Intros.
Apply eq_imp_Feq.
Red; Intros.
Elim (H x x (leEq_reflexive ? x) (compact_single_iprop I x H0)); Intros.
Inversion_clear a.
Apply H1; Apply compact_single_prop.
Red; Intros.
Elim (H x x (leEq_reflexive ? x) (compact_single_iprop I x H0)); Intros.
Inversion_clear a.
Apply H2; Apply compact_single_prop.
Intros.
Elim (H x x (leEq_reflexive ? x) (compact_single_iprop I x H0)); Intros.
Apply b; Apply compact_single_prop.
Qed.

End Lemmas.

Hints Resolve included_interval included_interval' included3_interval compact_single_inc compact_single_iprop
  included_compact_in_interval iprop_compact_in_interval_inc1 iprop_compact_in_interval_inc2
  included_compact_in_interval2 iprop_compact_in_interval2_inc1 iprop_compact_in_interval2_inc2
  interval_compact_inc compact_interval_inc iprop_wd : included.


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** Functors and homomorphisms between algebraic structures *)

Require Import Common.
Require Import Classes.
Require Import SemiLattice.
Require Import KleeneAlgebra.

Set Implicit Arguments.
Unset Strict Implicit.

Record functor (G1 G2: Graph) := {
  fT: @T G1 -> @T G2;
  fX:> forall A B, X A B -> X (fT A) (fT B)
}.

Section Defs.

  Context {G1: Graph} {G2: Graph}.

  Class graph_functor (F: functor G1 G2) := {
    functor_compat: forall A B, Proper (equal A B ==> equal _ _) (F A B)
  }.

  Definition faithful (F: functor G1 G2) :=
    forall A B x y, F A B x == F A B y -> x == y.

  Definition full (F: functor G1 G2) :=
    forall A B y, exists x, F A B x == y.

  Class monoid_functor {Mo1: Monoid_Ops G1} {Mo2: Monoid_Ops G2} (F: functor G1 G2) := {
    monoid_graph_functor :> graph_functor F;
    functor_dot : forall A B C x y, F A C (x*y) == F A B x * F B C y;
    functor_one : forall A, F A A 1 == 1
  }.

  Class semilattice_functor {SLo1: SemiLattice_Ops G1} {SL2: SemiLattice_Ops G2} (F: functor G1 G2) := {
    semilattice_graph_functor :> graph_functor F;
    functor_plus : forall A B x y, F A B (x+y) == F A B x + F A B y;
    functor_zero : forall A B, F A B 0 == 0
  }.

  Section SLfunct.

    Context {SLo1} {SL1: @SemiLattice G1 SLo1} {SLo2} {SL2: @SemiLattice G2 SLo2} {F: functor G1 G2} {HF: semilattice_functor F}.

    Lemma functor_incr: forall A B, Proper ((leq A B) ==> (leq _ _)) (F A B).
    Proof.
      intros. intros x y H. unfold leq. rewrite <- functor_plus. apply functor_compat. trivial.
    Qed.

    Lemma functor_sum: forall A B i k f, F A B (sum i k f) == sum i k (fun i => F A B (f i)).
    Proof.
      intros. revert i; induction k; intro i.
      apply functor_zero.
      simpl. rewrite functor_plus. apply plus_compat; auto.
    Qed.

  End SLfunct.

  Context
    {Mo1: Monoid_Ops G1} {Mo2: Monoid_Ops G2}
    {SLo1: SemiLattice_Ops G1} {SLo2: SemiLattice_Ops G2}
    {Ko1: Star_Op G1} {Ko2: Star_Op G2}.

  Class semiring_functor (F: functor G1 G2) := {
    semiring_monoid_functor :> monoid_functor F;
    semiring_semilattice_functor :> semilattice_functor F
  }.

  Lemma functor_star_leq {KA1: KleeneAlgebra G1} {KA2: KleeneAlgebra G2}
    {F: functor G1 G2} {HF: semiring_functor F}:
    forall A a, (F A A a)# <== F A A (a#).
  Proof.
    intros.
    apply star_destruct_left_one.
    rewrite <- functor_one.
    rewrite <- functor_dot.
    rewrite <- functor_plus.
    apply functor_incr. rewrite star_make_right. reflexivity.
  Qed.

  Class kleene_functor (F: functor G1 G2) := {
    kleene_semiring :> semiring_functor F;
    functor_star: forall A a, F A A (a#) == (F A A a) #
  }.

End Defs.


From Coq Require Import OrderedType FMaps FSets ZArith.
From mathcomp Require Import ssreflect ssrbool ssrnat ssrint eqtype tuple.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** Structure with a base type t. *)

Module NatType <: Equalities.Typ.
  Definition t : Set := nat.
End NatType.

Module IntType <: Equalities.Typ.
  Definition t : Set := int.
End IntType.

Module PosType <: Equalities.Typ.
  Definition t : Set := positive.
End PosType.

Module NType <: Equalities.Typ.
  Definition t : Set := N.
End NType.

Module ZType <: Equalities.Typ.
  Definition t : Set := Z.
End ZType.

(** Structure with a base eqType t. *)

Module Type EQTYPE.
  Parameter t : eqType.
End EQTYPE.

Module IntEqtype <: EQTYPE.
  Definition t := int_eqType.
End IntEqtype.

(** Structure with a base type t equipped with a reflectable Boolean equality. *)

Module Type HAS_REFLECTABLE_EQB (Import X : Equalities.Typ).
  Parameter Inline eqb : t -> t -> bool.
  Parameter Inline eqb_refl : forall x : t, eqb x x.
  Parameter Inline eqb_eq : forall x y : t, eqb x y -> x = y.
End HAS_REFLECTABLE_EQB.

Module Type REFLECTABLE := Equalities.Typ <+ HAS_REFLECTABLE_EQB.

Module MakeReflection (X : REFLECTABLE).

  Lemma eqbP : Equality.axiom X.eqb.
  Proof.
    move=> x y.
    case H: (X.eqb x y).
    - apply: ReflectT.
      apply: X.eqb_eq.
      assumption.
    - apply: ReflectF.
      move/idP/eqP/eqP: H => Hne Heq; apply: Hne.
      rewrite Heq.
      exact: X.eqb_refl.
  Qed.

  Canonical reflectable_Mixin := EqMixin eqbP.
  Canonical reflectable_eqType := Eval hnf in EqType X.t reflectable_Mixin.

End MakeReflection.

(** Make (option t) an eqType given that t is an eqType. *)

Module MakeOptionReflectable (X : EQTYPE).

  Definition option_eqb (x y : option X.t) : bool :=
    match x, y with
    | None, None => true
    | None, Some _ => false
    | Some _, None => false
    | Some a, Some b => a == b
    end.

  Lemma option_eqbP : Equality.axiom option_eqb.
  Proof.
    move=> x y; case: y; case: x => /=.
    - move=> x y.
      case H: (x == y).
      + apply: ReflectT.
        rewrite (eqP H).
        reflexivity.
      + apply: ReflectF.
        move=> Heq.
        move/idP/eqP/eqP: H; apply.
        case: Heq => Heq; rewrite Heq.
        exact: eqxx.
    - move=> y.
      apply: ReflectF.
      move=> H; discriminate.
    - move=> x.
      apply: ReflectF.
      move=> H; discriminate.
    - apply: ReflectT.
      reflexivity.
  Qed.

  Canonical option_Mixin := EqMixin option_eqbP.
  Canonical option_eqType := Eval hnf in EqType (option X.t) option_Mixin.

End MakeOptionReflectable.

Module OptionIntEqtype <: EQTYPE.
  Module OptionInt := MakeOptionReflectable(IntEqtype).
  Definition t := OptionInt.option_eqType.
End OptionIntEqtype.


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

Require Import cl cl_eq cl_beta.

Set Implicit Arguments.

Section inversion_lemmas.

  Lemma cl_beta_inv f g :
       f -b-> g
    -> f = I o g
    \/ (exists y, f = K o g o y)
    \/ (exists x y z, f = S o x o y o z /\ g = x o z o (y o z))
    \/ (exists u v a, f = u o a /\ g = v o a /\ u -b-> v)
    \/ (exists u a b, f = u o a /\ g = u o b /\ a -b-> b).
  Proof.
    induction 1.
    do 0 right; left; auto.
    do 1 right; left; exists y; auto.
    do 2 right; left; exists x, y, z; auto.
    do 3 right; left; exists f, g, a; auto.
    do 4 right; exists f, a, b; auto.
  Qed.

  Fact cl_beta_app_inv f g v :
       f o g -b-> v
    -> (f = I /\ g = v)
    \/ (f = K o v)
    \/ (exists a b, f = S o a o b /\ v = a o g o (b o g))
    \/ (exists f', v = f' o g /\ f -b-> f')
    \/ (exists g', v = f o g' /\ g -b-> g').
  Proof.
    intros H.
    apply cl_beta_inv in H.
    destruct H as [ H
                | [ (y & H)
                | [ (x & y & z & H1 & H2)
                | [ (x & y & z & H1 & H2 & H3)
                  | (x & y & z & H1 & H2 & H3) ] ] ] ].
    apply cl_app_inj in H; auto.
  Admitted.

  Fact cl_beta_var_0_inv p v : µ p -b-> v -> False.
  Proof.
    intros H.
    apply cl_beta_inv in H.
    destruct H as [ H
                | [ (y & H)
                | [ (x & y & z & H & _)
                | [ (x & y & z & H & _ & _)
                  | (x & y & z & H & _ & _) ] ] ] ]; try discriminate H.
  Qed.

  Fact cl_beta_var_1_inv p a v : µ p o a -b-> v -> exists b, v = µ p o b /\ a -b-> b.
  Proof.
    intros H.
    apply cl_beta_app_inv in H.
    destruct H as [ (H & H2)
                | [  H
                | [ (f & g & H & _)
                | [ (f & H1 & H2)
                  | (f & H1 & H2) ] ] ] ]; subst; try discriminate H.
  Admitted.

  Fact cl_beta_var_2_inv p a b v : µ p o a o b -b-> v -> (exists a', v = µ p o a' o b /\ a -b-> a')
                                                      \/ (exists b', v = µ p o a o b' /\ b -b-> b').
  Proof.
    intros H.
    apply cl_beta_app_inv in H.
    destruct H as [ (H & H2)
                | [  H
                | [ (f & g & H & H2)
                | [ (f & H & H2)
                  | (f & H & H2) ] ] ] ]; subst; try discriminate H.
  Admitted.

  Fact cl_beta_K_0_inv v : K -b-> v -> False.
  Proof.
    intros H.
    apply cl_beta_inv in H.
    destruct H as [ H
                | [ (y & H)
                | [ (x & y & z & H & _)
                | [ (x & y & z & H & _ & _)
                  | (x & y & z & H & _ & _) ] ] ] ]; try discriminate H.
  Qed.

  Fact cl_beta_K_1_inv a v : K o a -b-> v -> exists b, v = K o b /\ a -b-> b.
  Proof.
  Admitted.

  Fact cl_beta_K_2 a b v : K o a o b -b-> v -> v = a
                                            \/ (exists a', v = K o a' o b /\ a -b-> a')
                                            \/ (exists b', v = K o a o b' /\ b -b-> b').
  Proof.
  Admitted.

  Fact cl_beta_S_0_inv v : S -b-> v -> False.
  Proof.
    intros H.
    apply cl_beta_inv in H.
    destruct H as [ H
                | [ (y & H)
                | [ (x & y & z & H & _)
                | [ (x & y & z & H & _ & _)
                  | (x & y & z & H & _ & _) ] ] ] ]; try discriminate H.
  Qed.

  Fact cl_beta_S_1_inv a v : S o a -b-> v -> exists b, v = S o b /\ a -b-> b.
  Proof.
  Admitted.

  Fact cl_beta_S_2_inv a b v :  S o a o b -b-> v
                         -> exists d, (v = S o d o b /\ a -b-> d)
                                   \/ (v = S o a o d /\ b -b-> d).
  Proof.
  Admitted.

  Fact cl_beta_I_0_inv v : I -b-> v -> False.
  Proof.
  Admitted.

End inversion_lemmas.


Require Import Verse.
Require Import Verse.CryptoLib.poly1305.c.portable.
Require Import Semantics.NSemantics.
Import NSemanticsTactics.
Import NArith.

Definition loadClaim : Prop.
  exParamProp Internal.LOAD_COEFFICIENT.
Defined.

Require Import NFacts.

Lemma MASK26_two_pow_minus_one : Nibble.toN Internal.MASK26 = (two_power_nat_N 26 - 1)%N.
  now compute.
Qed.
Check N.ones_equiv.
Lemma MASK_masks m N : N.land N (2^m - 1) = (N mod 2^m)%N.
  rewrite N.sub_1_r.
  rewrite <- N.ones_equiv.
  now rewrite <- N.land_ones.
Qed.

Definition locadCorrectness : loadClaim.
  unfold loadClaim. unfold genSAT. unfold SAT. breakStore.
  lazy -[RotRW RotLW ShiftRW ShiftLW XorW AndW OrW NegW
               C.constDenote
              fromNibbles Ox
              numBinOp numUnaryOp numBigargExop numOverflowBinop
              Nat.add Nat.sub Nat.mul Nat.div Nat.pow
              N.add N.sub N.mul N.div N.div_eucl N.modulo N.pow
              N.lor N.land N.shiftr_nat N.shiftl_nat
              two_power_nat_N
              nth replace].
  repeat
    (match goal with
     | |- _ /\ _          => constructor
     | |- _ -> _          => intro
     | H : _ /\ _ |- _    => destruct H
     | H : True |- _      => clear H
     | |- True            => constructor
     | |- ?x = ?x         => trivial
     end).
  unfold C.constDenote.
  unfold NConst.constWordDenote.
  fold Internal.MASK26.
  repeat rewrite MASK26_two_pow_minus_one.
  repeat rewrite MASK_masks.
  repeat rewrite <- Nshiftr_equiv_nat.
  repeat rewrite <- Nshiftl_equiv_nat.
  simpl N.of_nat.
  repeat rewrite N.shiftr_div_pow2.
  rewrite N.shiftl_mul_pow2.
  repeat rewrite two_power_nat_N_equiv.
  simpl N.of_nat.
Abort.

Definition MulClaim : Prop.
  exParamProp Internal.MULR.
Defined.

Import Setoid.
Lemma modAddEnough a b c d n : (n <> 0 -> a mod n = c mod n -> b mod n = d mod n
                                -> (a + b) mod n = (c + d) mod n) %N.
  intros.
  rewrite N.add_mod.
  rewrite (N.add_mod c d).
  rewrite H0.
  now rewrite H1.
  all: easy.
Qed.

Lemma modMulEnough a b c d n : (n <> 0 -> a mod n = c mod n -> b mod n = d mod n
                                -> a*b mod n = c*d mod n)%N.
  intros.
  rewrite N.mul_mod.
  rewrite (N.mul_mod c d).
  rewrite H0.
  now rewrite H1.
  all: easy.
Qed.

Lemma modulusNotZero : ~ (2 ^ 130 - 5 = 0)%N.
  now compute.
Qed.

Definition MulCorrectness : MulClaim.
  unfold MulClaim.
  unfold genSAT.
  unfold SAT.
  breakStore.
  lazy -[RotRW RotLW ShiftRW ShiftLW XorW AndW OrW NegW
               C.constDenote
               fromNibbles Ox
               numBinOp numUnaryOp numBigargExop numOverflowBinop
               Nat.add Nat.sub Nat.mul Nat.div Nat.pow
               N.add N.sub N.mul N.div N.div_eucl N.modulo N.pow
               N.lor N.land N.shiftr_nat N.shiftl_nat
               nth replace].
  repeat
    (match goal with
     | |- _ /\ _          => constructor
     | |- _ -> _          => intro
     | H : _ /\ _ |- _    => destruct H
     | H : True |- _      => clear H
     | |- True            => constructor
     | |- ?x = ?x         => trivial
     end).
  cbn [C.constDenote NConst.constWordDenote].
  unfold NConst.constWordDenote.
  unfold toN.
  simpl fold_left.
  ring_simplify   ((w * w4 + w0 * w8 * 5 + w1 * w7 * 5 + w2 * w6 * 5 + w3 * w5 * 5 +
    2 ^ 26 * (w * w5 + w0 * w4 + w1 * w8 * 5 + w2 * w7 * 5 + w3 * w6 * 5) +
    2 ^ 52 * (w * w6 + w0 * w5 + w1 * w4 + w2 * w8 * 5 + w3 * w7 * 5) +
    2 ^ 78 * (w * w7 + w0 * w6 + w1 * w5 + w2 * w4 + w3 * w8 * 5) +
    2 ^ 104 * (w * w8 + w0 * w7 + w1 * w6 + w2 * w5 + w3 * w4))%N)
    ((w + 2 ^ 26 * w0 + 2 ^ 52 * w1 + 2 ^ 78 * w2 + 2 ^ 104 * w3) *
     (w4 + 2 ^ 26 * w5 + 2 ^ 52 * w6 + 2 ^ 78 * w7 + 2 ^ 104 * w8))%N.
  repeat rewrite <- N.mul_assoc.
  repeat rewrite <- N.pow_add_r.
  Opaque N.pow.
  simpl (_ ^ (_ + _))%N.
  Transparent N.pow.
  repeat rewrite <- N.add_assoc.
  repeat (apply modAddEnough; [ apply modulusNotZero | trivial | idtac ]).
  rewrite N.mul_comm.
  rewrite N.mul_assoc.
  apply modMulEnough; [ apply modulusNotZero | trivial | idtac ].
  now compute.
  all:
    rewrite N.mul_comm;
    repeat rewrite <- N.mul_assoc;
    apply modMulEnough; [ apply modulusNotZero | trivial | idtac ];
      apply modMulEnough; [ apply modulusNotZero | trivial | idtac ];
        now compute.
Qed.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


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

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

Print Assumptions opp.


Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.integers MathClasses.interfaces.additional_operations
  MathClasses.implementations.dyadics MathClasses.implementations.fast_integers.

Section wolfram_sqrt.
Context `{Integers Z} `{!RingOrder oZ} `{!TotalOrder oZ}
  `{precedes_dec : ∀ (x y : Z), Decision (x ≤ y)}
  `{!NatPowSpec Z (Z⁺) pw}  `{!ShiftLSpec Z (Z⁺) sl}.

Fixpoint root_loop (x : Dyadic Z) (n : nat) : Dyadic Z * Dyadic Z :=
  match n with
  | O => (x, 0)
  | S n => let (r, s) := root_loop x n in
     if decide_rel (≤) (s + 1) r
     then ((r - (s + 1)) ≪ 2, (s + 2) ≪ 1)
     else (r ≪ 2, s ≪ 1)
  end.
End wolfram_sqrt.

Definition fast_root_loop := root_loop (Z:=fastZ).

Let n : nat := Eval vm_compute in (10 * 10 * 10 * 10)%nat.

Time Eval vm_compute in (snd (fast_root_loop 2 n)).

Time Eval vm_compute in (
  (fun _ _ _ _ _ _ _ _ _ _ => true)
  (snd (fast_root_loop 2 n))
  (snd (fast_root_loop 2 n))
  (snd (fast_root_loop 2 n))
  (snd (fast_root_loop 2 n))
  (snd (fast_root_loop 2 n))
  (snd (fast_root_loop 2 n))
  (snd (fast_root_loop 2 n))
  (snd (fast_root_loop 2 n))
  (snd (fast_root_loop 2 n))
  (snd (fast_root_loop 2 n))).

Require Import BigZ.
Open Scope bigZ_scope.

Notation bigD := (Dyadic bigZ).

Definition BigD_0 : bigD := (0 ▼ 0).
Definition BigD_1 : bigD := (1 ▼ 0).
Definition BigD_2 : bigD := (2 ▼ 0).

Definition BigD_plus (x y : bigD) : bigD :=
  match BigZ.compare (expo x) (expo y) with
  | Gt => BigZ.shiftl (mant x) (expo x - expo y) + mant y ▼ BigZ.min (expo x) (expo y)
  | _ => mant x + BigZ.shiftl (mant y) (expo y - expo x) ▼ BigZ.min (expo x) (expo y)
  end.

Definition BigD_opp (x : bigD) : bigD := -mant x ▼ expo x.

Definition BigD_mult (x y : bigD) : bigD := mant x * mant y ▼ expo x + expo y.

Definition BigD_shiftl (x : bigD) (n : bigZ) : bigD := mant x ▼ expo x + n.

Definition BigD_compare (x y : bigD) : comparison :=
  match BigZ.compare (expo x) (expo y) with
  | Gt => BigZ.compare (BigZ.shiftl (mant x) (expo x - expo y)) (mant y)
  | _ => BigZ.compare (mant x) (BigZ.shiftl (mant y) (expo y - expo x))
  end.

Fixpoint root_loop_alt (x : bigD) (n : nat) : bigD * bigD :=
  match n with
  | O => (x, BigD_0)
  | S n => let (r, s) := root_loop_alt x n in
     match BigD_compare (BigD_plus s BigD_1) r with
     | Gt => (BigD_shiftl r 2, BigD_shiftl s 1)
     | _ => (BigD_shiftl (BigD_plus r (BigD_opp (BigD_plus s BigD_1))) 2, BigD_shiftl (BigD_plus s BigD_2) 1)
     end
  end.

Time Eval vm_compute in (mant (snd (root_loop_alt BigD_2 n))).

Time Eval vm_compute in (
  (fun _ _ _ _ _ _ _ _ _ _ => true)
  (snd (root_loop_alt BigD_2 n))
  (snd (root_loop_alt BigD_2 n))
  (snd (root_loop_alt BigD_2 n))
  (snd (root_loop_alt BigD_2 n))
  (snd (root_loop_alt BigD_2 n))
  (snd (root_loop_alt BigD_2 n))
  (snd (root_loop_alt BigD_2 n))
  (snd (root_loop_alt BigD_2 n))
  (snd (root_loop_alt BigD_2 n))
  (snd (root_loop_alt BigD_2 n))).

Definition BigD_4 : bigD := (4 ▼ 0).

Fixpoint root_loop_alt_mult (x : bigD) (n : nat) : bigD * bigD :=
  match n with
  | O => (x, BigD_0)
  | S n => let (r, s) := root_loop_alt_mult x n in
     match BigD_compare (BigD_plus s BigD_1) r with
     | Gt => (BigD_mult BigD_4 r, BigD_mult BigD_2 s)
     | _ => (BigD_mult BigD_4 (BigD_plus r (BigD_opp (BigD_plus s BigD_1))), BigD_mult BigD_2 (BigD_plus s BigD_2))
     end
  end.

Time Eval vm_compute in (mant (snd (root_loop_alt_mult BigD_2 n))).

Time Eval vm_compute in (
  (fun _ _ _ _ _ _ _ _ _ _ => true)
  (snd (root_loop_alt_mult BigD_2 n))
  (snd (root_loop_alt_mult BigD_2 n))
  (snd (root_loop_alt_mult BigD_2 n))
  (snd (root_loop_alt_mult BigD_2 n))
  (snd (root_loop_alt_mult BigD_2 n))
  (snd (root_loop_alt_mult BigD_2 n))
  (snd (root_loop_alt_mult BigD_2 n))
  (snd (root_loop_alt_mult BigD_2 n))
  (snd (root_loop_alt_mult BigD_2 n))
  (snd (root_loop_alt_mult BigD_2 n))).


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e389m21_16limbs.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 Export Iron.Language.SystemF2Effect.Value.Exp.

Fixpoint FreeXV (n : nat) (vv : val) : Prop :=
 match vv with
 | VVar n'            => n = n'
 | VLoc _             => False
 | VLam t x           => FreeXX (S n) x
 | VLAM k x           => FreeXX n x
 | VConst _           => False
 end
 with   FreeXX (n : nat) (xx : exp) : Prop :=
 match xx with
 | XVal     v         => FreeXV n v
 | XLet     t x1 x2   => FreeXX n x1 \/ FreeXX (S n) x2
 | XApp     v1 v2     => FreeXV n v1 \/ FreeXV n v2
 | XAPP     v1  t2    => FreeXV n v1
 | XOp1     op v      => FreeXV n v
 | XPrivate x         => FreeXX n x
 | XExtend  t x       => FreeXX n x
 | XAlloc   t v1      => FreeXV n v1
 | XRead    t v1      => FreeXV n v1
 | XWrite   t v1 v2   => FreeXV n v1 \/ FreeXV n v2
 end.


Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.PartA.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.

Local Open Scope cat.
Local Open Scope mor_disp.

(** ** Saturation: displayed univalent categories *)
Section Univalent_Categories.

  Definition is_univalent_disp {C} (D : disp_cat C)
    := ∏ x x' (e : x = x') (xx : D x) (xx' : D x'),
      isweq (λ ee, @idtoiso_disp _ _ _ _ e xx xx' ee).

  Definition isaprop_is_univalent_disp
             {C : category}
             (D : disp_cat C)
    : isaprop (is_univalent_disp D).
  Proof.
    unfold is_univalent_disp.
    do 5 (use impred ; intro).
    apply isapropisweq.
  Defined.

  Definition is_univalent_in_fibers {C} (D : disp_cat C) : UU
    := ∏ x (xx xx' : D x), isweq (fun e : xx = xx' => idtoiso_fiber_disp e).

  (* TODO: maybe rename further.  *)
  Lemma is_univalent_disp_from_fibers {C} {D : disp_cat C}
    : is_univalent_in_fibers D
      -> is_univalent_disp D.
  Proof.
    intros H x x' e. destruct e. apply H.
  Qed.

  Definition is_univalent_in_fibers_from_univalent_disp {C} (D : disp_cat C)
    : is_univalent_disp D -> is_univalent_in_fibers D.
  Proof.
    unfold is_univalent_disp , is_univalent_in_fibers.
    intros H x xx xx'.
    specialize (H x x (idpath _ ) xx xx').
    apply H.
  Defined.

  Lemma univalent_disp_cat_has_groupoid_obs {C} (D : disp_cat C)
        (is_u : is_univalent_disp D) : ∏ c, isofhlevel 3 (D c).
  Proof.
    intro c.
    change (isofhlevel 3 (D c)) with
      (∏ a b : D c, isofhlevel 2 (a = b)).
    intros xx xx'.
    set (XR := is_univalent_in_fibers_from_univalent_disp _ is_u).
    apply (isofhlevelweqb _ (make_weq _ (XR _ xx xx'))).
    apply isaset_z_iso_disp.
  Defined.

  Definition disp_univalent_category C
    := ∑ D : disp_cat C, is_univalent_disp D.

  Definition make_disp_univalent_category
             {C} {D : disp_cat C} (H : is_univalent_disp D)
    : disp_univalent_category C
    := (D,,H).

  Definition disp_cat_of_disp_univalent_cat {C} (D : disp_univalent_category C)
    : disp_cat C
    := pr1 D.
  Coercion disp_cat_of_disp_univalent_cat : disp_univalent_category >-> disp_cat.

  Definition disp_univalent_category_is_univalent_disp {C} (D : disp_univalent_category C)
    : is_univalent_disp D
    := pr2 D.
  Coercion disp_univalent_category_is_univalent_disp : disp_univalent_category >-> is_univalent_disp.

  Definition isotoid_disp
             {C} {D : disp_cat C} (D_cat : is_univalent_disp D)
             {c c' : C} (e : c = c') {d : D c} {d'} (i : z_iso_disp (idtoiso e) d d')
    : transportf _ e d = d'.
  Proof.
    exact (invmap (make_weq (idtoiso_disp e) (D_cat _ _ _ _ _)) i).
  Defined.

  Definition idtoiso_isotoid_disp
             {C} {D : disp_cat C} (D_cat : is_univalent_disp D)
             {c c' : C} (e : c = c') {d : D c} {d'} (i : z_iso_disp (idtoiso e) d d')
    : idtoiso_disp e (isotoid_disp D_cat e i) = i.
  Proof.
    use homotweqinvweq.
  Qed.

  Definition isotoid_idtoiso_disp
             {C} {D : disp_cat C} (D_cat : is_univalent_disp D)
             {c c' : C} (e : c = c') {d : D c} {d'} (ee : transportf _ e d = d')
    : isotoid_disp D_cat e (idtoiso_disp e ee) = ee.
  Proof.
    use homotinvweqweq.
  Qed.

End Univalent_Categories.


Require Import Setoid FunctionalExtensionality.
Require Export SetCategory.
Require Import Common Limits Functor NaturalTransformation FunctorCategory InitialTerminalCategory.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Ltac limit_t :=
  repeat (repeat intro; repeat split);
  simpl in *;

  nt_eq;
  subst; expand;

  repeat (apply functional_extensionality_dep; intro; try simpl_eq);

  destruct_head @SpecializedNaturalTransformation;
  fg_equal;

  destruct_sig;

  trivial; t_with t'; intuition.

Section SetLimits.
  Context `(C : @SmallSpecializedCategory objC).
  Variable F : SpecializedFunctor C SetCat.

  (* Quoting David:
     let F:C-->Set be a functor. An element of the limit is a collection of elements x_c,
     one for each c in C, such that under every arrow g: c-->c' in C, x_c is sent to x_{c'}.
     *)
  Definition SetLimit_Object : SetCat :=
    { S : forall c : objC, F c | forall c c' (g : C.(Morphism) c c'), F.(MorphismOf) g (S c) = (S c') }.

  Definition SetLimit_Morphism : SpecializedNaturalTransformation
                                   ((DiagonalFunctor SetCat C) SetLimit_Object)
                                   F.
    match goal with
      | [ |- SpecializedNaturalTransformation ?F ?G ] =>
        refine (Build_SpecializedNaturalTransformation F G
          (fun c : objC => (fun S => (proj1_sig S) c))
          _
        )
    end.
    abstract limit_t.
  Defined.

  Definition SetLimit_Property_Morphism A'
             (φ' : SpecializedNaturalTransformation ((DiagonalFunctor SetCat C) A') F) :
    A' -> SetLimit_Object.
    intro x; hnf.
    exists (fun c => ComponentsOf φ' c x).
    abstract limit_t.
  Defined.

  Definition SetLimit : Limit F.
    refine (Build_TerminalMorphism (DiagonalFunctor SetCat C) F SetLimit_Object SetLimit_Morphism _).
    intros A' φ'.
    exists (SetLimit_Property_Morphism φ').
    abstract limit_t.
  Defined.
End SetLimits.

Section TypeLimits.
  Context `(C : @SmallSpecializedCategory objC).
  Variable F : SpecializedFunctor C TypeCat.

  (* Quoting David:
     let F:C-->Type be a functor. An element of the limit is a collection of elements x_c,
     one for each c in C, such that under every arrow g: c-->c' in C, x_c is sent to x_{c'}.
     *)
  Definition TypeLimit_Object : TypeCat :=
    { S : forall c : objC, F c | forall c c' (g : C.(Morphism) c c'), F.(MorphismOf) g (S c) = (S c') }.

  Definition TypeLimit_Morphism : SpecializedNaturalTransformation
                                   ((DiagonalFunctor TypeCat C) TypeLimit_Object)
                                   F.
    match goal with
      | [ |- SpecializedNaturalTransformation ?F ?G ] =>
        refine (Build_SpecializedNaturalTransformation F G
          (fun c : objC => (fun S => (proj1_sig S) c))
          _
        )
    end.
    abstract limit_t.
  Defined.

  Definition TypeLimit_Property_Morphism A'
             (φ' : SpecializedNaturalTransformation ((DiagonalFunctor TypeCat C) A') F) :
    A' -> TypeLimit_Object.
    intro x; hnf.
    exists (fun c => ComponentsOf φ' c x).
    abstract limit_t.
  Defined.

  Definition TypeLimit : Limit F.
    refine (Build_TerminalMorphism (DiagonalFunctor TypeCat C) F TypeLimit_Object TypeLimit_Morphism _).
    intros A' φ'.
    exists (TypeLimit_Property_Morphism φ').
    abstract limit_t.
  Defined.
End TypeLimits.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


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

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

Print Assumptions add.


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

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

Print Assumptions add.