From Coq Require Import
     Arith.PeanoNat
     Logic.FunctionalExtensionality.

Require Export Heapster.Permissions.

(* Memory model *)
Definition addr : Set := nat * nat.

Definition eqb (a b : addr) : bool :=
  Nat.eqb (fst a) (fst b) && Nat.eqb (snd a) (snd b).

Lemma addr_dec : forall (a b : addr), {a = b} + {a <> b}.
Proof.
  intros [a1 a2] [b1 b2].
  destruct (Nat.eq_dec a1 b1); destruct (Nat.eq_dec a2 b2); subst; auto.
  - right. intros H. inversion H; subst. apply n. reflexivity.
  - right. intros H. inversion H; subst. apply n. reflexivity.
  - right. intros H. inversion H; subst. apply n. reflexivity.
Qed.

Lemma addr_neq_cases (b b' o o' : nat) :
  (b, o) <> (b', o') -> b <> b' \/ o <> o'.
Proof.
  intros.
  destruct (Nat.eq_dec b b'); destruct (Nat.eq_dec o o'); subst; auto.
Qed.

Lemma eqb_spec : forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros [x1 x2] [y1 y2]. destruct (eqb (x1, x2) (y1, y2)) eqn:?; constructor.
  - unfold eqb in Heqb. simpl in Heqb. symmetry in Heqb. apply Bool.andb_true_eq in Heqb.
    destruct Heqb. symmetry in H, H0.
    apply (Bool.reflect_iff _ _ (Nat.eqb_spec _ _)) in H.
    apply (Bool.reflect_iff _ _ (Nat.eqb_spec _ _)) in H0. subst. auto.
  - unfold eqb in Heqb. simpl in Heqb. apply Bool.andb_false_iff in Heqb.
    destruct Heqb.
    + intro. inversion H0. subst. rewrite Nat.eqb_refl in H. inversion H.
    + intro. inversion H0. subst. rewrite Nat.eqb_refl in H. inversion H.
Qed.

Inductive SByte :=
| Byte : nat -> SByte
| Ptr : addr -> SByte
(* | SUndef : SByte. *)
.
Definition mem_block := nat -> option SByte.

Variant logical_block :=
| LBlock (size : nat) (bytes : mem_block) : logical_block.

Definition memory := nat -> option logical_block.


Require Import HoTT.Basics HoTT.Utf8.

(* Indexed Inductive Definitions *)

(* Specify the operations of an inductive definition *)
Cumulative Inductive DataSpec@{i} (I : Type@{i}) : Type@{i+1} :=
  | single_argument (i : I)
  | infinitary_argument (A : Type@{i}) (B : A → I)
.

(* An [OpSpec I] is, informally, a list of constructors for an
[I]-indexed inductive definition.  The first three constructors [el],
[ind_arg], and [nonind_arg] generate inductively a single constructor:
[el] specifies the output index of the constructor, while the other
two add inductive and non-inductive arguments respectively.  The
"list" aspect (more precisely, a binary tree) is governed by [op_prod]
and [op_skip].  Putting these all in the same inductive definition
allows them to be all mixed up, but that doesn't materially affect the
generality. *)
Cumulative Inductive OpSpec@{i} (I : Type@{i}) : Type@{i+1} :=
  | el (i : I)
  | ind_arg (A : DataSpec@{i} I) (B : OpSpec I)
  | nonind_arg (A : Type@{i}) (B : A → OpSpec I)
  | op_prod (A B : OpSpec I)
  | op_skip
.
Arguments single_argument {I} i.
Arguments infinitary_argument {I} A B.
Arguments el {I} i.
Arguments ind_arg {I} A B.
Arguments nonind_arg {I} A B.
Arguments op_prod {I} A B.
Arguments op_skip {I}.

(* As an example that may make this more comprehensible to category
theorists, suppose we have a dependent polynomial, which semantically
is a triple of morphisms:

I <--p-- B --q--> A --r--> I.

We represent q by a dependent type B : A -> Type and the other two by
functions r : A -> I and p : ∀ a, B a -> I. *)
Section DependentPolynomial.
  Context (I : Type) (A : Type) (B : A -> Type) (r : A -> I) (p : ∀ a, B a -> I).
  (* The constructors of the corresponding indexed inductive type (the
     putative initial algebra for this dependent polynomial functor)
     are then, in the above syntax: *)
  Definition OpSpec_DepPoly : OpSpec I
    := nonind_arg A (λ a, ind_arg (infinitary_argument (B a) (p a)) (el (r a))).
End DependentPolynomial.

(* Conversely, we can turn an [OpSpec] into a dependent polynomial. *)
Section ToDepPoly.
  Context {I : Type}.
  Fixpoint constructors (op : OpSpec I) : Type
    := match op with
       | el i => Unit
       | ind_arg A B => constructors B
       | nonind_arg A B => { a : A & constructors (B a) }
       | op_prod A B => constructors A + constructors B
       | op_skip => Empty
       end.
  Fixpoint out_index (op : OpSpec I) : constructors op -> I
    := match op return constructors op -> I with
       | el i => λ _, i
       | ind_arg A B => out_index B
       | nonind_arg A B => λ ab, out_index (B ab.1) ab.2
       | op_prod A B => λ ab, match ab with
                              | inl a => out_index A a
                              | inr b => out_index B b
                              end
       | op_skip => Empty_rec I
       end.
  Definition argdata (dt : DataSpec I) : Type
    := match dt with
       | single_argument i => Unit
       | infinitary_argument A B => A
       end.
  Fixpoint arguments (op : OpSpec I) : constructors op -> Type
    := match op return constructors op -> Type with
       | el i => λ _, Empty
       | ind_arg A B => λ c, argdata A + arguments B c
       | nonind_arg A B => λ ab, arguments (B ab.1) ab.2
       | op_prod A B => λ ab, match ab with
                              | inl a => arguments A a
                              | inr b => arguments B b
                              end
       | op_skip => Empty_rec Type
       end.
  Definition arg_index (dt : DataSpec I) : argdata dt -> I
    := match dt return argdata dt -> I with
       | single_argument i => λ _, i
       | infinitary_argument A B => B
       end.
  Fixpoint in_index (op : OpSpec I) : ∀ c, arguments op c -> I
    := match op return ∀ c, arguments op c -> I with
       | el i => λ _, Empty_rec I
       | ind_arg A B => λ c xy, match xy with
                                | inl x => arg_index A x
                                | inr y => in_index B c y
                                end
       | nonind_arg A B => λ ab x, in_index (B ab.1) ab.2 x
       | op_prod A B => λ ab, match ab with
                                | inl a => in_index A a
                                | inr b => in_index B b
                                end
       | op_skip => Empty_ind (λ c, arguments op_skip c -> I)
       end.

  (* If we start from a dependent polynomial, then this recaptures it,
  up to trivialities like Σs over Unit or coproducts with Empty. *)
  Context (A : Type) (B : A -> Type) (r : A -> I) (p : ∀ a, B a -> I).
  Eval compute in (constructors (OpSpec_DepPoly I A B r p)).
  (* ==> ∃ _ : A, Unit *)
  Eval compute in (out_index (OpSpec_DepPoly I A B r p)).
  (* ==> λ ab, r ab.1 *)
  Eval compute in (arguments (OpSpec_DepPoly I A B r p)).
  (* ==> λ ab, B ab ₁ ⊔ Empty *)
  Eval compute in (in_index (OpSpec_DepPoly I A B r p)).
  (* ==> λ ab xy,
       match xy with
       | inl x => p ab.1 x
       | inr y => match y return I with end
       end
   *)
End ToDepPoly.

Definition functor_DataSpec@{i j} {I : Type@{i}} {J : Type@{j}} (f : I → J)
  : DataSpec@{i} I → DataSpec@{j} J
  := λ A, match A with
     | single_argument i => single_argument (f i)
     | infinitary_argument A B => infinitary_argument A (f o B)
     end.

Definition functor_OpSpec@{i j} {I : Type@{i}} {J : Type@{j}} (f : I → J)
  : OpSpec@{i} I → OpSpec@{j} J
  := fix F A := match A with
     | el i => el (f i)
     | ind_arg A B => ind_arg (functor_DataSpec f A) (F B)
     | nonind_arg A B => nonind_arg A (F o B)
     | op_prod A B => op_prod (F A) (F B)
     | op_skip => op_skip
     end.

(* Now we define the "algebra structure" corresponding to a given list
of constructors [A : OpSpec I].  Given [X : I -> Type], an element of
[Operations X A] is an "[A]-algebra structure" on [X], and the
intended indexed inductive definition should be the initial such
[A]-algebra. *)
Section el_op.
Universe i.
Context {I : Type@{i}} (Xin Xout : I → Type@{i}).
Definition ElDataSpec@{} (A : DataSpec@{i} I) : Type@{i}
  := match A with
     | single_argument i => Xin i
     | infinitary_argument A B => ∀ a, Xin (B a)
     end.
Fixpoint Operations@{} (A : OpSpec@{i} I) : Type@{i}
  := match A with
     | el i => Xout i
     | ind_arg A B => ElDataSpec A → Operations B
     | nonind_arg A B => ∀ a, Operations (B a)
     | op_prod A B => Operations A * Operations B
     | op_skip => Unit
     end.

(* We can check that this produces the correct result on a dependent
polynomial:

Eval compute in (λ A B r p, Operations (OpSpec_DepPoly I A B r p)).
 ==> λ A B r p, ∀ a : A, (∀ b : B a, Xin (p a b)) → Xout (r a) *)

(* Next we specify the notion of "dependent algebra structure", which
gives the hypotheses of the desired eliminator. *)
Universe j.
Constraint i <= j. (* Don't consider eliminating into smaller universes *)
Context (Pin : ∀ i, Xin i → Type@{j}) (Pout : ∀ i, Xout i → Type@{j}).
Definition InductiveHypothesis@{} (A : DataSpec@{i} I)
  : ElDataSpec A → Type@{j}
  := match A return ElDataSpec A → Type@{_} with
     | single_argument i => Pin i
     | infinitary_argument A B => λ f, ∀ a, Pin (B a) (f a)
     end.
Fixpoint Methods@{} (A : OpSpec@{i} I)
  : Operations A → Type@{j}
  := match A return Operations A → Type@{_} with
     | el i => Pout i
     | ind_arg A B => λ f, ∀ x, InductiveHypothesis A x → Methods B (f x)
     | nonind_arg A B => λ f, ∀ a, Methods (B a) (f a)
     | op_prod A B => λ x, Methods A (fst x) * Methods B (snd x)
     | op_skip => λ _, Unit
     end.

(*
Eval compute in (λ A B r p (op : Operations (OpSpec_DepPoly I A B r p)), Methods (OpSpec_DepPoly I A B r p) op).
==> λ A B r p op,
  ∀ (a : A) (x : ∀ b : B a, X (p a b)),
  (∀ b : B a, P (p a b) (x b)) → P (r a) (op a x)
*)

(* Finally, we specify the computation equations that a putative solution to the elimination rule ought to satisfy. *)
Context (Ein : ∀ i x, Pin i x) (Eout : ∀ i x, Pout i x).
Definition InductiveData@{} (A : DataSpec@{i} I)
  : ∀ x, InductiveHypothesis A x
  := match A return ∀ x, InductiveHypothesis A x with
     | single_argument i => Ein i
     | infinitary_argument A B => λ f a, Ein (B a) (f a)
     end.
Fixpoint Equations@{} (A : OpSpec@{i} I)
  : ∀ op, Methods A op → Type@{j}
  := match A return ∀ op, Methods A op → Type@{_} with
     | el i => λ x y, Eout i x = y
     | ind_arg A B => λ f f',
       ∀ x, Equations B (f x) (f' x (InductiveData A x))
     | nonind_arg A B => λ f f',
       ∀ a, Equations (B a) (f a) (f' a)
     | op_prod A B => λ x x',
       Equations A (fst x) (fst x') * Equations B (snd x) (snd x')
     | op_skip => λ _ _,
       Unit
     end.
(* Alternatively, have InductiveData be a relation, like in general II elim *)

(*
Eval compute in (λ A B r p (op : Operations (OpSpec_DepPoly I A B r p)) m, Equations (OpSpec_DepPoly I A B r p) op m).
==> λ A B r p op m,
  ∀ (a : A) (x : ∀ b : B a, X (p a b)),
    E (r a) (op a x) = m a x (λ b : B a, E (p a b) (x b))
*)

End el_op.

Definition data_to_op@{i} {I : Type@{i}} : DataSpec@{i} I → OpSpec@{i} I
  := λ A, match A with
     | single_argument i => el i
     | infinitary_argument A B => nonind_arg A (el o B)
     end.

(* is an equivalence *)
Definition data_to_op_El@{i j} {I : Type@{i}} {El : I → Type@{j}}
  : ∀ {A : DataSpec@{i} I},
    ElDataSpec@{i} El A → Operations@{j} El El (data_to_op A)
  := λ {A}, match A with
     | single_argument i => idmap
     | infinitary_argument A B => idmap
     end.
Definition op_to_data_El@{i j} {I : Type@{i}} {El : I → Type@{j}}
  : ∀ {A : DataSpec@{i} I},
    Operations@{j} El El (data_to_op A) → ElDataSpec@{i} El A
  := λ {A}, match A with
     | single_argument i => idmap
     | infinitary_argument A B => idmap
     end.

(* is an equivalence *)
Definition ElDataSpec_compose@{i j k} {I : Type@{i}} {J : Type@{j}}
  {f : I → J} {El : J → Type@{k}}
  : ∀ {A : DataSpec@{i} I},
    ElDataSpec@{i} (El o f) A → ElDataSpec@{j} El (functor_DataSpec f A)
  := λ {A}, match A with
     | single_argument i => idmap
     | infinitary_argument A B => idmap
     end.

(* is an equivalence *)
Definition Operations_compose@{i j k} {I : Type@{i}} {J : Type@{j}}
  {f : I → J} {El : J → Type@{k}}
  : ∀ {A : OpSpec@{i} I},
    Operations@{j} El El (functor_OpSpec f A) →
    Operations@{j} (El o f) (El o f) A
  := fix comp {A} := match A with
     | el i => idmap
     | ind_arg A B => λ f, (λ a, comp (f (ElDataSpec_compose a)))
     | nonind_arg A B => λ f a, comp (f a)
     | op_prod A B => λ x, (comp (fst x), comp (snd x))
     | op_skip => λ _, tt
     end.

Definition functor_ElDataSpec {I : Type@{i}} {Elin1 Elin2 : I → Type@{i}}
  (Fin : ∀ i, Elin2 i → Elin1 i)
  : ∀ {A : DataSpec@{i} I},
    ElDataSpec@{i} Elin2 A → ElDataSpec@{i} Elin1 A
  := λ {A}, match A return ElDataSpec@{i} Elin2 A → ElDataSpec@{i} Elin1 A with
     | single_argument i => Fin i
     | infinitary_argument A B => λ f a, Fin _ (f a)
     end.
Definition functor_Operations {I : Type@{i}}
  {Elin1 Elin2 Elout1 Elout2 : I → Type@{i}}
  (Fin : ∀ i, Elin2 i → Elin1 i) (Fout : ∀ i, Elout1 i → Elout2 i)
  : ∀ {A : OpSpec@{i} I},
    Operations@{i} Elin1 Elout1 A →
    Operations@{i} Elin2 Elout2 A
  := fix func {A} := match A with
     | el i => Fout i
     | ind_arg A B => λ f a, func (f (functor_ElDataSpec Fin a))
     | nonind_arg A B => λ f a, func (f a)
     | op_prod A B => λ x, (func (fst x), func (snd x))
     | op_skip => λ _, tt
     end.
Definition functor_Operations1 {I : Type@{i}}
  {Elin Elout1 Elout2 : I → Type@{i}}
  (Fout : ∀ i, Elout1 i → Elout2 i)
  : ∀ {A : OpSpec@{i} I},
    Operations@{i} Elin Elout1 A →
    Operations@{i} Elin Elout2 A
  := fix func {A} := match A with
     | el i => Fout i
     | ind_arg A B => λ f a, func (f a)
     | nonind_arg A B => λ f a, func (f a)
     | op_prod A B => λ x, (func (fst x), func (snd x))
     | op_skip => λ _, tt
     end.
Definition functor_Methods1 {I : Type@{i}}
  {Elin Elout1 Elout2 : I → Type@{i}}
  (FElout : ∀ i, Elout1 i → Elout2 i)
  {Pin : ∀ i, Elin i → Type@{j}}
  {Pout1 : ∀ i, Elout1 i → Type@{j}} {Pout2 : ∀ i, Elout2 i → Type@{j}}
  (FPout : ∀ i x, Pout1 i x → Pout2 i (FElout i x))
  : ∀ {A : OpSpec@{i} I} {ops : Operations@{i} Elin Elout1 A},
    Methods@{i j} Elin Elout1 Pin Pout1 A ops →
    Methods@{i j} Elin Elout2 Pin Pout2 A (functor_Operations1 FElout ops)
  := fix func {A} := match A with
     | el i => FPout i
     | ind_arg A B => λ ops f a x, func (ops a) (f a x)
     | nonind_arg A B => λ ops f a, func (ops a) (f a)
     | op_prod A B => λ ops x, (func (fst ops) (fst x), func (snd ops) (snd x))
     | op_skip => λ _ _, tt
     end.
Definition functor_Methods1_rev {I : Type@{i}}
  {Elin Elout1 Elout2 : I → Type@{i}}
  (FElout : ∀ i, Elout1 i → Elout2 i)
  {Pin : ∀ i, Elin i → Type@{j}}
  {Pout1 : ∀ i, Elout1 i → Type@{j}} {Pout2 : ∀ i, Elout2 i → Type@{j}}
  (FPout : ∀ i x, Pout2 i (FElout i x) → Pout1 i x)
  : ∀ {A : OpSpec@{i} I} {ops : Operations@{i} Elin Elout1 A},
    Methods@{i j} Elin Elout2 Pin Pout2 A (functor_Operations1 FElout ops) →
    Methods@{i j} Elin Elout1 Pin Pout1 A ops
  := fix func {A} := match A with
     | el i => FPout i
     | ind_arg A B => λ ops f a x, func (ops a) (f a x)
     | nonind_arg A B => λ ops f a, func (ops a) (f a)
     | op_prod A B => λ ops x, (func (fst ops) (fst x), func (snd ops) (snd x))
     | op_skip => λ _ _, tt
     end.
Definition functor_Methods0_rev {I : Type@{i}}
  {Elin Elout1 Elout2 : I → Type@{i}}
  (Fout : ∀ i, Elout1 i → Elout2 i)
  {Pin : ∀ i, Elin i → Type@{j}}
  {Pout2 : ∀ i, Elout2 i → Type@{j}}
  (Pout1 : ∀ i, Elout1 i → Type@{j} := λ i, Pout2 i o Fout i)
  : ∀ {A : OpSpec@{i} I} {ops : Operations@{i} Elin Elout1 A},
    Methods@{i j} Elin Elout2 Pin Pout2 A (functor_Operations1 Fout ops) →
    Methods@{i j} Elin Elout1 Pin Pout1 A ops
  := fix func {A} : ∀ {ops}, _ → _ := match A with
     | el i => λ x, idmap
     | ind_arg A B => λ ops f a x, func (f a x)
     | nonind_arg A B => λ ops f a, func (f a)
     | op_prod A B => λ ops x, (func (fst x), func (snd x))
     | op_skip => λ _ _, tt
     end.
Definition functor_Methods0 {I : Type@{i}}
  {Elin Elout1 Elout2 : I → Type@{i}}
  (Fout : ∀ i, Elout1 i → Elout2 i)
  {Pin : ∀ i, Elin i → Type@{j}}
  {Pout2 : ∀ i, Elout2 i → Type@{j}}
  (Pout1 : ∀ i, Elout1 i → Type@{j} := λ i, Pout2 i o Fout i)
  : ∀ {A : OpSpec@{i} I} {ops : Operations@{i} Elin Elout1 A},
    Methods@{i j} Elin Elout1 Pin Pout1 A ops →
    Methods@{i j} Elin Elout2 Pin Pout2 A (functor_Operations1 Fout ops)
  := fix func {A} : ∀ {ops}, _ → _ := match A with
     | el i => λ x, idmap
     | ind_arg A B => λ ops f a x, func (f a x)
     | nonind_arg A B => λ ops f a, func (f a)
     | op_prod A B => λ ops x, (func (fst x), func (snd x))
     | op_skip => λ _ _, tt
     end.

Definition functor_Equations0_rev {I : Type@{i}}
  {Elin Elout1 Elout2 : I → Type@{i}}
  (Fout : ∀ i, Elout1 i → Elout2 i)
  {Pin : ∀ i, Elin i → Type@{j}}
  {Pout2 : ∀ i, Elout2 i → Type@{j}}
  (Pout1 : ∀ i, Elout1 i → Type@{j} := λ i, Pout2 i o Fout i)
  {Ein : ∀ i x, Pin i x}
  {Eout2 : ∀ i x, Pout2 i x}
  (Eout1 : ∀ i x, Pout1 i x := λ i x, Eout2 i (Fout i x))
  : ∀ {A : OpSpec@{i} I} {ops : Operations@{i} Elin Elout1 A}
      {M : Methods@{i j} Elin Elout2 Pin Pout2 A
           (functor_Operations1 Fout ops)},
    Equations@{i j} Elin Elout1 Pin Pout1 Ein Eout1 A ops
      (functor_Methods0_rev Fout M) →
    Equations@{i j} Elin Elout2 Pin Pout2 Ein Eout2 A
      (functor_Operations1 Fout ops) M
  := fix func {A} : ∀ {ops M}, _ → _ := match A with
     | el i => λ ops M, idmap
     | ind_arg A B => λ ops M f a, func (f a)
     | nonind_arg A B => λ ops M f a, func (f a)
     | op_prod A B => λ ops M x,
       (func (fst x),
        func (snd x))
     | op_skip => λ _ _ _, tt
     end.

Module Initial.
Section initial.

(* TODO: prove we have sorts and operations that satisfy the eliminator *)

Universe i.
Context {I : Type@{i}}.

(* Section test_constructors. *)
Context (A : OpSpec@{i} I).

Local Notation "( ? p )" := (λ A, match A with p => Unit | _ => Empty end)
  (p pattern).
Local Notation "( ' p => x )" :=
  (λ A, match A as A return ∀ H : (? p) A, _ with
   | p => λ _, x
   | _ => λ XX, match XX in Empty with end
   end)
  (p pattern).

Record infinitary_argument_data := {
  inf_arg_data_A : Type@{i};
  inf_arg_data_B : inf_arg_data_A → I
}.
Inductive init_Data@{} (El : I → Type@{i}) (A' : DataSpec@{i} I) : Type@{i} :=
  | init_inc (H : (? single_argument _) A')
    (_ : El (('single_argument i => i) A' H))
  | init_inf (H : (? infinitary_argument _ _) A')
    (_ : let '{|inf_arg_data_A:=A; inf_arg_data_B:=B|}
          := ('infinitary_argument A B =>
              {|inf_arg_data_A:=A; inf_arg_data_B:=B|}) A' H in
         ∀ a : A, El (B a))
.
Definition init_Data_inc_rect {El i} (P : init_Data El (single_argument i) → Type@{j})
  (IS : ∀ x, P (init_inc El (single_argument i) tt x)) : ∀ X, P X
  := λ X, match X with
     | init_inc tt x => IS x
     | init_inf XX _ => match XX with end
     end.
Definition init_Data_inf_rect {El A B} (P : init_Data El (infinitary_argument A B) → Type@{j})
  (IS : ∀ f, P (init_inf El (infinitary_argument A B) tt f)) : ∀ X, P X
  := λ X, match X with
     | init_inc XX _ => match XX with end
     | init_inf tt f => IS f
     end.
(* is an equivalence *)
Fixpoint init_Data_to_ElDataSpec {El} (A : DataSpec@{i} I)
  : init_Data El A → ElDataSpec El A
  := match A with
     | single_argument i => init_Data_inc_rect
       (λ _, ElDataSpec El (single_argument i))
       idmap
     | infinitary_argument A B => init_Data_inf_rect
       (λ _, ElDataSpec El (infinitary_argument A B))
       idmap
     end.
Fixpoint ElDataSpec_to_init_Data {El} (A : DataSpec@{i} I)
  : ElDataSpec El A → init_Data El A
  := match A with
     | single_argument i as A' => init_inc El A' tt
     | infinitary_argument A B as A' => init_inf El A' tt
     end.

Record infinitary_cons_data := {
  inf_cons_data_A : Type@{i};
  inf_cons_data_B : inf_cons_data_A → OpSpec@{i} I
}.
Inductive init@{} (A' : OpSpec@{i} I) (i : I) : Type@{i} :=
  | init_el (H : (? el _) A')
    (_ : ('el j => j) A' H = i)
  | init_ind_arg (H : (? ind_arg _ _) A')
    (_ : init_Data (init A) (('ind_arg A _ => A) A' H))
    (_ : init (('ind_arg _ B => B) A' H) i)
  | init_nonind_arg (H : (? nonind_arg _ _) A')
    (AB := ('nonind_arg A B =>
            {|inf_cons_data_A:=A; inf_cons_data_B:=B|}) A' H)
    (a : AB.(inf_cons_data_A))
    (_ : init (AB.(inf_cons_data_B) a) i)
  | init_op_prod_l (H : (? op_prod _ _) A')
    (_ : init (('op_prod A _ => A) A' H) i)
  | init_op_prod_r (H : (? op_prod _ _) A')
    (_ : init (('op_prod _ B => B) A' H) i)
.

(* End test_constructors. *)

(* Context  (A : OpSpec@{i} I). *)

Definition sorts : I → Type@{i} := init A.

Fixpoint operations_helper A'
  : Operations@{i} sorts (init A') A'
  := match A' return Operations@{i} sorts (init A') A' with
     | el i as A' => init_el A' _ tt 1
     | ind_arg A B as A' => λ a, functor_Operations1
       (λ i, init_ind_arg A' i tt (ElDataSpec_to_init_Data _ a))
       (operations_helper B)
     | nonind_arg A B as A' => λ a, functor_Operations1
       (λ i, init_nonind_arg A' i tt a)
       (operations_helper (B a))
     | op_prod A B as A' =>
       (functor_Operations1 (λ i, init_op_prod_l A' i tt) (operations_helper A),
        functor_Operations1 (λ i, init_op_prod_r A' i tt) (operations_helper B))
     | op_skip as A' => tt
     end.
Definition operations : Operations@{i} sorts sorts A
  := operations_helper A.

Section dependent_eliminator.
Universe j.
Constraint i <= j.
Context
  (P : ∀ i, sorts i → Type@{j})
  (M : Methods@{i j} sorts sorts P P A operations)
.

Local Notation "( @ p => IS & A H => P )"
  := (λ A', match A' as A return ∀ H : (? p) A, P with
      | p => λ 'tt, IS
      | _ => λ XX, match XX with end
      end)
     (p pattern, A ident, H ident).

Local Notation P' A' i x := (∀ (P2 : ∀ i, init A' i → Type@{j}),
         Methods@{i j} sorts (init A') P P2 A' (operations_helper A') →
         P2 i x).
Local Notation P2' A' B a := (∀ (P2 : ∀ i, init _ i → Type@{j}),
             Methods@{i j} sorts _ P P2 (ind_arg A' B)
               (operations_helper (ind_arg A' B)) →
             Methods@{i j} sorts _ P
             (λ i b, P2 i (init_ind_arg (ind_arg A' B) i tt a b))
             B (operations_helper B)).
Fixpoint eliminators_helper@{} A' i (x : init A' i) {struct x}
  : ∀ (P2 : ∀ i, init A' i → Type@{j}),
    Methods@{i j} sorts (init A') P P2 A' (operations_helper A') →
    P2 i x
  := match x return P' A' i x with
     | init_el H p as x =>
       (@ el i => λ p, match p with idpath => λ H, idmap end &
        A' H => ∀ p, P' A' i (init_el _ _ H p))
       A' H p
     | init_ind_arg H a b =>
       (@ ind_arg A B => λ a, λ b IH H M', IH _
          (match a return P2' A B a with
           | init_inc H2 x =>
             (@ single_argument i => λ x H (M' : ∀ a, _), functor_Methods0_rev _
                (M' _ (eliminators_helper _ _ x P M)) &
              A' H2 => ∀ x, P2' A' B (init_inc _ A' H2 x))
             A H2 x
           | init_inf H2 f =>
             (@ infinitary_argument A2 B2 => λ f H M', functor_Methods0_rev _
                (M' _ (λ a2, eliminators_helper _ _ (f a2) P M)) &
              A' H2 => ∀ f, P2' A' B (init_inf _ A' H2 f))
             A H2 f
           end H M') &
        A' H => ∀ a b, P' _ i b → P' A' i (init_ind_arg _ _ H a b))
       A' H a b (eliminators_helper _ i b)
     | init_nonind_arg H a b =>
       (@ nonind_arg A B => λ a b H M',
          eliminators_helper (B a) i b _
          (functor_Methods0_rev _ (M' a)) &
        A' H => ∀ a b, P' A' i (init_nonind_arg _ _ H a b))
       A' H a b
     | init_op_prod_l H a =>
       (@ op_prod A B => λ a H M',
          eliminators_helper A i a _
          (functor_Methods0_rev _ (fst M')) &
        A' H => ∀ a, P' A' i (init_op_prod_l _ _ H a))
       A' H a
     | init_op_prod_r H b =>
       (@ op_prod A B => λ b H M',
          eliminators_helper B i b _
          (functor_Methods0_rev _ (snd M')) &
        A' H => ∀ b, P' A' i (init_op_prod_r _ _ H b))
       A' H b
     end.

Definition eliminators@{} i x : P i x
  := eliminators_helper A i x P M.

Fixpoint equations_helper@{} A'
  : ∀ (P2 : ∀ i, init A' i → Type@{j}) M,
    Equations@{i j} sorts (init A') P P2
      eliminators (λ i x, eliminators_helper A' i x P2 M)
      A' (operations_helper A') M
  := match A' with
     | el i => λ P2 M, idpath
     | ind_arg (single_argument i) B => λ P2 M a,
       functor_Equations0_rev _ (equations_helper B _ _)
     | ind_arg (infinitary_argument A B2) B => λ P2 M a,
       functor_Equations0_rev _ (equations_helper _ _ _)
     | nonind_arg A B => λ P2 M a,
       functor_Equations0_rev _ (equations_helper _ _ _)
     | op_prod A B => λ P2 M,
       (functor_Equations0_rev _ (equations_helper _ _ _),
        functor_Equations0_rev _ (equations_helper _ _ _))
     | op_skip => λ P2 M, tt
     end.

Definition equations@{}
  : Equations@{i j} sorts sorts P P eliminators eliminators A operations M
  := equations_helper A P M.
End dependent_eliminator.

(* Derived from dependent eliminator *)
Section initiality.
Universe j.
Constraint i <= j.
Context
  {sorts' : I → Type@{j}}
  (operations' : Operations@{j} sorts' sorts' A)
.

Fixpoint nondependent_methods@{} {A : OpSpec@{i} I}
  : Operations@{j} sorts' sorts' A →
    Methods@{i j} sorts (init A) (λ i _, sorts' i) (λ i _, sorts' i) A (operations_helper A)
  := match A return Operations@{j} sorts' sorts' A →
    Methods@{i j} sorts (init A) (λ i _, sorts' i) (λ i _, sorts' i) A (operations_helper A) with
     | el i => idmap
     | ind_arg (single_argument i) B => λ f _ a, functor_Methods0 _
       (nondependent_methods (A := B) (f a))
     | ind_arg (infinitary_argument A B2) B => λ f _ a, functor_Methods0 _
       (nondependent_methods (A := B) (f a))
     | nonind_arg A B => λ f a, functor_Methods0 _
       (nondependent_methods (A := B a) (f a))
     | op_prod A B => λ x,
       (functor_Methods0 _ (nondependent_methods (fst x)),
        functor_Methods0 _ (nondependent_methods (snd x)))
     | op_skip => idmap
     end.

(* Should really define morphisms including equations,
   then prove that this one is unique. *)

Definition initial_morphism_sorts@{} : ∀ i, sorts i → sorts' i
  := eliminators (λ i _, sorts' i) (nondependent_methods operations').

End initiality.
End initial.
End Initial.

(* (* Specify the sorts of an inductive definition *)
Cumulative Inductive SortSpec@{i} : Type@{i+1} :=
  | u
  | nonind_ix (A : Type@{i}) (B : A → SortSpec)
  | sort_prod (A B : SortSpec)
.

(* The intended interpretation, as a bunch of families of types: *)
Fixpoint Sorts@{i ii | i < ii} (S : SortSpec@{i}) : Type@{ii}
  := match S with
     | u => Type@{i}
     | nonind_ix A B => ∀ a, Sorts (B a)
     | sort_prod A B => Sorts A * Sorts B
     end.
(* Could do an inductive version in Type@{i+1}, probably not worth it *)
(* Alternatively, just use Indices → Type@{i} *)

Fixpoint Indices (S : SortSpec@{i}) : Type@{i}
  := match S with
     | u => Unit
     | nonind_ix A B => { a : A & Indices (B a) }
     | sort_prod A B => Indices A + Indices B
     end.

Fixpoint get_sort@{i ii} {S : SortSpec@{i}}
  : Sorts@{i ii} S → Indices S → Type@{i}
  := match S return Sorts S → Indices S → Type@{i} with
     | u => λ X _, X
     | nonind_ix A B => λ X i, get_sort (X i.1) i.2
     | sort_prod A B => λ X i, match i with
       | inl a => get_sort (fst X) a
       | inr b => get_sort (snd X) b
       end
     end.
(*
Theorem isequiv_get_sort `{Funext} {S} : IsEquiv (get_sort@{i j k} (S := S)).
*)

Fixpoint Motives@{i j ii ijj} (S : SortSpec@{i})
  : Sorts@{i ii} S → Type@{ijj}
  := match S return Sorts S → Type@{ijj} with
     | u => λ X, X → Type@{j}
     | nonind_ix A B => λ f, ∀ a, Motives (B a) (f a)
     | sort_prod A B => λ x, Motives A (fst x) * Motives B (snd x)
     end.
Fixpoint Eliminators@{i j ii ijj ij} (S : SortSpec@{i})
  : ∀ A : Sorts@{i ii} S, Motives@{i j ii ijj} S A → Type@{ij}
  := match S return ∀ A : Sorts S, Motives S A → Type@{ij} with
     | u => λ X P,
       ∀ x, P x
     | nonind_ix A B => λ f f',
       ∀ a, Eliminators (B a) (f a) (f' a)
     | sort_prod A B => λ x x',
       Eliminators A (fst x) (fst x') * Eliminators B (snd x) (snd x')
     end. *)

(* Record IndSpec@{i} : Type@{i+1} := {
  IndSorts : SortSpec@{i};
  IndOps   : OpSpec@{i} (Indices IndSorts);
}.
Definition Algebra@{i ii | i < i} (S : IndSpec@{i}) : Type@{j}
  := { El : Sorts@{i ii} S.(IndSorts) & Operations (get_sort El) S.(IndOps) }. *)


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


(** This module layers context handling facilities on top of the core
   linear logic module, [LinLog]. The most commonly useful definitions
   in this module are the tactics [product_to_context],
   [break_context_at], and [permute_context]. *)
Require Import Sig.
Require LinLog.
Require Export PermutationHelpers.
Module Context(Term:Sig).
Module LinLogTerm := LinLog.LinLog Term.
Export LinLogTerm.
Import List Permutation.
Import ListNotations.

Definition Context := list LinProp.

(** Convert a product into a list. *)
Fixpoint product_to_context (P:LinProp) : Context :=
  match P with
  | x ⊗ y => x :: product_to_context y
  | x => [x]
  end.

(** If we take ⊤ as a right-identity on products, we can convert a
   list of propositions into a single product. *)
Fixpoint context_to_product (C:Context) : LinProp :=
  match C with
  | [] => ⊤
  | [x] => x
  | h::t => h ⊗ context_to_product t
  end.

Lemma context_to_product_left_inverse :
  forall P, context_to_product (product_to_context P) = P.
Proof. induction P; auto. simpl. rewrite IHP2.
  destruct P2; auto.
Qed.

(** A product consisting of the two elements of a context is just as
   good as the context represented as a list. *)
Lemma product_as_context : forall A B C, [A,B] ⊢ C -> [A ⊗ B] ⊢ C.
Proof. intros. apply Elim. replace [A⊗B] with ([] ++ [A⊗B]) by auto.
  apply TimesElim with (A:=A) (B:=B). refl. assumption.
Qed.

Lemma product_app_as_context : forall A B C D,
  A++[B,C] ⊢ D -> A ++ [B⊗C] ⊢ D.
Proof.
  intros. apply Elim. apply TimesElim with (A:=B) (B:=C). refl. assumption.
Qed.

(** Rewrite a list append expression to pop the had of the right
   operand onto the tail of the left operand. *)
Lemma app_pop_cons : forall {A} P (X:A) T, P++(X::T) = (P++[X])++T.
Proof. intros. replace (X::T) with ([X]++T) by auto. apply app_assoc. Qed.

Ltac simplify_all_apps :=
  match goal with
  | |- context f [(?P ++ ?X::?Y)++?Z] =>
    let tmp := fresh in
    assert ((P++X::Y)++Z = P++(X::Y++Z)) as tmp by
      (rewrite <- app_assoc; simpl; reflexivity);
    simpl in tmp; rewrite tmp; clear tmp
  | _ => idtac
  end.

(** Flatten a product into a [Context]. *)
Ltac product_to_context :=
  match goal with
  | |- [_⊗_] ⊢ _ => apply product_as_context;
                     match goal with
                     | |- ?P::?X ⊢ _ => replace (P::X) with ([P]++X) by auto;
                                        product_to_context
                     end
  | |- ?P++[_⊗_] ⊢ _ => apply product_app_as_context;
                         rewrite app_pop_cons;
                         product_to_context
  | _ => simpl; repeat simplify_all_apps
  end.

(** [break_at n lst] returns a pair whose first component is no more
   than the first [n] elements of [list], and whose second component
   is the remaining elements of [lst]. *)
Definition break_at {A} (n:nat) (L:list A) :=
  let fix go n pre l :=
    match n with
    | 0 => (rev pre, l)
    | S n' => match l with
              | [] => (rev pre, [])
              | h::t => go n' (h::pre) t
              end
    end in
  go n [] L.

(** Tactic for splitting a context into two appended sub-lists. *)
Ltac break_context_at i :=
  match goal with
  |- ?C ⊢ _ => let parts := fresh in
               set (parts:=break_at i C); simpl in parts;
               let pre := fresh in
               set (pre:=fst parts); simpl in pre;
               let pos := fresh in
               set (pos:=snd parts); simpl in pos;
               let hperm := fresh in
               assert (hperm:Permutation C (pre++pos)) by auto;
               rewrite hperm;
               clear parts; subst pre; subst pos; clear hperm
  end.

Lemma context_app_comm : forall A B C, A++B ⊢ C -> B++A ⊢ C.
Proof. intros.
assert (hperm:Permutation (A++B) (B++A)) by apply Permutation_app_comm.
rewrite <- hperm. assumption.
Qed.

(** Tactic for permuting a context. If the goal is [Context ⊢
   Conclusion], then [permute_context Context'] will attempt to
   replace [Context] with [Context'] in the goal. *)
Ltac permute_context Desired :=
  match goal with
  |- ?C ⊢ _ => let H := fresh in
               assert (H:Permutation C Desired) by permut;
               rewrite H; clear H
  end.

End Context.


(**
This file is part of the Elfic library

Copyright (C) Boldo, Clément, Leclerc

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

From Coq Require Import
    ssreflect
    ssrsearch
    Utf8

    Reals
    RIneq
    Qreals
    Lra
.

From Coquelicot Require Import
    Hierarchy
    Rbar
    Lub
.

Require Import
    countable_sets
    hierarchy_notations
    Rbar_compl
.

Section open_subspaces.

    Context {S : UniformSpace}.

    (* I est un type d'indexation *)
    Lemma open_union {I : Type} :
        ∀ U : I -> (S -> Prop), (∀ i : I, open (U i))
            -> open (fun x => ∃ i : I, U i x).
    Proof.
        move => U HU x.
        case => i Uix.
        case: (HU i x).
            exact Uix.
        move => ɛ Hɛ.
        exists ɛ => y Bxɛy.
        exists i; apply Hɛ => //.
    Qed.

    Context {A : AbsRing}.
    Context {E : NormedModule A}.
    Open Scope hy_scope.

    Lemma NM_open_ball_norm : forall (a : E) (ɛ : R), 0 < ɛ -> open (ball_norm a ɛ).
    Proof.
        move => a ɛ Hɛ; unfold open => x Hx.
        suff: locally_norm x (ball_norm a ɛ)
            by apply locally_le_locally_norm.
        unfold locally_norm, ball_norm in Hx |- *.
        pose η := ɛ - (norm (minus x a)).
        assert (0 < η); unfold η.
        apply Rgt_lt, (Rgt_minus ɛ (norm (minus x a))) => //.
        pose sigη := mkposreal η H.
        exists sigη => y /= Hη.
        apply Rle_lt_trans with (norm (minus y x) + (norm (minus x a))).
        replace (minus y a) with (minus y x + minus x a)
            by rewrite <-(minus_trans x) => //.
        apply norm_triangle.
        clear sigη; clear H.
        replace ɛ with ((ɛ - ‖ minus x a ‖) + ‖ minus x a ‖) at 1.
        unfold plus => /=.
        apply (Rplus_lt_compat_r (‖ minus x a ‖) (‖ minus y x ‖) (ɛ - (‖ minus x a ‖))).
        unfold η in Hη.
        unfold plus => //.
        setoid_rewrite Rplus_assoc.
        rewrite Rplus_opp_l; apply Rplus_ne.
    Qed.

    Lemma NM_open_neq : ∀ x : E,
        open (fun y => y ≠ x).
    Proof.
        move => x y Neqxy.
        assert (0 < ‖ minus x y ‖) as Hdxy.
            apply norm_gt_0.
            unfold minus.
            move => Abs.
            apply Neqxy.
            apply plus_reg_r with (opp y).
            rewrite plus_opp_r Abs => //.
        suff: (locally_norm y (λ y0 : E, y0 ≠ x)).
            apply locally_le_locally_norm.
        exists (RIneq.mkposreal _ Hdxy) => z /= By.
        move => Abs.
        rewrite Abs in By.
        unfold ball_norm in By.
        apply: Rlt_irrefl.
        exact By.
    Qed.

End open_subspaces.

Section closed_subspaces.

    Context {S : UniformSpace}.

    (* I est un type d'indexation *)
    (* Etonnament, je n'ai pas eu à utiliser de tier exclu ici ! *)
    Lemma closed_inter {I : Type} :
        ∀ F : I -> (S -> Prop), (∀ i : I, closed (F i))
            -> closed (fun x => ∀ i : I, F i x).
    Proof.
        move => F HF.
        move => x NHx i.
        unfold closed in HF.
        pose HFix := HF i x; clearbody HFix.
        apply HFix.
        move => H.
        apply NHx.
        unfold locally.
        unfold locally in H; case: H => ɛ Hɛ.
        exists ɛ => y /Hɛ => Abs.
        move => H'.
        apply Abs => //.
    Qed.

End closed_subspaces.

Section density.

    Context {S : UniformSpace}.

    (* Je définit ici une notion de densité fonctionnel :
    on se donne explicitement une fonction de choix permettant de savoir quel
    est l'élément proche dans la partie dense *)
    Definition fun_dense (P : S -> Prop) (Q : S -> Prop) (f : ∀ x : S, Q x -> posreal -> S) : Prop :=
        (∀ x : S, P x -> Q x) ∧
        (∀ x : S, ∀ π : Q x,
            ∀ ɛ : posreal, ball x ɛ (f x π ɛ) ∧ P (f x π ɛ)).

    Definition dense (P : S -> Prop) (Q : S -> Prop) : Prop :=
        ∃ f, fun_dense P Q f.

    Lemma fun_dense_dense {P Q : S -> Prop} {f : ∀ x : S, Q x -> posreal -> S} :
        fun_dense P Q f -> dense P Q.
    Proof.
        exists f => //.
    Qed.

    Definition fun_separable (u : nat -> S) (P : S -> Prop) (f : ∀ x : S, P x -> posreal -> nat) : Prop :=
        (∀ n : nat, P (u n)) ∧
        (∀ x : S, ∀ π : P x,
            ∀ ɛ : posreal, ball x ɛ (u (f x π ɛ))).

    Definition separable (P : S -> Prop) : Prop :=
        ∃ u : nat -> S, (∀ n : nat, P (u n)) ∧ ∀ x : S, P x ->
            ∀ ɛ : posreal, ∃ n : nat, ball x ɛ (u n).

    Lemma fun_separable_separable {u : nat -> S} {P : S -> Prop} {f : (∀ x : S, P x -> posreal -> nat)} :
        fun_separable u P f -> separable P.
    Proof.
        move => [H1 H2].
        exists u; split => //.
        move => x Px ɛ.
        exists (f x Px ɛ); apply H2.
    Qed.

    Definition seq_separable (u : nat -> S) (P : S -> Prop) : Prop :=
        (∀ n : nat, P (u n)) ∧
        (∀ x : S, P x ->
            ∀ ɛ : posreal, ∃ n : nat, ball x ɛ (u n)).

    Lemma fun_separble_seq_separable {u : nat -> S} {P : S -> Prop} {f} :
        fun_separable u P f -> seq_separable u P.
    Proof.
        move => [H1 H2].
        split => //.
        move => x Px ɛ.
        exists (f x Px ɛ) => //.
    Qed.

End density.

Section denseQR.

    Definition QinR (x : R) :=
        ∃ r : Q, x = Q2R r.

    Definition denseQR_fn : ∀ x : R_UniformSpace, True -> posreal -> R_UniformSpace :=
        fun x _ sigɛ => Q2R
            match sigɛ with mkposreal ɛ _ =>
                let q := up (/ɛ) in
                (Qmake (up (x*IZR q)) (Z.to_pos q))
            end.

    Theorem fun_denseQR : fun_dense QinR (fun _ : R_UniformSpace => True) denseQR_fn.
    Proof.
        split; [easy | unfold denseQR_fn; move => x _ [ɛ Hɛ]; split; swap 1 2].
        unfold QinR; exists ((up (x * IZR (up (/ ɛ))) # Z.to_pos (up (/ ɛ)))) => //.
        unfold ball => /=; unfold AbsRing_ball.
        pose a := x;
        pose b := (x + ɛ)%R;
        assert (ɛ = b - a)%R as Eqɛ.
            unfold a, b;
            unfold Rminus;
            rewrite Rplus_assoc;
            replace (ɛ + - x)%R with (ɛ - x)%R by unfold Rminus => //;
            rewrite Rplus_minus => //.
        fold a.
        pose q := up (/ɛ).
        rewrite Eqɛ in q.
        rewrite Eqɛ; fold q.
        assert (a < b)%R.
            unfold a, b.
            replace x with (x + 0)%R at 1
                by apply Rplus_ne.
            apply Rplus_lt_compat_l => //.
        unfold abs => /=.
        apply Raux.Rabs_lt.
        suff: (a < (Q2R (up (a * IZR q) # Z.to_pos q)) < b).
            case => H1 H2; split.
            rewrite Ropp_minus_distr.
            unfold minus => /=; unfold plus => /=; unfold opp => /=.
            lra.
            unfold minus, plus, opp => /=.
            lra.
        (* maintenant je peut reprendre telle quelle la preuve donnée dans topo_bases_R *)
        assert (0 < b-a)%R as T1.
        rewrite <-Eqɛ => //.
        assert (0 < /(b-a))%R as T2.
        now apply Rinv_0_lt_compat.
        assert (0 < IZR q)%R.
        now apply Rlt_trans with (2:=proj1 (archimed _)).
        unfold Q2R; simpl.
        rewrite Z2Pos.id.
        2: apply lt_IZR; easy.
        split.
        apply Rmult_lt_reg_r with (IZR q); try assumption.
        unfold Rdiv; rewrite Rmult_assoc Rinv_l.
        2: now apply Rgt_not_eq.
        rewrite Rmult_1_r.
        apply archimed.
        apply Rmult_lt_reg_r with (IZR q); try assumption.
        unfold Rdiv; rewrite Rmult_assoc Rinv_l.
        2: now apply Rgt_not_eq.
        rewrite Rmult_1_r.
        apply Rplus_lt_reg_r with (-(a*IZR q))%R.
        apply Rle_lt_trans with (1:=(proj2 (archimed _))).
        apply Rlt_le_trans with (IZR q * (b-a))%R;[idtac|right; ring].
        apply Rmult_lt_reg_r with (/(b-a))%R; try assumption.
        rewrite Rmult_assoc Rinv_r.
        2: now apply Rgt_not_eq.
        rewrite Rmult_1_l Rmult_1_r.
        apply archimed.
    Qed.

    Definition separableR_fn : ∀ x : R_UniformSpace, True -> posreal -> nat :=
        fun x π sigɛ => bij_QN
            match sigɛ with mkposreal ɛ _ =>
                let q := up (/ɛ) in
                (Qmake (up (x*IZR q)) (Z.to_pos q))
            end.

    Theorem fun_separableR : fun_separable (fun n => Q2R (bij_NQ n)) (fun _ => True) separableR_fn.
    Proof.
        split => //.
        unfold separableR_fn => x _ ɛ.
        case: fun_denseQR => [_ H].
        case: (H x I ɛ) => [{}H _].
        unfold denseQR_fn in H.
        rewrite bij_NQN => //.
    Qed.

    Theorem separableR : separable (fun _ : R_UniformSpace => True).
    Proof.
        exact (fun_separable_separable fun_separableR).
    Qed.

    Theorem seq_separableR : seq_separable (fun n => Q2R (bij_NQ n)) (fun _ : R_UniformSpace => True).
    Proof.
        exact (fun_separble_seq_separable fun_separableR).
    Qed.

End denseQR.

Section NM_density.

    Context {A : AbsRing}.
    Context {E : NormedModule A}.

    Definition NM_separable (P : E -> Prop) : Prop :=
        ∃ u : nat -> E, ∀ x : E, P x ->
            ∀ ɛ : posreal, ∃ n : nat, ball_norm x ɛ (u n).

    Lemma separable_NM_separable :
        ∀ P : E -> Prop, separable P -> NM_separable P.
    Proof.
        move => P; unfold separable.
        case => u [Hu1 Hu2].
        exists u => x /Hu2.
        pose Hloc := locally_ball_norm; clearbody Hloc.
        unfold locally_norm, ball_norm in Hloc.
        move => Hux ɛ.
        case: (Hloc A E x ɛ) => ɛ' Hɛ'; clear Hloc.
        case: (Hux ɛ') => k /Hɛ' Hprox.
        exists k => //.
    Qed.

    Definition NM_seq_separable (u : nat -> E) (P : E -> Prop) : Prop :=
        (∀ n : nat, P (u n)) ∧
        (∀ x : E, P x ->
            ∀ ɛ : posreal, ∃ n : nat, ball_norm x ɛ (u n)).

    Lemma seq_separable_NM_seq_separable {u : nat -> E} {P : E -> Prop} :
        seq_separable u P -> NM_seq_separable u P.
    Proof.
        unfold separable.
        case => [Hu1 Hu2].
        split => //.
        move => x /Hu2.
        pose Hloc := locally_ball_norm; clearbody Hloc.
        unfold locally_norm, ball_norm in Hloc.
        move => Hux ɛ.
        case: (Hloc A E x ɛ) => ɛ' Hɛ'; clear Hloc.
        case: (Hux ɛ') => k /Hɛ' Hprox.
        exists k => //.
    Qed.

    Definition dist (x : E) (P : E -> Prop) :=
        (Glb_Rbar (fun d : R => ∃ y : E, P y ∧ ‖ minus x y ‖ = d)).

    Definition NM_seq_separable_weak (u : nat -> E) (P : E -> Prop) : Prop :=
        (∀ x : E, P x ->
            ∀ ɛ : posreal, ∃ n : nat, ball_norm x ɛ (u n)).

    Lemma NM_seq_separable_seq_separable_weak {u : nat -> E} {P : E -> Prop} :
        NM_seq_separable u P -> NM_seq_separable_weak u P.
    Proof.
        move => [_ H2] //.
    Qed.

    Lemma NM_seq_separable_weak_le {u : nat -> E} {P : E -> Prop} :
        ∀ Q : E -> Prop,
            (∀ x : E, Q x -> P x) ->
            NM_seq_separable_weak u P ->
            NM_seq_separable_weak u Q.
    Proof.
        move => Q LeQP H x /LeQP/H//.
    Qed.

End NM_density.

Section NM_seq_separable_subspace.

    (*
    A montrer : une partie d'un NM separable l'est encore :

    Tout sous-espace d'un espace pseudométrisable séparable est encore séparable, preuve directe :
    Soit (X, d) un espace pseudométrique séparable, et soit A un sous-espace de X. On va construire une suite dense dans A.
    Choisissons (xn)n∈ℕ* une suite dense dans X. Pour tout entier n > 0, fixons un point an de A vérifiant d(xn, an) < d(xn, A) + 1/n.
    Soit a un point de A et soit ε > 0. Par densité de (xn)n∈ℕ*, il existe un entier n > 3/ε tel que d(a, xn) < ε/3.
    On a alors (par construction de la suite (an)) d(xn, an) < ε/3 + 1/n < 2ε/3 donc (par inégalité triangulaire) d(a, an)< ε.
    La suite (an) est donc bien dense dans A.
    *)

End NM_seq_separable_subspace.

Lemma NM_separableR : NM_separable (fun _ : R_NormedModule => True).
Proof.
    apply separable_NM_separable.
    apply separableR.
Qed.

Lemma NM_seq_separableR : NM_seq_separable (fun n => Q2R (bij_NQ n)) (fun _ : R_NormedModule => True).
Proof.
    apply seq_separable_NM_seq_separable.
    apply seq_separableR.
Qed.

Lemma NM_seq_separable_weakR : NM_seq_separable_weak (fun n => Q2R (bij_NQ n)) (fun _ : R_NormedModule => True).
Proof.
    apply NM_seq_separable_seq_separable_weak.
    apply NM_seq_separableR.
Qed.


Require Import Metalib.Metatheory.
Require Import LibTactics.
Require Export syntax_ott.
Require Import rules_inf.
Require Import Lia.

(* R: proper types *)
Inductive R : typ -> Prop :=
| R_int : R t_int
| R_top : R t_top
| R_ordFun : forall A B, ord B -> R A -> R B -> R (t_arrow A B)
| R_ordRcd : forall l A, ord A -> R A -> R (t_rcd l A)
| R_spl : forall B C A, spl A B C -> R B -> R C -> R A.

#[local]
Hint Constructors R : core.

Lemma rfun : forall B, R B -> forall A, R A -> R (t_arrow A B).
Proof.
  intros B RB.
  induction RB; intros; eauto.
Qed.

Lemma rrcd : forall A, R A-> forall l, R (t_rcd l A).
Proof.
  intros A RA.
  induction RA; intros; eauto.
Qed.

Lemma types_are_proper : forall A, R A.
Proof.
  introv. induction* A.
  - apply~ rfun.
  - apply~ rrcd.
Qed.

Ltac proper_ind A := assert (r: R A) by apply (types_are_proper A); inductions r.

(* split *)
Lemma split_ord_false : forall T T1 T2,
    spl T T1 T2 -> ord T -> False.
Proof.
  introv s o. gen T1 T2.
  induction o; intros; inverts* s.
Qed.

#[export]
Hint Resolve split_ord_false : falseHd.

Ltac solve_false := try intro; try solve [false; eauto with falseHd].

Lemma ord_or_split: forall A,
    ord A \/ exists B C, spl A B C.
Proof.
  intros A. induction* A.
  lets* [?|(?&?&?)]: IHA2.
  -
    destruct~ IHA as [?|(?&?&?)].
    right*.
Qed.
(*
Ltac destructT A := lets [?|(?&?&?)]: (ord_or_split A).
*)

Lemma split_unique : forall T A1 A2 B1 B2,
    spl T A1 B1 -> spl T A2 B2 -> A1 = A2 /\ B1 = B2.
Proof.
  introv s1 s2. gen A2 B2.
  induction s1; intros;
    inverts* s2;
    forwards* (eq1&eq2): IHs1; split; congruence.
Qed.

Ltac split_unify :=
  repeat match goal with
  | [ H1: spl ?A _ _ , H2: spl ?A _ _ |- _ ] =>
           (progress forwards (?&?): split_unique H1 H2;
            subst; clear H2)
  | [ H: spl (t_and _ _) _ _ |- _ ] => inverts H
  | [ H: spl (t_arrow _ _) _ _ |- _ ] => inverts H
  | [ H: spl (t_rcd _ _) _ _ |- _ ] => inverts H
         end;
  auto.

(* topLike *)
Lemma topLike_arrow_inv : forall A B,
    topLike (t_arrow A B) -> topLike B.
Proof.
  introv H. inverts~ H.
Qed.

Lemma topLike_and_l_inv : forall A B,
    topLike (t_and A B) -> topLike A.
Proof.
  introv H. inverts~ H.
Qed.

Lemma topLike_and_r_inv : forall A B,
    topLike (t_and A B) -> topLike B.
Proof.
  introv H. inverts~ H.
Qed.

#[export]
Hint Immediate topLike_arrow_inv topLike_and_l_inv topLike_and_r_inv: core.

Lemma topLike_spl_combine: forall A B C,
    spl C A B -> topLike A -> topLike B -> topLike C.
Proof.
  introv s tl1 tl2. induction* s.
  inverts tl1. inverts tl2. auto.
Qed.

Lemma topLike_split_l_inv: forall A B C,
    topLike C -> spl C A B -> topLike A.
Proof.
  introv tl s. induction* s.
  inverts* tl.
Qed.

Lemma topLike_split_r_inv: forall A B C,
    topLike C -> spl C A B -> topLike B.
Proof.
  introv tl s. induction* s.
  inverts* tl.
Qed.

#[export]
Hint Immediate topLike_spl_combine topLike_split_l_inv topLike_split_r_inv : core.

(* topLike specification eqv *)
Lemma topLike_super_top: forall A,
    topLike A <-> algo_sub t_top A.
Proof with eauto.
  split; intros H.
  - proper_ind A...
  - inductions H... iauto.
Qed.

Lemma toplike_sub : forall A B,
    topLike A -> algo_sub A B -> topLike B.
Proof.
  introv TL S.
  induction S; inverts* TL;
    applys* topLike_spl_combine.
Qed.

#[export]
 Hint Resolve <- topLike_super_top : core.

#[export]
Hint Immediate topLike_super_top  toplike_sub : core.

(* subtyping *)
(* generalize S_top *)
Lemma toplike_super_any : forall A B,
    topLike A -> algo_sub B A.
Proof.
  introv TL.
  proper_ind A; auto.
  applys~ S_and H.
  - applys* IHr1.
  - applys* IHr2.
Qed.

(* generalize S_andl *)
Lemma sub_l_andl : forall A B C, algo_sub A C -> algo_sub (t_and A B) C.
Proof.
  introv s. induction* s.
Qed.

(* generalize S_andr *)
Lemma sub_l_andr : forall A B C, algo_sub B C -> algo_sub (t_and A B) C.
Proof.
  introv s. induction* s.
Qed.

(* generalize S_arr *)
Lemma sub_fun : forall A B C D,
    algo_sub B D -> algo_sub C A -> algo_sub (t_arrow A B) (t_arrow C D).
Proof.
  introv s. induction* s.
Qed.

(* generalize S_rcd *)
Lemma sub_rcd : forall A B l,
    algo_sub A B -> algo_sub (t_rcd l A) (t_rcd l B).
Proof.
  introv H.
  induction* H.
Qed.

#[export]
Hint Immediate toplike_super_any : core.
#[export]
Hint Resolve sub_l_andl sub_l_andr sub_fun sub_rcd: core.

(* modular subtyping <=> algorithmic subtyping *)
Theorem modular_sub_eqv: forall A B,
    msub A B <-> algo_sub A B.
Proof.
  split; introv H;
  induction* H.
Qed.

(* algorithmic subtyping relexivity *)
Lemma sub_reflexivity : forall A, algo_sub A A.
Proof.
  introv. induction* A.
Qed.

#[export]
Hint Resolve sub_reflexivity : core.

(* around split and subtyping *)
Lemma spl_sub_l : forall A B C,
    spl A B C -> algo_sub A B.
Proof.
  introv H. induction* H.
Qed.

Lemma spl_sub_r : forall A B C,
    spl A B C -> algo_sub A C.
Proof.
  introv H. induction* H.
Qed.

#[export]
Hint Immediate spl_sub_l spl_sub_r : core.

(* splitting does not lose or add information to a type *)
Lemma split_sub: forall A B C,
    spl A B C -> algo_sub A (t_and B C) /\ algo_sub (t_and B C) A.
Proof with eauto.
  intros A B C H.
  split.
  - lets~: spl_sub_l H. lets~: spl_sub_r H.
    apply~ S_and...
  - induction H...
Qed.

(* some subtyping inversion lemmas *)
(* inversion on left split *)
Lemma sub_inversion_split_l : forall A B A1 A2,
    algo_sub A B -> spl A A1 A2 -> ord B -> algo_sub A1 B \/ algo_sub A2 B.
Proof.
  intros. gen A1 A2.
  induction H; intros; try solve_false; split_unify; eauto.
  - (* arrow *)
    forwards* [?|?]: IHalgo_sub2.
  - (* rec *)
    forwards* [?|?]: IHalgo_sub.
Qed.

(* inversion on right split *)
Lemma sub_r_spl_l : forall A B B1 B2,
    algo_sub A B -> spl B B1 B2 -> algo_sub A B1.
Proof.
  introv Hsub Hspl.
  inverts Hsub; solve_false.
  split_unify.
Qed.

Lemma sub_r_spl_r : forall A B B1 B2,
    algo_sub A B -> spl B B1 B2 -> algo_sub A B2.
Proof.
  introv Hsub Hspl.
  inverts Hsub; solve_false.
  split_unify.
Qed.

Lemma sub_inversion_split_r : forall A B B1 B2,
    algo_sub A B -> spl B B1 B2 -> algo_sub A B1 /\ algo_sub A B2.
Proof with (try solve_false; split_unify).
  introv Hsub Hspl. gen B1 B2.
  inductions Hsub; intros; eauto...
Qed.

#[export]
Hint Immediate sub_r_spl_l sub_r_spl_r : core.

(* to prove inversion lemma for arrow types *)
(* which is not necessary for later proof *)
Lemma sub_trans_spl_l : forall A A1 A2 B,
    spl A A1 A2 -> ord B -> algo_sub A1 B -> algo_sub A B.
Proof with (solve_false).
  introv Hspl Hord Hs. gen B.
  induction* Hspl; intros.
  - inverts* Hs...
  - inverts* Hs...
Qed.

Lemma sub_trans_spl_r : forall A A1 A2 B,
    spl A A1 A2 -> ord B -> algo_sub A2 B -> algo_sub A B.
Proof with (solve_false).
  introv Hspl Hord Hs. gen B.
  induction* Hspl; intros.
  - inverts* Hs...
  - inverts* Hs...
Qed.

Lemma sub_inversion_arrow : forall A B C D,
    algo_sub (t_arrow A B) (t_arrow C D) -> (algo_sub C A /\ algo_sub B D) \/ topLike D.
Proof with (simpl in *; solve_false; split_unify; try eassumption; eauto 3).
  introv s.
  proper_ind (t_arrow C D).
  - clear IHr1 IHr2 r1 r2. gen C D.
    proper_ind (t_arrow A B); intros.
    + inverts s...
    + inverts keep H;
      forwards~ [?|?]: sub_inversion_split_l s H.
      * forwards~ [(?&?)|?]: IHr1 H0 H1.
        left. split*. applys~ sub_trans_spl_l H5.
      * forwards~ [(?&?)|?]: IHr2 H0 H1.
        left. split*. applys~ sub_trans_spl_r H5.
  - inverts keep H.
    forwards~ (?&?): sub_inversion_split_r s H.
    forwards~ [(?&?)|?]: IHr1 H0;
      forwards~ [(?&?)|?]: IHr2 H1; eauto.
Qed.

(* prove trans via proper type *)
Lemma sub_transtivity : forall A B C,
    algo_sub A B -> algo_sub B C -> algo_sub A C.
Proof with (try solve_false; split_unify; eauto).
  introv S1 S2. gen A C.
  proper_ind B; intros;
    try solve [inductions S2; eauto].
  - (* arrow *)
    inductions S2... clear IHS2_1 IHS2_2.
    (* S_arr *)
    inductions S1...
    + applys* S_top.
  - (* rcd *)
    inductions S2... clear IHS2.
    (* S_rcd *)
    inductions S1...
    + applys* S_top.
      applys* toplike_sub H1.
  - (* split A B C *)
    gen A B.
    proper_ind C0; (* the type at the end *)
      introv S1 S2 Hspl HRb IH;
      try solve [ (* if C0 is an ordinary type *)
            forwards~ (?&?): sub_inversion_split_r S1 Hspl;
            forwards~ [?|?]: sub_inversion_split_l S2; eauto ].
    (* splittable type *)
    forwards* (?&?): sub_inversion_split_r S2 H.
Qed.

#[export]
Hint Immediate sub_transtivity : core.

(* any part of a toplike type is a toplike type *)
Example sub_spl_demo : forall A B C,
    algo_sub t_top A -> spl A B C -> algo_sub A B /\ algo_sub A C /\ algo_sub t_top B /\ algo_sub t_top C.
Proof.
  jauto.
Qed.

(******************************************************************************)
(* an alternative proof method *)
(* prove transtivity via typ_size *)

Lemma split_decrease_size: forall A B C,
    spl A B C -> size_typ B < size_typ A /\ size_typ C < size_typ A.
Proof.
  introv H. pose proof (size_typ_min).
  induction H;
    simpl in *; simpl; intuition eauto; lia.
Qed.

Ltac spl_size :=
  try repeat match goal with
         | [ H: spl _ _ _ |- _ ] =>
           ( lets (?&?): split_decrease_size H; clear H)
             end.

Ltac elia :=
  try solve [pose proof (size_typ_min); pose proof (size_exp_min);
             spl_size; simpl in *; simpl;
             try lia].

#[export]
Hint Extern 0 => match goal with
                 | [ H1: topLike (t_arrow _ ?D), H2: ~topLike ?D |- False ] => (
                     inverts H1;
                       contradiction)
                 | [ H: topLike t_int |- False ] => (
                     inverts H )
                 | [ H1: ord ?A, H2: spl (t_arrow _ ?A) _ _ |- False ] => (
                     inverts H2;
                       auto with falseHd)
                 end : falseHd.

Ltac indTypSize s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with | [ h : typ |- _ ] => (gen h) end;
  induction i as [|i IH]; [
      intros; match goal with | [ H : _ < 0 |- _ ] => inverts H end
    | intros ].

#[local]
Hint Extern 0 =>
  match goal with
  | [ IH: forall _ , _ , H1: algo_sub  ?A ?B , H2: algo_sub ?B ?C |- algo_sub ?A ?C ] =>
    (forwards: IH H1 H2; elia)
  end : core.

Section sub_trans.
Lemma trans : forall A B C, algo_sub A B -> algo_sub B C -> algo_sub A C.
Proof.
  introv s1 s2.
  indTypSize (size_typ A + size_typ B + size_typ C).
  lets [?|(?&?&?)]: ord_or_split C.
  - (* ord C *)
    lets [?|(?&?&?)]: ord_or_split B.
    + (* ord B *)
      inverts keep s2 as s2_1 s2_2 s2_3;
        inverts s1 as s1_1 s1_2 s1_3; solve_false; auto.
      * (* topLike arr *)
        applys* S_top.
      * (* topLike rcd *)
        applys* S_top.
    + (* spl B x x0 *)
      (* splitl_inv turns B into x or x0 *)
      lets (?&?): split_decrease_size B. eauto.
      forwards~ [s2' |s2']: sub_inversion_split_l s2 H0.
      applys* IH s2'. elia.
      applys* IH s2'. elia.
  - (* spl C x x0 *)
    (* inversion turns C into x and x0 *)
    lets (?&?): split_decrease_size C. eauto.
    forwards~ g1: IH s1 x. eauto. elia.
    forwards~ g2: IH s1 x0. eauto. elia.
    applys~ S_and H.
Qed.

End sub_trans.
(******************************************************************************)

Ltac auto_sub :=
  repeat (auto ;
          match goal with
          | [ |- algo_sub (t_and ?C ?D) (t_and ?A ?B) ] => (eapply S_and; try apply Sp_and)
          | [ |- algo_sub (t_and (t_arrow ?A ?B) (t_arrow ?A ?C)) (t_arrow ?A (t_and ?B ?C)) ] => (eapply S_and)
          | [ H1: algo_sub ?A ?B, H2: algo_sub ?B ?C |- algo_sub ?A ?C ] =>
            (forwards: trans H1 H2; auto)
          | [ H: algo_sub t_top ?A |- algo_sub _ ?A ] =>
            (apply topLike_super_top in H; apply S_top; auto)
          | [ H: topLike ?A |- algo_sub _ (t_arrow _ ?A) ] =>
            (apply TL_arr in H; apply S_top; auto)

          | [ H1: spl ?A ?B ?C, H2: ord ?D, H3: algo_sub ?A ?D |- _ ] => (
              forwards [?|?]: sub_inversion_split_l H1 H2 H3;
              clear H3)
          | [ H1: spl ?A ?B ?C |- _ ] => (
              forwards : split_sub H1;
              forwards : spl_sub_l H1;
              forwards : spl_sub_r H1;
              clear H1)
          | [ |- algo_sub (t_arrow ?A ?B) (t_arrow ?C ?D) ] => apply sub_fun
          | [ H1: algo_sub ?A ?B |- algo_sub ?A ?C ] =>
            assert ( algo_sub B C ) by auto
          end).

(* original declarative bcd subtyping <=> algorithmic subtyping *)

Lemma declarative_sub_tl : forall A B, topLike B -> original_bcd_sub A B.
Proof.
  introv Htl. gen A.
  induction Htl; eauto.
Qed.

Lemma declarative_sub_split : forall A B B1 B2,
    spl B B1 B2 -> original_bcd_sub A B1 -> original_bcd_sub A B2 ->
    original_bcd_sub A B.
Proof with (try solve_false; split_unify).
  introv Hspl Hsub1 Hsub2. gen A.
  induction* Hspl.
  - assert (original_bcd_sub (t_and (t_arrow A C) (t_arrow A D)) (t_arrow A B)) by eauto.
    eauto.
  - assert (original_bcd_sub (t_and (t_rcd l C) (t_rcd l D)) (t_rcd l B)) by eauto.
    eauto.
Qed.

Theorem declarative_sub_eqv: forall A B,
    original_bcd_sub A B <-> algo_sub A B.
Proof.
  split; introv H;
    induction* H.
  - applys~ declarative_sub_tl.
  - applys~ declarative_sub_split H.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************)
(*             Intensional Lambda Calculus                            *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                   Lambda_tactics.v                                 *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import Lambda.Terms.
Require Import Lambda.Test.
Require Import Lambda.General.
Require Import Omega.

Definition termred := lambda -> lambda -> Prop.

Definition preserve (R : termred) (P : lambda -> Prop) :=
  forall x : lambda, P x -> forall y : lambda, R x y -> P y.

Inductive multi_step : termred -> termred :=
  | zero_red : forall red M, multi_step red M M
  | succ_red : forall (red: lambda-> lambda -> Prop) M N P,
                   red M N -> multi_step red N P -> multi_step red M P
.

Inductive sequential : termred -> termred -> termred :=
  | seq_red : forall (red1 red2 : termred) M N P,
                red1 M N -> red2 N P -> sequential red1 red2 M P.

Hint Resolve zero_red succ_red seq_red
.

Definition reflective red := forall (M: lambda), red M M.

Lemma refl_multi_step : forall (red: termred), reflective (multi_step red).
Proof. red; split_all. Qed.

Lemma refl_seq : forall (red1 red2: termred),
                   reflective red1 -> reflective red2 -> reflective(sequential red1 red2).
Proof. red; split_all; eapply2 seq_red. Qed.

Ltac reflect := match goal with
| |- reflective (multi_step _) => eapply2 refl_multi_step
| |- multi_step _ _ _ => try (eapply2 refl_multi_step)
| |- reflective (sequential _) => eapply2 refl_seq; reflect
| |- sequential _ _ _ _ => try (eapply2 refl_seq)
| _ => split_all
end.

Ltac one_step :=
match goal with
| |- multi_step _ _ ?N => apply succ_red with N; auto; try red; try reflect
end.

Ltac seq_l :=
match goal with
| |- sequential _ _ ?M ?N => apply seq_red with N; auto; red; reflect
end.

Ltac seq_r :=
match goal with
| |- sequential _ _ ?M ?N => apply seq_red with M; auto; red; reflect
end.

Definition transitive red := forall (M N P: lambda), red M N -> red N P -> red M P.

Lemma transitive_red : forall red, transitive (multi_step red).
Proof. red; induction 1; split_all.
apply succ_red with N; auto.
Qed.

Definition preserves_abs (red : termred) :=
forall M N, red M N -> red (Abs M) (Abs N).

Definition preserves_app (red : termred) :=
forall M M' N N', red M M' -> red N N' -> red (App M N) (App M' N').

Lemma preserves_abs_multi_step : forall red, preserves_abs red -> preserves_abs (multi_step red).
Proof.
red; induction 2; split_all.
apply succ_red with (Abs N); auto.
Qed.

Lemma preserves_app_multi_step : forall (red: termred), reflective red -> preserves_app red -> preserves_app (multi_step red).
Proof.
red. induction 3; split_all. generalize H0; induction 1.
reflect.
apply succ_red with (App M N); auto.
assert( transitive (multi_step red)) by eapply2 transitive_red.
apply X0 with (App N0 N); auto.
one_step.
Qed.

Lemma preserves_abs_seq : forall (red1 red2: termred), preserves_abs red1 -> preserves_abs red2 -> preserves_abs (sequential red1 red2).
Proof.
red; split_all.
inversion H1.
apply seq_red with (Abs N0); auto.
Qed.

Lemma preserves_app_seq : forall (red1 red2: termred), preserves_app red1 -> preserves_app red2 -> preserves_app (sequential red1 red2).
Proof.
red; split_all.
inversion H1; inversion H2.
apply seq_red with (App N0 N1); auto.
Qed.

Hint Resolve preserves_abs_multi_step  preserves_app_multi_step preserves_abs_seq preserves_app_seq .

Definition preserves_abs1 (red: termred) := forall M N, red M N -> forall M0, M = Abs M0 ->
  exists N0, red M0 N0 /\ Abs N0 = N.

Lemma preserves_abs1_multi_step : forall red, preserves_abs1 red -> preserves_abs1 (multi_step red).
Proof.
unfold preserves_abs1.  induction 2; split_all.
exist M0.
assert(exists N0 : lambda, red M0 N0 /\ Abs N0 = N) by eapply2 H; split_all.
assert(exists N0 : lambda, multi_step red x N0 /\ Abs N0 = P) by eapply2 IHmulti_step; split_all.
exist x0.
apply succ_red with x; auto.
Qed.

Lemma preserves_abs1_seq : forall red1, preserves_abs1 red1 -> forall red2, preserves_abs1 red2 -> preserves_abs1 (sequential red1 red2).
Proof.
unfold preserves_abs1; split_all.
inversion H1.
elim(H M N0 H3 M0); split_all.
elim(H0 N0 N H4 x); split_all.
exist x0.
apply seq_red with x; auto.
Qed.

Hint Resolve preserves_abs1_multi_step preserves_abs1_seq.

Definition lift_rec_preserves (red: termred) :=
forall (M N : lambda), red M N -> forall (n k : nat), red  (lift_rec M n k) (lift_rec N n k).

Lemma lift_rec_preserves_multi_step :
forall red, lift_rec_preserves red -> lift_rec_preserves (multi_step red).
Proof. unfold lift_rec_preserves; induction 2; split_all.
apply succ_red with (lift_rec N n k); auto.
Qed.

Lemma lift_rec_preserves_seq :
forall red1 red2, lift_rec_preserves red1 -> lift_rec_preserves red2 ->
                  lift_rec_preserves (sequential red1 red2).
Proof. red; unfold lift_rec_preserves; split_all.
inversion H1. apply seq_red with (lift_rec N0 n k); auto.
Qed.

Hint Resolve  lift_rec_preserves_multi_step lift_rec_preserves_seq.

Definition preserves_lift_rec (red: lambda ->  lambda -> Prop) :=
forall M N, red M N -> forall M0 n k, lift_rec M0 n k = M -> exists N0, red M0 N0 /\ lift_rec N0 n k = N.

Lemma preserves_lift_rec_multi_step :
forall red, preserves_lift_rec red -> preserves_lift_rec (multi_step red).
Proof. unfold preserves_lift_rec. induction 2; split_all.
exist M0.
elim(H M N H0 M0 n k); split_all.
elim(IHmulti_step H x n k); split_all.
exist x0.
apply succ_red with x; auto.
Qed.

Lemma preserves_lift_rec_seq :
forall red1, preserves_lift_rec red1 -> forall red2, preserves_lift_rec red2 ->
                                                     preserves_lift_rec (sequential red1 red2).
Proof. unfold preserves_lift_rec. induction 3; split_all.
elim(H M N H1 M0 n k); split_all.
elim(H0 N P H2 x n k); split_all.
exist x0.
apply seq_red with x; auto.
Qed.

Ltac eelim_for_equal :=
match goal with
| H: forall _, _ = _ -> _  |- _ => eelim H; clear H; subst; eelim_for_equal
| _ => split_all
end.

Ltac inv_lift_rec :=
match goal with
| H: Ref _ = lift_rec ?l _ _  |- _ => gen_case_inv H l; inv_lift_rec
| H: App _ _ = lift_rec ?l _ _ |- _ => gen_case_inv H l; inv_lift_rec
| H: Abs _ = lift_rec ?l _ _ |- _ => gen_case_inv H l; inv_lift_rec
| H: lift_rec ?l _ _ = Ref _ |- _ => gen_case_inv H l; inv_lift_rec
| H: lift_rec ?l _ _ = App _ _ |- _ => gen_case_inv H l; inv_lift_rec
| H: lift_rec ?l _ _ = Abs _ |- _ => gen_case_inv H l; inv_lift_rec
| _ => subst; eelim_for_equal
 end.

Ltac inv1 prop :=
match goal with
| H: prop (Ref _) |- _ => inversion H; clear H; inv1 prop
| H: prop (App  _ _) |- _ => inversion H; clear H; inv1 prop
| H: prop (Abs _) |- _ => inversion H; clear H; inv1 prop
| _ => split_all
 end.

Definition implies_red (red1 red2: termred) := forall M N, red1 M N -> red2 M N.

Lemma implies_red_multi_step: forall red1 red2, implies_red red1  (multi_step red2) ->
                                                implies_red (multi_step red1) (multi_step red2).
Proof. red.
intros red1 red2 IR M N R; induction R; split_all.
apply transitive_red with N; auto.
Qed.
Lemma implies_red_seq:
 forall red1 red2 red3,
  implies_red red1  (multi_step red3)  ->
  implies_red red2 (multi_step red3) ->
  implies_red (sequential red1 red2) (multi_step red3) .
Proof.
red; split_all. inversion H1. apply transitive_red with N0; auto.
Qed.

Definition subst_rec_preserves_l (red: termred) :=
forall (M M' N : lambda), red M M' -> forall ( k : nat), red  (subst_rec M N k) (subst_rec M' N k).

Definition subst_rec_preserves_r (red: termred) :=
forall (M N N' : lambda), red N N' -> forall ( k : nat), red  (subst_rec M N k) (subst_rec M N' k).

Definition subst_rec_preserves (red: termred) :=
forall (M M' : lambda), red M M' -> forall N N', red N N' -> forall ( k : nat), red  (subst_rec M N k) (subst_rec M' N' k).

Lemma subst_rec_preserves_l_multi_step :
forall (red: termred), subst_rec_preserves_l red -> subst_rec_preserves_l (multi_step red).
Proof. unfold subst_rec_preserves_l.
 induction 2; split_all.
apply succ_red with (subst_rec N0 N k); auto.
Qed.

Lemma subst_rec_preserves_r_multi_step :
forall (red: termred), subst_rec_preserves_r red -> subst_rec_preserves_r (multi_step red).
Proof. unfold subst_rec_preserves_r.
 induction 2; split_all.
apply succ_red with (subst_rec M N k); auto.
Qed.

Lemma subst_rec_preserves_multi_step :
forall (red: termred), subst_rec_preserves_l red -> subst_rec_preserves_r red -> subst_rec_preserves (multi_step red).
Proof.
unfold subst_rec_preserves. split_all.
assert(transitive (multi_step red)) by eapply2 transitive_red.
unfold transitive in *.
apply X with  (subst_rec M' N k); auto.
eapply2 subst_rec_preserves_l_multi_step.
eapply2 subst_rec_preserves_r_multi_step.
Qed.

Lemma subst_rec_preserves_l_seq :
forall red1 , subst_rec_preserves_l red1  -> forall red2 , subst_rec_preserves_l red2  ->
                                                subst_rec_preserves_l (sequential red1 red2).
Proof. unfold subst_rec_preserves_l; split_all.
inversion H1.
apply seq_red with (subst_rec N0 N k); auto.
Qed.

Lemma subst_rec_preserves_r_seq :
forall red1 , subst_rec_preserves_r red1  -> forall red2 , subst_rec_preserves_r red2  ->
                                                         subst_rec_preserves_r (sequential red1 red2).
Proof. unfold subst_rec_preserves_r; split_all.
inversion H1.
apply seq_red with (subst_rec M N0 k); auto.
Qed.

Lemma subst_rec_preserves_seq :
forall red1 , subst_rec_preserves red1  -> forall red2 , subst_rec_preserves red2  ->
                                                         subst_rec_preserves (sequential red1 red2).
Proof. unfold subst_rec_preserves; split_all.
inversion H1.
inversion H2.
apply seq_red with (subst_rec N0 N1 k); auto.
Qed.

Hint Resolve  subst_rec_preserves_multi_step subst_rec_preserves_seq.

Hint Resolve  subst_rec_preserves_multi_step subst_rec_preserves_seq.

Ltac inv red :=
match goal with
| H: multi_step red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red (Ref _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red (Abs _) _ |- _ => inversion H; clear H; inv red
| H: red (Ref _) _ |- _ => inversion H; clear H; inv red
| H: red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: red (Abs _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red _ (Ref _) |- _ => inversion H; clear H; inv red
| H: multi_step red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: multi_step red _ (Abs _) |- _ => inversion H; clear H; inv red
| H: red _ (Ref _) |- _ => inversion H; clear H; inv red
| H: red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: red _ (Abs _) |- _ => inversion H; clear H; inv red
| |- red (lift _ _) (lift _ _) => unfold lift; eapply2 (lift_rec_preserves red); inv red
| _ => subst; split_all
 end.

Definition diamond (red1 red2 : termred) :=
forall M N, red1 M N -> forall P, red2 M P -> exists Q, red2 N Q /\ red1 P Q.

Lemma diamond_flip: forall red1 red2, diamond red1 red2 -> diamond red2 red1.
Proof. unfold diamond; split_all. elim (H M P H1 N H0); split_all. exist x. Qed.

Lemma diamond_strip :
forall red1 red2, diamond red1 red2 -> diamond red1 (multi_step red2).
Proof. intros.
eapply2 diamond_flip.
red; induction 1; split_all.
exist P.
elim (H M P0 H2 N); split_all.
elim(IHmulti_step H x); split_all.
exist x0.
apply succ_red with x; auto.
Qed.

Definition diamond_star (red1 red2: termred) := forall  M N, red1 M N -> forall P, red2 M P ->
  exists Q, red1 P Q /\ multi_step red2 N Q.

Lemma diamond_star_strip: forall red1 red2, diamond_star red1 red2 -> diamond (multi_step red2) red1 .
Proof.
red. induction 2; split_all.
exist P.
elim(H M P0 H2 N H0); split_all.
elim(IHmulti_step H x); split_all.
exist x0.
apply transitive_red with x; auto.
Qed.

Lemma diamond_tiling :
forall red1 red2, diamond red1 red2 -> diamond (multi_step red1) (multi_step red2).
Proof.
red.  induction 2; split_all.
exist P.
elim(diamond_strip red red2 H M N H0 P0); split_all.
elim(IHmulti_step H x H4); split_all.
exist x0.
apply succ_red with x; auto.
Qed.

Hint Resolve diamond_tiling.

Lemma diamond_seq: forall red red1 red2, diamond red red1 -> diamond red red2 -> diamond red (sequential red1 red2).
Proof. unfold diamond; split_all.
inversion H2.
elim(H M N H1 N0); split_all.
elim(H0 N0 x H11 P); split_all.
exist x0.
apply seq_red with x; auto.
Qed.

Lemma relocate_null :
forall (n n0 : nat), relocate n n0 0 = n.
Proof. split_all. unfold relocate. case (test n0 n); intro; auto with arith. Qed.

Lemma relocate_lessthan : forall m n k, m<=k -> relocate k m n = (n+k).
Proof. split_all. unfold relocate. elim(test m k); split_all; try noway. Qed.
Lemma relocate_greaterthan : forall m n k, m>k -> relocate k m n = k.
Proof. split_all. unfold relocate. elim(test m k); split_all; try noway. Qed.

Ltac relocate_lt :=
try (rewrite relocate_lessthan; [| omega]; relocate_lt);
try (rewrite relocate_greaterthan; [| omega]; relocate_lt);
try(rewrite relocate_null).

Lemma relocate_zero_succ :
forall n k, relocate 0 (S n) k = 0.
Proof.  split_all. Qed.

Lemma relocate_succ :
forall n n0 k, relocate (S n) (S n0) k = S(relocate n n0 k).
Proof.
intros; unfold relocate. elim(test(S n0) (S n)); elim(test n0 n); split_all.
noway.
noway.
Qed.

Lemma relocate_mono : forall M N n k, relocate M n k = relocate N n k -> M=N.
Proof.
intros M N n k.
unfold relocate.
elim(test n M); elim(test n N); split_all; omega.
Qed.

Lemma lift_rec_mono : forall M N n k, lift_rec M n k = lift_rec N n k -> M=N.
Proof.
induction M; split_all.
gen_case_inv H N.
assert(n=n1) by eapply2 relocate_mono.
subst; auto.
gen_case_inv H N.
assert(M = l) by eapply2 IHM.
congruence.
gen_case_inv H N.
assert(M1 = l) by eapply2 IHM1.
assert(M2 = l0) by eapply2 IHM2. congruence.
Qed.

Lemma insert_Ref_lt : forall M n k, n< k -> insert_Ref M n k = Ref n.
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
Qed.

Lemma insert_Ref_eq : forall M n k, n= k -> insert_Ref M n k = lift k M.
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
unfold lift; unfold lift_rec. unfold relocate. elim(test 0 n); split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
unfold lift; unfold lift_rec. unfold relocate. elim(test 0 n); split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
Qed.

Lemma insert_Ref_gt : forall M n k, n> k -> insert_Ref M n k = Ref (pred n).
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
Qed.

Ltac insert_Ref_out :=
try (rewrite insert_Ref_lt; [|unfold relocate; split_all; omega]; insert_Ref_out);
try (rewrite insert_Ref_eq; [|unfold relocate; split_all; omega]; insert_Ref_out);
try (rewrite insert_Ref_gt; [|unfold relocate; split_all; omega]; insert_Ref_out);
unfold lift; unfold lift_rec; fold lift_rec.

(* status *)

Fixpoint status (M: lambda) :=
match M with
| Ref i => S i
| Abs M1 => pred (status M1)
| App (Abs _) _ => 0
| App M1 M2 => status M1
end.

Definition abs_rank := 10.

Fixpoint rank (M: lambda) :=
match M with
| Ref _ => 1
| App M1 M2 => S((rank M1) + (rank M2))
| Abs M1 =>  abs_rank * rank M1
end.

Lemma rank_positive: forall M, rank M > 0.
Proof.
induction M; split_all; try omega.
Qed.

Lemma lift_rec_preserves_status :
forall (M: lambda) (n k: nat), status (lift_rec M n k) = relocate (status M) (S n) k.
Proof.
cut(forall p (M: lambda) (n k: nat), p>= rank M -> status (lift_rec M n k) = relocate (status M) (S n) k).
split_all. eapply2 H.
induction p; intro M. split_all.
assert(rank M > 0) by eapply2 rank_positive.
noway.
(* p > 0 *)
induction M; split_all; try (rewrite relocate_succ; auto);
try (eapply2 IHM1).
(* 2 *)
rewrite IHM.
unfold relocate.
elim(test (S(S n)) (status M)); elim(test (S n) (pred(status M))); split_all; try noway.
omega.
assert(rank M > 0) by eapply2 rank_positive.
omega.
(* 1 *)
clear IHM2.
gen2_case IHM1 H M1; try (rewrite relocate_succ; auto); try (eapply2 IHM1).
gen2_case IHM1 H l; try (rewrite relocate_succ; auto); try (eapply2 IHM1).
omega.
gen2_case IHM1 H l1; try (rewrite relocate_succ; auto); try (eapply2 IHM1); omega.
omega.
Qed.

Hint Resolve lift_rec_preserves_status.

Lemma lift_rec_preserves_rank :
forall (M: lambda) (n k: nat), rank (lift_rec M n k) = rank M.
Proof. induction M; split_all. Qed.

Lemma subst_rec_preserves_status:
forall (M N: lambda)(k : nat), (status M <= k -> status (subst_rec M N k) = status M).
Proof.
cut(forall p (M: lambda), p>= rank M -> forall (N: lambda) (k : nat), (status M <= k -> status (subst_rec M N k) = status M)).
split_all. eapply2 H.
induction p; intro M. split_all.
assert(rank M > 0) by eapply2 rank_positive.
noway.
(* p > 0 *)
induction M; intros.
(* 4 *)
split_all. simpl in *. insert_Ref_out; split_all.
(* 3 *)
split_all.
(* 2 *)
split_all.
rewrite IHM. auto. simpl in *; omega. simpl in *; omega.
(* 1 *)
unfold subst_rec; fold subst_rec.
(* 1 *)
generalize IHM1 H H0; clear IHM1 H H0; case M1; intros.
(* 4 *)
unfold subst_rec; fold subst_rec.
simpl in H0.
split_all.
insert_Ref_out; try (split_all; fail).
(* 3 *)
split_all.
(* 2 *)
 insert_Ref_out; split_all.
(* 1 *)
unfold subst_rec; fold subst_rec.
(* 1 *)
generalize IHM1 H H0; clear IHM1 H H0; case l; intros.
(* 4 *)
unfold subst_rec; fold subst_rec.
simpl in H0.
insert_Ref_out; try (split_all; fail).
(* 3 *)
split_all.
(* 2 *)
 insert_Ref_out; split_all.
(* 1 *)
unfold subst_rec; fold subst_rec.
(* 1 *)
generalize IHM1 H H0; clear IHM1 H H0; case l1; intros.
(* 4 *)
unfold subst_rec; fold subst_rec.
simpl in H0.
insert_Ref_out; try (split_all; fail).
(* 2 *)
split_all.
(* 1 *)
unfold subst_rec; fold subst_rec.
(* 1 *)
replace (App (subst_rec l3 N k) (subst_rec l4 N k)) with (subst_rec (App l3 l4) N k) by auto.
eapply2 IHp.
simpl in *; omega.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* Cat: Category Theory with classes.
 *
 * This module implements the category [TYPE] of Types and Coq function spaces
 * between them.
 *
 * Author: Matthieu Sozeau <mattam@mattam.org>
 *)

Require Import Cat.Functor.
Require Import Coq.Classes.SetoidTactics.

(** The [arrow] homset takes Type's [A] and [B] to the [A -> B] function space. *)

Definition arrow A B := A -> B.

(** Here we build a setoid instance for functions which relates the ones which argree on every input. *)

Program Instance arrow_setoid `(s : Setoid b) : Setoid (a -> b) := {
  equiv f g := forall x, f x == g x
}.
Next Obligation.
Proof.
  constructor ; red ; intros.
  reflexivity.

  symmetry ; auto.

  transitivity (y x0) ; auto.
Qed.
Implicit Arguments arrow_setoid [a b s].

(** Not an instance, would make any setoid constraint trivial. *)
Program Definition eq_setoid A : Setoid A :=
  @Build_Setoid A (@Logic.eq A) _.

Next Obligation.
  apply eq_equivalence.
Qed.

(** We can build the corresponding category of types and functions (our Set category) from [arrow_setoid]. *)

Program Instance TYPE : Category Type arrow := {
  morphisms a b := arrow_setoid (s:=eq_setoid b) ;
  id a x := x;
  compose a b c f g x := g (f x)
}.

  Next Obligation.
  Proof.
    unfold arrow.
    constructor ; intros.
  Qed.

  Next Obligation.
  Proof.
    do 3 (red ; intros).
    rewrite (H x1).
    rewrite (H0 (y x1)).
    reflexivity.
  Qed.

(** Some interesting endo-functors in this category: *)

Require Import Coq.Lists.List.

(** Lists with map. *)

(* Program Instance list_map_functor : Functor TYPE TYPE list map. *)

(*   Next Obligation. *)
(*   Proof. *)
(*     do 2 red ; intros. *)
(*     induction x0 ; auto. *)
(*     simpl. *)
(*     rewrite IHx0. *)
(*     rewrite H.  *)
(*     reflexivity. *)
(*   Qed. *)

(*   Next Obligation. *)
(*   Proof. *)
(*     induction x ; auto. *)
(*     simpl ; rewrite IHx. *)
(*     reflexivity. *)
(*   Qed. *)

(*   Next Obligation. *)
(*   Proof. *)
(*     induction x ; auto. *)
(*     simpl ; rewrite IHx. *)
(*     reflexivity. *)
(*   Qed. *)

(** The option map. *)

(* Program Instance option_functor : Functor TYPE TYPE option *)
(*   (fun a b f x => match x return _ with Some a => Some (f a) | None => None end). *)

(*   Next Obligation. *)
(*   Proof. *)
(*     do 2 red ; intros. *)
(*     induction x0 ; auto. *)
(*     f_equal. *)
(*     apply H. *)
(*   Qed. *)

(*   Next Obligation. *)
(*   Proof. *)
(*     destruct x ; auto. *)
(*   Qed. *)

(*   Next Obligation. *)
(*   Proof. *)
(*     destruct x ; auto. *)
(*   Qed. *)

(** Representation functors. *)

Require Import Coq.Classes.SetoidAxioms.

(** The section functor, or covariant functor for any category [C] on an object [A]. *)

Program Instance section_functor `(C : Category obj hom, ! Object C a ) :
  Functor C TYPE (hom a) (fun x y (f : hom x y) (g : hom a x) => f ∘ g).

  Next Obligation.
  Proof.
    do 2 red ; intros.
    (* BUG when using H and no extensionality *)
    setoid_extensionality.
    rewrite H.
    reflex.
  Qed.

  Next Obligation.
  Proof.
    setoid_extensionality.
    apply id_unit_left.
  Qed.

  Next Obligation.
  Proof.
    setoid_extensionality.
    apply assoc.
  Qed.

(** The points functor, or contravariant functor induced by an object [b] into [opposite Type] for any category [C]. *)

Class ContravariantFunctor `(C : Category (opposite obj) (flip hom), D : Category obj' hom' ) Fobj Fmor := {
  contravariant_functor :> Functor C D Fobj Fmor
}.

(* Definition ContravariantFunctor [ C : Category (opposite obj) (flip hom), D : Category obj' hom' ] Fobj Fmor :=  *)
(*   Functor C D Fobj Fmor. *)

(* Typeclasses unfold SetoidClass.equiv. *)
(* Typeclasses unfold flip. *)
(* Typeclasses unfold @opposite. *)

Program Instance points_functor `(Cop : Category (opposite obj) (flip hom), ! Object Cop b ) :
  Functor Cop TYPE ((flip hom) b) (fun x y (f : (flip hom) x y) (g : (flip hom) b x) => f ∘ g).

  Next Obligation.
  Proof.
    do 2 red ; intros.
    setoid_extensionality.
    rewrite H. reflexivity.
  Qed.

  Next Obligation.
  Proof.
    setoid_extensionality.
    apply id_unit_left.
  Qed.

  Next Obligation.
  Proof.
    setoid_extensionality.
    apply assoc.
  Qed.


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

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

Print Assumptions freeze.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq.

(* Ltac debugging feature: recursive elim + eq generation *)
Lemma testL1 : forall A (s : seq A), s = s.
Proof.
move=> A s; elim branch: s => [|x xs _].
match goal with _ : _ = [::] |- [::] = [::] => move: branch => // | _ => fail end.
match goal with _ : _ =  _ :: _ |- _ :: _ = _ :: _ => move: branch => // | _ => fail end.
Qed.

(* The same but with explicit eliminator and a conflict in the intro pattern *)
Lemma testL2 : forall A (s : seq A), s = s.
Proof.
move=> A s; elim/last_ind branch: s => [|x s _].
match goal with _ : _ = [::] |- [::] = [::] => move: branch => // | _ => fail end.
match goal with _ : _ =  rcons _ _ |- rcons _ _ = rcons _ _ => move: branch => // | _ => fail end.
Qed.

(* The same but without names for variables involved in the generated eq *)
Lemma testL3 : forall A (s : seq A), s = s.
Proof.
move=> A s; elim branch: s; move: (s) => _.
match goal with _ : _ = [::] |- [::] = [::] => move: branch => // | _ => fail end.
move=> _;match goal with _ : _ =  _ :: _ |- _ :: _ = _ :: _ => move: branch => // | _ => fail end.
Qed.

Inductive foo : Type := K1 : foo | K2 : foo -> foo -> foo | K3 : (nat -> foo) -> foo.

(* The same but with more intros to be done *)
Lemma testL4 : forall (o : foo), o = o.
Proof.
move=> o; elim branch: o.
match goal with _ : _ = K1 |- K1 = K1 => move: branch => // | _ => fail end.
move=> _; match goal with _ : _ = K2 _ _ |- K2 _ _ = K2 _ _ => move: branch => // | _ => fail end.
move=> _; match goal with _ : _ =  K3 _ |- K3 _ = K3 _ => move: branch => // | _ => fail end.
Qed.

(* Occurrence counting *)
Lemma testO1: forall (b : bool), b = b.
Proof.
move=> b; case: (b) / idP.
match goal with |- is_true b -> true = true => done | _ => fail end.
match goal with |- ~ is_true b -> false = false => done | _ => fail end.
Qed.

(* The same but only the second occ *)
Lemma testO2: forall (b : bool), b = b.
Proof.
move=> b; case: {2}(b) / idP.
match goal with |- is_true b -> b = true => done | _ => fail end.
match goal with |- ~ is_true b -> b = false => move/(introF idP) => // | _ => fail end.
Qed.

(* The same but with eq generation *)
Lemma testO3: forall (b : bool), b = b.
Proof.
move=> b; case E: {2}(b) / idP.
match goal with _ : is_true b, _ : b = true |- b = true => move: E => _; done | _ => fail end.
match goal with H : ~ is_true b, _ : b = false |- b = false => move: E => _; move/(introF idP): H => // | _ => fail end.
Qed.

(* Views *)
Lemma testV1 : forall A (s : seq A), s = s.
Proof.
move=> A s; case/lastP E: {1}s => [| x xs].
match goal with _ : s = [::] |- [::] = s => symmetry; exact E | _ => fail end.
match goal with _ : s = rcons x xs |- rcons _ _ = s => symmetry; exact E | _ => fail end.
Qed.

Lemma testV2 : forall A (s : seq A), s = s.
Proof.
move=> A s; case/lastP E: s => [| x xs].
match goal with _ : s = [::] |- [::] = [::] => done | _ => fail end.
match goal with _ : s = rcons x xs |- rcons _ _ = rcons _ _ => done | _ => fail end.
Qed.

Lemma testV3 : forall A (s : seq A), s = s.
Proof.
move=> A s; case/lastP: s => [| x xs].
match goal with |- [::] = [::] => done | _ => fail end.
match goal with |- rcons _ _ = rcons _ _ => done | _ => fail end.
Qed.

(* Patterns *)
Lemma testP1: forall (x y : nat), (y == x) && (y == x) -> y == x.
move=> x y; elim: {2}(_ == _) / eqP.
match goal with |- (y = x -> is_true ((y == x) && true) -> is_true (y == x)) => move=>-> // | _ => fail end.
match goal with |- (y <> x -> is_true ((y == x) && false) -> is_true (y == x)) => move=>_; rewrite andbC // | _ => fail end.
Qed.

(* The same but with an implicit pattern *)
Lemma testP2 : forall (x y : nat), (y == x) && (y == x) -> y == x.
move=> x y; elim: {2}_ / eqP.
match goal with |- (y = x -> is_true ((y == x) && true) -> is_true (y == x)) => move=>-> // | _ => fail end.
match goal with |- (y <> x -> is_true ((y == x) && false) -> is_true (y == x)) => move=>_; rewrite andbC // | _ => fail end.
Qed.

(* The same but with an eq generation switch *)
Lemma testP3 : forall (x y : nat), (y == x) && (y == x) -> y == x.
move=> x y; elim E: {2}_ / eqP.
match goal with _ : y = x |- (is_true ((y == x) && true) -> is_true (y == x)) => rewrite E; reflexivity | _ => fail end.
match goal with _ : y <> x |- (is_true ((y == x) && false) -> is_true (y == x)) => rewrite E => /= H; exact H  | _ => fail end.
Qed.

Inductive spec : nat -> nat -> nat -> Prop :=
| specK : forall a b c, a = 0 -> b = 2 -> c = 4 -> spec a b c.
Lemma specP : spec 0 2 4. Proof. by constructor. Qed.

Lemma testP4 : (1+1) * 4 = 2 + (1+1) + (2 + 2).
Proof.
case: specP => a b c defa defb defc.
match goal with |- (a.+1 + a.+1) * c = b + (a.+1 + a.+1) + (b + b) => subst; done | _ => fail end.
Qed.

Lemma testP5 : (1+1) * 4 = 2 + (1+1) + (2 + 2).
Proof.
case: (1 + 1) _ / specP => a b c defa defb defc.
match goal with |- b * c = a.+2 + b + (a.+2 + a.+2) => subst; done | _ => fail end.
Qed.

Lemma testP6 : (1+1) * 4 = 2 + (1+1) + (2 + 2).
Proof.
case: {2}(1 + 1) _ / specP => a b c defa defb defc.
match goal with |- (a.+1 + a.+1) * c = a.+2 + b + (a.+2 + a.+2) => subst; done | _ => fail end.
Qed.

Lemma testP7 : (1+1) * 4 = 2 + (1+1) + (2 + 2).
Proof.
case: _ (1 + 1) (2 + _) / specP => a b c defa defb defc.
match goal with |- b * a.+4 = c + c => subst; done | _ => fail end.
Qed.

Lemma testP8 : (1+1) * 4 = 2 + (1+1) + (2 + 2).
Proof.
case E: (1 + 1) (2 + _) / specP=> [a b c defa defb defc].
match goal with |- b * a.+4 = c + c => subst; done | _ => fail end.
Qed.

Variables (T : Type) (tr : T -> T).

Inductive exec (cf0 cf1 : T) : seq T -> Prop :=
| exec_step : tr cf0 = cf1 -> exec cf0 cf1 [::]
| exec_star : forall cf2 t, tr cf0 = cf2 ->
  exec cf2 cf1 t -> exec cf0 cf1 (cf2 :: t).

Inductive execr (cf0 cf1 : T) : seq T -> Prop :=
| execr_step : tr cf0 = cf1 -> execr cf0 cf1 [::]
| execr_star : forall cf2 t, execr cf0 cf2 t ->
  tr cf2 = cf1 -> execr cf0 cf1 (t ++ [:: cf2]).

Lemma execP : forall cf0 cf1 t, exec cf0 cf1 t <-> execr cf0 cf1 t.
Proof.
move=> cf0 cf1 t; split => [] Ecf.
  elim: Ecf.
    match goal with |- forall cf2 cf3 : T, tr cf2 = cf3 ->
      execr cf2 cf3 [::] => admit | _ => fail end.
  match goal with |- forall (cf2 cf3 cf4 : T) (t0 : seq T),
   tr cf2 = cf4 -> exec cf4 cf3 t0 -> execr cf4 cf3 t0 ->
   execr cf2 cf3 (cf4 :: t0) => admit | _ => fail end.
elim: Ecf.
  match goal with |- forall cf2 : T,
    tr cf0 = cf2 -> exec cf0 cf2 [::] => admit | _ => fail end.
match goal with |- forall (cf2 cf3 : T) (t0 : seq T),
 execr cf0 cf3 t0 -> exec cf0 cf3 t0 -> tr cf3 = cf2 ->
 exec cf0 cf2 (t0 ++ [:: cf3]) => admit | _ => fail end.
Qed.

Require Import seq div prime bigop.

Lemma mem_primes : forall p n,
  (p \in primes n) = [&& prime p, n > 0 & p %| n].
Proof.
move=> p n; rewrite andbCA; case: posnP => [-> // | /= n_gt0].
apply/mapP/andP=> [[[q e]]|[pr_p]] /=.
  case/mem_prime_decomp=> pr_q e_gt0; case/dvdnP=> u -> -> {p}.
  by rewrite -(prednK e_gt0) expnS mulnCA dvdn_mulr.
rewrite {1}(prod_prime_decomp n_gt0) big_seq.
elim/big_prop: _ => [| u v IHu IHv | [q e] /= mem_qe dv_p_qe].
- by rewrite Euclid_dvd1.
- by rewrite Euclid_dvdM //; case/orP.
exists (q, e) => //=; case/mem_prime_decomp: mem_qe => pr_q _ _.
by rewrite Euclid_dvdX // dvdn_prime2 // in dv_p_qe; case: eqP dv_p_qe.
Qed.

Lemma sub_in_partn : forall pi1 pi2 n,
  {in \pi(n), {subset pi1 <= pi2}} -> n`_pi1 %| n`_pi2.
Proof.
move=> pi1 pi2 n pi12; rewrite ![n`__]big_mkcond /=.
elim/big_rel: _ => // [*|p _]; first exact: dvdn_mul.
rewrite lognE -mem_primes; case: ifP => pi1p; last exact: dvd1n.
by case: ifP => pr_p; [rewrite pi12 | rewrite if_same].
Qed.

Function plus (m n : nat) {struct n} : nat :=
   match n with
   | 0 => m
   | S p => S (plus m p)
   end.

Lemma exF x y z: plus (plus x y) z = plus x (plus y z).
elim/plus_ind: z / (plus _ z).
match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end.
Undo 2.
elim/plus_ind: (plus _ z).
match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end.
Undo 2.
elim/plus_ind: {z}(plus _ z).
match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end.
Undo 2.
elim/plus_ind: {z}_.
match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end.
Undo 2.
elim/plus_ind: z / _.
match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end.
 done.
by move=> _ p _ ->.
Qed.


From Hammer Require Import Hammer.

Require Export Coq.Classes.Equivalence.

Require Import Coq.Logic.Decidable.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Program.Program.

Generalizable Variables A B R.

Open Scope equiv_scope.

Class DecidableEquivalence `(equiv : Equivalence A) :=
setoid_decidable : forall x y : A, decidable (x === y).

Class EqDec A R {equiv : Equivalence R} :=
equiv_dec : forall x y : A, { x === y } + { x =/= y }.

Notation " x == y " := (equiv_dec (x :>) (y :>)) (no associativity, at level 70) : equiv_scope.

Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } :=
match x with
| left H => @right _ _ H
| right H => @left _ _ H
end.

Local Open Scope program_scope.

Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x === y } :=
swap_sumbool (x == y).

Infix "<>" := nequiv_dec (no associativity, at level 70) : equiv_scope.

Definition equiv_decb `{EqDec A} (x y : A) : bool :=
if x == y then true else false.

Definition nequiv_decb `{EqDec A} (x y : A) : bool :=
negb (equiv_decb x y).

Infix "==b" := equiv_decb (no associativity, at level 70).
Infix "<>b" := nequiv_decb (no associativity, at level 70).

Program Instance nat_eq_eqdec : EqDec nat eq := eq_nat_dec.

Program Instance bool_eqdec : EqDec bool eq := bool_dec.

Program Instance unit_eqdec : EqDec unit eq := fun x y => in_left.

Next Obligation.
Proof. hammer_hook "EquivDec" "EquivDec.unit_eqdec".
destruct x ; destruct y.
reflexivity.
Qed.

Obligation Tactic := unfold complement, equiv ; program_simpl.

Program Instance prod_eqdec `(EqDec A eq, EqDec B eq) :
! EqDec (prod A B) eq :=
{ equiv_dec x y :=
let '(x1, x2) := x in
let '(y1, y2) := y in
if x1 == y1 then
if x2 == y2 then in_left
else in_right
else in_right }.

Program Instance sum_eqdec `(EqDec A eq, EqDec B eq) :
EqDec (sum A B) eq := {
equiv_dec x y :=
match x, y with
| inl a, inl b => if a == b then in_left else in_right
| inr a, inr b => if a == b then in_left else in_right
| inl _, inr _ | inr _, inl _ => in_right
end }.

Program Instance bool_function_eqdec `(EqDec A eq) : ! EqDec (bool -> A) eq :=
{ equiv_dec f g :=
if f true == g true then
if f false == g false then in_left
else in_right
else in_right }.

Next Obligation.
Proof. hammer_hook "EquivDec" "EquivDec.bool_function_eqdec".
extensionality x.
destruct x ; auto.
Qed.

Require Import List.

Program Instance list_eqdec `(eqa : EqDec A eq) : ! EqDec (list A) eq :=
{ equiv_dec :=
fix aux (x y : list A) :=
match x, y with
| nil, nil => in_left
| cons hd tl, cons hd' tl' =>
if hd == hd' then
if aux tl tl' then in_left else in_right
else in_right
| _, _ => in_right
end }.

Next Obligation. destruct y ; unfold not in *; eauto. Defined.

Solve Obligations with unfold equiv, complement in * ;
program_simpl ; intuition (discriminate || eauto).