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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


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

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

Print Assumptions sub.


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

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

Print Assumptions carry.


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

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

Print Assumptions sub.


From Hammer Require Import Hammer.

Require Export RegExp.Utility.
Require Export RegExp.Definitions.
Require Export RegExp.Boolean.
Require Export RegExp.Concat.

Unset Standard Proposition Elimination Names.

Lemma Char_true : forall c, (Char c) ~== (String c ""%string).
Proof. hammer_hook "Char" "Char.Char_true".
intro c.  simpl.
destruct(ascii_dec c c); simpl.
auto.
elim n. auto.
Qed.

Lemma Char_false : forall s c, s <> (String c ""%string) -> (Char c) ~!= s.
Proof. hammer_hook "Char" "Char.Char_false".
induction s.
intros c Hs.  simpl.  auto.
induction s; intros c Hs; simpl.
destruct(ascii_dec c a); simpl.
rewrite e in Hs.  elim Hs.  auto.
auto.
destruct(ascii_dec c a); simpl.
eapply Empty_false.
eapply Empty_false.
Qed.

Add Parametric Morphism : Char with
signature ascii_eq ==> re_eq as Char_mor.
Proof.
intros x y Hxy.  destruct Hxy.  setoid_reflexivity.
Qed.

Lemma derive_Char_is_id : forall a r, derive a (Char a ++ r) =R= r.
Proof. hammer_hook "Char" "Char.derive_Char_is_id".
intros a r.  simpl.
destruct(ascii_dec a a).
setoid_rewrite Cat_left_id.  setoid_reflexivity.
elim n.  auto.
Qed.

Fixpoint string_to_re (s:string):RegExp :=
match s with
| EmptyString => Eps
| String a s' => (Char a) ++ (string_to_re s')
end.

Lemma string_to_re_true : forall s:string, (string_to_re s) ~== s.
Proof. hammer_hook "Char" "Char.string_to_re_true".
induction s.
simpl.  auto.
simpl.  destruct(ascii_dec a a).
erewrite Cat_left_id_s.  auto.
elim n.  auto.
Qed.

Lemma string_to_re_false : forall s s':string, s <> s' -> (string_to_re s) ~!= s'.
Proof. hammer_hook "Char" "Char.string_to_re_false".
induction s.
intros s' Hs.  simpl.  eapply Eps_false.  auto.
induction s'.
intros Hs.  simpl.  auto.
intro Hs.  simpl.  destruct(ascii_dec a a0).
erewrite Cat_left_id_s.  rewrite e in Hs.  eapply IHs.
destruct(string_dec s s').
rewrite e0 in Hs.  elim Hs. auto.
auto.
erewrite Cat_left_zero_s.  auto.
Qed.


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(** * Finite sets library *)

(** This file proposes an implementation of the non-dependant
    interface [MSetInterface.S] using strictly ordered list. *)

Require Export MSetInterface OrdersFacts OrdersLists.
Set Implicit Arguments.
Unset Strict Implicit.

(** * Functions over lists

   First, we provide sets as lists which are not necessarily sorted.
   The specs are proved under the additional condition of being sorted.
   And the functions returning sets are proved to preserve this invariant. *)

Module Ops (X:OrderedType) <: WOps X.

  Definition elt := X.t.
  Definition t := list elt.

  Definition empty : t := nil.

  Definition is_empty (l : t) := if l then true else false.

  (** ** The set operations. *)

  Fixpoint mem x s :=
    match s with
    | nil => false
    | y :: l =>
        match X.compare x y with
        | Lt => false
        | Eq => true
        | Gt => mem x l
        end
    end.

  Fixpoint add x s :=
    match s with
    | nil => x :: nil
    | y :: l =>
        match X.compare x y with
        | Lt => x :: s
        | Eq => s
        | Gt => y :: add x l
        end
    end.

  Definition singleton (x : elt) := x :: nil.

  Fixpoint remove x s :=
    match s with
    | nil => nil
    | y :: l =>
        match X.compare x y with
        | Lt => s
        | Eq => l
        | Gt => y :: remove x l
        end
    end.

  Fixpoint union (s : t) : t -> t :=
    match s with
    | nil => fun s' => s'
    | x :: l =>
        (fix union_aux (s' : t) : t :=
           match s' with
           | nil => s
           | x' :: l' =>
               match X.compare x x' with
               | Lt => x :: union l s'
               | Eq => x :: union l l'
               | Gt => x' :: union_aux l'
               end
           end)
    end.

  Fixpoint inter (s : t) : t -> t :=
    match s with
    | nil => fun _ => nil
    | x :: l =>
        (fix inter_aux (s' : t) : t :=
           match s' with
           | nil => nil
           | x' :: l' =>
               match X.compare x x' with
               | Lt => inter l s'
               | Eq => x :: inter l l'
               | Gt => inter_aux l'
               end
           end)
    end.

  Fixpoint diff (s : t) : t -> t :=
    match s with
    | nil => fun _ => nil
    | x :: l =>
        (fix diff_aux (s' : t) : t :=
           match s' with
           | nil => s
           | x' :: l' =>
               match X.compare x x' with
               | Lt => x :: diff l s'
               | Eq => diff l l'
               | Gt => diff_aux l'
               end
           end)
    end.

  Fixpoint equal (s : t) : t -> bool :=
    fun s' : t =>
    match s, s' with
    | nil, nil => true
    | x :: l, x' :: l' =>
        match X.compare x x' with
        | Eq => equal l l'
        | _ => false
        end
    | _, _ => false
    end.

  Fixpoint subset s s' :=
    match s, s' with
    | nil, _ => true
    | x :: l, x' :: l' =>
        match X.compare x x' with
        | Lt => false
        | Eq => subset l l'
        | Gt => subset s l'
        end
    | _, _ => false
    end.

  Definition fold (B : Type) (f : elt -> B -> B) (s : t) (i : B) : B :=
    fold_left (flip f) s i.

  Fixpoint filter (f : elt -> bool) (s : t) : t :=
    match s with
    | nil => nil
    | x :: l => if f x then x :: filter f l else filter f l
    end.

  Fixpoint for_all (f : elt -> bool) (s : t) : bool :=
    match s with
    | nil => true
    | x :: l => if f x then for_all f l else false
    end.

  Fixpoint exists_ (f : elt -> bool) (s : t) : bool :=
    match s with
    | nil => false
    | x :: l => if f x then true else exists_ f l
    end.

  Fixpoint partition (f : elt -> bool) (s : t) : t * t :=
    match s with
    | nil => (nil, nil)
    | x :: l =>
        let (s1, s2) := partition f l in
        if f x then (x :: s1, s2) else (s1, x :: s2)
    end.

  Definition cardinal (s : t) : nat := length s.

  Definition elements (x : t) : list elt := x.

  Definition min_elt (s : t) : option elt :=
    match s with
    | nil => None
    | x :: _ => Some x
    end.

  Fixpoint max_elt (s : t) : option elt :=
    match s with
    | nil => None
    | x :: nil => Some x
    | _ :: l => max_elt l
    end.

  Definition choose := min_elt.

  Fixpoint compare s s' :=
   match s, s' with
    | nil, nil => Eq
    | nil, _ => Lt
    | _, nil => Gt
    | x::s, x'::s' =>
      match X.compare x x' with
       | Eq => compare s s'
       | Lt => Lt
       | Gt => Gt
      end
   end.

End Ops.

Module MakeRaw (X: OrderedType) <: RawSets X.
  Module Import MX := OrderedTypeFacts X.
  Module Import ML := OrderedTypeLists X.

  Include Ops X.

  (** ** Proofs of set operation specifications. *)

  Section ForNotations.

  Definition inf x l :=
   match l with
   | nil => true
   | y::_ => match X.compare x y with Lt => true | _ => false end
   end.

  Fixpoint isok l :=
   match l with
   | nil => true
   | x::l => inf x l && isok l
   end.

  Notation Sort l := (isok l = true).
  Notation Inf := (lelistA X.lt).
  Notation In := (InA X.eq).

  (* TODO: modify proofs in order to avoid these hints *)
  Hint Resolve (@Equivalence_Reflexive _ _ X.eq_equiv).
  Hint Immediate (@Equivalence_Symmetric _ _ X.eq_equiv).
  Hint Resolve (@Equivalence_Transitive _ _ X.eq_equiv).

  Definition IsOk s := Sort s.

  Class Ok (s:t) : Prop := ok : Sort s.

  Hint Resolve @ok.
  Hint Unfold Ok.

  Instance Sort_Ok s `(Hs : Sort s) : Ok s := { ok := Hs }.

  Lemma inf_iff : forall x l, Inf x l <-> inf x l = true.
  Proof.
    intros x l; split; intro H.
    (* -> *)
    destruct H; simpl in *.
      reflexivity.
    rewrite <- compare_lt_iff in H; rewrite H; reflexivity.
    (* <- *)
    destruct l as [|y ys]; simpl in *.
      constructor; fail.
    revert H; case_eq (X.compare x y); try discriminate; [].
    intros Ha _.
    rewrite compare_lt_iff in Ha.
    constructor; assumption.
  Qed.

  Lemma isok_iff : forall l, sort X.lt l <-> Ok l.
  Proof.
    intro l; split; intro H.
    (* -> *)
    elim H.
      constructor; fail.
    intros y ys Ha Hb Hc.
    change (inf y ys && isok ys = true).
    rewrite inf_iff in Hc.
    rewrite andb_true_iff; tauto.
    (* <- *)
    induction l as [|x xs].
      constructor.
    change (inf x xs && isok xs = true) in H.
    rewrite andb_true_iff, <- inf_iff in H.
    destruct H; constructor; tauto.
  Qed.

  Hint Extern 1 (Ok _) => rewrite <- isok_iff.

  Ltac inv_ok := match goal with
   | H:sort X.lt (_ :: _) |- _ => inversion_clear H; inv_ok
   | H:sort X.lt nil |- _ => clear H; inv_ok
   | H:sort X.lt ?l |- _ => change (Ok l) in H; inv_ok
   | H:Ok _ |- _ => rewrite <- isok_iff in H; inv_ok
   | |- Ok _ => rewrite <- isok_iff
   | _ => idtac
  end.

  Ltac inv := invlist InA; inv_ok; invlist lelistA.
  Ltac constructors := repeat constructor.

  Ltac sort_inf_in := match goal with
   | H:Inf ?x ?l, H':In ?y ?l |- _ =>
     cut (X.lt x y); [ intro | apply Sort_Inf_In with l; auto]
   | _ => fail
  end.

  Global Instance isok_Ok s `(isok s = true) : Ok s | 10.
  Proof.
  intros. assumption.
  Qed.

  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
  Definition Subset s s' := forall a : elt, In a s -> In a s'.
  Definition Empty s := forall a : elt, ~ In a s.
  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
  Definition Exists (P : elt -> Prop) (s : t) := exists x, In x s /\ P x.

  Lemma mem_spec :
   forall (s : t) (x : elt) (Hs : Ok s), mem x s = true <-> In x s.
  Proof.
  induction s; intros x Hs; inv; simpl.
  intuition. discriminate. inv.
  elim_compare x a; rewrite InA_cons; intuition; try order.
  discriminate.
  sort_inf_in. order.
  rewrite <- IHs; auto.
  rewrite IHs; auto.
  Qed.

  Lemma add_inf :
   forall (s : t) (x a : elt), Inf a s -> X.lt a x -> Inf a (add x s).
  Proof.
  simple induction s; simpl.
  intuition.
  intros; elim_compare x a; inv; intuition.
  Qed.
  Hint Resolve add_inf.

  Global Instance add_ok s x : forall `(Ok s), Ok (add x s).
  Proof.
  repeat rewrite <- isok_iff; revert s x.
  simple induction s; simpl.
  intuition.
  intros; elim_compare x a; inv; auto.
  Qed.

  Lemma add_spec :
   forall (s : t) (x y : elt) (Hs : Ok s),
    In y (add x s) <-> X.eq y x \/ In y s.
  Proof.
  induction s; simpl; intros.
  intuition. inv; auto.
  elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition.
  left; order.
  Qed.

  Lemma remove_inf :
   forall (s : t) (x a : elt) (Hs : Ok s), Inf a s -> Inf a (remove x s).
  Proof.
  induction s; simpl.
  intuition.
  intros; elim_compare x a; inv; auto.
  apply Inf_lt with a; auto.
  Qed.
  Hint Resolve remove_inf.

  Global Instance remove_ok s x : forall `(Ok s), Ok (remove x s).
  Proof.
  repeat rewrite <- isok_iff; revert s x.
  induction s; simpl.
  intuition.
  intros; elim_compare x a; inv; auto.
  Qed.

  Lemma remove_spec :
   forall (s : t) (x y : elt) (Hs : Ok s),
    In y (remove x s) <-> In y s /\ ~X.eq y x.
  Proof.
  induction s; simpl; intros.
  intuition; inv; auto.
  elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition;
   try sort_inf_in; try order.
  Qed.

  Global Instance singleton_ok x : Ok (singleton x).
  Proof.
  unfold singleton; simpl; auto.
  Qed.

  Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x.
  Proof.
  unfold singleton; simpl; split; intros; inv; auto.
  Qed.

  Ltac induction2 :=
    simple induction s;
     [ simpl; auto; try solve [ intros; inv ]
     | intros x l Hrec; simple induction s';
        [ simpl; auto; try solve [ intros; inv ]
        | intros x' l' Hrec'; simpl; elim_compare x x'; intros; inv; auto ]].

  Lemma union_inf :
   forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'),
   Inf a s -> Inf a s' -> Inf a (union s s').
  Proof.
  induction2.
  Qed.
  Hint Resolve union_inf.

  Global Instance union_ok s s' : forall `(Ok s, Ok s'), Ok (union s s').
  Proof.
  repeat rewrite <- isok_iff; revert s s'.
  induction2; constructors; try apply @ok; auto.
  apply Inf_eq with x'; auto; apply union_inf; auto; apply Inf_eq with x; auto.
  change (Inf x' (union (x :: l) l')); auto.
  Qed.

  Lemma union_spec :
   forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'),
   In x (union s s') <-> In x s \/ In x s'.
  Proof.
  induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto.
  left; order.
  Qed.

  Lemma inter_inf :
   forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'),
   Inf a s -> Inf a s' -> Inf a (inter s s').
  Proof.
  induction2.
  apply Inf_lt with x; auto.
  apply Hrec'; auto.
  apply Inf_lt with x'; auto.
  Qed.
  Hint Resolve inter_inf.

  Global Instance inter_ok s s' : forall `(Ok s, Ok s'), Ok (inter s s').
  Proof.
  repeat rewrite <- isok_iff; revert s s'.
  induction2.
  constructors; auto.
  apply Inf_eq with x'; auto; apply inter_inf; auto; apply Inf_eq with x; auto.
  Qed.

  Lemma inter_spec :
   forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'),
   In x (inter s s') <-> In x s /\ In x s'.
  Proof.
  induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto;
   try sort_inf_in; try order.
  left; order.
  Qed.

  Lemma diff_inf :
   forall (s s' : t) (Hs : Ok s) (Hs' : Ok s') (a : elt),
   Inf a s -> Inf a s' -> Inf a (diff s s').
  Proof.
  intros s s'; repeat rewrite <- isok_iff; revert s s'.
  induction2.
  apply Hrec; trivial.
  apply Inf_lt with x; auto.
  apply Inf_lt with x'; auto.
  apply Hrec'; auto.
  apply Inf_lt with x'; auto.
  Qed.
  Hint Resolve diff_inf.

  Global Instance diff_ok s s' : forall `(Ok s, Ok s'), Ok (diff s s').
  Proof.
  repeat rewrite <- isok_iff; revert s s'.
  induction2.
  Qed.

  Lemma diff_spec :
   forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'),
   In x (diff s s') <-> In x s /\ ~In x s'.
  Proof.
  induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto;
   try sort_inf_in; try order.
  right; intuition; inv; auto.
  Qed.

  Lemma equal_spec :
   forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'),
   equal s s' = true <-> Equal s s'.
  Proof.
  induction s as [ | x s IH]; intros [ | x' s'] Hs Hs'; simpl.
  intuition.
  split; intros H. discriminate. assert (In x' nil) by (rewrite H; auto). inv.
  split; intros H. discriminate. assert (In x nil) by (rewrite <-H; auto). inv.
  inv.
  elim_compare x x' as C; try discriminate.
  (* x=x' *)
  rewrite IH; auto.
  split; intros E y; specialize (E y).
  rewrite !InA_cons, E, C; intuition.
  rewrite !InA_cons, C in E. intuition; try sort_inf_in; order.
  (* x<x' *)
  split; intros E. discriminate.
  assert (In x (x'::s')) by (rewrite <- E; auto).
  inv; try sort_inf_in; order.
  (* x>x' *)
  split; intros E. discriminate.
  assert (In x' (x::s)) by (rewrite E; auto).
  inv; try sort_inf_in; order.
  Qed.

  Lemma subset_spec :
   forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'),
   subset s s' = true <-> Subset s s'.
  Proof.
  intros s s'; revert s.
  induction s' as [ | x' s' IH]; intros [ | x s] Hs Hs'; simpl; auto.
  split; try red; intros; auto.
  split; intros H. discriminate. assert (In x nil) by (apply H; auto). inv.
  split; try red; intros; auto. inv.
  inv. elim_compare x x' as C.
  (* x=x' *)
  rewrite IH; auto.
  split; intros S y; specialize (S y).
  rewrite !InA_cons, C. intuition.
  rewrite !InA_cons, C in S. intuition; try sort_inf_in; order.
  (* x<x' *)
  split; intros S. discriminate.
  assert (In x (x'::s')) by (apply S; auto).
  inv; try sort_inf_in; order.
  (* x>x' *)
  rewrite IH; auto.
  split; intros S y; specialize (S y).
  rewrite !InA_cons. intuition.
  rewrite !InA_cons in S. rewrite !InA_cons. intuition; try sort_inf_in; order.
  Qed.

  Global Instance empty_ok : Ok empty.
  Proof.
  constructors.
  Qed.

  Lemma empty_spec : Empty empty.
  Proof.
  unfold Empty, empty; intuition; inv.
  Qed.

  Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s.
  Proof.
  intros [ | x s]; simpl.
  split; auto. intros _ x H. inv.
  split. discriminate. intros H. elim (H x); auto.
  Qed.

  Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s.
  Proof.
  intuition.
  Qed.

  Lemma elements_spec2 : forall (s : t) (Hs : Ok s), sort X.lt (elements s).
  Proof.
  intro s; repeat rewrite <- isok_iff; auto.
  Qed.

  Lemma elements_spec2w : forall (s : t) (Hs : Ok s), NoDupA X.eq (elements s).
  Proof.
  intro s; repeat rewrite <- isok_iff; auto.
  Qed.

  Lemma min_elt_spec1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s.
  Proof.
  destruct s; simpl; inversion 1; auto.
  Qed.

  Lemma min_elt_spec2 :
   forall (s : t) (x y : elt) (Hs : Ok s),
   min_elt s = Some x -> In y s -> ~ X.lt y x.
  Proof.
  induction s as [ | x s IH]; simpl; inversion 2; subst.
  intros; inv; try sort_inf_in; order.
  Qed.

  Lemma min_elt_spec3 : forall s : t, min_elt s = None -> Empty s.
  Proof.
  destruct s; simpl; red; intuition. inv. discriminate.
  Qed.

  Lemma max_elt_spec1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s.
  Proof.
  induction s as [ | x s IH]. inversion 1.
  destruct s as [ | y s]. simpl. inversion 1; subst; auto.
  right; apply IH; auto.
  Qed.

  Lemma max_elt_spec2 :
   forall (s : t) (x y : elt) (Hs : Ok s),
   max_elt s = Some x -> In y s -> ~ X.lt x y.
  Proof.
  induction s as [ | a s IH]. inversion 2.
  destruct s as [ | b s]. inversion 2; subst. intros; inv; order.
  intros. inv; auto.
  assert (~X.lt x b) by (apply IH; auto).
  assert (X.lt a b) by auto.
  order.
  Qed.

  Lemma max_elt_spec3 : forall s : t, max_elt s = None -> Empty s.
  Proof.
  induction s as [ | a s IH]. red; intuition; inv.
  destruct s as [ | b s]. inversion 1.
  intros; elim IH with b; auto.
  Qed.

  Definition choose_spec1 :
    forall (s : t) (x : elt), choose s = Some x -> In x s := min_elt_spec1.

  Definition choose_spec2 :
    forall s : t, choose s = None -> Empty s := min_elt_spec3.

  Lemma choose_spec3: forall s s' x x', Ok s -> Ok s' ->
   choose s = Some x -> choose s' = Some x' -> Equal s s' -> X.eq x x'.
  Proof.
   unfold choose; intros s s' x x' Hs Hs' Hx Hx' H.
   assert (~X.lt x x').
    apply min_elt_spec2 with s'; auto.
    rewrite <-H; auto using min_elt_spec1.
   assert (~X.lt x' x).
    apply min_elt_spec2 with s; auto.
    rewrite H; auto using min_elt_spec1.
   order.
  Qed.

  Lemma fold_spec :
   forall (s : t) (A : Type) (i : A) (f : elt -> A -> A),
   fold f s i = fold_left (flip f) (elements s) i.
  Proof.
  reflexivity.
  Qed.

  Lemma cardinal_spec :
   forall (s : t) (Hs : Ok s),
   cardinal s = length (elements s).
  Proof.
  auto.
  Qed.

  Lemma filter_inf :
   forall (s : t) (x : elt) (f : elt -> bool) (Hs : Ok s),
   Inf x s -> Inf x (filter f s).
  Proof.
  simple induction s; simpl.
  intuition.
  intros x l Hrec a f Hs Ha; inv.
  case (f x); auto.
  apply Hrec; auto.
  apply Inf_lt with x; auto.
  Qed.

  Global Instance filter_ok s f : forall `(Ok s), Ok (filter f s).
  Proof.
  repeat rewrite <- isok_iff; revert s f.
  simple induction s; simpl.
  auto.
  intros x l Hrec f Hs; inv.
  case (f x); auto.
  constructors; auto.
  apply filter_inf; auto.
  Qed.

  Lemma filter_spec :
   forall (s : t) (x : elt) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   (In x (filter f s) <-> In x s /\ f x = true).
  Proof.
  induction s; simpl; intros.
  split; intuition; inv.
  destruct (f a) as [ ]_eqn:F; rewrite !InA_cons, ?IHs; intuition.
  setoid_replace x with a; auto.
  setoid_replace a with x in F; auto; congruence.
  Qed.

  Lemma for_all_spec :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   (for_all f s = true <-> For_all (fun x => f x = true) s).
  Proof.
  unfold For_all; induction s; simpl; intros.
  split; intros; auto. inv.
  destruct (f a) as [ ]_eqn:F.
  rewrite IHs; auto. firstorder. inv; auto.
  setoid_replace x with a; auto.
  split; intros H'. discriminate.
  rewrite H' in F; auto.
  Qed.

  Lemma exists_spec :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   (exists_ f s = true <-> Exists (fun x => f x = true) s).
  Proof.
  unfold Exists; induction s; simpl; intros.
  firstorder. discriminate. inv.
  destruct (f a) as [ ]_eqn:F.
  firstorder.
  rewrite IHs; auto.
  firstorder.
  inv.
  setoid_replace a with x in F; auto; congruence.
  exists x; auto.
  Qed.

  Lemma partition_inf1 :
   forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s),
   Inf x s -> Inf x (fst (partition f s)).
  Proof.
  intros s f x; repeat rewrite <- isok_iff; revert s f x.
  simple induction s; simpl.
  intuition.
  intros x l Hrec f a Hs Ha; inv.
  generalize (Hrec f a H).
  case (f x); case (partition f l); simpl.
  auto.
  intros; apply H2; apply Inf_lt with x; auto.
  Qed.

  Lemma partition_inf2 :
   forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s),
   Inf x s -> Inf x (snd (partition f s)).
  Proof.
  intros s f x; repeat rewrite <- isok_iff; revert s f x.
  simple induction s; simpl.
  intuition.
  intros x l Hrec f a Hs Ha; inv.
  generalize (Hrec f a H).
  case (f x); case (partition f l); simpl.
  intros; apply H2; apply Inf_lt with x; auto.
  auto.
  Qed.

  Global Instance partition_ok1 s f : forall `(Ok s), Ok (fst (partition f s)).
  Proof.
  repeat rewrite <- isok_iff; revert s f.
  simple induction s; simpl.
  auto.
  intros x l Hrec f Hs; inv.
  generalize (Hrec f H); generalize (@partition_inf1 l f x).
  case (f x); case (partition f l); simpl; auto.
  Qed.

  Global Instance partition_ok2 s f : forall `(Ok s), Ok (snd (partition f s)).
  Proof.
  repeat rewrite <- isok_iff; revert s f.
  simple induction s; simpl.
  auto.
  intros x l Hrec f Hs; inv.
  generalize (Hrec f H); generalize (@partition_inf2 l f x).
  case (f x); case (partition f l); simpl; auto.
  Qed.

  Lemma partition_spec1 :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f -> Equal (fst (partition f s)) (filter f s).
  Proof.
  simple induction s; simpl; auto; unfold Equal.
  split; auto.
  intros x l Hrec f Hf.
  generalize (Hrec f Hf); clear Hrec.
  destruct (partition f l) as [s1 s2]; simpl; intros.
  case (f x); simpl; auto.
  split; inversion_clear 1; auto.
  constructor 2; rewrite <- H; auto.
  constructor 2; rewrite H; auto.
  Qed.

  Lemma partition_spec2 :
   forall (s : t) (f : elt -> bool),
   Proper (X.eq==>eq) f ->
   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
  Proof.
  simple induction s; simpl; auto; unfold Equal.
  split; auto.
  intros x l Hrec f Hf.
  generalize (Hrec f Hf); clear Hrec.
  destruct (partition f l) as [s1 s2]; simpl; intros.
  case (f x); simpl; auto.
  split; inversion_clear 1; auto.
  constructor 2; rewrite <- H; auto.
  constructor 2; rewrite H; auto.
  Qed.

  End ForNotations.

  Definition In := InA X.eq.
  Instance In_compat : Proper (X.eq==>eq==> iff) In.
  Proof. repeat red; intros; rewrite H, H0; auto. Qed.

  Module L := MakeListOrdering X.
  Definition eq := L.eq.
  Definition eq_equiv := L.eq_equiv.
  Definition lt l1 l2 :=
    exists l1' l2', Ok l1' /\ Ok l2' /\ eq l1 l1' /\ eq l2 l2' /\ L.lt l1' l2'.

  Instance lt_strorder : StrictOrder lt.
  Proof.
  split.
  intros s (s1 & s2 & B1 & B2 & E1 & E2 & L).
  repeat rewrite <- isok_iff in *.
  assert (eqlistA X.eq s1 s2).
   apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *.
   transitivity s; auto. symmetry; auto.
  rewrite H in L.
  apply (StrictOrder_Irreflexive s2); auto.
  intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12)
                  (s2'' & s3' & B2' & B3 & E2' & E3 & L23).
  exists s1', s3'.
  repeat rewrite <- isok_iff in *.
  do 4 (split; trivial).
  assert (eqlistA X.eq s2' s2'').
   apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *.
   transitivity s2; auto. symmetry; auto.
  transitivity s2'; auto.
  rewrite H; auto.
  Qed.

  Instance lt_compat : Proper (eq==>eq==>iff) lt.
  Proof.
  intros s1 s2 E12 s3 s4 E34. split.
  intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
  exists s1', s3'; do 2 (split; trivial).
   split. transitivity s1; auto. symmetry; auto.
   split; auto. transitivity s3; auto. symmetry; auto.
  intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
  exists s1', s3'; do 2 (split; trivial).
   split. transitivity s2; auto.
   split; auto. transitivity s4; auto.
  Qed.

  Lemma compare_spec_aux : forall s s', CompSpec eq L.lt s s' (compare s s').
  Proof.
  induction s as [|x s IH]; intros [|x' s']; simpl; intuition.
  elim_compare x x'; auto.
  Qed.

  Lemma compare_spec : forall s s', Ok s -> Ok s' ->
   CompSpec eq lt s s' (compare s s').
  Proof.
  intros s s' Hs Hs'.
  destruct (compare_spec_aux s s'); constructor; auto.
  exists s, s'; repeat split; auto using @ok.
  exists s', s; repeat split; auto using @ok.
  Qed.

End MakeRaw.

(** * Encapsulation

   Now, in order to really provide a functor implementing [S], we
   need to encapsulate everything into a type of strictly ordered lists. *)

Module Make (X: OrderedType) <: S with Module E := X.
 Module Raw := MakeRaw X.
 Include Raw2Sets X Raw.
End Make.

(** For this specific implementation, eq coincides with Leibniz equality *)

Require Eqdep_dec.

Module Type OrderedTypeWithLeibniz.
  Include OrderedType.
  Parameter eq_leibniz : forall x y, eq x y -> x = y.
End OrderedTypeWithLeibniz.

Module Type SWithLeibniz.
  Declare Module E : OrderedTypeWithLeibniz.
  Include SetsOn E.
  Parameter eq_leibniz : forall x y, eq x y -> x = y.
End SWithLeibniz.

Module MakeWithLeibniz (X: OrderedTypeWithLeibniz) <: SWithLeibniz with Module E := X.
  Module E := X.
  Module Raw := MakeRaw X.
  Include Raw2SetsOn X Raw.

  Lemma eq_leibniz_list : forall xs ys, eqlistA X.eq xs ys -> xs = ys.
  Proof.
    induction xs as [|x xs]; intros [|y ys] H; inversion H; [ | ].
    reflexivity.
    f_equal.
    apply X.eq_leibniz; congruence.
    apply IHxs; subst; assumption.
  Qed.

  Lemma eq_leibniz : forall s s', eq s s' -> s = s'.
  Proof.
    intros [xs Hxs] [ys Hys] Heq.
    change (equivlistA X.eq xs ys) in Heq.
    assert (H : eqlistA X.eq xs ys).
      rewrite <- Raw.isok_iff in Hxs, Hys.
      apply SortA_equivlistA_eqlistA with X.lt; auto with *.
    apply eq_leibniz_list in H.
    subst ys.
    f_equal.
    apply Eqdep_dec.eq_proofs_unicity.
    intros x y; destruct (bool_dec x y); tauto.
  Qed.

End MakeWithLeibniz.


Require Import TypeECC.

Lemma lift_inj: forall n t u k, lift_rec n t k = lift_rec n u k -> t = u.
Proof.
induction n; intros.
repeat rewrite lift_rec0 in H; trivial.
apply IHn with k.
rewrite <- simpl_subst_rec with (p:=k) (N:=t); auto with arith.
rewrite <- simpl_subst_rec with (M:=u) (p:=k) (N:=t); auto with arith.
rewrite H; trivial.
Qed.

Lemma lift_ref_inv :
 forall n t k i,
 lift_rec n t k = Ref i ->
  k > i /\ t = Ref i \/
  n+k <= i /\ t = Ref (i-n).
Proof.
destruct t; try (intros;discriminate).
simpl.
intros k i.
case (le_gt_dec k n0); intros;auto.
injection H;intros; subst i.
right; split;auto with arith.

injection H;intros; subst i.
auto.
Qed.

Lemma lift_srt_inv :
 forall n t k s,
 lift_rec n t k = Srt s -> t = Srt s.
Proof.
destruct t; simpl; intros; try discriminate; trivial.
destruct (le_gt_dec k n0); discriminate.
Qed.

Lemma lift_abs_inv :
 forall n t k T M,
 lift_rec n t k = Abs T M ->
 exists2 T', lift_rec n T' k = T &
 exists2 M', lift_rec n M' (S k) = M &
 t = Abs T' M'.
Proof.
destruct t; simpl; intros; try discriminate; trivial.
destruct (le_gt_dec k n0); discriminate.
injection H; eauto.
Qed.

Lemma lift_app_inv :
 forall n t k u v,
 lift_rec n t k = App u v ->
 exists2 u', lift_rec n u' k = u &
 exists2 v', lift_rec n v' k = v &
 t = App u' v'.
Proof.
destruct t; simpl; intros; try discriminate; trivial.
destruct (le_gt_dec k n0); discriminate.
injection H; eauto.
Qed.

Lemma lift_prod_inv :
 forall n t k T M,
 lift_rec n t k = Prod T M ->
 exists2 T', lift_rec n T' k = T &
 exists2 M', lift_rec n M' (S k) = M &
 t = Prod T' M'.
Proof.
destruct t; simpl; intros; try discriminate; trivial.
destruct (le_gt_dec k n0); discriminate.
injection H; eauto.
Qed.

Lemma red1_red1_lift_ex :
  forall n t u, red1 t u -> forall k t', lift_rec n t' k = t ->
   exists2 u', red1 t' u' & u=lift_rec n u' k.
Proof.
induction 1; intros.
apply lift_app_inv in H; destruct H as (U', eqU', (N',eqN', eqt)).
subst N t'.
apply lift_abs_inv in eqU'; destruct eqU' as (T',eqT', (M',eqM', eqU')).
subst T M U'.
rewrite <- distr_lift_subst.
exists (subst N' M'); auto with coc.
(**)
apply lift_abs_inv in H0; destruct H0 as (a,eqa,(b,eqb,eqt')).
subst M N t'.
destruct IHred1 with k a as (a',reda,eqM'); trivial.
subst M'.
exists (Abs a' b); auto with coc.

apply lift_abs_inv in H0; destruct H0 as (a,eqa,(b,eqb,eqt')).
subst M N t'.
destruct IHred1 with (S k) b as (b',redb,eqM'); trivial.
subst M'.
exists (Abs a b'); auto with coc.

apply lift_app_inv in H0; destruct H0 as (a,eqa,(b,eqb,eqt')).
subst M1 M2 t'.
destruct IHred1 with k a as (a',reda,eqM'); trivial.
subst N1.
exists (App a' b); auto with coc.

apply lift_app_inv in H0; destruct H0 as (a,eqa,(b,eqb,eqt')).
subst M1 M2 t'.
destruct IHred1 with k b as (b',redb,eqM'); trivial.
subst N2.
exists (App a b'); auto with coc.

apply lift_prod_inv in H0; destruct H0 as (a,eqa,(b,eqb,eqt')).
subst M1 M2 t'.
destruct IHred1 with k a as (a',reda,eqM'); trivial.
subst N1.
exists (Prod a' b); auto with coc.

apply lift_prod_inv in H0; destruct H0 as (a,eqa,(b,eqb,eqt')).
subst M1 M2 t'.
destruct IHred1 with (S k) b as (b',redb,eqM'); trivial.
subst N2.
exists (Prod a b'); auto with coc.
Qed.

Lemma red_red_lift_ex :
  forall n t k u,
  red (lift_rec n t k) u ->
  exists2 u', red t u' & u=lift_rec n u' k.
Proof.
induction 1; intros.
exists t; auto with coc.
elim IHred;intros.
elim red1_red1_lift_ex with (1:=H0) (2:=sym_equal H2);intros.
exists x0; trivial.
constructor 2 with x; trivial.
Qed.

Lemma red_lift_lift_inv :
  forall n t u k, red (lift_rec n t k) (lift_rec n u k) -> red t u.
Proof.
intros.
elim red_red_lift_ex with (1 := H); intros.
rewrite (lift_inj _ _ _ _ H1); trivial.
Qed.

Lemma conv_lift_lift_inv :
  forall t u k, conv (lift_rec 1 t k) (lift_rec 1 u k) -> conv t u.
Proof.
intros.
assert (conv (subst_rec (Ref 0) (lift_rec 1 t k) k)
             (subst_rec (Ref 0) (lift_rec 1 u k) k)).
 apply conv_conv_subst; auto with coc.
rewrite simpl_subst_rec in H0; auto.
rewrite simpl_subst_rec in H0; auto.
do 2 rewrite lift_rec0 in H0; trivial.
Qed.

Lemma red_red_lift :
  forall n t u k, red t u -> red (lift_rec n t k) (lift_rec n u k).
induction 1; intros; auto with coc.
constructor 2 with (lift_rec n P k); auto with coc.
Qed.

Lemma red_red_subst :
  forall x t u k, red t u -> red (subst_rec x t k) (subst_rec x u k).
induction 1; intros; auto with coc.
constructor 2 with (subst_rec x P k); auto with coc.
Qed.

  Lemma ins_item_ge_inv :
   forall A n e f,
   ins_in_env A n e f -> forall v t, n <= v -> item t f (S v) -> item t e v.
Proof.
induction 1; intros.
inversion H0; trivial.
destruct v.
inversion H0.
inversion_clear H1; auto 10 with coc arith.
Qed.

  Lemma ins_item_lt_inv :
   forall A n e f,
   ins_in_env A n e f ->
   forall v t, n > v ->
   item_lift t f v ->
   exists2 t', t = lift_rec 1 t' n & item_lift t' e v.
Proof.
induction 1; intros.
inversion H.
destruct v.
destruct H1.
subst t0.
inversion_clear H2.
rewrite permute_lift.
exists (lift 1 t); auto.
exists t; auto.

destruct H1.
inversion_clear H2.
elim IHins_in_env with v (lift (S v) x); intros; auto with arith.
subst t0.
rewrite simpl_lift.
rewrite H2.
rewrite permute_lift.
exists (lift 1 x0); auto.

destruct H4.
subst x0.
rewrite <- simpl_lift.
exists x1; auto.

exists x;auto.
Qed.

Lemma pre_strength :
  forall A e M T,
  typ e M T ->
  forall f k M',
  lift_rec 1 M' k = M ->
  ins_in_env A k f e ->
  wf f ->
  exists2 T', red T (lift_rec 1 T' k) & typ f M' T'.
Proof.
induction 1; intros.
(* prop *)
apply lift_srt_inv in H0; subst M'.
exists (Srt (kind 0)); auto with coc.
constructor; trivial.

(* kind *)
apply lift_srt_inv in H0; subst M'.
exists (Srt (kind (S n))); auto with coc.
constructor; trivial.

(* vars *)
apply lift_ref_inv in H1.
destruct H1.
 destruct H1; subst M'.
 specialize ins_item_lt_inv with (1:=H2) (2:=H1) (3:=H0); intro.
 destruct H4.
 subst t.
 exists x; auto with coc.
 constructor; trivial.

 destruct H1; subst M'.
 destruct v; simpl.
  inversion H1.
 rewrite <- minus_n_O.
 destruct H0.
 assert (k<=v); auto with arith.
 specialize ins_item_ge_inv with (1:=H2) (2:=H5) (3:=H4); intro.
 exists (lift (S v) x).
  subst t.
  unfold lift; rewrite simpl_lift_rec; simpl; auto with arith coc.

  constructor ; trivial.
  exists x; trivial.

(* Abs *)
apply lift_abs_inv in H3; destruct H3 as (T1,eqT,(M1,eqM,eqM')); subst.
destruct IHtyp1 with (M':=T1) (2:=H4) (3:=H5) as (T',reds,tyT1); intros; trivial.
assert (T'=Srt s1).
 apply lift_srt_inv with 1 k.
 rewrite red_normal with (1:=reds); trivial.
 red;red;intros.
 inversion H3.
clear reds; subst T'.
assert (wf (T1 :: f)).
 apply wf_var with s1; trivial.
assert (ins_in_env A (S k) (T1::f) (lift_rec 1 T1 k::e)).
 constructor; trivial.
destruct IHtyp3 with (M':=M1) (2:=H6) (3:=H3) as (U',redU,tyU); intros; trivial.
exists (Prod T1 U'); simpl; auto with coc.
apply type_abs with s1 s2 s3; trivial.
specialize type_case with (1:=tyU);intro.
destruct H7.
replace s2 with x; trivial.
assert (conv (Srt x) (Srt s2)).
 apply typ_conv_conv with (u:=lift_rec 1 U' (S k)) (2:=H0).
  change (Srt x) with (lift_rec 1 (Srt x) (S k)).
  apply typ_weak_weak with (1:=H7) (2:=H6); trivial.
  apply wf_var with s1; trivial.

  apply sym_conv; auto with coc.
apply conv_sort; trivial.

(* App *)
apply lift_app_inv in H1; destruct H1 as (u',equ,(v',eqv,eqM')); subst.
destruct IHtyp2 with (M':=u') (2:=H2) (3:=H3) as (T',redp, tyu'); trivial.
destruct IHtyp1 with (M':=v') (2:=H2) (3:=H3) as (V',redV, tyv'); trivial.
apply red_prod_prod with (1:=redp); intros.
apply lift_prod_inv in H1; destruct H1 as (a',eqa,(b',eqb,eqT')); subst.
clear IHtyp1 IHtyp2.
exists (subst v' b').
 rewrite distr_lift_subst.
 unfold subst.
 apply red_red_subst; trivial.

 apply type_app with a'; trivial.
 apply type_case in tyu'.
 destruct tyu'.
 apply inv_typ_prod with (1:=H1); intros.
 apply type_conv with V' s1; auto with coc.
 apply conv_lift_lift_inv with k.
 apply trans_conv_conv with V; auto with coc.
 apply sym_conv; auto with coc.

(* Prod *)
exists (Srt s3); auto with coc.
apply lift_prod_inv in H2; destruct H2 as (T', eqT', (U', eqU', eqM')); subst.
destruct IHtyp1 with (M':=T') (2:=H3) (3:=H4) as (T1, reds, tyT'); trivial.
assert (T1=Srt s1).
 apply lift_srt_inv with 1 k.
 rewrite red_normal with (1:=reds); trivial.
 red;red;intros.
 inversion H2.
clear reds; subst T1.
assert (wf (T' :: f)).
 apply wf_var with s1; trivial.
assert (ins_in_env A (S k) (T'::f) (lift_rec 1 T' k::e)).
 constructor; trivial.
destruct IHtyp2 with (M':=U') (2:=H5) (3:=H2) as (U1, reds, tyU'); trivial.
apply type_prod with s1 s2; trivial.
apply red_normal in reds.
 symmetry in reds; apply lift_srt_inv in reds.
 subst U1; trivial.

 red; red; intros.
 inversion H6.

(* conv *)
destruct IHtyp1 with (1:=H2) (2:=H3) (3:=H4) as (U', redU, tyM').
elim church_rosser with V (lift_rec 1 U' k); intros.
2:apply trans_conv_conv with U; auto with coc.
apply red_red_lift_ex in H6.
destruct H6 as (U1, redU', eqx); subst x.
exists U1; trivial.
apply type_reduction with U'; trivial.
Qed.

Lemma strengthening_env :
  forall A k e f,
  ins_in_env A k f e ->
  wf e ->
  wf f.
Proof.
induction 1; intros.
 inversion_clear H.
   apply typ_wf with (1 := H0).
 inversion_clear H0.
   apply wf_var with s.
   elim pre_strength with (1 := H1) (M' := t) (3 := H); intros; auto.
   replace (Srt s) with x; trivial.
    apply lift_srt_inv with 1 n.
    symmetry  in |- *.
    apply red_normal; trivial.
    red in |- *; red in |- *; intros.
    inversion H3.
  specialize typ_wf with (1 := H1); auto.
Qed.

Lemma strengthening :
  forall A e f M T k,
  typ e (lift_rec 1 M k) (lift_rec 1 T k) ->
  ins_in_env A k f e ->
  typ f M T.
Proof.
intros.
assert (wff : wf f).
 apply strengthening_env with (1 := H0).
 apply typ_wf with (1 := H).
elim pre_strength with (1 := H) (M' := M) (3 := H0); trivial; intros.
elim type_case with (1 := H); intros.
apply type_conv with x x0; trivial.
 apply sym_conv.
 apply red_conv.
 apply red_lift_lift_inv in H1; trivial.

 elim pre_strength with (1 := H3) (M' := T) (3 := H0); intros; trivial.
 apply red_normal in H4.
  symmetry in H4; apply lift_srt_inv in H4.
  subst x1; trivial.

  red; red; intros.
  inversion H6.
Qed.

Lemma strengthening0 :
  forall A e M T,
  typ (cons A e) (lift 1 M) (lift 1 T) ->
  typ e M T.
Proof.
intros.
apply strengthening with A (A :: e) 0; trivial.
constructor.
Qed.


(* Make [omega] work for [N] *)

Require Import Coq.Arith.Arith Coq.omega.Omega Coq.NArith.NArith.

Global Set Asymmetric Patterns.

Local Open Scope N_scope.

Hint Rewrite Nplus_0_r nat_of_Nsucc nat_of_Nplus nat_of_Nminus
  N_of_nat_of_N nat_of_N_of_nat
  nat_of_P_o_P_of_succ_nat_eq_succ nat_of_P_succ_morphism : N.

Theorem nat_of_N_eq : forall n m,
  nat_of_N n = nat_of_N m
  -> n = m.
  intros ? ? H; apply (f_equal N_of_nat) in H;
    autorewrite with N in *; assumption.
Qed.

Theorem Nneq_in : forall n m,
  nat_of_N n <> nat_of_N m
  -> n <> m.
  congruence.
Qed.

Theorem Nneq_out : forall n m,
  n <> m
  -> nat_of_N n <> nat_of_N m.
  intuition.
  apply nat_of_N_eq in H0; tauto.
Qed.

Theorem Nlt_out : forall n m, n < m
  -> (nat_of_N n < nat_of_N m)%nat.
  unfold Nlt; intros.
  rewrite nat_of_Ncompare in H.
  apply nat_compare_Lt_lt; assumption.
Qed.

Theorem Nlt_in : forall n m, (nat_of_N n < nat_of_N m)%nat
  -> n < m.
  unfold Nlt; intros.
  rewrite nat_of_Ncompare.
  apply (proj1 (nat_compare_lt _ _)); assumption.
Qed.

Theorem Nge_out : forall n m, n >= m
  -> (nat_of_N n >= nat_of_N m)%nat.
  unfold Nge; intros.
  rewrite nat_of_Ncompare in H.
  apply nat_compare_ge; assumption.
Qed.

Theorem Nge_in : forall n m, (nat_of_N n >= nat_of_N m)%nat
  -> n >= m.
  unfold Nge; intros.
  rewrite nat_of_Ncompare.
  apply nat_compare_ge; assumption.
Qed.

Ltac nsimp H := simpl in H; repeat progress (autorewrite with N in H; simpl in H).

Ltac pre_nomega :=
  try (apply nat_of_N_eq || apply Nneq_in || apply Nlt_in || apply Nge_in); simpl;
    repeat (progress autorewrite with N; simpl);
    repeat match goal with
             | [ H : _ <> _ |- _ ] => apply Nneq_out in H; nsimp H
             | [ H : _ = _ -> False |- _ ] => apply Nneq_out in H; nsimp H
             | [ H : _ |- _ ] => (apply (f_equal nat_of_N) in H
               || apply Nlt_out in H || apply Nge_out in H); nsimp H
           end.

Ltac nomega := pre_nomega; omega || (unfold nat_of_P in *; simpl in *; omega).


Require Import Bedrock.Examples.AutoSep.

(** Factorial is mandatory, isn't it? *)

Inductive factR : W -> W -> Prop :=
| FR0 : factR 0 1
| FRS : forall w r : W, w <> 0 -> factR (w ^- $1) r -> factR w (w ^* r).

Lemma FR0' : forall w : W, w = 0 -> factR w $1.
  intros; subst; apply FR0.
Qed.

Lemma FRS' : forall w r v : W, w <> 0 -> factR (w ^- $1) r -> v = w ^* r -> factR w v.
  intros; subst; eapply FRS; eauto.
Qed.

Hint Resolve FR0' FRS'.

Definition factS : spec := SPEC("n") reserving 1
  PRE[V] Emp
  POST[R] [| factR (V "n") R |].

Definition fact := bmodule "fact" {{
  bfunction "fact"("n", "acc") [factS]
    "acc" <- 1;;

    [PRE[V] Emp
     POST[R] [| exists r, factR (V "n") r /\ R = V "acc" ^* r |] ]
    While ("n" <> 0) {
      "acc" <- "n" * "acc";;
      "n" <- "n" - 1
    };;

    Return "acc"
  end
}}.

Lemma times_1 : forall (n m x : W), factR n x
  -> m = $1 ^* x
  -> factR n m.
  intros; subst; replace ($1 ^* x) with x by W_eq; auto.
Qed.

Hint Resolve times_1.

Theorem factOk : moduleOk fact.
(*TIME  Clear Timing Profile. *)
  vcgen; abstract (sep_auto; eauto; words).

  (* sep_canceler ltac:(isConst) auto_ext ltac:(hints_ext_simplifier auto_ext).  *)
  (* simpl. intros. refine (H8 _ _ _ _).  *)
(*TIME  Print Timing Profile. *)
Qed.

Definition factDriver := bimport [[ "fact"!"fact" @ [factS] ]]
  bmodule "factDriver" {{
    bfunction "main"("x") [SPEC reserving 4
      PRE[_] Emp
      POST[R] [| R = $24 |] ]
      "x" <-- Call "fact"!"fact"(4)
      [PRE[_, R] Emp
       POST[R'] [| R' = R |]];;
      Return "x"
    end
  }}.

Theorem factR_4 : forall r, factR 4 r -> r = 24.
  intros;
    repeat match goal with
             | [ H : factR _ _ |- _ ] => inversion H; clear H; subst; []
           end;
    match goal with
      | [ H : factR _ _ |- _ ] => inversion H; clear H; subst; [ reflexivity
        | elimtype False; match goal with
                            | [ H : _ |- _ ] => apply H; reflexivity
                          end ]
    end.
Qed.

Hint Resolve factR_4.

Theorem factDriverOk : moduleOk factDriver.
(*TIME  Clear Timing Profile. *)
  vcgen; abstract (sep_auto; words).
(*TIME  Print Timing Profile. *)
Qed.

Definition factProg := link fact factDriver.

Theorem factProgOk : moduleOk factProg.
  link factOk factDriverOk.
Qed.


(** Coq coding by choukh, Jan 2021 **)

Require Import ZFC.Lib.NatIsomorphism.
Require Import ZFC.Lib.Algebra.Inj_2n3m.
Require Import ZFC.Lib.IndexedFamilyUnion.
Require Export ZFC.Elements.EST6_1.

(* 集合的支配关系 *)
Definition Dominate : set → set → Prop := λ A B, ∃ f, f: A ⇔ B.
Notation "A ≼ B" := (Dominate A B) (at level 70).
Notation "A ≺ B" := (A ≼ B ∧ A ≉ B) (at level 70).

(* 空集被任意集合支配 *)
Lemma empty_dominated : ∀ A, ∅ ≼ A.
Proof. intros. exists ∅. apply empty_injection. Qed.

(* 等势的集合相互支配 *)
Lemma eqnum_dominate : ∀ A B, A ≈ B → A ≼ B.
Proof with auto.
  intros * [f Hf]. exists f. apply bijection_is_injection...
Qed.

(* 支配关系是自反的 *)
Lemma dominate_refl : ∀ A, A ≼ A.
Proof.
  intros. exists (Ident A).
  apply bijection_is_injection. apply ident_bijection.
Qed.
Global Hint Immediate dominate_refl : core.

(* 支配关系是传递的 *)
Lemma dominate_trans : ∀ A B C, A ≼ B → B ≼ C → A ≼ C.
Proof.
  intros * [f Hf] [g Hg].
  exists (g ∘ f). eapply compo_injection; eauto.
Qed.

Lemma dominate_rewrite_l : ∀ A B C, B ≈ A → B ≼ C → A ≼ C.
Proof.
  intros * Hqn Hdm. eapply dominate_trans.
  apply eqnum_dominate. symmetry. apply Hqn. apply Hdm.
Qed.

Lemma dominate_rewrite_r : ∀ A B C, C ≈ A → B ≼ C → B ≼ A.
Proof.
  intros * Hqn Hdm. eapply dominate_trans; revgoals.
  apply eqnum_dominate. apply Hqn. apply Hdm.
Qed.

(* 可以证明支配关系也是反对称的 *)

(* 施罗德-伯恩斯坦定理 *)
Theorem Schröeder_Bernstein : ∀ A B, A ≼ B → B ≼ A → A ≈ B.
Proof with eauto; try congruence.
  intros * [f [Hif [Hdf Hrf]]] [g [Hig [Hdg Hrg]]].
  set (A - ran g) as C₀.
  set (λ x, g⟦f⟦x⟧⟧) as F.
  set (λ n, iter n F C₀) as Cᵢ. set (⋃ᵢ Cᵢ) as C.
  set (λ n, f⟦Cᵢ n⟧) as Dᵢ. set (⋃ᵢ Dᵢ) as D.
  set (Func A B (λ x, match (ixm (x ∈ C)) with
    | inl _ => f[x]
    | inr _ => g⁻¹[x]
  end)) as h.
  assert (Hif' := Hif). destruct Hif' as [Hff Hsf].
  assert (Hig' := Hig). destruct Hig' as [Hfg Hsg].
  assert (HeqC0: Cᵢ 0 = C₀) by reflexivity.
  assert (HeqCn: ∀ n, Cᵢ (S n) = g⟦Dᵢ n⟧). { intros. unfold Dᵢ... }
  assert (HsubC: C₀ ⊆ C). {
    intros x Hx. eapply nat_IFUnionI. rewrite HeqC0...
  }
  assert (HsubA: C ⊆ A). {
    intros x Hx. apply nat_IFUnionE in Hx as [m Hm].
    destruct m. rewrite HeqC0 in Hm. apply SepE1 in Hm...
    rewrite HeqCn in Hm. apply img_included in Hm. apply Hrg...
  }
  assert (Hxrg:∀x ∈ A, x ∉ C → x ∈ ran g). {
    intros x Hx H. destruct (classic (x ∈ ran g))...
    exfalso. apply H. apply HsubC. apply SepI...
  }
  assert (Hdc: ∀ n, ∀x ∈ ran g, (g⁻¹)[x] ∈ Dᵢ n → x ∈ C). {
    intros n x Hx H. eapply nat_IFUnionI. rewrite HeqCn.
    eapply imgI. apply H. rewrite inv_op. apply func_correct.
    apply inv_func_iff_sr... rewrite inv_dom...
  }
  exists h. apply meta_bijection.
  - intros x Hx. destruct (ixm (x ∈ C)).
    + eapply ap_ran. split... apply Hx.
    + rewrite <- Hdg, <- inv_ran. eapply ap_ran. split...
      apply inv_func_iff_sr... rewrite inv_dom. apply Hxrg...
  - intros x1 Hx1 x2 Hx2 Heq.
    destruct (ixm (x1 ∈ C)) as [H1|H1];
    destruct (ixm (x2 ∈ C)) as [H2|H2].
    + apply (injectiveE f)...
    + apply nat_IFUnionE in H1 as [m Hcm].
      exfalso. apply H2. eapply Hdc. apply Hxrg...
      rewrite <- Heq. eapply imgI. apply Hcm. apply func_correct...
    + apply nat_IFUnionE in H2 as [m Hcm].
      exfalso. apply H1. eapply Hdc. apply Hxrg...
      rewrite Heq. eapply imgI. apply Hcm. apply func_correct...
    + apply (injectiveE g⁻¹)... apply inv_injective...
      rewrite inv_dom. apply Hxrg...
      rewrite inv_dom. apply Hxrg...
  - intros y Hy. destruct (classic (y ∈ D)). {
      apply nat_IFUnionE in H as [m H].
      apply imgE in H as [x [Hx Hpf]].
      apply nat_IFUnionI in Hx. apply func_ap in Hpf...
      exists x. split. apply HsubA...
      destruct (ixm (x ∈ C))... exfalso...
    }
    exists (g[y]). split. eapply ap_ran... split...
    destruct (ixm (g[y] ∈ C)) as [Hgy|Hgy];
      [exfalso|rewrite inv_dom_reduction]...
    apply nat_IFUnionE in Hgy as [m Hgy]. destruct m.
    + rewrite HeqC0 in Hgy. apply SepE in Hgy as [_ Hgy].
      apply Hgy. eapply ap_ran... split...
    + rewrite HeqCn in Hgy. apply imgE in Hgy as [x [Hx Hp]].
      apply domI in Hp as Hxdg. apply func_ap in Hp...
      apply injectiveE in Hp... subst x. apply H. eapply nat_IFUnionI...
Qed.

(* 子集被支配 *)
Lemma dominate_sub : ∀ A B, A ⊆ B → A ≼ B.
Proof with auto.
  intros. exists (Ident A).
  pose proof (ident_bijection A) as [Hi [Hd Hr]].
  split; [|split]... rewrite Hr...
Qed.

(* 集合的并支配其元素 *)
Lemma union_dominate : ∀ a A, a ∈ A → a ≼ ⋃A.
Proof. intros. apply dominate_sub. apply ex2_3. apply H. Qed.

(* 若一个集合分别是两个等势的集合的子集和母集，则这三个集合等势 *)
Corollary sub_squeeze_to_eqnum : ∀ A B C,
  A ⊆ B → B ⊆ C → A ≈ C → A ≈ B ∧ B ≈ C.
Proof.
  intros * H1 H2 Hqn.
  apply dominate_sub in H1.
  apply dominate_sub in H2.
  apply eqnum_dominate in Hqn as H3. symmetry in Hqn.
  apply eqnum_dominate in Hqn as H4.
  split; apply Schröeder_Bernstein; auto;
  eapply dominate_trans; eauto.
Qed.

(* B支配A当且仅当存在B的子集与A等势 *)
Lemma dominate_iff : ∀ A B, A ≼ B ↔ (∃ C, C ⊆ B ∧ A ≈ C).
Proof with auto.
  intros. split.
  - intros [f [Hi [Hd Hr]]]. exists (dom f⁻¹). split.
    + intros x Hx. rewrite inv_dom in Hx. apply Hr...
    + exists f. split; [|split]... rewrite inv_dom...
  - intros [C [Hsub [f [Hi [Hd Hr]]]]]. exists f.
    split; [|split]... rewrite Hr...
Qed.

(* 任意自然数被ω支配 *)
Lemma ω_dominate : ∀n ∈ ω, n ≼ ω.
Proof with auto.
  intros n Hn. apply dominate_sub.
  apply trans_sub... apply ω_trans.
Qed.

(* 被有限集支配的集合是有限集 *)
Lemma dominated_by_finite_is_finite : ∀ A B,
  A ≼ B → finite B → finite A.
Proof with auto.
  intros A B [f [Hf [Hd Hr]]] Hfin.
  apply set_finite_iff_eqnum_finite_set.
  exists (dom (f⁻¹)). split.
  - symmetry. exists (f⁻¹). split; [|split]...
    apply inv_injective... rewrite inv_ran...
  - apply (subset_of_finite_is_finite _ B)...
    intros y Hy. rewrite inv_dom in Hy. apply Hr...
Qed.

Fact ω_eqnum_ω_cp_ω : ω ≈ ω × ω.
Proof with nauto.
  apply Schröeder_Bernstein.
  - set (Func ω (ω × ω) (λ n, <n, ∅>)) as f.
    exists f. apply meta_injection.
    + intros n Hn. apply CPrdI...
    + intros x1 _ x2 _ Heq. apply op_iff in Heq as []...
  - set (Func (ω × ω) ω (λ p, (2 ^ π1 p ⋅ 3 ^ π2 p)%ω)) as f.
    exists f. apply meta_injection.
    + intros p Hp.
      apply CPrdE1 in Hp as [n [Hn [m [Hm Hp]]]].
      subst p. zfc_simple. apply mul_ran; apply exp_ran...
    + intros p1 H1 p2 H2 Heq.
      apply CPrdE1 in H1 as [n [Hn [m [Hm H1]]]].
      apply CPrdE1 in H2 as [p [Hp [q [Hq H2]]]].
      subst p1 p2. zfc_simple.
      do 4 rewrite pow_isomorphic_ω in Heq...
      do 2 rewrite mul_isomorphic_ω in Heq...
      repeat rewrite proj_embed_id in Heq.
      apply embed_injective in Heq.
      apply inj_2n3m in Heq as [H1 H2].
      apply proj_injective in H1...
      apply proj_injective in H2... apply op_iff...
Qed.


Require Export D.

(** **** Exercise: 3 stars (update_permute)  *)
Theorem update_permute : forall n1 n2 x1 x2 x3 st,
  x2 <> x1 ->
  (update (update st x2 n1) x1 n2) x3 = (update (update st x1 n2) x2 n1) x3.
Proof.
  intros. unfold update. destruct (eq_id_dec x1 x3); destruct (eq_id_dec x2 x3); try (rewrite<-e in e0; contradiction); try reflexivity.
  Qed.


Require Export Coq.Strings.String.
Require Export Coq.ZArith.BinInt.
Require Export Coq.Arith.PeanoNat.
Require Export Lia.

Require Export Common.

From mathcomp Require Import all_ssreflect.
Set Bullet Behavior "Strict Subproofs".

(*Now we can transform "reflect" into computable "dec" EVEN if "reflect" is opaque.
  This is what we are missing in the ssreflect library. We do NOT match on
  "reflect"; we match on the boolean predicate directly*)
Definition reflect_dec' {P} {b} (H: reflect P b): {P} + {~P} :=
  match b as b1 return b = b1 -> _ with
  | true => fun Heq => left (elimT H Heq)
  | false => fun Hneq => right (elimF H Hneq)
  end erefl.

(*Type variable (ex: a)*)
Definition typevar : Set := string.

(*
Definition typevar_eqb : typevar -> typevar -> bool :=
  String.eqb.

Lemma typevar_eqb_spec (t1 t2: typevar) : reflect (t1 = t2) (typevar_eqb t1 t2).
Proof.
  apply String.eqb_spec.
Qed.*)

Definition string_eqMixin := EqMixin String.eqb_spec.
Canonical string_eqType := EqType string string_eqMixin.
(*Definition typevar_eqMixin := EqMixin typevar_eqb_spec.*)
Canonical typevar_eqType := EqType typevar string_eqMixin.

Definition typevar_eq_dec (t1 t2: typevar):
  {t1 = t2} + {t1 <> t2} := reflect_dec' (String.eqb_spec t1 t2).

(*Type symbol (ex: list a)*)
Record typesym : Set := mk_ts {
  ts_name : string;
  ts_args : list typevar;
  (*ts_args_uniq : nodupb typevar_eq_dec ts_args*)
  }.

Fixpoint list_eqb {A: Type} (eq: A -> A -> bool) (l1 l2: list A) : bool :=
  match l1, l2 with
  | x1 :: t1, x2 :: t2 => eq x1 x2 && list_eqb eq t1 t2
  | nil, nil => true
  | _, _ => false
  end.

Lemma list_eqb_spec: forall {A: Type} (eq: A -> A -> bool)
  (Heq: forall (x y : A), reflect (x = y) (eq x y))
  (l1 l2: list A),
  reflect (l1 = l2) (list_eqb eq l1 l2).
Proof.
  intros. revert l2. induction l1; simpl; intros.
  - destruct l2; simpl. apply ReflectT. constructor.
    apply ReflectF. intro C; inversion C.
  - destruct l2; simpl. apply ReflectF. intro C; inversion C.
    specialize (Heq a a0). destruct Heq.
    2 : {
      apply ReflectF. intro C; inversion C; subst; contradiction.
    }
    subst; simpl. specialize (IHl1 l2). destruct IHl1; subst.
    apply ReflectT. auto. apply ReflectF. intro C; inversion C; subst; contradiction.
Qed.

Definition bool_eqb (b1 b2: bool) : bool :=
  match b1, b2 with
  | true, true => true
  | false, false => true
  | _, _ => false
  end.

Lemma typesym_eq: forall (t1 t2: typesym),
  (ts_name t1) = (ts_name t2) ->
  (ts_args t1) = (ts_args t2) ->
  t1 = t2.
Proof.
  intros. destruct t1; destruct t2; simpl in *; subst. f_equal.
  (*apply bool_irrelevance.*)
Qed.

(*Definition is_true_eqb {b1 b2: bool} (p1: is_true b1) (p2: is_true b2) : bool :=
  Bool.eqb b1 b2.*)
(*
Definition typesym_eqb (t1 t2: typesym) :=
  String.eqb (ts_name t1) (ts_name t2) &&
  list_eqb typevar_eqb (ts_args t1) (ts_args t2) &&
  (*This is not needed (we show that below), but it is
    very useful for the "rewrite" lemmas in IndTypes*)
  is_true_eqb (ts_args_uniq t1) (ts_args_uniq t2).*)

Definition typesym_eqb (t1 t2: typesym) :=
  ((ts_name t1) == (ts_name t2)) &&
  ((ts_args t1) == (ts_args t2)).

Lemma typesym_eqb_spec: forall (t1 t2: typesym),
  reflect (t1 = t2) (typesym_eqb t1 t2).
Proof.
  move=>[n1 a1] [n2 a2]; rewrite /typesym_eqb/=.
  case: (n1 == n2) /eqP => Hn/=; last by
    apply ReflectF => [[C]].
  case: (a1 == a2) /eqP => Ha/=; last by
    apply ReflectF => [[C]].
  apply ReflectT. by rewrite Hn Ha.
Qed.

Definition typesym_eqMixin := EqMixin typesym_eqb_spec.
Canonical typesym_eqType := EqType typesym typesym_eqMixin.

(*
Definition typesym_eqb (t1 t2: typesym) :=
  String.eqb (ts_name t1) (ts_name t2) &&
  list_eqb typevar_eqb (ts_args t1) (ts_args t2).
(*
Lemma typesym_eqb_equiv: forall t1 t2,
  typesym_eqb t1 t2 = typesym_eqb' t1 t2.
Proof.
  intros. unfold typesym_eqb, typesym_eqb'.
  destruct (String.eqb_spec (ts_name t1) (ts_name t2)); simpl; auto.
  destruct (list_eqb_spec _ typevar_eqb_spec (ts_args t1) (ts_args t2)); simpl; auto.
  unfold is_true_eqb.
  rewrite e0. apply eqb_reflx.
Qed.*)

Lemma typesym_eqb_spec: forall (t1 t2: typesym),
  reflect (t1 = t2) (typesym_eqb t1 t2).
Proof.
  intros t1 t2. unfold typesym_eqb.
  destruct (String.eqb_spec (ts_name t1) (ts_name t2)); simpl.
  - destruct (list_eqb_spec typevar_eqb String.eqb_spec (ts_args t1) (ts_args t2)); simpl.
    + apply ReflectT. apply typesym_eq; auto.
    + apply ReflectF. intros C. destruct t1; destruct t2; subst. inversion C; contradiction.
  - apply ReflectF. intro C; destruct t1; destruct t2; inversion C; subst; contradiction.
Qed.*)

Definition typesym_eq_dec (t1 t2: typesym) : {t1 = t2} + {t1 <> t2} :=
  reflect_dec' (typesym_eqb_spec t1 t2).

Definition ts_unit : typesym := mk_ts "unit" nil (*eq_refl*).

(*Value types*)
Unset Elimination Schemes.
Inductive vty : Set :=
  | vty_int : vty
  | vty_real : vty
  | vty_var: typevar -> vty
  | vty_cons: typesym -> list vty -> vty.
Set Elimination Schemes.

(*Induction for this type*)
Section TyInd.
Variable P : vty -> Prop.
Variable Hint: P vty_int.
Variable Hreal: P vty_real.
Variable Hvar: forall v, P (vty_var v).
Variable Hcons: forall tsym vs,
  Forall P vs -> P (vty_cons tsym vs).

Fixpoint vty_ind (t: vty) : P t :=
  match t with
  | vty_int => Hint
  | vty_real => Hreal
  | vty_var t => Hvar t
  | vty_cons tsym vs => Hcons tsym vs
    ((fix vty_ind_list (l: list vty) : Forall P l :=
      match l with
      | nil => Forall_nil _
      | x :: t => Forall_cons _ (vty_ind x) (vty_ind_list t)
      end) vs)
  end.

End TyInd.

(*Need a version for Type too*)

Inductive ForallT {A: Type} (P: A -> Type) : list A -> Type :=
  | ForallT_nil: ForallT P nil
  | ForallT_cons: forall {x: A} {l: list A},
    P x -> ForallT P l -> ForallT P (x :: l).

Lemma ForallT_hd {A: Type} (P: A -> Type) (x: A) (l: list A):
  ForallT P (x :: l) ->
  P x.
Proof.
  intros. inversion X; subst. apply X0.
Qed.

Lemma ForallT_tl {A: Type} (P: A -> Type) (x: A) (l: list A):
  ForallT P (x :: l) ->
  ForallT P l.
Proof.
  intros. inversion X; auto.
Qed.

Section TyIndType.

Variable P : vty -> Type.
Variable Hint: P vty_int.
Variable Hreal: P vty_real.
Variable Hvar: forall v, P (vty_var v).
Variable Hcons: forall tsym vs,
  ForallT P vs -> P (vty_cons tsym vs).

Fixpoint vty_rect (t: vty) : P t :=
  match t with
  | vty_int => Hint
  | vty_real => Hreal
  | vty_var t => Hvar t
  | vty_cons tsym vs => Hcons tsym vs
    ((fix vty_ind_list (l: list vty) : ForallT P l :=
      match l with
      | nil => ForallT_nil _
      | x :: t => ForallT_cons _ (vty_rect x) (vty_ind_list t)
      end) vs)
  end.

  End TyIndType.

(*Decidable equality on types*)
Fixpoint vty_eqb (t1 t2: vty) : bool :=
  match t1, t2 with
  | vty_int, vty_int => true
  | vty_real, vty_real => true
  | vty_var t1, vty_var t2 => t1 == t2
  | vty_cons ts1 vs1, vty_cons ts2 vs2 =>
    (ts1 == ts2) &&
    ((fix vty_eqb_list (l1 l2: list vty) : bool :=
      match l1, l2 with
      | nil, nil => true
      | x1 :: t1, x2 :: t2 => vty_eqb x1 x2 && vty_eqb_list t1 t2
      | _, _ => false
      end) vs1 vs2)
  | _, _ => false
  end.

Lemma vty_eqb_eq: forall t1 t2,
  vty_eqb t1 t2 -> t1 = t2.
Proof.
  move=> t1; elim: t1 =>/=[t2 | t2 | v t2 | ts vs Hall t2];
  case: t2 =>//.
  - by move=> v2 => /eqP ->.
  - move=> ts2 vs2 => /andP[/eqP Hts Hlist].
    subst. f_equal. rewrite {ts2}.
    move: vs2 Hall Hlist. elim: vs =>
      [// [// | h2 t2 //] | h t /= IH [// | h2 t2 /=] Hall /andP[Hh Ht]].
    have->//: h = h2 by apply (Forall_inv Hall).
    f_equal. apply IH=>//. by apply (Forall_inv_tail Hall).
Qed.

Lemma vty_eq_eqb: forall t1 t2,
  t1 = t2 ->
  vty_eqb t1 t2.
Proof.
  move=> t1; elim: t1 =>/=[t2 | t2 | v t2 | ts vs Hall t2];
  case: t2 => //.
  - by move=> v2 [] /eqP.
  - move=> ts1 vs1 [] Hts Hvs; subst. rewrite eq_refl/=.
    rewrite {ts1}. move: Hall. elim: vs1 => [// | h t /= IH Hall].
    apply /andP; split.
    + by apply (Forall_inv Hall).
    + by apply IH, (Forall_inv_tail Hall).
Qed.

Lemma vty_eq_spec: forall t1 t2,
  reflect (t1 = t2) (vty_eqb t1 t2).
Proof.
  move=>t1 t2. case Heq: (vty_eqb t1 t2); constructor.
  - by apply vty_eqb_eq.
  - move=> C. have: vty_eqb t1 t2 by apply (vty_eq_eqb _ _ C).
    by rewrite Heq.
Qed.

Definition vty_eqMixin := EqMixin vty_eq_spec.
Canonical vty_eqType := EqType vty vty_eqMixin.

Definition vty_eq_dec (v1 v2: vty): {v1 = v2} + {v1 <> v2} :=
  reflect_dec' (vty_eq_spec v1 v2).

(* Sorts *)

(*Get the type variables in a type, with no duplicates*)
Fixpoint type_vars (t: vty) : list typevar :=
  match t with
  | vty_int => nil
  | vty_real => nil
  | vty_var v => [v]
  | vty_cons sym ts => big_union typevar_eq_dec type_vars ts
  end.

Lemma type_vars_unique: forall t,
  NoDup (type_vars t).
Proof.
  destruct t; simpl; try solve[constructor].
  - constructor; auto. constructor.
  - apply big_union_nodup.
Qed.

Definition is_sort (t: vty) : bool :=
  null (type_vars t).

Definition sort : Set := {t: vty | is_sort t}.

Coercion sort_to_ty (s: sort) : vty := @proj1_sig _ _ s.

Definition sorts_to_tys (l: list sort) : list vty :=
  map sort_to_ty l.

Lemma sort_inj: forall {s1 s2: sort},
  sort_to_ty s1 = sort_to_ty s2 ->
  s1 = s2.
Proof.
  intros s1 s2; destruct s1; destruct s2; simpl; intros Heq; subst.
  assert (i = i0) by apply bool_irrelevance.
  subst; reflexivity.
Qed.

Definition sort_eqb_spec: forall (s1 s2: sort),
  reflect (s1 = s2) ((sort_to_ty s1) == (sort_to_ty s2)).
Proof.
  move=> s1 s2. case: ((sort_to_ty s1) == (sort_to_ty s2)) /eqP => Hsort;
  constructor.
  - by apply sort_inj.
  - by move=> C; subst.
Qed.

Definition sort_eqMixin := EqMixin sort_eqb_spec.
Canonical sort_eqType := EqType sort sort_eqMixin.

Definition sort_eq_dec (s1 s2: sort) :
  {s1 = s2} + {s1 <> s2} :=
  reflect_dec _ _ (sort_eqb_spec s1 s2).
(*
Proof.
  intros. destruct (vty_eq_dec (sort_to_ty s1) (sort_to_ty s2)).
  - left. apply sort_inj. auto.
  - right. intro C; subst; contradiction.
Defined.*)

Lemma int_is_sort: is_sort vty_int.
Proof.
  unfold is_sort; simpl. auto.
Qed.

Definition s_int : sort := exist _ vty_int int_is_sort.

Lemma real_is_sort: is_sort vty_real.
Proof.
  unfold is_sort; simpl. auto.
Qed.

Definition s_real : sort := exist _ vty_real real_is_sort.

Lemma sort_type_vars: forall (s: sort),
  type_vars s = nil.
Proof.
  intros s. destruct s; simpl. unfold is_sort in i.
  destruct (type_vars x); auto. inversion i.
Qed.

Definition typesym_to_sort_proof: forall (t: typesym) (s: list sort),
  null (type_vars (vty_cons t (map sort_to_ty s))).
Proof.
  intros. assert (type_vars (vty_cons t (map sort_to_ty s)) = nil).
  2: { rewrite H; auto. } simpl. apply big_union_nil_eq. intros x Hinx.
  rewrite in_map_iff in Hinx. destruct Hinx as [y [Hy Hiny]]; subst.
  destruct y; simpl in *. unfold is_sort in i. clear Hiny.
  destruct (type_vars x); auto. inversion i.
Qed.

Definition typesym_to_sort (t: typesym) (s: list sort)  : sort :=
  exist _ (vty_cons t (map sort_to_ty s)) (typesym_to_sort_proof t s).

(* Type substitution *)

(*Substitute according to function*)
Fixpoint v_subst_aux (v: typevar -> vty) (t: vty) : vty :=
  match t with
  | vty_int => vty_int
  | vty_real => vty_real
  | vty_var tv => v tv
  | vty_cons ts vs => vty_cons ts (map (v_subst_aux v) vs)
  end.

Lemma v_subst_aux_sort: forall (v: typevar -> sort) t,
  is_sort (v_subst_aux v t).
Proof.
  intros v t. unfold is_sort.
  assert (H: type_vars (v_subst_aux v t) = nil); [|rewrite H; auto].
  induction t; simpl; intros; auto.
  apply sort_type_vars.
  induction vs; simpl; intros; auto.
  inversion H; subst.
  rewrite H2. auto.
Qed.

Definition v_subst (v: typevar -> sort) (t: vty) : sort :=
  exist _ (v_subst_aux v t) (v_subst_aux_sort v t).

Fixpoint ty_subst_fun (vs: list typevar) (s: list vty) (d: vty) : typevar -> vty :=
  fun v => match vs, s with
            | v1 :: tl1, ty :: tl2 => if typevar_eq_dec v v1 then ty else
              ty_subst_fun tl1 tl2 d v
            | _, _ => d
            end.

Lemma ty_subst_fun_sort: forall vs (s: list sort) (d: sort) (t: typevar),
  is_sort (ty_subst_fun vs (sorts_to_tys s) d t).
Proof.
  intros. revert s. induction vs; simpl; intros; auto. destruct d; auto.
  destruct s; simpl. destruct d; auto.
  destruct (typevar_eq_dec t a); subst. destruct s; auto. apply IHvs.
Qed.

Definition ty_subst_fun_s (vs: list typevar) (s: list sort) (d: sort) : typevar -> sort :=
  fun t => exist _ (ty_subst_fun vs (sorts_to_tys s) d t) (ty_subst_fun_sort vs s d t).

Definition ty_subst (vs: list typevar) (ts: list vty) (expr: vty) : vty :=
  v_subst_aux (ty_subst_fun vs ts vty_int) expr.

Definition ty_subst_list (vs: list typevar) (ts: list vty) (exprs: list vty) : list vty :=
  map (ty_subst vs ts) exprs.

Definition ty_subst_s (vs: list typevar) (ts: list sort) (expr: vty) : sort :=
  v_subst (ty_subst_fun_s vs ts s_int) expr.

Definition ty_subst_list_s (vs: list typevar) (ts: list sort) (exprs: list vty) : list sort :=
  map (ty_subst_s vs ts) exprs.

Lemma type_vars_cons: forall ts (vs: list vty),
  type_vars (vty_cons ts vs) = nil ->
  (forall x, In x vs -> type_vars x = nil).
Proof.
  intros. apply big_union_nil with(x:=x) in H; auto.
Qed.

(*Lemmas about substitution*)
Lemma ty_subst_s_cons: forall (vs: list typevar) (ts: list Types.sort)
  (t: typesym) (args: list vty),
  ty_subst_s vs ts (vty_cons t args) = typesym_to_sort t (ty_subst_list_s vs ts args).
Proof.
  intros. unfold ty_subst_list_s, ty_subst_s, v_subst. simpl. apply sort_inj; simpl.
  f_equal.
  apply list_eq_ext'; rewrite !map_length; auto.
  intros n d Hn. rewrite -> !(map_nth_inbound) with (d2:=d) by auto.
  rewrite -> (map_nth_inbound) with (d2:=s_int) by (rewrite map_length; auto).
  rewrite -> (map_nth_inbound) with (d2:=d) by auto.
  reflexivity.
Qed.

Lemma ty_subst_fun_nth: forall (vars: list typevar) (vs: list vty)
  (d: vty) (n: nat) (a: typevar) (s: vty),
  length vars = length vs ->
  (n < length vars)%coq_nat ->
  NoDup vars ->
  ty_subst_fun vars vs d (List.nth n vars a) = List.nth n vs s.
Proof.
intros vars vs d n a s'. revert n. revert vs. induction vars.
- simpl; intros; lia.
- intros; destruct vs.
  + inversion H.
  + destruct n.
    * simpl. destruct (typevar_eq_dec a0 a0); auto. contradiction.
    * simpl.
      inversion H1; subst. simpl in H0.
      destruct (typevar_eq_dec (List.nth n vars a) a0); subst; auto.
      -- exfalso. apply H4. apply nth_In. lia.
      -- apply IHvars; try lia. inversion H; auto. assumption.
Qed.

Lemma ty_subst_fun_in_sort (vars: list typevar) (srts: list sort)
  (d: vty) x:
  length srts = length vars ->
  In x vars ->
  is_sort (ty_subst_fun vars (sorts_to_tys srts) d x).
Proof.
  intros. generalize dependent srts.
  induction vars; simpl; intros. inversion H0.
  simpl in H0. destruct srts; simpl in *.
  - inversion H.
  - destruct (typevar_eq_dec x a); subst; simpl.
    + destruct s; auto.
    + destruct H0; subst; try contradiction.
      apply IHvars; auto.
Qed.

Lemma subst_same: forall (vars: list typevar) (srts: list Types.sort),
  length vars = length srts ->
  NoDup vars ->
  map (fun x => ty_subst_s vars srts (vty_var x)) vars = srts.
Proof.
  intros. apply list_eq_ext'; rewrite map_length; auto. intros n d Hd.
  assert (a: typevar). apply "A"%string.
  rewrite -> (map_nth_inbound) with (d2:=a); auto.
  unfold ty_subst_s. apply sort_inj; simpl.
  rewrite -> ty_subst_fun_nth with(s:=vty_int); try lia; unfold sorts_to_tys.
  rewrite -> (map_nth_inbound) with (d2:=d). reflexivity. lia.
  rewrite map_length; lia.
  assumption.
Qed.

Lemma is_sort_cons_iff: forall (ts: typesym) (l: list vty),
  is_sort (vty_cons ts l) <->
  forall x, In x l -> is_sort x.
Proof.
  intros. split; intros.
  - unfold is_sort in *. simpl in H.
    rewrite -> null_nil in *.
    eapply big_union_nil in H. apply H. assumption.
  - unfold is_sort in *. simpl. rewrite -> null_nil in *.
    apply big_union_nil_eq. intros.
    rewrite <- null_nil. apply H. auto.
Qed.

Lemma is_sort_cons: forall (ts: typesym) (l: list vty),
  is_sort (vty_cons ts l) ->
  forall x, In x l -> is_sort x.
Proof.
  intros ts l. apply is_sort_cons_iff.
Qed.

(* If we have a sort, then substituting a valuation does nothing *)
Lemma subst_is_sort_eq (t: vty) (Ht: is_sort t) (v: typevar -> vty):
  t = v_subst_aux v t.
Proof.
  induction t; simpl in *; auto. inversion Ht.
  f_equal. apply list_eq_ext'; [rewrite map_length|]; auto; intros.
  rewrite -> map_nth_inbound with (d2:=d); auto.
  rewrite Forall_nth in H. apply H; auto.
  apply (is_sort_cons _ _ Ht). apply nth_In; auto.
Qed.

Lemma subst_sort_eq: forall (s: sort) (v: typevar -> sort),
  s = v_subst v (sort_to_ty s).
Proof.
  intros. unfold v_subst. destruct s. apply sort_inj. simpl.
  apply subst_is_sort_eq; auto.
Qed.

Lemma v_subst_aux_ext (v1 v2: typevar -> vty) ty:
  (forall x, In x (type_vars ty) -> v1 x = v2 x ) ->
  v_subst_aux v1 ty = v_subst_aux v2 ty.
Proof.
  intros. induction ty; simpl; auto.
  rewrite H; simpl; auto.
  f_equal. simpl in H. induction vs; simpl in *; auto.
  inversion H0; subst.
  f_equal.
  - apply H3. intros; apply H. simpl_set; triv.
  - apply IHvs; auto. intros. apply H; simpl_set; auto.
Qed.

Lemma v_subst_ext (v1 v2: typevar -> sort) ty:
  (forall x, In x (type_vars ty) -> v1 x = v2 x) ->
  v_subst v1 ty = v_subst v2 ty.
Proof.
  intros. apply sort_inj, v_subst_aux_ext.
  intros. apply H in H0. apply (f_equal sort_to_ty) in H0.
  auto.
Qed.

Lemma v_ty_subst_eq_aux (params: list typevar) (srts: list sort)
  (v: typevar -> sort) ty
  (Hnodup: NoDup params)
  (Hlen: length srts = length params):
  (forall i, (i < length params)%coq_nat ->
    v (List.nth i params EmptyString) = List.nth i srts s_int) ->
  (forall x, In x (type_vars ty) -> In x params) ->
  v_subst_aux v ty = ty_subst params (sorts_to_tys srts) ty.
Proof.
  intros.
  unfold ty_subst.
  apply v_subst_aux_ext.
  intros.
  apply H0 in H1.
  destruct (In_nth _ _ EmptyString H1) as [i [Hi Hx]]; subst.
  rewrite H; auto.
  rewrite (ty_subst_fun_nth _ _ _ _ _ s_int); auto.
  - unfold sorts_to_tys.
    rewrite -> map_nth_inbound with(d2:=s_int); auto.
    rewrite Hlen; auto.
  - unfold sorts_to_tys. rewrite map_length. auto.
Qed.

(*Suppose we have a list of params and a list of srts such that
  for all i, v(nth i params) = nth i srts. Suppose that all
  type variables in ty are in params.
  Then v_subst v ty = ty_subst_list params srts ty*)
Lemma v_ty_subst_eq (params: list typevar) (srts: list sort)
  (v: typevar -> sort) ty
  (Hnodup: NoDup params)
  (Hlen: length srts = length params):
  (forall i, (i < length params)%coq_nat ->
    v (List.nth i params EmptyString) = List.nth i srts s_int) ->
  (forall x, In x (type_vars ty) -> In x params) ->
  v_subst v ty = ty_subst_s params srts ty.
Proof.
  intros.
  apply sort_inj; simpl.
  apply v_ty_subst_eq_aux; auto.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Essentials.HoTT_Facts.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Cat.Cat.

(* Product Category *)

(** The product of two categories has as objects pairs of objects (first component from the first category and the second component from the second category) and as arrows pairs of arrows.
 *)

Local Open Scope morphism_scope.

Local Obligation Tactic := idtac.

Program Definition Prod_Cat (C C' : Category) : Category :=
{|
  Obj := C * C';

  Hom :=
    fun a b =>
      (((fst a) –≻ (fst b)) * ((snd a) –≻ (snd b)))%type;

  compose :=
    fun a b c f g =>
      (((fst g) ∘ (fst f)), ((snd g) ∘ (snd f)))%morphism;

  id := fun c => (id, id)
|}.

Next Obligation.
  cbn.
  intros.
  rewrite (assoc (fst _)).
  rewrite assoc.
  trivial.
Defined.

Next Obligation.
  cbn.
  intros C C' a b c d f g h.
  rewrite (assoc_sym (fst _)).
  rewrite assoc_sym.
  trivial.
Defined.

Next Obligation.
  cbn.
  intros.
  rewrite (id_unit_left (fst _)).
  rewrite id_unit_left.
  trivial.
Defined.

Next Obligation.
  cbn.
  intros.
  rewrite (id_unit_right (fst _)).
  rewrite id_unit_right.
  trivial.
Defined.

Next Obligation.
Proof.
  intros C C' a b.
  apply Prod_Trunc; apply Hom_HSet.
Defined.

Notation "C × D" := (Prod_Cat C D) : category_scope.

Local Obligation Tactic := basic_simpl; auto.

Theorem Prod_compose_id
        (C D : Category)
        (a b c : C) (d : D)
        (f : a –≻ b) (g : b –≻ c)
  : (g ∘ f, id d)%morphism =
    @compose (_ × _) (_, _) (_, _) (_, _) (f, id d) (g, id d).
Proof.
  cbn; auto.
Qed.

Theorem Prod_id_compose
        (C D : Category)
        (a : C) (b c d : D)
        (f : b –≻ c) (g : c –≻ d)
  : (id a, g ∘ f)%morphism =
    @compose (_ × _) (_, _) (_, _) (_, _) (id a, f) (id a, g).
Proof.
  cbn; auto.
Qed.

Theorem Prod_cross_compose
        (C D : Category)
        (a b : C) (c d : D)
        (f : a –≻ b) (g : c –≻ d)
  : @compose
      (_ × _) (_, _) (_, _) (_, _)
      (@id _ a, g) (f, @id _ d)
    = @compose
        (_ × _) (_, _) (_, _) (_, _)
        (f, @id _ c) (@id _ b, g)
.
Proof.
  cbn; auto.
Qed.

Program Definition Cat_Proj1
        (C C' : Category) :
  ((C × C') –≻ C)%functor
  :=
    {|FO := fst; FA := fun _ _ f => fst f|}
.

Program Definition Cat_Proj2
        (C C' : Category) :
  ((C × C') –≻ C')%functor
  :=
    {|FO := snd; FA := fun _ _ f => snd f|}
.

Instance Prod_Cat_HSet
        (C C' : Category)
        (HC : IsHSet C)
        (HC' : IsHSet C'):
  IsHSet (C × C')%category
.
Proof.
  apply Prod_Trunc; trivial.
Defined.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Coq_Cats.Type_Cat.Type_Cat.
Require Import Limits.Limit Limits.GenProd_GenSum.
Require Import Archetypal.Discr.Discr.
Require Import PreSheaf.PreSheaf.
Require Import NatTrans.NatTrans NatTrans.Func_Cat.

Section PSh_GenProd.
  Context (C : Category) (A : Type) (map : A → PShCat C).

  Local Notation Fm := (Discr_Func (PShCat C) map) (only parsing).

  Local Hint Extern 1 => match goal with
                          [|- context [(?F _a id)%morphism]] => rewrite (F_id F)
                        end.
  Local Hint Extern 1 =>
  match goal with
    [|- context [(?F _a (?f ∘ ?g))%morphism]] =>
    cbn_rewrite (F_compose F f g)
  end.

  (** The generalized product presheaf. *)
  Program Definition PSh_GenProd_func : PreSheaf C :=
    {|
      FO :=
        fun c =>
          ∀ x : A, ((Fm _o x) _o c)%object;
      FA :=
        fun _ _ h f x => (map x _a h (f x))%morphism
    |}.

  (** The projections of generalized product presheaf. *)
  Program Definition PSh_GenProd_proj (x : A) :
    (PSh_GenProd_func –≻ map x)%nattrans :=
    {|
      Trans := fun c y => y x
    |}.

  (** The cone for generalized product presheaf. *)
  Program Definition PSh_GenProd_Cone : Cone Fm :=
    {|
      cone_apex :=
        {|FO := fun _ => PSh_GenProd_func;
          FA :=
            fun _ _ h => id
        |};
      cone_edge := {|Trans := fun x => PSh_GenProd_proj x |}
    |}.

  Local Hint Extern 1 =>
    match goal with
      [|- context [Trans ?f _ ((?F _a)%morphism ?h _)]] =>
      cbn_rewrite (equal_f (Trans_com f h))
    end.

  Local Hint Extern 1 => match goal with [H : unit |- _] => destruct H end.

  Local Hint Resolve NatTrans_eq_simplify.

  Local Hint Extern 1 => rewrite From_Term_Cat.

  (** The morphism that maps to the generalized product given a map to its
      components. *)
  Program Definition PSh_GenProd_morph_ex
          (Cn : LoKan_Cone (Functor_To_1_Cat
                              (Discr_Cat A)) (Discr_Func (PShCat C) map))
    : ((Cn _o)%object tt –≻ PSh_GenProd_func)%nattrans :=
    {|
      Trans := fun c y x => Trans (Trans (cone_edge Cn) x) c y
    |}.

  Local Hint Extern 1 => progress cbn.

  Local Obligation Tactic := basic_simpl; auto 10.

  Program Definition PSh_GenProd : (Π map)%object :=
    {|
      LRKE := PSh_GenProd_Cone;
      LRKE_morph_ex :=
        fun Cn =>
          {|
            cone_morph :=
              {|
                Trans :=
                  fun x =>
                    match x as u return
                          ((Cn _o)%object u –≻ PSh_GenProd_func)%nattrans
                    with
                      tt => PSh_GenProd_morph_ex Cn
                    end
              |}
          |}
    |}.

  Local Obligation Tactic := idtac.

  Next Obligation.
  Proof.
    intros Cn h h'.
    apply NatTrans_eq_simplify.
    extensionality x.
    apply NatTrans_eq_simplify.
    extensionality y.
    extensionality z.
    extensionality u.
    cbn in *.
    destruct x.
    cbn_rewrite
      <-
      (
        equal_f
          (
            f_equal
              (
                fun w : (Cn ∘ Functor_To_1_Cat
                          (Discr_Cat A) –≻ Discr_Func (PShCat C) map)%nattrans
                => Trans (Trans w u) y
              )
              (cone_morph_com h)
          )
          z
      ).
    cbn_rewrite
      <-
      (
        equal_f
          (
            f_equal
              (
                fun w : (Cn ∘ Functor_To_1_Cat
                          (Discr_Cat A) –≻ Discr_Func (PShCat C) map)%nattrans
                => Trans (Trans w u) y
              )
              (cone_morph_com h')
          )
          z
      ).
    trivial.
  Qed.

End PSh_GenProd.


(******************************************************************************)
(* Chapter 1.4: Functors                                                      *)
(******************************************************************************)
(* @suharahiromichi *)

(*
(0)
同じディレクトリにある Categories.v を使う。

(1) ベースライン
http://www.megacz.com/berkeley/coq-categories/
これをもとに改変。Instance ... Proper を使うようにした。
 *)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import finset fintype.

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

Require Import Notations.
Require Import Morphisms.
Require Import Categories.

Class Functor `(C1 : Category) `(C2 : Category) (fobj : C1 -> C2) :=
  {
    functor_fobj := fobj;
    fmor                : forall {a b : C1}, a ~> b -> (fobj a) ~> (fobj b);
    fmor_respects       : forall {a b : C1} {f f' : a ~> b},
                            f === f' -> fmor f === fmor f';
    fmor_preserves_id   : forall {a : C1}, @fmor a a id === id;
(* forall a, fmor (id a) === id (fobj a); *)
    fmor_preserves_comp : forall {a b c : C1} {f : a ~> b} {g : b ~> c},
                            (fmor g) \\o (fmor f) === fmor (g \\o f)
  }.
Coercion functor_fobj : Functor >-> Funclass.

Check functor_fobj : ∀Obj Hom C1 Obj0 Hom0 C2 fobj _ _, C2.
(* ,の前の最後の「_」は、普通の引数で、C1（の対象） *)
Check @fmor        : ∀Obj Hom C1 Obj0 Hom0 C2 fobj _ a b _, fobj a ~> fobj b.
(* ,の前の最後の「_」は、普通の引数で、a ~> b の型を持つ。 *)

(* fobj と fmor の意味：
カテゴリ1 C1 = (Obj, Hom)
カテゴリ2 C2 = (Obj0, Hom0)

fobj : C1 -> C2、カテゴリC1（の対象）からC2（の対象）への写像
ファンクタからのコアーションが効く。

fmor : (a ~> b) -> (fobj a ~> fobj b)
カテゴリC1（の射）からC2（の射）への写像、
ただし fobj が与えられないと、意味をなさないことに注意！
 *)

Check @fmor : ∀Obj Hom C1 Obj0 Hom0 C2 fobj _ a b _, fobj a ~> fobj b.
Check fmor : _ ~> _ -> _ ~> _.
About fmor.                       (* Set Implicit Arguments の所為で、
                                     fobj は implicit になっている。 *)
Arguments fmor {Obj Hom Obj0 Hom0 C1 C2} fobj {_ a b} _ : rename.
Check fmor.                          (* fobj を指定するようにする。 *)

Notation "F \ f" := (fmor F f) : category_scope.
Open Scope category_scope.

(* parametric_morphism_fmor *)
(* これの証明に、Classの公理に Proper (eqv ==> eqv) fmor が必要なわけではない。 *)
(* また、(@fmor _ _ .... a b) は fmor と略せない。  *)
Instance functor_fmor_Proper `(C1 : Category) `(C2 : Category)
         (Fobj : C1 -> C2) (F : Functor Fobj) (a b : C1) :
  Proper (@eqv (a ~> b) ==> @eqv (Fobj a ~> Fobj b)) (@fmor _ _ _ _ _ _ _ _ a b).
Proof.
  move=> x y.                               (* これが肝 *)
  Check (@fmor_respects _ _ C1 _ _ C2 Fobj F a b x y).
  by apply (@fmor_respects _ _ C1 _ _ C2 Fobj F a b x y).
Qed.

(* 恒等関手 *)
(* the identity functor *)
Definition functor_id `(C : Category) : Functor (fun (x : C) => x).
Proof.
  (* 恒等関手 : C -> C *)
  Check (fun (x : C) => C).                 (* カテゴリC(の対象)から、カテゴリC(の対象)の写像 *)
  Check (fun (a b : C) (f : a ~> b) => f).  (* カテゴリC(の射)から、カテゴリC(の射)の写像 *)

  (* ***** *)
  About Build_Functor.
  Check (@Build_Functor _ _ C _ _ C).
  Check (@Build_Functor _ _ C _ _ C (fun (x : C) => x)). (* fobj を与える。 *)
  Check (@Build_Functor _ _ C _ _ C (fun (x : C) => x)
                        (fun (a b : C) (f : a ~> b) => f)). (* fmor を与える。 *)
  apply (@Build_Functor _ _ C _ _ C (fun x => x) (fun a b f => f)).
  (* fmor_respects *)
  - move=> a b f f' H.
    rewrite H.
    reflexivity.
  (* fmor_preserves_id *)
  - reflexivity.
  (* fmor_preserves_comp *)
  - reflexivity.
Defined.

(* 定数関手 *)
(* the constant functor *)
Definition functor_const `(C : Category) `{D : Category} (d : D) :
  Functor (fun (x : C) => d).
Proof.
  (* 定数関手 : C -> D *)
  Check (fun (x : C) => d).                 (* カテゴリC(の対象)から、カテゴリD(の対象)の写像 *)
  Check (fun (a b : C) (f : a ~> b) => id).  (* カテゴリC(の射)から、カテゴリD(の射)の写像 *)

  About Build_Functor.
  Check (@Build_Functor _ _ C _ _ D (fun (x : C) => d)). (* fobj を与える。 *)
  Check (@Build_Functor _ _ C _ _ D (fun (x : C) => d)
                        (fun (a b : C) (f : a ~> b) => id)). (* fmor を与える。 *)
  apply (@Build_Functor _ _ C _ _ D (fun _ => d) (fun _ _ _ => id)).
  - reflexivity.
  - reflexivity.
  - move=> a b c _ _.
    by apply left_identity.
Defined.

Generalizable Variables Fobj Gobj.

Locate "_ ○ _".                            (* "f ○ g" := fun x => f (g x) *)
Locate "_ \o _".                            (* SSReflect では、こっちを使う。 *)
Locate "_ \\o _".                           (* "f \\o g" := comp f g *)

(* 関手の合成 *)
(* functors compose *)
Definition functor_comp `(C1 : Category) `(C2 : Category) `(C3 : Category)
           `(F : @Functor _ _ C1 _ _ C2 Fobj) `(G : @Functor _ _ C2 _ _ C3 Gobj) :
  Functor (Gobj \o Fobj).
Proof.
  Check F : C1 -> C2.              (* C1の対象からC2の対象への写像  *)
  Check Fobj : C1 -> C2.           (* C1の対象からC2の対象への写像  *)
  Check fmor F.                    (* C1の射からC2の射への写像 *)
  Check G : C2 -> C3.              (* C2の対象からC3の対象への写像  *)
  Check Gobj : C2 -> C3.           (* C2の対象からC3の対象への写像  *)
  Check fmor G.                    (* C2の射からC3の射への写像 *)

  Check G \o F.
  Check Gobj \o Fobj.

  Check (fun (a b : C1) (m : a ~> b) => fmor F m). (* m は C1の射 *) (* C2の射を返す *)
  Check (fun (a b : C1) (m : a ~> b) => F \ m).

  Check (fun (a b : C1) (m : a ~> b) => fmor G (fmor F m)). (* C3の射を返す *)
  Check (fun (a b : C1) (m : a ~> b) => G \ (F \ m)).

  Check @Build_Functor _ _ C1 _ _ C3.
  Check @Build_Functor _ _ C1 _ _ C3 (G \o F). (* fobj を与える。 *)
  Check @Build_Functor _ _ C1 _ _ C3 (G \o F)
        (fun a b m => G \ (F \ m)).  (* fmor を与える。 *)

  apply (@Build_Functor _ _ C1 _ _ C3 (G \o F)
                        (fun a b m => G \ (F \ m))).
  - move=> a b f f' H.
    rewrite H.
    reflexivity.
  - repeat setoid_rewrite fmor_preserves_id.
    reflexivity.
  - rewrite /=.                             (* G \o F のfuncompを評価する。 *)
    repeat setoid_rewrite fmor_preserves_comp.
    reflexivity.
Defined.

(* みなおし、ここまで。 *)

Notation "f >>>> g" := (@functor_comp _ _ _ _ _ _ _ _ _ _ f _ g)   : category_scope.
Open Scope category_scope.

Generalizable Variables Xobj Yobj Zobj a b.

(*
Lemma functor_comp_assoc `{C : Category} `{D : Category} `{E : Category} `{F : Category}
      `(F1 : @Functor _ _ C _ _ D Xobj)
      `(F2 : @Functor _ _ D _ _ E Yobj)
      `(F3 : @Functor _ _ E _ _ F Zobj) :
  forall (a b : C) (f : a ~> b),
    ((F1 >>>> F2) >>>> F3) \ f === (F1 >>>> (F2 >>>> F3)) \ f.

Lemma functor_comp_assoc `{C':Category}`{D:Category}`{E:Category}`{F:Category}
  {F1obj}(F1:Functor C' D F1obj)
  {F2obj}(F2:Functor D E F2obj)
  {F3obj}(F3:Functor E F F3obj)
  `(f:a~>b) :
  ((F1 >>>> F2) >>>> F3) \ f ~~ (F1 >>>> (F2 >>>> F3)) \ f.
  intros; simpl.
  reflexivity.
  Qed.
*)

(* this is like JMEq, but for the particular case of ~~; note it does not require any axioms! *)

Inductive heq_morphisms `{C : Category} {a b : C} (f : a ~> b) :
  forall {a' b' : C}, a' ~> b' -> Prop :=
| heq_morphisms_intro {f' : a ~> b} :
    eqv f f' -> @heq_morphisms _ _ C a b f a b f'.

Definition heq_morphisms_refl `{C : Category} a b f :
  @heq_morphisms _ _ C a b f a  b  f.
Proof.
  apply heq_morphisms_intro.
  reflexivity.
Qed.
Check heq_morphisms_refl.
Check @heq_morphisms_refl :
  forall {Obj Hom C} {a b : Obj} {f : a ~> b},
    heq_morphisms f f.

Definition heq_morphisms_symm `{C : Category} a b f a' b' f' :
  @heq_morphisms _ _ C a b f a' b' f' -> @heq_morphisms _ _ C a' b' f' a b f.
Proof.
  generalize Obj Hom C a b f a' b' f'.
  refine (fun ob hom c a b f a' b' f' isd =>
            match isd with
              | heq_morphisms_intro f''' z => @heq_morphisms_intro _ _ c _ _ f''' f _
            end).
  rewrite z.
  reflexivity.
Qed.
Check heq_morphisms_symm.
Check @heq_morphisms_symm :
  forall {Obj Hom C}
         {a b : Obj} {f : a ~> b}
         {a' b' : Obj} {f' : a' ~> b'},
    heq_morphisms f f' -> heq_morphisms f' f.

Definition heq_morphisms_tran `{C : Category} a b f a' b' f' a'' b'' f'' :
  @heq_morphisms _ _ C a b f a' b' f' ->
  @heq_morphisms _ _ C a' b' f' a'' b'' f'' ->
  @heq_morphisms _ _ C a b f a'' b'' f''.
  destruct 1.
  destruct 1.
  apply heq_morphisms_intro.
  setoid_rewrite <- H0.
  apply H.
Qed.
Check heq_morphisms_tran.
Check @heq_morphisms_tran :
  forall {Obj Hom C}
         {a b : Obj} {f : a ~> b}
         {a' b' : Obj} {f' : a' ~> b'}
         {a'' b'' : Obj} {f'' : a'' ~> b''},
    heq_morphisms f f' -> heq_morphisms f' f'' -> heq_morphisms f f''.

(*
Add Parametric Relation  (Ob:Type)(Hom:Ob->Ob->Type)(C:Category Ob Hom)(a b:Ob) : (hom a b) (eqv a b)
  reflexivity proved by  heq_morphisms_refl
  symmetry proved by     heq_morphisms_symm
  transitivity proved by heq_morphisms_tran
  as parametric_relation_heq_morphisms.
  Add Parametric Morphism `(c:Category Ob Hom)(a b c:Ob) : (comp a b c)
  with signature (eqv _ _ ==> eqv _ _ ==> eqv _ _) as parametric_morphism_comp.
  auto.
  Defined.
*)

Implicit Arguments heq_morphisms [ Obj Hom C a b a' b' ].
Hint Constructors heq_morphisms.

Definition EqualFunctors `{C1 : Category} `{C2 : Category}
           {F1obj} (F1 : Functor F1obj)
           {F2obj} (F2 : Functor F2obj) :=
  forall a b (f f' : hom a b),
    f === f' -> heq_morphisms (fmor F1 f) (fmor F2 f').
(* f f' : a~~{C1}~~>b *)

Notation "f ~~~~ g" := (EqualFunctors f g) (at level 45).

Class IsomorphicCategories `(C : Category) `(D : Category) :=
  {
    ic_f_obj    : C -> D;
    ic_g_obj    : D -> C;
    ic_f        : Functor ic_f_obj;
    ic_g        : Functor ic_g_obj;

    ic_forward  : ic_f >>>> ic_g ~~~~ functor_id C;
    ic_backward : ic_g >>>> ic_f ~~~~ functor_id D
  }.

(* this causes Coq to die: *)
(* Definition IsomorphicCategories := Isomorphic (CategoryOfCategories). *)


Require Import String.
Require Import ZArith.

Inductive val : Type :=
| Vbool : bool -> val
| Vint  : Z -> val
| Vstr  : string -> val
| Vaddr : Z -> val.

Inductive op1 : Type :=
| Oneg
| Onot.

Inductive op2 : Type :=
| Oadd
| Osub
| Omul
| Odiv
| Omod
| Oeq
| Olt
| Ole
| Oconj
| Odisj.

Inductive expr : Type :=
| Eval : val -> expr
| Evar : string -> expr
| Eop1 : op1 -> expr -> expr
| Eop2 : op2 -> expr -> expr -> expr
| Elen : expr -> expr
| Eidx : expr -> expr -> expr.

Definition store : Type :=
  list (string * val).

Definition heap : Type :=
  list val.

Inductive stmt : Type :=
| Snop : stmt
| Sset : string -> expr -> stmt
| Salloc : string -> expr -> expr -> stmt
| Swrite : string -> expr -> expr -> stmt
| Scall : string -> string -> list expr -> stmt
| Sifelse : expr -> stmt -> stmt -> stmt
| Swhile : expr -> stmt -> stmt
| Sseq : stmt -> stmt -> stmt
| Sincall : stmt -> expr -> string -> store -> stmt.

Inductive func : Type :=
| Func : string -> list string -> stmt -> expr -> func.

Inductive prog : Type :=
| Prog : list func -> stmt -> expr -> prog.


Require Import propInv4.
Require Import verif_cond_7.
Require Import extra7.
Local Open Scope Z.

Theorem proof4_7: (startnewloop hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1) /\ cond7 ->
 (inv hands1 dryer1 ctrlState1 ctrlTimer1 timer1).

Proof.
intros.
split.
unfold propInv4.
inversion_clear H.
inversion_clear H1.
inversion_clear H2.
inversion_clear H3.
intros.
(*analysis of cases i<timer1 and i=timer1*)
elim Zle_lt_or_eq with i timer1.
intros.
apply startnewloop_to_propInv.
assumption.
split.
apply H3.
inversion_clear H0.
auto with zarith.
assumption.
(*analysis of case i=timer1*)
intros.
rewrite H6 in H5.
inversion_clear H5.
elimtype False.
auto.
inversion_clear H3.
assumption.
apply extra7.
split.
inversion_clear H.
inversion_clear H0.
split.
apply H.
assumption.
apply H.
Qed.