Set Implicit Arguments.

Require Import
        Bool
        List
        Data.Zipper
        Tactics.Tactics.

Section PROPERTIES.

  Variable A : Type.
  Variable eqADec : forall (x y : A), {x = y} + {x <> y}.

  Lemma to_list__from_list : forall (xs : list A), to_list (from_list xs) = xs.
  Proof.
    induction xs ; crush.
  Qed.

  Lemma from_list__to_list : forall (z : zipper A),
      from_list (to_list (startz z)) = (startz z).
  Proof.
    destruct z ; simpl.
    unfold from_list.
    auto.
  Qed.

  Lemma startp__startz : forall (z : zipper A), Is_true (beginp (startz z)).
  Proof.
    intros z ; unfold Is_true, beginp, startz ; destruct z ; auto.
  Qed.

  Lemma endp__endz : forall (z : zipper A), Is_true (endp (endz z)).
  Proof.
    intros z ; unfold Is_true , endp, endz ; destruct z ; auto.
  Qed.

  Definition second (xs : list A) : option A :=
    match xs with
    | (_ :: x :: _) => Some x
    | _             => None
    end.

  Definition combine (x : option A)(xs : list A) : list A :=
    match x with
    | Some y => y :: xs
    | _      => xs
    end.

  Lemma right_correct : forall (z : zipper A),
      safe_cursor (right z) = (second (future z)) /\
      (past (right z) = (combine (safe_cursor z) (past z))).
  Proof.
    intros z ; destruct z ; destruct l0 ; crush.
  Qed.

  Lemma left_correct : forall (z : zipper A),
      (past (left z) = tl (past z)) /\
      (safe_cursor (left z) = (hd_error (combine (hd_error (past z)) (future z)))).
  Proof.
    intros z ; destruct z ; destruct l ; crush.
  Qed.

  Lemma insert_correct : forall (z : zipper A)(x : A), safe_cursor (insert x z) = Some x.
  Proof.
    intros z x ; destruct z ; crush.
  Qed.

  Lemma count_occ_app
    : forall (xs ys : list A)(x : A),
      count_occ eqADec (xs ++ ys) x = count_occ eqADec xs x + count_occ eqADec ys x.
  Proof.
    induction xs ; intros ; crush.
    destruct (eqADec a x) eqn : Ha ; substs*.
  Qed.

  Lemma delete_removes : forall (z : zipper A),
      match safe_cursor z with
      | Some x =>
        count_occ eqADec (to_list z) x =
        1 + count_occ eqADec (to_list (delete z)) x
      | _      => True
      end.
  Proof.
    Hint Rewrite count_occ_app.
    intros z ; destruct (safe_cursor z) eqn : Ha ; crush.
    destruct z ; destruct l0 ; crush.
    destruct (eqADec a a) ; crush.
  Qed.

  Lemma push_pop_correct
    : forall (z : zipper A)(x : A),
      pop (push x z) = z.
  Proof.
    destruct z ; crush.
  Qed.

  Lemma replacez_correct
    : forall (z : zipper A)(x : A),
      Is_true (endp z) \/ (safe_cursor (replacez x z) = Some x).
  Proof.
    intros z x ; destruct z ; destruct l0 ; crush.
  Qed.

  Lemma reversez_idem : forall (z : zipper A), reversez (reversez z) = z.
  Proof.
    destruct z ; crush.
  Qed.
End PROPERTIES.


(* generated by Ott 0.25, locally-nameless lngen from: systemf.ott *)
Require Import Metalib.Metatheory.
(** syntax *)
Definition typ := var. (*r type variables *)
Definition x := var. (*r variables *)

Inductive Typ : Set :=  (*r type *)
 | t_var_b (_:nat) (*r variable *)
 | t_var_f (typ5:atom) (*r variable *)
 | t_arr (t1:Typ) (t2:Typ) (*r function *)
 | t_all (t:Typ) (*r polymorphic *).

Inductive Exp : Set :=  (*r expression *)
 | e_var_b (_:nat) (*r variable *)
 | e_var_f (x5:atom) (*r variable *)
 | e_lam (t:Typ) (e:Exp) (*r abstraction *)
 | e_ap (e1:Exp) (e2:Exp) (*r application *)
 | e_Lam (e:Exp) (*r type abstraction *)
 | e_App (e:Exp) (t:Typ) (*r type application *).

Definition D : Set := list typ.

Definition G : Set := list (x * Typ).

(* EXPERIMENTAL *)
(** auxiliary functions on the new list types *)
(** library functions *)
(** subrules *)
(** arities *)
(** opening up abstractions *)
Fixpoint open_Typ_wrt_Typ_rec (k:nat) (t_5:Typ) (t__6:Typ) {struct t__6}: Typ :=
  match t__6 with
  | (t_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => t_var_b nat
        | inleft (right _) => t_5
        | inright _ => t_var_b (nat - 1)
      end
  | (t_var_f typ5) => t_var_f typ5
  | (t_arr t1 t2) => t_arr (open_Typ_wrt_Typ_rec k t_5 t1) (open_Typ_wrt_Typ_rec k t_5 t2)
  | (t_all t) => t_all (open_Typ_wrt_Typ_rec (S k) t_5 t)
end.

Fixpoint open_Exp_wrt_Exp_rec (k:nat) (e_5:Exp) (e__6:Exp) {struct e__6}: Exp :=
  match e__6 with
  | (e_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => e_var_b nat
        | inleft (right _) => e_5
        | inright _ => e_var_b (nat - 1)
      end
  | (e_var_f x5) => e_var_f x5
  | (e_lam t e) => e_lam t (open_Exp_wrt_Exp_rec (S k) e_5 e)
  | (e_ap e1 e2) => e_ap (open_Exp_wrt_Exp_rec k e_5 e1) (open_Exp_wrt_Exp_rec k e_5 e2)
  | (e_Lam e) => e_Lam (open_Exp_wrt_Exp_rec k e_5 e)
  | (e_App e t) => e_App (open_Exp_wrt_Exp_rec k e_5 e) t
end.

Fixpoint open_Exp_wrt_Typ_rec (k:nat) (t5:Typ) (e_5:Exp) {struct e_5}: Exp :=
  match e_5 with
  | (e_var_b nat) => e_var_b nat
  | (e_var_f x5) => e_var_f x5
  | (e_lam t e) => e_lam (open_Typ_wrt_Typ_rec k t5 t) (open_Exp_wrt_Typ_rec k t5 e)
  | (e_ap e1 e2) => e_ap (open_Exp_wrt_Typ_rec k t5 e1) (open_Exp_wrt_Typ_rec k t5 e2)
  | (e_Lam e) => e_Lam (open_Exp_wrt_Typ_rec (S k) t5 e)
  | (e_App e t) => e_App (open_Exp_wrt_Typ_rec k t5 e) (open_Typ_wrt_Typ_rec k t5 t)
end.

Definition open_Exp_wrt_Exp e_5 e__6 := open_Exp_wrt_Exp_rec 0 e__6 e_5.

Definition open_Exp_wrt_Typ t5 e_5 := open_Exp_wrt_Typ_rec 0 e_5 t5.

Definition open_Typ_wrt_Typ t_5 t__6 := open_Typ_wrt_Typ_rec 0 t__6 t_5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_Typ *)
Inductive lc_Typ : Typ -> Prop :=    (* defn lc_Typ *)
 | lc_t_var_f : forall (typ5:typ),
     (lc_Typ (t_var_f typ5))
 | lc_t_arr : forall (t1 t2:Typ),
     (lc_Typ t1) ->
     (lc_Typ t2) ->
     (lc_Typ (t_arr t1 t2))
 | lc_t_all : forall (t:Typ),
      ( forall typ5 , lc_Typ  ( open_Typ_wrt_Typ t (t_var_f typ5) )  )  ->
     (lc_Typ (t_all t)).

(* defns LC_Exp *)
Inductive lc_Exp : Exp -> Prop :=    (* defn lc_Exp *)
 | lc_e_var_f : forall (x5:x),
     (lc_Exp (e_var_f x5))
 | lc_e_lam : forall (t:Typ) (e:Exp),
     (lc_Typ t) ->
      ( forall x5 , lc_Exp  ( open_Exp_wrt_Exp e (e_var_f x5) )  )  ->
     (lc_Exp (e_lam t e))
 | lc_e_ap : forall (e1 e2:Exp),
     (lc_Exp e1) ->
     (lc_Exp e2) ->
     (lc_Exp (e_ap e1 e2))
 | lc_e_Lam : forall (e:Exp),
      ( forall typ5 , lc_Exp  ( open_Exp_wrt_Typ e (t_var_f typ5) )  )  ->
     (lc_Exp (e_Lam e))
 | lc_e_App : forall (e:Exp) (t:Typ),
     (lc_Exp e) ->
     (lc_Typ t) ->
     (lc_Exp (e_App e t)).
(** free variables *)
Fixpoint tt_fv_Typ (t_5:Typ) : vars :=
  match t_5 with
  | (t_var_b nat) => {}
  | (t_var_f typ5) => {{typ5}}
  | (t_arr t1 t2) => (tt_fv_Typ t1) \u (tt_fv_Typ t2)
  | (t_all t) => (tt_fv_Typ t)
end.

Fixpoint tt_fv_Exp (e_5:Exp) : vars :=
  match e_5 with
  | (e_var_b nat) => {}
  | (e_var_f x5) => {}
  | (e_lam t e) => (tt_fv_Typ t) \u (tt_fv_Exp e)
  | (e_ap e1 e2) => (tt_fv_Exp e1) \u (tt_fv_Exp e2)
  | (e_Lam e) => (tt_fv_Exp e)
  | (e_App e t) => (tt_fv_Exp e) \u (tt_fv_Typ t)
end.

Fixpoint e_fv_Exp (e_5:Exp) : vars :=
  match e_5 with
  | (e_var_b nat) => {}
  | (e_var_f x5) => {{x5}}
  | (e_lam t e) => (e_fv_Exp e)
  | (e_ap e1 e2) => (e_fv_Exp e1) \u (e_fv_Exp e2)
  | (e_Lam e) => (e_fv_Exp e)
  | (e_App e t) => (e_fv_Exp e)
end.

(** substitutions *)
Fixpoint t_subst_Typ (t_5:Typ) (ryp5:typ) (t__6:Typ) {struct t__6} : Typ :=
  match t__6 with
  | (t_var_b nat) => t_var_b nat
  | (t_var_f typ5) => (if eq_var typ5 ryp5 then t_5 else (t_var_f typ5))
  | (t_arr t1 t2) => t_arr (t_subst_Typ t_5 ryp5 t1) (t_subst_Typ t_5 ryp5 t2)
  | (t_all t) => t_all (t_subst_Typ t_5 ryp5 t)
end.

Fixpoint e_subst_Exp (e_5:Exp) (y5:x) (e__6:Exp) {struct e__6} : Exp :=
  match e__6 with
  | (e_var_b nat) => e_var_b nat
  | (e_var_f x5) => (if eq_var x5 y5 then e_5 else (e_var_f x5))
  | (e_lam t e) => e_lam t (e_subst_Exp e_5 y5 e)
  | (e_ap e1 e2) => e_ap (e_subst_Exp e_5 y5 e1) (e_subst_Exp e_5 y5 e2)
  | (e_Lam e) => e_Lam (e_subst_Exp e_5 y5 e)
  | (e_App e t) => e_App (e_subst_Exp e_5 y5 e) t
end.

Fixpoint t_subst_Exp (t5:Typ) (ryp5:typ) (e_5:Exp) {struct e_5} : Exp :=
  match e_5 with
  | (e_var_b nat) => e_var_b nat
  | (e_var_f x5) => e_var_f x5
  | (e_lam t e) => e_lam (t_subst_Typ t5 ryp5 t) (t_subst_Exp t5 ryp5 e)
  | (e_ap e1 e2) => e_ap (t_subst_Exp t5 ryp5 e1) (t_subst_Exp t5 ryp5 e2)
  | (e_Lam e) => e_Lam (t_subst_Exp t5 ryp5 e)
  | (e_App e t) => e_App (t_subst_Exp t5 ryp5 e) (t_subst_Typ t5 ryp5 t)
end.

(** definitions *)

(* defns Jtype *)
Inductive type : D -> Typ -> Prop :=    (* defn type *)
 | type_var : forall (D5:D) (typ5:typ),
      In  typ5   D5  ->
     type D5 (t_var_f typ5)
 | type_arr : forall (D5:D) (t1 t2:Typ),
     type D5 t1 ->
     type D5 t2 ->
     type D5 (t_arr t1 t2)
 | type_all : forall (L:vars) (D5:D) (t:Typ),
      ( forall typ5 , typ5 \notin  L  -> type  ( typ5  ::  D5 )   ( open_Typ_wrt_Typ t (t_var_f typ5) )  )  ->
     type D5 (t_all t).

(* defns Jexp *)
Inductive exp : D -> G -> Exp -> Typ -> Prop :=    (* defn exp *)
 | exp_var : forall (D5:D) (G5:G) (x5:x) (t:Typ),
     type D5 t ->
      In ( x5 ,  t )  G5  ->
     exp D5 G5 (e_var_f x5) t
 | exp_lam : forall (L:vars) (D5:D) (G5:G) (t1:Typ) (e:Exp) (t2:Typ),
     type D5 t1 ->
      ( forall x5 , x5 \notin  L  -> exp D5  (( x5 ,  t1 ) ::  G5 )   ( open_Exp_wrt_Exp e (e_var_f x5) )  t2 )  ->
     exp D5 G5 (e_lam t1 e) (t_arr t1 t2)
 | exp_ap : forall (D5:D) (G5:G) (e1 e2:Exp) (t t2:Typ),
     exp D5 G5 e1 (t_arr t2 t) ->
     exp D5 G5 e2 t2 ->
     exp D5 G5 (e_ap e1 e2) t
 | exp_Lam : forall (L:vars) (D5:D) (G5:G) (e:Exp) (t:Typ),
      ( forall typ5 , typ5 \notin  L  -> exp  ( typ5  ::  D5 )  G5  ( open_Exp_wrt_Typ e (t_var_f typ5) )   ( open_Typ_wrt_Typ t (t_var_f typ5) )  )  ->
     exp D5 G5 (e_Lam e) (t_all t)
 | exp_App : forall (D5:D) (G5:G) (e:Exp) (t t':Typ),
     exp D5 G5 e (t_all t') ->
     type D5 t ->
     exp D5 G5 (e_App e t)  (open_Typ_wrt_Typ  t' t ) .

(* defns Jdynamics *)
Inductive val : Exp -> Prop :=    (* defn val *)
 | val_lam : forall (t:Typ) (e:Exp),
     lc_Typ t ->
     lc_Exp (e_lam t e) ->
     val (e_lam t e)
 | val_Lam : forall (e:Exp),
     lc_Exp (e_Lam e) ->
     val (e_Lam e)
with red : Exp -> Exp -> Prop :=    (* defn red *)
 | red_lam : forall (t1:Typ) (e e2:Exp),
     lc_Typ t1 ->
     lc_Exp (e_lam t1 e) ->
     val e2 ->
     red (e_ap (e_lam t1 e) e2)  (open_Exp_wrt_Exp  e   e2 )
 | red_ap1 : forall (e1 e2 e1':Exp),
     lc_Exp e2 ->
     red e1 e1' ->
     red (e_ap e1 e2) (e_ap e1' e2)
 | red_ap2 : forall (e1 e2 e2':Exp),
     val e1 ->
     red e2 e2' ->
     red (e_ap e1 e2) (e_ap e1 e2')
 | red_Lam : forall (e:Exp) (t:Typ),
     lc_Exp (e_Lam e) ->
     lc_Typ t ->
     red (e_App (e_Lam e) t)  (open_Exp_wrt_Typ  e   t )
 | red_App : forall (e:Exp) (t:Typ) (e':Exp),
     lc_Typ t ->
     red e e' ->
     red (e_App e t) (e_App e' t).

(* defns Jequiv *)
Inductive eq : D -> G -> Exp -> Exp -> Typ -> Prop :=    (* defn eq *)
 | eq_refl : forall (D5:D) (G5:G) (e:Exp) (t:Typ),
     exp D5 G5 e t ->
     eq D5 G5 e e t
 | eq_comm : forall (D5:D) (G5:G) (e2 e1:Exp) (t:Typ),
     eq D5 G5 e1 e2 t ->
     eq D5 G5 e2 e1 t
 | eq_trans : forall (D5:D) (G5:G) (e1 e3:Exp) (t:Typ) (e2:Exp),
     eq D5 G5 e1 e2 t ->
     eq D5 G5 e2 e3 t ->
     eq D5 G5 e1 e3 t
 | eq_lam : forall (L:vars) (D5:D) (G5:G) (t':Typ) (e1 e2:Exp) (t t'':Typ),
      ( forall x5 , x5 \notin  L  -> eq D5 G5  ( open_Exp_wrt_Exp e1 (e_var_f x5) )   ( open_Exp_wrt_Exp e2 (e_var_f x5) )  t'' )  ->
     exp D5 G5 (e_lam t' e1) t ->
     exp D5 G5 (e_lam t' e2) t ->
     eq D5 G5 (e_lam t' e1) (e_lam t' e2) t
 | eq_ap1 : forall (D5:D) (G5:G) (e1 e2 e1':Exp) (t t':Typ),
     eq D5 G5 e1 e1' t' ->
     exp D5 G5 (e_ap e1 e2) t ->
     exp D5 G5 (e_ap e1' e2) t ->
     eq D5 G5 (e_ap e1 e2) (e_ap e1' e2) t
 | eq_ap2 : forall (D5:D) (G5:G) (e1 e2 e2':Exp) (t t':Typ),
     eq D5 G5 e2 e2' t' ->
     exp D5 G5 (e_ap e1 e2) t ->
     exp D5 G5 (e_ap e1 e2') t ->
     eq D5 G5 (e_ap e1 e2) (e_ap e1 e2') t
 | eq_Lam : forall (L:vars) (D5:D) (G5:G) (e1 e2:Exp) (t t':Typ),
      ( forall typ5 , typ5 \notin  L  -> eq D5 G5  ( open_Exp_wrt_Typ e1 (t_var_f typ5) )   ( open_Exp_wrt_Typ e2 (t_var_f typ5) )  t' )  ->
     exp D5 G5 (e_Lam e1) t ->
     exp D5 G5 (e_Lam e2) t ->
     eq D5 G5 (e_Lam e1) (e_Lam e2) t
 | eq_App0 : forall (D5:D) (G5:G) (e1:Exp) (t':Typ) (e2:Exp) (t t'':Typ),
     eq D5 G5 e1 e2 t'' ->
     exp D5 G5 (e_App e1 t') t ->
     exp D5 G5 (e_App e2 t') t ->
     eq D5 G5 (e_App e1 t') (e_App e2 t') t
 | eq_ap : forall (L:vars) (D5:D) (G5:G) (t1:Typ) (e2 e1:Exp) (t2:Typ),
      ( forall x5 , x5 \notin  L  -> exp D5  (( x5 ,  t1 ) ::  G5 )   ( open_Exp_wrt_Exp e2 (e_var_f x5) )  t2 )  ->
     exp D5 G5 e1 t1 ->
     eq D5 G5 (e_ap  ( (e_lam t1 e2) )  e1)  (open_Exp_wrt_Exp  e2   e1 )  t2
 | eq_App : forall (L:vars) (D5:D) (G5:G) (e:Exp) (r t:Typ),
      ( forall typ5 , typ5 \notin  L  -> exp  ( typ5  ::  D5 )  G5  ( open_Exp_wrt_Typ e (t_var_f typ5) )  t )  ->
     type D5 r ->
     eq D5 G5 (e_App (e_Lam e) r)  (open_Exp_wrt_Typ  e   r )  t.

(** infrastructure *)
Hint Constructors type exp val red eq lc_Typ lc_Exp.


(** Coq coding by choukh, July 2022 **)

Require Import Bool Notions NatEmbed.

Definition 枚举器ᵀ {A} (f : ℕ → A?) := 枚举器 (λ _, True) f.
Definition 可枚举ᵀ A := ∃ f : ℕ → A?, 枚举器ᵀ f.

Lemma 自然数可枚举 : 可枚举ᵀ ℕ.
Proof. exists (λ n, Some n). split; eauto. Qed.
Global Hint Resolve 自然数可枚举 : core.

Local Lemma 积类型枚举器 {A B} (f : ℕ → A?) (g : ℕ → B?) : 枚举器ᵀ f → 枚举器ᵀ g →
  枚举器ᵀ (λ' ⟨n, m⟩, if (f n, g m) is (Some x, Some y) then Some (x, y) else None).
Proof.
  intros Hf Hg (a, b). split; auto. intros _.
  destruct (Hf a) as [[n fn] _], (Hg b) as [[m gm] _]; auto.
  exists ⟨n, m⟩. now rewrite GF, fn, gm.
Qed.

Lemma 积类型可枚举 {A B} : 可枚举ᵀ A → 可枚举ᵀ B → 可枚举ᵀ (A * B).
Proof. intros [] []; eexists; now eapply 积类型枚举器. Qed.
Global Hint Resolve 积类型可枚举 : core.

Notation 可识别 A := (∀ x y : A, 命题可判定 (x = y)).

Structure 可识别类型 := {
  ID载体 :> Type;
  ID性质 : 可识别 ID载体
}.

Global Instance 自然数可识别 : 可识别 ℕ.
Proof. unfold 命题可判定. decide equality. Qed.

Global Instance 布尔类型可识别 : 可识别 bool.
Proof. unfold 命题可判定. decide equality. Qed.

Global Instance 可选类型可识别 A : 可识别 A → 可识别 (option A).
Proof. unfold 命题可判定. decide equality. Qed.

Global Instance 积类型可识别 A B : 可识别 A → 可识别 B → 可识别 (A * B).
Proof. unfold 命题可判定. decide equality. Qed.

Lemma 命题可判定_iff_可判定 {A} (p : A → Prop) :
  inhabited (∀ x, 命题可判定 (p x)) ↔ 可判定 p.
Proof.
  split.
  - intros [dec]. exists (λ x, if dec x then true else false).
    intros x. destruct (dec x); firstorder congruence.
  - intros [f H]. constructor. intros x. specialize (H x).
    destruct (f x); firstorder congruence.
Qed.

Definition 离散 A := @可判定 (A * A) (uncurry (λ x y, x = y)).

Lemma 离散_iff_可识别 A : 离散 A ↔ inhabited (可识别 A).
Proof.
  split.
  - intros dec. apply 命题可判定_iff_可判定 in dec as [dec].
    constructor. intros x y. destruct (dec (x, y)); firstorder.
  - intros [dec]. apply 命题可判定_iff_可判定.
    constructor. intros (x, y). apply dec.
Qed.

Lemma 自然数离散 : 离散 ℕ.
Proof. apply 离散_iff_可识别. auto. Qed.
Global Hint Resolve 自然数离散 : core.

Lemma 布尔类型离散 : 离散 bool.
Proof. apply 离散_iff_可识别. auto. Qed.

Lemma 可选类型离散 A : 离散 A → 离散 (option A).
Proof.
  intros [H] % 离散_iff_可识别.
  eapply 离散_iff_可识别. constructor. auto.
Qed.

Lemma 积类型离散 A B : 离散 A → 离散 B → 离散 (A * B).
Proof.
  intros [H1] % 离散_iff_可识别 [H2] % 离散_iff_可识别.
  eapply 离散_iff_可识别. constructor. auto.
Qed.
Global Hint Resolve 积类型离散 : core.


(** * Attributes of Functoriality of functor composition *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Functor.Composition.Functorial.Core.
Require Import NaturalTransformation.Composition.Core.
Require Import NaturalTransformation.Isomorphisms.
Require Import Functor.Attributes.
Require Import FunctorCategory.Core.
Require Import Category.Morphisms.
Require Import NaturalTransformation.Paths.
Require Import HoTT.Truncations.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope category_scope.
Local Open Scope natural_transformation_scope.
Local Open Scope morphism_scope.

(** ** Precomposition with an essentially surjective functor is faithful *)
Section faithfull_precomposition_essential_surjective.
  (** Quoting the HoTT Book:

  Lemma. If [A], [B], [C] are precategories and [H : A → B] is an
  essentially surjective functor, then [(– ∘ H) : (B → C) → (A → C)]
  is faithful. *)

  Context `{fs : Funext}.
  Variables A B C : PreCategory.

  Variable H : Functor A B.

  Context `{H_is_essentially_surjective : IsEssentiallySurjective A B H}.

  Lemma isfaithful_precomposition_essentially_surjective_helper
        (F G : Functor B C)
        (T U : NaturalTransformation F G)
        (a : A) (b : B)
        (f : H a <~=~> b)
        (H' : T oR H = U oR H)
  : T b = U b.
  Proof.
    apply (ap components_of) in H'.
    apply apD10 in H'; hnf in H'; simpl in H'.
    rewrite <- !(path_components_of_isomorphic' f).
    rewrite H'.
    reflexivity.
  Qed.

  Global Instance isfaithful_precomposition_essentially_surjective
  : @IsFaithful _ (B -> C) (A -> C) (compose_functor _ _ _ H).
  Proof.
    repeat match goal with
             | _ => eapply isfaithful_precomposition_essentially_surjective_helper;
                   eassumption
             | _ => intro
             | _ => progress hnf in *
             | _ => progress simpl in *
             | _ => apply path_forall
             | _ => progress strip_truncations
             | [ H : _ |- _ ] => apply ap10 in H
             | _ => progress path_natural_transformation
             | [ H : sig _ |- _ ] => destruct H
             | [ H : _, t : _ |- _ ]
               => generalize dependent (H t); clear H
           end.
  Qed.
End faithfull_precomposition_essential_surjective.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


Require Import Coq.ZArith.Zpower Coq.ZArith.ZArith.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.Lists.List.
Require Import Crypto.Util.ListUtil Crypto.Util.CaseUtil Crypto.Util.ZUtil.
Require Import Crypto.ModularArithmetic.PrimeFieldTheorems.
Require Import Crypto.BaseSystem.
Require Import Crypto.ModularArithmetic.PseudoMersenneBaseParams.
Require Import Crypto.ModularArithmetic.PseudoMersenneBaseParamProofs.
Require Import Crypto.ModularArithmetic.ExtendedBaseVector.
Require Import Crypto.ModularArithmetic.ModularBaseSystemListZOperations.
Require Import Crypto.Tactics.VerdiTactics.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.Notations.
Require Import Crypto.ModularArithmetic.Pow2Base.
Require Import Crypto.ModularArithmetic.Conversion.
Local Open Scope Z_scope.

Section Defs.
  Context `{prm :PseudoMersenneBaseParams} (modulus_multiple : digits).
  Local Notation base := (base_from_limb_widths limb_widths).
  Local Notation "u [ i ]" := (nth_default 0 u i).

  Definition decode (us : digits) := F.of_Z modulus (BaseSystem.decode base us).

  Definition encode (x : F modulus) := encodeZ limb_widths (F.to_Z x).

  (* Converts from length of extended base to length of base by reduction modulo M.*)
  Definition reduce (us : digits) : digits :=
    let high := skipn (length limb_widths) us in
    let low := firstn (length limb_widths) us in
    let wrap := map (Z.mul c) high in
    BaseSystem.add low wrap.

  Definition mul (us vs : digits) := reduce (BaseSystem.mul (ext_base limb_widths) us vs).

  (* In order to subtract without underflowing, we add a multiple of the modulus first. *)
  Definition sub (us vs : digits) := BaseSystem.sub (add modulus_multiple us) vs.

  (* [carry_and_reduce] multiplies the carried value by c, and, if carrying
     from index [i] in a list [us], adds the value to the digit with index
     [(S i) mod (length us)] *)
  Definition carry_and_reduce :=
    carry_gen limb_widths (fun ci => c * ci) (fun Si => (Si mod (length limb_widths))%nat).

  Definition carry i : digits -> digits :=
    if eq_nat_dec i (pred (length limb_widths))
    then carry_and_reduce i
    else carry_simple limb_widths i.

  Definition carry_sequence is (us : digits) : digits := fold_right carry us is.

  Definition carry_full : digits -> digits := carry_sequence (full_carry_chain limb_widths).

  Definition modulus_digits := encodeZ limb_widths modulus.

  (* Constant-time comparison with modulus; only works if all digits of [us]
    are less than 2 ^ their respective limb width. *)
  Fixpoint ge_modulus' {A} (f : Z -> A) us (result : Z) i :=
    dlet r := result in
    match i return A with
    | O =>
      dlet x := (cmovl (modulus_digits [0]) (us [0]) r 0) in f x
    | S i' =>
      ge_modulus' f us (cmovne (modulus_digits [i]) (us [i]) r 0) i'
    end.

  Definition ge_modulus us := ge_modulus' id us 1 (length limb_widths - 1)%nat.

  Definition conditional_subtract_modulus int_width (us : digits) (cond : Z) :=
    (* [and_term] is all ones if us' is full, so the subtractions subtract q overall.
       Otherwise, it's all zeroes, and the subtractions do nothing. *)
     map2 (fun x y => x - y) us (map (Z.land (neg int_width cond)) modulus_digits).

  Definition freeze int_width (us : digits) : digits :=
    let us' := carry_full (carry_full (carry_full us)) in
     conditional_subtract_modulus int_width us' (ge_modulus us').

  Context {target_widths} (target_widths_nonneg : forall x, In x target_widths -> 0 <= x)
          (bits_eq : sum_firstn limb_widths   (length limb_widths) =
                     sum_firstn target_widths (length target_widths)).

  Definition pack := @convert limb_widths limb_widths_nonneg
                              target_widths target_widths_nonneg
                              (Z.eq_le_incl _ _ bits_eq).

  Definition unpack := @convert target_widths target_widths_nonneg
                                limb_widths limb_widths_nonneg
                                (Z.eq_le_incl _ _ (Z.eq_sym bits_eq)).

End Defs.


(**************************************************
 * Author: Ana Nora Evans (ananevans@virginia.edu)
 **************************************************)

Require Import Coq.Arith.Arith.
Require Import Coq.ZArith.ZArith.
Require Import Coq.omega.Omega.
Require Coq.Bool.Bool.
Require Import Coq.Lists.List. Import ListNotations.
Require Import List ZArith.

From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Import QcNotation. Open Scope qc_scope.
Import GenLow GenHigh.
(* Suppress some annoying warnings: *)
Set Warnings "-extraction-opaque-accessed,-extraction".

Require Import Coq.Strings.String.
Local Open Scope string.

Require Import Common.Definitions.
Require Import Common.Util.
Require Import Common.Maps.
Require Import Common.Either.

Require Import TargetSFI.Machine.
Require Import TargetSFI.CS.

Require Import CompCert.Events.

Import Env.
Import SFIComponent.
Import RiscMachine.
Import CS.

Module DoNotation.
Import ssrfun.
Notation "'do!' X <- A ; B" :=
  (bindGen A (fun X => B))
  (at level 200, X ident, A at level 100, B at level 200).
End DoNotation.
Import DoNotation.

(*******************************
 * Env.CN Generator
 *******************************)

Theorem decComponentId: forall x y : Component.id, {x = y} + {x <> y}.
Proof. decide equality. Defined.

Theorem decRegisterFile: forall regs1 regs2 : RiscMachine.RegisterFile.t,
    {regs1 = regs2} + {regs1 <> regs2}.
Proof.
  apply List.list_eq_dec. apply Z.eq_dec.
Defined.

Definition cut_list (l : list Component.id) : list Component.id :=
  let fix gen_seq len :=
      match len with
      | O => [ 1%nat ]
      | S len' => List.app (gen_seq len') [ (len+1) ]
      end
  in
  let len:nat := (N.to_nat SFI.COMP_MAX) in
  let l' : (list Component.id) := (List.nodup decComponentId l) in
  if (  Nat.leb len (List.length l') )
  then (List.firstn len l')
  else (gen_seq len).

Instance genCN : Gen Env.CN :=
  {
    arbitrary :=
      let len := N.to_nat SFI.COMP_MAX in
      let double := len * 2 in
      liftGen cut_list (vectorOf double arbitrary )
  }.

(*******************************
 * Addresses Generator
 *******************************)
Definition genSFIComponentId : G SFIComponent.id :=
  do! n <- choose (O,N.to_nat SFI.COMP_MAX);
  returnGen (N.of_nat n).

Definition even_gen : G N :=
  do! x <- arbitrary;
    returnGen ((2*(N.of_nat x))%N).

Definition odd_gen : G N :=
  do! x <- arbitrary;
    returnGen ((2*(N.of_nat x)+1)%N).

Definition odd_even_frecv_gen (even_freq : nat) (odd_freq : nat) : G N :=
  freq [
      (even_freq, even_gen);
        (odd_freq, odd_gen)
    ].

Definition genBlockIds (frecv_code : nat) (frecv_data : nat) : G (list N) :=
  let how_many : nat := plus frecv_code frecv_data in
  vectorOf how_many (odd_even_frecv_gen frecv_code frecv_data).

Definition genOffset : G N :=
  liftGen N.of_nat (choose (O,N.to_nat (SFI.SLOT_SIZE - 1))).

Definition genBlockOffsetPairs (frecv_code : nat) (frecv_data : nat) : G (list (N*N)) :=
  let how_many : nat := plus frecv_code frecv_data in
  do! blockIds <- genBlockIds frecv_code frecv_data;
    do! offsets <- vectorOf how_many genOffset;
    returnGen (List.combine blockIds offsets).

Definition genAbstractAddresses (frecv_code : nat) (frecv_data : nat) :
  G (list (SFIComponent.id*(N*N))) :=
  let how_many := plus frecv_code frecv_data in
  (* generator of pairs of lists cid * block id * offset *)
  do! cids <- vectorOf how_many genSFIComponentId;
    do! bl_off <- genBlockOffsetPairs frecv_code frecv_data;
    returnGen (List.combine cids bl_off).

Definition genAddresses (frecv_code : nat) (frecv_data : nat) :
  G (list RiscMachine.address) :=
  do! addresses <- genAbstractAddresses frecv_code frecv_data;
  returnGen
    (
      List.map (fun '(cid,(bid,off)) => SFI.address_of cid bid off)
               addresses
    ).

(* frecv_code = number of addresses in code slots
   frecv_data = number of addresses in data slots
   cid = the component id of all addresses generated *)
Definition genAddressesForCid (frecv_code : nat) (frecv_data : nat) cid :
  G (list RiscMachine.address) :=
  let how_many : nat := plus frecv_code frecv_data in
  (* generate a 1ist of how_many addresses with generated block id and offset and given cid *)
  do! bl_off <- genBlockOffsetPairs frecv_code frecv_data;
  returnGen
    (List.map
       (fun '(bid,off) => SFI.address_of cid bid off)
       bl_off
    ).

(*******************************
 * Env.E Generator
 *******************************)
Definition genEForCid cid : G Env.E :=
  do! addresses <- genAddressesForCid 10 0 cid;
    do! pids <- vectorOf 10 (choose (1,100));
    returnGen (List.combine addresses pids).

Instance genE : Gen Env.E :=
  {
    arbitrary :=
      let cids := List.map N.of_nat (List.seq 0 (N.to_nat SFI.COMP_MAX)) in
      foldGen (fun (acc : Env.E) cid =>
                 do! addrs <- genAddressesForCid 10 0 cid;
                   do! pids <- vectorOf 10 (choose (1,100));
                   returnGen (acc ++ (List.combine addrs pids))%list
              ) cids nil
  }.

(*******************************
 * Env Generator
 *******************************)

Definition genEnv : G Env.t := liftGen2 pair arbitrary arbitrary.

Instance genEnvInst : Gen Env.t :=
  {
    arbitrary := genEnv
  }.

(*******************************
 * MachineState Generator
 *******************************)
Import RiscMachine.ISA.

Instance genReg : Gen RiscMachine.Register.t :=
  {
    arbitrary := elems [ RiscMachine.Register.R_ONE
                         ; RiscMachine.Register.R_COM
                         ; RiscMachine.Register.R_AUX1
                         ; RiscMachine.Register.R_AUX2
                         ; RiscMachine.Register.R_RA
                         ; RiscMachine.Register.R_SP
                         ; RiscMachine.Register.R_SFI_SP
                         ; RiscMachine.Register.R_AND_CODE_MASK
                         ; RiscMachine.Register.R_AND_DATA_MASK
                         ; RiscMachine.Register.R_OR_CODE_MASK
                         ; RiscMachine.Register.R_OR_DATA_MASK
                         ; RiscMachine.Register.R_T
                         ; RiscMachine.Register.R_D ]
  }.

Instance genValue : Gen RiscMachine.value :=
  {
    arbitrary := arbitrary
  }.

Instance genImmediate : Gen RiscMachine.immediate :=
  {
    arbitrary := arbitrary
  }.

Instance genOp : Gen RiscMachine.ISA.binop :=
  {
    arbitrary := elems [ Addition
                         ; Subtraction
                         ; Multiplication
                         ; Equality
                         ; Leq
                         ; BitwiseOr
                         ; BitwiseAnd
                         ; ShiftLeft
                       ]
  }.

Definition genIConst : G instr :=
  do! val <- arbitrary;
    do! reg <- arbitrary;
    returnGen (IConst val reg).

Definition gen2Reg (it :  RiscMachine.Register.t -> RiscMachine.Register.t -> instr) : G instr :=
  do! r1 <- arbitrary;
    do! r2 <- arbitrary;
    returnGen (it r1 r2).

Definition genIBinOp : G instr :=
  do! op <- arbitrary;
    do! r1 <- arbitrary;
    do! r2 <- arbitrary;
    do! r3 <- arbitrary;
    returnGen (IBinOp op r1 r2 r3).

Definition genIBnz : G instr :=
  do! reg <- arbitrary;
    do! imm <- arbitrary;
    returnGen (IBnz reg imm).

Definition genIJump : G instr :=
  do! reg <- arbitrary;
  returnGen (IJump reg).

Definition genIJal (addresses : list RiscMachine.address) : G instr :=
  elements INop (List.map
                   (fun addr => IJal addr)
                   addresses
                ).

Definition genInstr (addresses : list RiscMachine.address) : G instr :=
  oneOf [ (returnGen INop)
          ; genIConst
          ; gen2Reg IMov
          ; genIBinOp
          ; gen2Reg ILoad
          ; gen2Reg IStore
          ; genIBnz
          ; genIJump
          ; genIJal addresses
          ; (returnGen IHalt)
        ].

Definition genMemForAddresses (g : Env.t)
           (addresses : list RiscMachine.address) : G RiscMachine.Memory.t :=
  let env_addresses := List.map fst (snd g) in (* add env addresses to the memory *)
  do! res <- sequenceGen
       (List.map
          ( fun addr =>
              if ( SFI.is_code_address addr )
              then
                do! i <- genInstr addresses;
                  returnGen (addr, RiscMachine.Instruction i)
              else
                do! v <- arbitrary;
                returnGen (addr, RiscMachine.Data v)
          ) (env_addresses++addresses));
    returnGen
      (RiscMachine.Memory.of_list res)
.

Definition genMem (g : Env.t) : G RiscMachine.Memory.t :=
  let frecv_code := 50%nat in
  let frecv_data := 50%nat in
  let how_many : nat := (frecv_code + frecv_data)%nat in
  do! addresses <- genAddresses frecv_code frecv_data;
    genMemForAddresses g addresses.

Definition genPCFromMem (mem : RiscMachine.Memory.t) : G RiscMachine.pc :=
  (* pc is a random code address *)
  elements N0 (RiscMachine.Memory.filter_used_addresses mem SFI.is_code_address).

Definition genRegsAddress (mem : RiscMachine.Memory.t)
           (rptr : RiscMachine.Register.t) (code : bool) : G RiscMachine.RegisterFile.t :=
  do! l1 <- vectorOf ((N.to_nat rptr) - 1)%nat arbitrary;
    do! l2 <- vectorOf (RiscMachine.Register.NO_REGISTERS - (N.to_nat rptr))%nat arbitrary;
  do! addr <-
  (if code
  then
    elements Z0 (List.map
                   Z.of_N
                   (RiscMachine.Memory.filter_used_addresses mem SFI.is_code_address))
  else
    elements Z0 (List.map
                   Z.of_N

                   (RiscMachine.Memory.filter_used_addresses mem SFI.is_data_address)));

    returnGen
      (
        l1 ++ [addr] ++ l2
      )%list.

Definition genRegsFromMemPC (mem : RiscMachine.Memory.t) (pc : RiscMachine.pc)
  : G RiscMachine.RegisterFile.t :=
  (* the register values are random with some care for the cases when I need valid addresses *)
  match RiscMachine.Memory.get_word mem pc with
  | Some (RiscMachine.Instruction (ILoad rptr rs)) => genRegsAddress mem rptr false
  | Some (RiscMachine.Instruction (IStore rptr rd)) => genRegsAddress mem rptr false
  | Some (RiscMachine.Instruction (IJump rt)) => genRegsAddress mem rt true
  | _ => vectorOf RiscMachine.Register.NO_REGISTERS arbitrary
  end.

Definition genStateForEnv (g : Env.t) : G MachineState.t :=
  (*  (RiscMachine.Memory.t * RiscMachine.pc) * RiscMachine.RegisterFile.t. *)
  do! mem <- genMem g;
    do! pc <- genPCFromMem mem;
    do! regs <- genRegsFromMemPC mem pc;
    returnGen (mem,pc,regs).

Definition genTrace (g : Env.t) (st : MachineState.t): G trace :=
  let mem :=  MachineState.getMemory st in
  let pc := MachineState.getPC st in
  let regs := MachineState.getRegs st in
  match RiscMachine.Memory.get_word mem pc with
  | Some (RiscMachine.Instruction (IJump rt)) => (* possible ret event *)
    match RegisterFile.get_register rt regs with
    | Some addr =>
      let pc' := Memory.to_address addr in
      if (SFI.is_same_component_bool pc pc')
      then returnGen E0
      else
        match (ret_trace g pc pc' regs) with
        | Some t => returnGen t
        | _ => returnGen E0 (* TODO this is actually error *)
        end
    | None => (* TODO this is actually error *) returnGen E0
    end
  | Some (RiscMachine.Instruction (IJal imm)) => (* possible call event *)
      if (SFI.is_same_component_bool pc imm)
      then returnGen E0
      else
        match (call_trace g pc imm regs) with
        | Some t => returnGen t
        | _ => returnGen E0 (* TODO this is actually error *)
        end
  | _ => returnGen E0
  end.

Definition update_mem (mem : Memory.t) (instr : ISA.instr) (regs : RegisterFile.t) : Memory.t :=
  match instr with
  | IStore reg_src reg_dst =>
    match RegisterFile.get_register reg_src regs with
    | Some addr => let ptr :=  Memory.to_address addr in
      match  RegisterFile.get_register reg_src regs with
      | Some val => Memory.set_value mem ptr val
      | _ => mem (* TODO this is actually error *)
      end
    | _ => mem  (* TODO this is actually error *)
    end
  | _ => mem
  end.

Definition update_pc (mem : Memory.t) (instr : ISA.instr) (pc : RiscMachine.pc)
           (regs : RegisterFile.t) : RiscMachine.pc :=
  match instr with
  | IJump rt =>
    match RegisterFile.get_register rt regs with
    | Some addr => Memory.to_address addr
    | _ => pc  (* TODO this is actually error *)
    end
  | IJal imm => imm
  | IBnz reg offset =>
    match RegisterFile.get_register reg regs with
    | Some flag =>
      if (Z.eqb flag Z0) then pc
      else Memory.to_address ((Z.of_N pc) + offset)%Z
    | _ => pc
    end
  | _ => pc
  end.

Definition update_regs (mem : Memory.t) (instr : ISA.instr)  (pc : RiscMachine.pc)
           (regs : RegisterFile.t) : RegisterFile.t :=
  match instr with
  | IConst val reg =>  RegisterFile.set_register reg val regs
  | ILoad rptr rd =>
    match RegisterFile.get_register rptr regs with
    | Some addr =>
      let ptr :=  Memory.to_address addr in
      match Memory.get_value mem ptr with
      | Some val => RegisterFile.set_register rd val regs
      | _ => regs
      end
    | _ => regs  (* TODO this is actually error *)
    end
  | IMov rs rd =>
    match (RegisterFile.get_register rs regs) with
    | Some v => RegisterFile.set_register rd v regs
    | _ => regs
    end
  | IBinOp op r1 r2 rd =>
    match (RegisterFile.get_register r1 regs,
           RegisterFile.get_register r2 regs) with
    | (Some v1, Some v2) => RegisterFile.set_register
                             rd (RiscMachine.eval_binop op v1 v2) regs
    | _ => regs
    end
  | IJal imm => RegisterFile.set_register RiscMachine.Register.R_RA ((Z.of_N pc)+1)%Z regs
  | _ => regs
  end.

Definition genNextState (g : Env.t) (st : MachineState.t) (t : trace) : G MachineState.t :=
  let mem :=  MachineState.getMemory st in
  let pc := MachineState.getPC st in
  let regs := MachineState.getRegs st in
  match RiscMachine.Memory.get_word mem pc with
  | Some (Instruction instr) =>
    returnGen ( (update_mem mem instr regs,
                 update_pc mem instr pc regs), update_regs mem instr pc regs)
  | _ => returnGen ( (mem,pc), regs)  (* TODO this is actually error *)
  end.


Parameter (C:Type).
Lemma test : False -> C.

intros. inversion H.
Proof.

Parameter (A:Set) (P Q: A -> Prop).

Lemma lm3 : (exists x, forall R : A -> Prop, R x) -> 2 = 3.
intros.
inversion H.
apply (H0 (fun _ => 2 = 3)).
Defined.

Print lm3.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e512m569_16limbs.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.montgomery32_2e285m9_9limbs.Synthesis.

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

Print Assumptions opp.


Require Import Coq.Program.Equality.
Generalizable All Variables.

Notation "{{ p , v }}" := (existS _ p v).

Lemma elim2: forall (U : Type) (P : U -> Type) (p : U) (x y : P p),
               {{p, x}} = {{p, y}} -> x = y.
Proof.
  exact inj_pair2.
Qed.
Arguments elim2 {U P p x y} _.

Record SClass {A:Type} (h:A) :=
  { IClass := A;
    get : A := h}.

Arguments IClass {A h} _.
Arguments get {A h} _.


Require Export Task.driver_state.

Import ListNotations.
Import FloatIO.
Import DebugIO.
Import DScopeNotations.
Import RecordSetNotations'.
Open Scope D_scope.

Definition model_handlers := driver_default_handlers.

Definition init_sim (sim: simTy) :=
  let sim' := log_sim "init_sim:sim" sim in
  sim'.

Definition differential_equations (sim: simTy) : simTy :=
  let sim_log := log_sim "differential_equations" sim in
  let vars := sim_log.(vars) in
  let t := svGetFloat SvT vars in
  let x := svGetFloat SvX vars in
  let xd := svGetFloat SvXD vars in
  let gravity := svGetFloat SvGRAVITY vars in
  let damping_coefficient := svGetFloat SvDampingCoefficient vars in
  let spring_coefficient := svGetFloat SvSpringCoefficient vars in
  let mass := svGetFloat SvMass vars in
  let xdd := (- (spring_coefficient * x + damping_coefficient * xd)) / mass - gravity in
  let sim1 := set_var SvXDD xdd sim_log in
  let sim1log := log_sim "differential_equations:sim1" sim1 in
  sim1log.


(* File reduced by coq-bug-finder from original input, then from 8752 lines to 735 lines, then from 735 lines to 310 lines, then from 228 lines to 105 lines, then from 98 lines to 41 lines *)
(* coqc version trunk (September 2014) compiled on Sep 6 2014 6:15:6 with OCaml 4.01.0
   coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (3ea6d6888105edd5139ae0a4d8f8ecdb586aff6c) *)
Notation idmap := (fun x => x).
Axiom path_forall : forall {A : Type} {P : A -> Type} (f g : forall x : A, P x), (forall x, f x = g x) -> f = g.
Local Set Primitive Projections.
Record PreCategory := { object :> Type ; morphism : object -> object -> Type }.
Bind Scope category_scope with PreCategory.
Set Implicit Arguments.
Delimit Scope functor_scope with functor.
Record Functor (C D : PreCategory) := {}.
Definition opposite (C : PreCategory) : PreCategory := @Build_PreCategory C (fun s d => morphism C d s).
Notation "C ^op" := (opposite C) (at level 3, format "C '^op'") : category_scope.
Definition oppositeF C D (F : Functor C D) : Functor C^op D^op := Build_Functor (C^op) (D^op).
Local Notation "F ^op" := (oppositeF F) (at level 3, format "F ^op") : functor_scope.
Axiom oppositeF_involutive : forall C D (F : Functor C D), ((F^op)^op)%functor = F.
Local Open Scope functor_scope.
Goal forall C D : PreCategory,
       (fun c : Functor C^op D^op => (c^op)^op) = idmap.
  intros.
  exact (path_forall (fun F : Functor C^op D^op => (F^op)^op) _ (@oppositeF_involutive _ _)).
  Undo.
  Unset Printing Notations.
  Set Debug Unification.
(*   Check (eq_refl : Build_PreCategory (opposite D).(object) *)
(*                  (fun s d : (opposite D).(object) =>  *)
(*                     (opposite D).(morphism) d s) =  *)
(*                    @Build_PreCategory D (fun s d => morphism D d s)). *)
(* opposite D). *)
  exact (path_forall (fun F => (F^op)^op) _ (@oppositeF_involutive _ _)).
Qed.
 (* Toplevel input, characters 22-101:
Error:
In environment
C : PreCategory
D : PreCategory
The term
 "path_forall
    (fun F : Functor (opposite C) (opposite D) => oppositeF (oppositeF F))
    (fun F : Functor (opposite C) (opposite D) => F)
    (oppositeF_involutive (D:=opposite D))" has type
 "eq (fun F : Functor (opposite C) (opposite D) => oppositeF (oppositeF F))
    (fun F : Functor (opposite C) (opposite D) => F)"
while it is expected to have type
 "eq (fun c : Functor (opposite C) (opposite D) => oppositeF (oppositeF c))
    (fun x : Functor (opposite C) (opposite D) => x)"
(cannot unify "{|
               object := opposite D;
               morphism := fun s d : opposite D => morphism (opposite D) d s |}"
and "opposite D").
 *)


Require Import Program.

Set Primitive Projections.

CoInductive Stream (A : Type) := mkStream { hd : A; tl : Stream A}.

Arguments mkStream [A] hd tl.
Arguments hd [A] s.
Arguments tl [A] s.

Definition eta {A} (s : Stream A) := {| hd := s.(hd); tl := s.(tl) |}.

CoFixpoint ones := {| hd := 1; tl := ones |}.
CoFixpoint ticks := {| hd := tt; tl := ticks |}.

CoInductive stream_equiv {A} (s : Stream A) (s' : Stream A) : Prop :=
  mkStreamEq { hdeq : s.(hd) = s'.(hd); tleq : stream_equiv s.(tl) s'.(tl) }.
Arguments hdeq {A} {s} {s'}.
Arguments tleq {A} {s} {s'}.

Program CoFixpoint ones_eq : stream_equiv ones ones.(tl) :=
  {| hdeq := eq_refl; tleq := ones_eq |}.

CoFixpoint stream_equiv_refl {A} (s : Stream A) : stream_equiv s s :=
  {| hdeq := eq_refl; tleq := stream_equiv_refl (tl s) |}.

CoFixpoint stream_equiv_sym {A} (s s' : Stream A) (H : stream_equiv s s') : stream_equiv s' s :=
  {| hdeq := eq_sym H.(hdeq); tleq := stream_equiv_sym _ _ H.(tleq) |}.

CoFixpoint stream_equiv_trans {A} {s s' s'' : Stream A}
           (H : stream_equiv s s') (H' : stream_equiv s' s'') : stream_equiv s s'' :=
  {| hdeq := eq_trans H.(hdeq) H'.(hdeq);
     tleq := stream_equiv_trans H.(tleq) H'.(tleq) |}.

Program Definition eta_eq {A} (s : Stream A) : stream_equiv s (eta s):=
  {| hdeq := eq_refl; tleq := stream_equiv_refl (tl (eta s))|}.

Section Parks.
  Variable A : Type.

  Variable R : Stream A -> Stream A -> Prop.
  Hypothesis bisim1 : forall s1 s2:Stream A,
      R s1 s2 -> hd s1 = hd s2.
  Hypothesis bisim2 : forall s1 s2:Stream A,
      R s1 s2 -> R (tl s1) (tl s2).
  CoFixpoint park_ppl :
    forall s1 s2:Stream A, R s1 s2 -> stream_equiv s1 s2 :=
    fun s1 s2 (p : R s1 s2) =>
      mkStreamEq _ _ _ (bisim1 s1 s2 p)
      (park_ppl (tl s1)
                (tl s2)
                (bisim2 s1 s2 p)).
End Parks.

Program CoFixpoint iterate {A} (f : A -> A) (x : A) : Stream A :=
  {| hd := x; tl := iterate f (f x) |}.

Program CoFixpoint map {A B} (f : A -> B) (s : Stream A) : Stream B :=
  {| hd := f s.(hd); tl := map f s.(tl) |}.

Theorem map_iterate A (f : A -> A) (x : A) : stream_equiv (iterate f (f x))
                                                         (map f (iterate f x)).
Proof.
apply park_ppl with
(R:= fun s1 s2 => exists x : A, s1 = iterate f (f x) /\
                        s2 = map f (iterate f x)).
now intros s1 s2 (x0,(->,->)).
intros s1 s2 (x0,(->,->)).
now exists (f x0).
now exists x.
Qed.

Fail Check (fun A (s : Stream A) => eq_refl : s = eta s).

Notation convertible x y := (eq_refl x : x = y).

Fail Check convertible ticks {| hd := hd ticks; tl := tl ticks |}.

CoInductive U := inU
 { outU : U }.

CoFixpoint u : U :=
  inU u.

CoFixpoint force (u : U) : U :=
  inU (outU u).

Lemma eq (x : U) : x = force x.
Proof.
  Fail destruct x.
Abort.
  (* Impossible *)


(* -----------------Description----------------------------------------------------------

This file contains useful definitions and basic properties of fundamental concepts
about auctions such as matching, maximum matching (MM), individual rational matching (IR),
uniform matching, fair matching etc. This file also contains results on matchings,
IR matchings, uniform matchings.

    Terms          <==>     Explanations
    -----------------------------------------------------
    All_matchable M        Every bid-ask pair in M are matchable
    matching M             All_matchable M && NoDup B_M && NoDup A_M
    matching_in B A M      matching M && B_M [<=] B && A_M [<=] A
    Is_MM M B A            M is maximal matching for B and A
    rational m             bid_of m  >= tp m >= ask_of m
    Is_IR M                forall m, In n M -> rational m
    Uniform M              all bid-ask pairs in M is traded at single price
    fair_on_bids B M       M is fair on all bids (i.e. B)
    fair_on_asks A M       M is fair on all asks (i.e. A)
    Is_fair M B A          M is fair on B and A

Most of the results in this file contains the introduction and elimination rules
for all the above defined notions.

-----------------------------------------------------------------------------*)

Require Import ssreflect ssrbool.
Require Export Lists.List.
Require Export GenReflect SetSpecs.

Require Export BidAsk.
Require Export DecList.
Require Export DecSort.

Section Matching.

(*----------------- Notion of matching and  Maximal Matching (MM) ------------------------*)

(* Definition matchable (b: Bid)(a: Ask):=  (sp (a)) <= (bp (b)). *)

  Definition All_matchable (M: list fill_type):= forall m, In m M -> (ask_of m) <= (bid_of m).

Definition all_matchable (M:list fill_type) := forallb (fun m =>
 (ask_of m) <=? (bid_of m)) M.

Lemma all_matchableP (M:list fill_type): reflect (All_matchable M) (all_matchable M).
Proof. {  apply reflect_intro.  unfold Prop_bool_eq. split.
          { induction M. intros. simpl. auto. intros. simpl. apply /andP. split.
            apply /leP. unfold All_matchable in H. apply H. auto.
            assert (H1: All_matchable M).
            revert H. unfold All_matchable. simpl. auto.  apply IHM in H1. eauto. }
          { induction M. intros. unfold All_matchable. intros. destruct H0.
            simpl. intros. move /andP in H. destruct H. unfold All_matchable. intros.
            destruct H1. move /leP in H. subst a. exact. eapply IHM in H0.
            unfold All_matchable in H0. eapply H0 in H1. exact. } } Qed.

Definition matching (M: list fill_type):=
  (All_matchable M) /\ (NoDup (bids_of M)) /\ (NoDup (asks_of M)).

Definition matching_in (B:list Bid) (A:list Ask) (M:list fill_type):=
(matching M) /\ ((bids_of M) [<=] B) /\ ((asks_of M) [<=] A).

Definition Is_MM (M : list fill_type)(B: list Bid)(A: list Ask) :=
  matching_in B A M /\
  (forall M': list fill_type, matching_in B A M'-> |M'| <= |M|).

Lemma All_matchable_elim (m: fill_type)(M: list fill_type):
  All_matchable (m::M) -> (ask_of m) <= (bid_of m).
Proof.  intros H.  unfold All_matchable in H. simpl in H. auto.  Qed.

Lemma All_matchable_elim1 (m: fill_type)(M: list fill_type):
  All_matchable (m::M) -> All_matchable M.
Proof.  unfold All_matchable. intros.  simpl in H. auto. Qed.

Lemma All_matchable_elim2  (m: fill_type)(M: list fill_type):
  All_matchable M -> All_matchable (delete m M).
Proof. unfold All_matchable. intros. apply H. eapply delete_elim1. eauto. Qed.

Definition empty_fill: list fill_type:= nil.

Lemma All_matchable_nil: All_matchable nil.
Proof. unfold All_matchable. intros. inversion H. Qed.

Lemma All_matchable_intro (m: fill_type)(M: list fill_type):
  (ask_of m) <= (bid_of m) -> All_matchable M -> All_matchable (m::M).
Proof. { intros H1 H2. unfold All_matchable. simpl. intros m0 H3. destruct H3.
         subst m0. exact. eauto. } Qed.

Hint Immediate All_matchable_intro All_matchable_nil: core.
Hint Resolve All_matchable_elim All_matchable_elim1 All_matchable_elim2 : core.

Lemma nill_is_matching (B: list Bid)(A: list Ask) : matching_in B A nil.
Proof. { unfold matching_in. split. unfold matching.
         split. apply All_matchable_nil.
         split. simpl. constructor. simpl. constructor.
         split. simpl. auto. simpl. auto. } Qed.
Hint Resolve nill_is_matching: core.

(*-------------introduction and elimination for matching ------------------------*)

(*-------    Definition matching (M: list fill_type):=
             (All_matchable M) /\ (NoDup (bids_of M)) /\ (NoDup (asks_of M)).    *)

Lemma matching_elim0 (m: fill_type) (M: list fill_type): matching M -> In m M ->
                                                         (ask_of m) <= (bid_of m).
Proof. intros. unfold matching in H.  destruct H. unfold All_matchable in H.
apply H in H0. exact. Qed.

Lemma matching_elim1 (M: list fill_type): matching M -> NoDup (bids_of M).
Proof.  intro H. unfold matching in H. destruct H. destruct H0. exact. Qed.

Lemma matching_elim2 (M: list fill_type): matching M -> NoDup (asks_of M).
Proof. intro H. unfold matching in H. destruct H. destruct H0. exact. Qed.

Lemma matching_elim3 (M: list fill_type): matching M -> NoDup M.
Proof. { intro H. destruct H. destruct H0.
         induction M as [|m].
         { auto. }
         { constructor. intro H2. assert (H4: In (bid_of m) (bids_of M)). eauto.
           simpl in H0. assert (H5: ~In (bid_of m) (bids_of M)). eauto. contradiction.
           apply IHM. all: eauto. } } Qed.

Lemma matching_elim4 (m: fill_type) (M: list fill_type): matching (m::M) ->
                                                         ~ In (ask_of m) (asks_of M).
Proof. { intros. unfold matching in H. destruct H. destruct H0. simpl in H1.
         eapply nodup_elim2 in H1. exact. } Qed.

Lemma matching_elim5 (m: fill_type) (M: list fill_type): matching (m::M) ->
                                                         ~ In (bid_of m) (bids_of M).
Proof. { intros. unfold matching in H. destruct H. destruct H0. simpl in H0.
         eapply nodup_elim2 in H0. exact. } Qed.

Lemma matching_elim6 (m: fill_type) (M: list fill_type): matching (m::M) -> matching M.
Proof. { intros. unfold matching in H. destruct H. destruct H0. unfold matching.
         split. eapply All_matchable_elim1. eauto. split. eauto. eauto. } Qed.

Lemma matching_elim14 (m1 m2: fill_type) (M: list fill_type): matching M -> In m1 M -> In m2 M ->
                                                              m1 <> m2 -> bid_of m1 <> bid_of m2.
Proof. { induction M.
         { intros. destruct H0. }
         { intros.  destruct H. destruct H3. destruct H1;destruct H0.
           { subst m1. subst m2. destruct H2. exact. }
           { subst a. simpl in H4.
             assert (H5: In (bid_of m1) (bids_of M)). eauto.
             assert (H6: ~ In (bid_of m2) (bids_of M)). eauto.
             intro h7. rewrite h7 in H5. contradiction. }
           { subst a. simpl in H4.
             assert (H5: In (bid_of m2) (bids_of M)). eauto.
             assert (H6: ~ In (bid_of m1) (bids_of M)). eauto.
             intro h7. rewrite h7 in H6. contradiction. }
           { apply IHM. unfold matching;eauto. all: exact. } } } Qed.

Lemma matching_elim15 (m1 m2: fill_type) (M: list fill_type): matching M -> In m1 M -> In m2 M ->
                                                              m1 <> m2 -> ask_of m1 <> ask_of m2.
Proof.  { induction M.
          { intros. destruct H0. }
          { intros.  destruct H. destruct H3. destruct H1;destruct H0.
            { subst m1. subst m2. destruct H2. exact. }
            { subst a. simpl in H4.
              assert (H5: In (ask_of m1) (asks_of M)). eauto.
              assert (H6: ~ In (ask_of m2) (asks_of M)). eauto.
              intro h7. rewrite h7 in H5. contradiction. }
            { subst a. simpl in H4.
              assert (H5: In (ask_of m2) (asks_of M)). eauto.
              assert (H6: ~ In (ask_of m1) (asks_of M)). eauto.
              intro h7. rewrite h7 in H6. contradiction. }
            { apply IHM. unfold matching;eauto. all: exact. } } } Qed.

Lemma matching_elim7 (m: fill_type) (M: list fill_type): In m M -> matching M ->
                                                         ~ In (ask_of m) (asks_of (delete m M)).
Proof.  { intros H1 H2. unfold matching in H2.
          destruct H2. destruct H0.
          intro H3.
          assert (H4: exists m', (In m' (delete m M))/\ (ask_of m = ask_of m')).
          eauto. destruct H4 as [m' H4]. destruct H4 as [H4 H5].
          assert (H6: In m' M). eapply included_elim2. eapply included_elim4.
          apply included_intro2. exact H1. apply included_intro2. exact H4.
          apply included_refl. assert (H7: m'<>m).
          cut (NoDup M).
          { intro. eapply delete_elim2. exact H7. exact H4. }
          apply matching_elim3. unfold matching. auto.
          eapply matching_elim15 in H7. symmetry in H5.
          contradiction. instantiate (1:=M).
          unfold matching. auto. exact. exact. } Qed.

Lemma matching_elim8 (m: fill_type) (M: list fill_type): In m M -> matching M ->
                                                         ~ In (bid_of m) (bids_of (delete m M)).
Proof.  { intros H1 H2. unfold matching in H2. destruct H2. destruct H0.
          intro H3.
          assert (H4: exists m', (In m' (delete m M))/\ (bid_of m = bid_of m')). eauto.
          destruct H4 as [m' H4]. destruct H4 as [H4 H5].
          assert (H6: In m' M).
          eapply included_elim2. eapply included_elim4.
          apply included_intro2. exact H1. apply included_intro2. exact H4.
          apply included_refl.
          assert (H7: m'<>m).
          cut (NoDup M). intro. eapply del_all_elim2.
          apply del_all_intro. exact H6. eapply delete_elim2.
          exact H7. exact H4.
          apply matching_elim3.
          unfold matching. auto. eapply matching_elim14 in H7.
          symmetry in H5. contradiction. instantiate (1:=M).
          unfold matching. auto. exact. exact. } Qed.

Lemma matching_elim9 (m: fill_type) (M: list fill_type): matching M ->  matching (delete m M).
Proof. { intros H. unfold matching in H. destruct H. destruct H0.
         unfold matching. split.
         { eauto. }
         split.
         {  assert (H2: included (delete m M) (M)).
            eapply included_elim4a. eapply included_M_imp_included_bids in H2.
            eapply nodup_included_nodup in H2.
            all: exact. }
         { assert (H2: included (delete m M) (M)).
           eapply included_elim4a. eapply included_M_imp_included_asks in H2.
           eapply nodup_included_nodup in H2.
           all: exact. } } Qed.

Lemma matching_elim10 (m: fill_type) (M: list fill_type): matching M -> In m M ->
                                                          ~ In (bid_of m) (bids_of (delete m M)).
Proof. intros. eapply  matching_elim8. exact. exact. Qed.

Lemma matching_elim11 (m: fill_type) (M: list fill_type): matching M -> In m M ->
                                                          ~ In (ask_of m) (asks_of (delete m M)).
Proof. intros. eapply  matching_elim7. all: exact. Qed.

Lemma matching_elim12 (m: fill_type) (M: list fill_type): matching (m::M) ->
                                                          ~ In (bid_of m) (bids_of M).
Proof. { intros. intro. destruct H. destruct H1.  simpl in H1.
         eapply nodup_elim2 in H1. contradiction. } Qed.

Lemma matching_elim13 (m: fill_type) (M: list fill_type): matching (m::M) ->
                                                          ~ In (ask_of m) (asks_of M).
Proof. { intros. intro. destruct H. destruct H1.  simpl in H2. eapply nodup_elim2 in H2.
         contradiction. } Qed.

Hint Resolve matching_elim0 matching_elim1 matching_elim2 matching_elim3: core.
Hint Resolve matching_elim4 matching_elim5 matching_elim6 matching_elim7: core.
Hint Resolve matching_elim8 matching_elim9 matching_elim10 matching_elim11: core.
Hint Resolve matching_elim12 matching_elim13: core.
Hint Resolve matching_elim14 matching_elim15: core.

(*-----------------introduction and elimination for matching_in -----------------*)
Lemma matching_in_intro (m: fill_type) (M: list fill_type)(B: list Bid)(A: list Ask):
  (ask_of m) <= (bid_of m) -> matching_in B A M -> ~ In (bid_of m) (bids_of M) ->
  ~ In (ask_of m) (asks_of M) -> In (bid_of m) B -> In (ask_of m) A -> matching_in B A (m::M).

Proof.  { intros H1 H2 H3 H4 H5 H6. unfold matching_in. split.
          unfold matching in H2. destruct H2. destruct H. destruct H2.
          destruct H0. unfold matching.
          split. eauto. split. simpl. eapply nodup_intro in H3. exact. exact.
          eapply nodup_intro in H4. exact. exact. destruct H2. destruct H0. split.
          simpl. unfold "[<=]". intros. destruct H7. subst a. exact. eauto.
          simpl. unfold "[<=]". intros. destruct H7. subst a. exact. eauto. } Qed.

  Lemma matching_in_elim0 (M: list fill_type)(B: list Bid)(A: list Ask): matching_in B A M ->
                                                                         matching M.
  Proof. intros. unfold matching_in in H. destruct H. exact. Qed.

Lemma matching_in_elim (m: fill_type) (M: list fill_type)(B: list Bid)(A: list Ask):
  matching_in B A (m::M) -> matching_in B A M.
Proof. { intros. unfold matching_in in H. destruct H. destruct H0.
         unfold matching_in. split. eauto. split. eauto. eauto. } Qed.

Lemma matching_in_elim1 (m: fill_type) (M: list fill_type) (B: list Bid)(A: list Ask):
  matching_in B A (m::M) ->  (ask_of m) <= (bid_of m).
Proof. { unfold matching_in. intros H. destruct H as [H1 H].
         destruct H1 as [H1 H2]. eauto. } Qed.

Lemma matching_in_elim2 (m: fill_type) (M: list fill_type) (B: list Bid)(A: list Ask):
  matching_in B A (m::M) ->   ~ In (bid_of m) (bids_of M).
Proof. { unfold matching_in;unfold matching. intros H.
         destruct H as [H1 H]. destruct H as [H2 H]. destruct H1 as [H1 H3].
         destruct H3 as [H3 H4]. eauto. } Qed.

Lemma matching_in_elim3 (m: fill_type) (M: list fill_type) (B: list Bid)(A: list Ask):
  matching_in B A (m::M) ->   ~ In (ask_of m) (asks_of M).
Proof. { unfold matching_in;unfold matching. intros H.
         destruct H as [H1 H]. destruct H as [H2 H]. destruct H1 as [H1 H3].
         destruct H3 as [H3 H4]. eauto. } Qed.

Lemma matching_in_elim4 (m: fill_type) (M: list fill_type) (B: list Bid)(A: list Ask):
  matching_in B A (m::M) ->   In (bid_of m) B.
Proof. { unfold matching_in;unfold matching. intros H.
         destruct H as [H1 H]. destruct H as [H2 H]. destruct H1 as [H1 H3].
         destruct H3 as [H3 H4]. eauto. } Qed.

Lemma matching_in_elim4a (m: fill_type) (M: list fill_type) (B: list Bid)(A: list Ask):
  matching_in B A M -> In m M ->  In (bid_of m) B.
Proof. intros. destruct H. destruct H1. eauto. Qed.

Lemma matching_in_elim5 (m: fill_type) (M: list fill_type) (B: list Bid)(A: list Ask):
  matching_in B A (m::M) ->   In (ask_of m) A.
Proof. { unfold matching_in;unfold matching. intros H.
         destruct H as [H1 H]. destruct H as [H2 H]. destruct H1 as [H1 H3].
         destruct H3 as [H3 H4]. eauto. } Qed.

Lemma matching_in_elim5a (m: fill_type) (M: list fill_type) (B: list Bid)(A: list Ask):
  matching_in B A M ->  In m M -> In (ask_of m) A.
Proof. intros. unfold matching_in in H. destruct H. destruct H1. eauto. Qed.

Lemma matching_in_elim6 (a: Ask)(B: list Bid)(A: list Ask)(M: list fill_type):
  matching_in B A M -> matching_in B (a::A) M.
Proof. { unfold matching_in. intros. destruct H. destruct H0. split. exact.
         split. exact. eauto. } Qed.

Lemma matching_in_elim7 (b: Bid)(B: list Bid)(A: list Ask)(M: list fill_type):
  matching_in B A M -> matching_in (b::B) A M.
Proof. { unfold matching_in. intros. destruct H. destruct H0. split. exact.
         split. eauto. exact. } Qed.

Lemma matching_in_elim7a (m: fill_type)(B: list Bid)(A: list Ask)(M: list fill_type):
matching_in B A M -> matching_in B A (delete m M).

Proof. { unfold matching_in. intros. destruct H. destruct H0. split. eauto. split. eauto. eauto. } Qed.

 Lemma matching_in_elim8 (B: list Bid)(A: list Ask)(b: Bid)(a: Ask)(M: list fill_type):
   matching_in (b::B) (a::A) M -> ~ In b (bids_of M) -> ~ In a (asks_of M) -> matching_in B A M.
 Proof. { unfold matching_in. intros. destruct H. destruct H2. destruct H.
          destruct H4. unfold matching. split.
          { split. { exact. } { eauto. } }
          split.
          { eapply subset_nodup_subset in H2. all: exact. }
          { eapply subset_nodup_subset in H3. all: exact. } } Qed.

Hint Resolve matching_in_elim4a matching_in_elim5a: core.
Hint Immediate matching_in_intro: auction.
Hint Resolve matching_in_elim0 matching_in_elim matching_in_elim1 matching_in_elim2
     matching_in_elim3 matching_in_elim4 matching_in_elim5 : auction.

Hint Resolve matching_in_elim6 matching_in_elim7 matching_in_elim7a  matching_in_elim8: core.

(*----------------- Individual rational and  Fair matching--------------------------*)

Definition rational (m: fill_type):=
  ((bid_of m) >= tp m) /\ (tp m >= (ask_of m)).
Definition Is_IR (M: list fill_type):= forall m, In m M -> rational m.

Lemma Is_IR_elim (m: fill_type)(M: list fill_type): Is_IR (m::M) -> rational m.
Proof. { unfold Is_IR. intros H.  specialize H with m. simpl in H.
         destruct H. left. exact. unfold rational. eauto. } Qed.

Lemma Is_IR_elim1 (m: fill_type)(M: list fill_type): Is_IR (m::M)-> Is_IR M.
Proof. unfold Is_IR. simpl. intros. eauto. Qed.

Lemma Is_IR_elim2 (m: fill_type)(M: list fill_type): Is_IR M -> Is_IR (delete m M).
Proof. unfold Is_IR. intros. eauto. Qed.

Lemma Is_IR_intro (m: fill_type)(M: list fill_type): rational m -> Is_IR M -> Is_IR (m::M).
Proof.  unfold Is_IR. intros. destruct H1. subst m0. exact. auto. Qed.

Hint Immediate Is_IR_intro: auction.
Hint Resolve Is_IR_elim Is_IR_elim1: auction.

Definition fair_on_bids (M: list fill_type)(B: list Bid):=
  (forall b b', In b B /\ In b' B -> b > b' -> In b' (bids_of M) -> In b (bids_of M)).

Definition fair_on_asks (M: list fill_type) (A: list Ask):=
  (forall s s', In s A /\ In s' A -> s < s' -> In s' (asks_of M) -> In s (asks_of M)).

Definition Is_fair (M: list fill_type) (B: list Bid) (A: list Ask)
  :=  fair_on_asks M A /\ fair_on_bids M B.

(*------------------Uniform matching------------------------------*)

Definition Uniform (M : list fill_type) := uniform (trade_prices_of M).

Lemma tps_of_delete (M: list fill_type) (m: fill_type) (x:nat):
  In x (trade_prices_of (delete m M)) -> In x (trade_prices_of M).
  Proof. { intro H.
         assert (H1: exists m', In m' (delete m M) /\ (x=(tp m'))).
         eauto. destruct H1 as [m' H1]. destruct H1 as [H1 H2].
         cut (In m' M). subst x. eauto.
         eapply delete_elim1. exact H1. } Qed.

Lemma Uniform_intro (M:list fill_type) (m:fill_type) : Uniform M -> Uniform (delete m M).
Proof. { unfold Uniform. intro H.
         case M as [|m' M'] eqn: HM.
         { simpl. constructor. }
         { simpl in H. assert ((forall x, In x (tp m' :: trade_prices_of M')-> x= (tp m'))).
           eapply uniform_elim1. exact.
           simpl. destruct (m_eqb m m') eqn: Hm.
           { apply uniform_elim2 in H.  exact. }
           { simpl. cut (forall x, In x (trade_prices_of (delete m M')) -> x=(tp m')).
             eapply uniform_intro. intros x H1.
             assert (H1b: In x (trade_prices_of M')).
             { eapply tps_of_delete. exact H1. }
             apply H0. auto. }}} Qed.

Lemma Uniform_intro1 (M:list fill_type) (m:fill_type) : Uniform (m::M) -> Uniform M.
Proof. unfold Uniform.  simpl.  eapply uniform_elim2. Qed.

Lemma Uniform_elim (M:list fill_type) (m1 m2:fill_type) :
  Uniform M -> In m1 M -> In m2 M -> tp m1 = tp m2.
Proof. { unfold Uniform. intros H1 H2 H3.
         cut (In (tp m2) (trade_prices_of M)).
         cut (In (tp m1) (trade_prices_of M)).
         eapply uniform_elim4. exact. all:auto. } Qed.

Lemma Uniform_intro2 (M:list fill_type) (m m':fill_type) : Uniform M ->
In m M -> tp m = tp m' -> Uniform (m'::M).
Proof. { unfold Uniform. intros H1 H2 H3.
         assert (H0:In (tp m) (trade_prices_of M)).
         auto. simpl. eapply uniform_intro. intros x H4.
         rewrite <- H3. eapply uniform_elim4. exact H1. all:auto. } Qed.

Hint Resolve Uniform_intro  Uniform_intro1 Uniform_elim : core.
Hint Immediate Uniform_intro2 : core.

(*-------------- buyers_above and sellers_above relationship and results------------------*)

Definition buyers_above (p: nat)(B: list Bid): list Bid :=
  filter (fun x:Bid => Nat.leb p (bp x))  B.

Lemma buyers_above_elim (p:nat)(B: list Bid)(x:Bid):
  In x (buyers_above p B)-> bp(x) >= p.
Proof. { unfold buyers_above. intros H.
         induction B.
         {  simpl in H. destruct H. }
         {  simpl in H.
            destruct (p <=? a) eqn: H1.
            { simpl in H. destruct H. subst x. move /leP in H1. auto.
            apply IHB in H. exact. }
            { apply IHB in H. exact. }}} Qed.

Lemma buyers_above_intro (p:nat)(B: list Bid)(x:Bid):
 ( In x B /\ (Nat.leb p x)) -> In x (buyers_above p B).
Proof. { intros H. destruct H as [H1  H2].
         induction B.
         { destruct H1. }
         { simpl in H1.
           destruct H1 as [H1a | H1b].
           { subst x. simpl. destruct (p <=? a) eqn: Hpa. auto.
            apply IHB. eapply insert_elim2. apply insert_intro3.
            auto. }
           { apply IHB in H1b. simpl. destruct (p <=? a) eqn: Hpa.
             eauto. exact. }}} Qed.

Definition sellers_above (p: nat)(A: list Ask): list Ask :=
  filter (fun x:Ask => Nat.leb p (sp x)) (A).

Lemma sellers_above_elim (p:nat)(A: list Ask)(x:Ask):
  In x (sellers_above p A)-> sp(x) >= p.
Proof. { unfold sellers_above. intros H.
         induction A.
         {  simpl in H. destruct H. }
         {  simpl in H.
            destruct (p <=? a) eqn: H1.
            { simpl in H. destruct H. subst x. move /leP in H1. auto.
            apply IHA in H. exact. }
            { apply IHA in H. exact. }}} Qed.

Lemma sellers_above_intro (p:nat)(A: list Ask)(x:Ask):
 ( In x A /\ Nat.leb p x ) -> In x (sellers_above p A).
Proof. { intros H. destruct H as [H1  H2].
         induction A.
         { destruct H1. }
         { simpl in H1.
           destruct H1 as [H1a | H1b].
           { subst x. simpl. destruct (p <=? a) eqn: Hpa. auto.
             apply IHA. eapply insert_elim2. apply insert_intro3.
            auto. }
           { apply IHA in H1b. simpl. destruct (p <=? a) eqn: Hpa.
             eauto. exact. }}} Qed.

Definition buyers_below (p: nat)(B: list Bid): list Bid :=
  filter (fun x:Bid => Nat.leb (bp x) p) (B).

Lemma buyers_below_intro (p:nat)(B: list Bid)(x:Bid):
 ( In x B /\ Nat.leb x p ) -> In x (buyers_below p B).
Proof. { intros H. destruct H as [H1  H2].
         induction B.
         { destruct H1. }
         { simpl in H1.
           destruct H1 as [H1a | H1b].
           { subst x. simpl. destruct (a <=? p) eqn: Hpa. auto.
             apply IHB. eapply insert_elim2. apply insert_intro3.
            auto. }
           { apply IHB in H1b. simpl. destruct (a <=? p) eqn: Hpa.
             eauto. exact. }}} Qed.

Lemma buyers_below_elim (p:nat)(B: list Bid)(x:Bid):
  In x (buyers_below p B)-> bp(x) <= p.
Proof.  { unfold sellers_above. intros H.
         induction B.
         {  simpl in H. destruct H. }
         {  simpl in H.
            destruct (a <=? p) eqn: H1.
            { simpl in H. destruct H. subst x. move /leP in H1. auto.
            apply IHB in H. exact. }
            { apply IHB in H. exact. }}} Qed.

Definition sellers_below (p: nat)(A: list Ask): list Ask :=
  filter (fun x:Ask => Nat.leb (sp x) p) (A).

Lemma sellers_below_intro (p:nat)(A: list Ask)(x:Ask):
 ( In x A /\ Nat.leb x p ) -> In x (sellers_below p A).
Proof. { intros H. destruct H as [H1  H2].
         induction A.
         { destruct H1. }
         { simpl in H1.
           destruct H1 as [H1a | H1b].
           { subst x. simpl. destruct (a <=? p) eqn: Hpa. auto.
             apply IHA. eapply insert_elim2. apply insert_intro3.
            auto. }
           { apply IHA in H1b. simpl. destruct (a <=? p) eqn: Hpa.
             eauto. exact. }}} Qed.

Lemma sellers_below_elim (p:nat)(A: list Ask)(x:Ask):
  In x (sellers_below p A)-> sp(x) <= p.
Proof. { unfold sellers_below. intros H.
         induction A.
         {  simpl in H. destruct H. }
         {  simpl in H.
            destruct (a <=? p) eqn: H1.
            { simpl in H. destruct H. subst x. move /leP in H1. auto.
            apply IHA in H. exact. }
            { apply IHA in H. exact. }}} Qed.

Hint Resolve buyers_above_elim buyers_above_intro: auction.
Hint Resolve sellers_above_elim sellers_above_intro: auction.

Hint Resolve buyers_below_elim buyers_below_intro: auction.
Hint Resolve sellers_below_elim sellers_below_intro: auction.

Theorem buyers_above_ge_sellers (p:nat)(M: list fill_type) (B: list Bid) (A: list Ask):
  matching_in B A M -> | buyers_above p (bids_of M)| >= | sellers_above p (asks_of M)|.
 Proof. { intros H. destruct H as [H H0]. destruct H0 as [H0 H1].
          destruct H as [H H2]. destruct H2 as [H2 H3].
          induction M.
          { simpl. auto. }
          { simpl.
            destruct (p <=? bid_of a) eqn: Hpb.
            { destruct (p <=? ask_of a) eqn: Hpa.
              { simpl. cut ((| buyers_above p (bids_of M) |) >= (| sellers_above p (asks_of M) |)).
            omega. apply IHM. all:eauto. }
              { simpl. cut ((| buyers_above p (bids_of M) |) >= (| sellers_above p (asks_of M) |)).
            omega. apply IHM. all:eauto. } }
            { destruct (p <=? ask_of a) eqn: Hpa.
              { move /leP in Hpb. move /leP in Hpa.
                unfold All_matchable in H. assert (H4: (ask_of a <= bid_of a)).
                apply H. auto. omega. }
              { apply IHM. all: eauto. }}}} Qed.

Theorem sellers_below_ge_buyers (p:nat)(M: list fill_type) (B: list Bid) (A: list Ask):
  matching_in B A M -> | buyers_below p (bids_of M)| <= | sellers_below p (asks_of M)|.
Proof. { intros H. destruct H as [H H0]. destruct H0 as [H0 H1].
          destruct H as [H H2]. destruct H2 as [H2 H3].
          induction M.
          { simpl. auto. }
          { simpl.
            destruct (bid_of a <=? p) eqn: Hpb.
            { destruct (ask_of a <=? p) eqn: Hpa.
              { simpl. cut ((| buyers_below p (bids_of M) |) <= (| sellers_below p (asks_of M) |)).
            omega. apply IHM. all:eauto. }
              { move /leP in Hpb. move /leP in Hpa.
                unfold All_matchable in H.
                assert (H4: (ask_of a <= bid_of a)).
                apply H. auto. omega. } }
            { destruct (ask_of a <=? p) eqn: Hpa.
              { simpl. cut ((| buyers_below p (bids_of M) |) <= (| sellers_below p (asks_of M) |)).
            omega. apply IHM. all:eauto.
              }
              { apply IHM. all: eauto. }}}} Qed.

Lemma matchable_buy_above_sell_below (b:Bid) (a: Ask) (B: list Bid) (A: list Ask) (p:nat): In b (buyers_above p B) -> In a (sellers_below p A)
-> a<=b.
Proof. intros. apply  buyers_above_elim in H. apply sellers_below_elim in H0. omega. Qed.

Lemma buy_below_above_total (M: list fill_type) (B:list Bid) (A:list Ask) (p:nat):
(matching_in B A M) -> (|(buyers_above p (bids_of M))|) + (|(buyers_below p (bids_of M))|) >= |M|.
Proof. { intros H. destruct H as [H H0]. destruct H0 as [H0 H1].
          destruct H as [H H2]. destruct H2 as [H2 H3].
          induction M. { simpl. auto. }
           { simpl.
            destruct (p <=? bid_of a) eqn: Hpb.
            { destruct (bid_of a <=? p) eqn: Hpa.
            { simpl. cut ((| buyers_above p (bids_of M) |) + (| buyers_below p (bids_of M) |) >= |M|).
            omega. apply IHM. all:eauto. }
            { simpl. cut ((| buyers_above p (bids_of M) |) + (| buyers_below p (bids_of M) |) >= |M|).
            omega. apply IHM. all:eauto. } }
            { destruct (bid_of a <=? p) eqn: Hpa.
            { simpl. cut ((| buyers_above p (bids_of M) |) + (| buyers_below p (bids_of M) |) >= |M|). omega. apply IHM. all:eauto. }
            { move /leP in Hpb. move /leP in Hpa. omega. } }}} Qed.

Lemma sell_below_above_total (M: list fill_type) (B:list Bid) (A:list Ask) (p:nat):
(matching_in B A M) -> (|(sellers_above p (asks_of M))|) + (|(sellers_below p (asks_of M))|) >= |M|.
Proof. { intros H. destruct H as [H H0]. destruct H0 as [H0 H1].
          destruct H as [H H2]. destruct H2 as [H2 H3].
          induction M. { simpl. auto. }
           { simpl.
            destruct (p <=? ask_of a) eqn: Hpb.
            { destruct (ask_of a <=? p) eqn: Hpa.
            { simpl. cut ((|(sellers_above p (asks_of M))|) + (|(sellers_below p (asks_of M))|) >= |M|).
            omega. apply IHM. all:eauto. }
            { simpl. cut ((|(sellers_above p (asks_of M))|) + (|(sellers_below p (asks_of M))|) >= |M|).
            omega. apply IHM. all:eauto. } }
            { destruct (ask_of a <=? p) eqn: Hpa.
            { simpl. cut ((|(sellers_above p (asks_of M))|) + (|(sellers_below p (asks_of M))|) >= |M|). omega. apply IHM. all:eauto. }
            { move /leP in Hpb. move /leP in Hpa. omega. } }}} Qed.

Lemma maching_buyer_right_plus_seller_left
(M: list fill_type) (B:list Bid) (A:list Ask) (p:nat):
(matching_in B A M) -> (|(buyers_above p (bids_of M))|) + (|(sellers_below p (asks_of M))|) >= |M|.
Proof.  intros H. apply sellers_below_ge_buyers with (p:=p) in H  as H1.
                  eapply buyers_above_ge_sellers with (p:=p) in H as H2.
                  eapply buy_below_above_total with (p:=p) in H as H3.
                  eapply sell_below_above_total with (p:=p) in H as H4.
                  omega. Qed.

End Matching.

Hint Unfold All_matchable : core.
Hint Immediate All_matchable_intro All_matchable_nil: core.
Hint Resolve All_matchable_elim All_matchable_elim1 All_matchable_elim2 : core.

Hint Resolve matching_elim0 matching_elim1 matching_elim2 matching_elim3: core.
Hint Resolve matching_elim4 matching_elim5 matching_elim6 matching_elim7: core.
Hint Resolve matching_elim8 matching_elim9: core.
Hint Resolve matching_elim10 matching_elim11: core.
Hint Resolve matching_elim12 matching_elim13: core.
Hint Resolve matching_elim14 matching_elim15: core.

Hint Resolve nill_is_matching: core.
Hint Immediate matching_in_intro: core.
Hint Resolve matching_in_elim0 matching_in_elim matching_in_elim1: core.
Hint Resolve matching_in_elim2 matching_in_elim3 matching_in_elim4: core.
Hint Resolve matching_in_elim4a matching_in_elim5a: core.
Hint Resolve matching_in_elim5 matching_in_elim6 matching_in_elim7 matching_in_elim7a matching_in_elim8: core.
Hint Immediate Is_IR_intro: core.
Hint Resolve Is_IR_elim Is_IR_elim1: core.

Hint Resolve Uniform_intro Uniform_elim Uniform_intro1 : core.
Hint Immediate Uniform_intro2 : core.


(****************************************************************************)
(*                                                                          *)
(*                                   Menhir                                 *)
(*                                                                          *)
(*           Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud         *)
(*                                                                          *)
(*  Copyright Inria. All rights reserved. This file is distributed 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, as described in the file LICENSE.            *)
(*                                                                          *)
(****************************************************************************)

From Coq Require Import Omega List Syntax Relations RelationClasses.

Local Obligation Tactic := intros.

(** A comparable type is equiped with a [compare] function, that define an order
   relation. **)
Class Comparable (A:Type) := {
  compare : A -> A -> comparison;
  compare_antisym : forall x y, CompOpp (compare x y) = compare y x;
  compare_trans :  forall x y z c,
    (compare x y) = c -> (compare y z) = c -> (compare x z) = c
}.

Theorem compare_refl {A:Type} (C: Comparable A) :
  forall x, compare x x = Eq.
Proof.
intros.
pose proof (compare_antisym x x).
destruct (compare x x); intuition; try discriminate.
Qed.

(** The corresponding order is a strict order. **)
Definition comparableLt {A:Type} (C: Comparable A) : relation A :=
  fun x y => compare x y = Lt.

Instance ComparableLtStrictOrder {A:Type} (C: Comparable A) :
  StrictOrder (comparableLt C).
Proof.
apply Build_StrictOrder.
unfold Irreflexive, Reflexive, complement, comparableLt.
intros.
pose proof H.
rewrite <- compare_antisym in H.
rewrite H0 in H.
discriminate H.
unfold Transitive, comparableLt.
intros x y z.
apply compare_trans.
Qed.

(** nat is comparable. **)
Program Instance natComparable : Comparable nat :=
  { compare := Nat.compare }.
Next Obligation.
symmetry.
destruct (Nat.compare x y)  as [] eqn:?.
rewrite Nat.compare_eq_iff in Heqc.
destruct Heqc.
rewrite Nat.compare_eq_iff.
trivial.
rewrite <- nat_compare_lt in *.
rewrite <- nat_compare_gt in *.
trivial.
rewrite <- nat_compare_lt in *.
rewrite <- nat_compare_gt in *.
trivial.
Qed.
Next Obligation.
destruct c.
rewrite Nat.compare_eq_iff in *; destruct H; assumption.
rewrite <- nat_compare_lt in *.
apply (Nat.lt_trans _ _ _ H H0).
rewrite <- nat_compare_gt in *.
apply (gt_trans _ _ _ H H0).
Qed.

(** A pair of comparable is comparable. **)
Program Instance PairComparable {A:Type} (CA:Comparable A) {B:Type} (CB:Comparable B) :
  Comparable (A*B) :=
  { compare := fun x y =>
      let (xa, xb) := x in let (ya, yb) := y in
      match compare xa ya return comparison with
        | Eq => compare xb yb
        | x => x
      end }.
Next Obligation.
destruct x, y.
rewrite <- (compare_antisym a a0).
rewrite <- (compare_antisym b b0).
destruct (compare a a0); intuition.
Qed.
Next Obligation.
destruct x, y, z.
destruct (compare a a0) as [] eqn:?, (compare a0 a1) as [] eqn:?;
try (rewrite <- H0 in H; discriminate);
try (destruct (compare a a1) as [] eqn:?;
  try (rewrite <- compare_antisym in Heqc0;
         rewrite CompOpp_iff in Heqc0;
         rewrite (compare_trans _ _ _  _ Heqc0 Heqc2) in Heqc1;
         discriminate);
  try (rewrite <- compare_antisym in Heqc1;
         rewrite CompOpp_iff in Heqc1;
         rewrite (compare_trans _ _ _ _ Heqc2 Heqc1) in Heqc0;
         discriminate);
  assumption);
rewrite (compare_trans _ _ _ _ Heqc0 Heqc1);
try assumption.
apply (compare_trans _ _ _ _ H H0).
Qed.

(** Special case of comparable, where equality is Leibniz equality. **)
Class ComparableLeibnizEq {A:Type} (C: Comparable A) :=
  compare_eq : forall x y, compare x y = Eq -> x = y.

(** Boolean equality for a [Comparable]. **)
Definition compare_eqb {A:Type} {C:Comparable A} (x y:A) :=
  match compare x y with
    | Eq => true
    | _ => false
  end.

Theorem compare_eqb_iff {A:Type} {C:Comparable A} {U:ComparableLeibnizEq C} :
  forall x y, compare_eqb x y = true <-> x = y.
Proof.
unfold compare_eqb.
intuition.
apply compare_eq.
destruct (compare x y); intuition; discriminate.
destruct H.
rewrite compare_refl; intuition.
Qed.

Instance NComparableLeibnizEq : ComparableLeibnizEq natComparable := Nat.compare_eq.

(** A pair of ComparableLeibnizEq is ComparableLeibnizEq **)
Instance PairComparableLeibnizEq
  {A:Type} {CA:Comparable A} (UA:ComparableLeibnizEq CA)
  {B:Type} {CB:Comparable B} (UB:ComparableLeibnizEq CB) :
    ComparableLeibnizEq (PairComparable CA CB).
Proof.
intros x y; destruct x, y; simpl.
pose proof (compare_eq a a0); pose proof (compare_eq b b0).
destruct (compare a a0); try discriminate.
intuition.
destruct H2, H0.
reflexivity.
Qed.

(** An [Finite] type is a type with the list of all elements. **)
Class Finite (A:Type) := {
  all_list : list A;
  all_list_forall : forall x:A, In x all_list
}.

(** An alphabet is both [ComparableLeibnizEq] and [Finite]. **)
Class Alphabet (A:Type) := {
  AlphabetComparable :> Comparable A;
  AlphabetComparableLeibnizEq :> ComparableLeibnizEq AlphabetComparable;
  AlphabetFinite :> Finite A
}.

(** The [Numbered] class provides a conveniant way to build [Alphabet] instances,
   with a good computationnal complexity. It is mainly a injection from it to
   [positive] **)
Class Numbered (A:Type) := {
  inj : A -> positive;
  surj : positive -> A;
  surj_inj_compat : forall x, surj (inj x) = x;
  inj_bound : positive;
  inj_bound_spec : forall x, (inj x < Pos.succ inj_bound)%positive
}.

Program Instance NumberedAlphabet {A:Type} (N:Numbered A) : Alphabet A :=
  { AlphabetComparable := {| compare := fun x y => Pos.compare (inj x) (inj y) |};
    AlphabetFinite :=
      {| all_list := fst (Pos.iter
                           (fun '(l, p) => (surj p::l, Pos.succ p))
                           ([], 1%positive) inj_bound) |} }.
Next Obligation. simpl. now rewrite <- Pos.compare_antisym. Qed.
Next Obligation.
  match goal with c : comparison |- _ => destruct c end.
  - rewrite Pos.compare_eq_iff in *. congruence.
  - rewrite Pos.compare_lt_iff in *. eauto using Pos.lt_trans.
  - rewrite Pos.compare_gt_iff in *. eauto using Pos.lt_trans.
Qed.
Next Obligation.
  intros x y. unfold compare. intros Hxy.
  assert (Hxy' : inj x = inj y).
  (* We do not use [Pos.compare_eq_iff] directly to make sure the
     proof is executable. *)
  { destruct (Pos.eq_dec (inj x) (inj y)) as [|[]]; [now auto|].
    now apply Pos.compare_eq_iff. }
  (* Using rewrite here leads to non-executable proofs. *)
  transitivity (surj (inj x)).
  { apply eq_sym, surj_inj_compat. }
  transitivity (surj (inj y)); cycle 1.
  { apply surj_inj_compat. }
  apply f_equal, Hxy'.
Defined.
Next Obligation.
  rewrite <-(surj_inj_compat x).
  generalize (inj_bound_spec x). generalize (inj x). clear x. intros x.
  match goal with |- ?Hx -> In ?s (fst ?p) =>
    assert ((Hx -> In s (fst p)) /\ snd p = Pos.succ inj_bound); [|now intuition] end.
  rewrite Pos.lt_succ_r.
  induction inj_bound as [|y [IH1 IH2]] using Pos.peano_ind;
    (split; [intros Hx|]); simpl.
  - rewrite (Pos.le_antisym _ _ Hx); auto using Pos.le_1_l.
  - auto.
  - rewrite Pos.iter_succ. destruct Pos.iter; simpl in *. subst.
    rewrite Pos.le_lteq in Hx. destruct Hx as [?%Pos.lt_succ_r| ->]; now auto.
  - rewrite Pos.iter_succ. destruct Pos.iter. simpl in IH2. subst. reflexivity.
Qed.

(** Definitions of [FSet]/[FMap] from [Comparable] **)
Require Import OrderedTypeAlt.
Require FSetAVL.
Require FMapAVL.
Import OrderedType.

Module Type ComparableM.
  Parameter t : Type.
  Declare Instance tComparable : Comparable t.
End ComparableM.

Module OrderedTypeAlt_from_ComparableM (C:ComparableM) <: OrderedTypeAlt.
  Definition t := C.t.
  Definition compare : t -> t -> comparison := compare.

  Infix "?=" := compare (at level 70, no associativity).

  Lemma compare_sym x y : (y?=x) = CompOpp (x?=y).
  Proof. exact (Logic.eq_sym (compare_antisym x y)). Qed.
  Lemma compare_trans c x y z :
    (x?=y) = c -> (y?=z) = c -> (x?=z) = c.
  Proof.
  apply compare_trans.
  Qed.
End OrderedTypeAlt_from_ComparableM.

Module OrderedType_from_ComparableM (C:ComparableM) <: OrderedType.
  Module Alt := OrderedTypeAlt_from_ComparableM C.
  Include (OrderedType_from_Alt Alt).
End OrderedType_from_ComparableM.


(*|
#######################################################
Abstracting leads to a term ill-typed... yet well-typed
#######################################################

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

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

I was stuck on a problem for a while, for which I derived a smaller
standalone example:
|*)

Axiom f : nat -> Set.

Goal forall (n : nat) (e : n = n) (x : f n),
    match e in _ = _n return f _n -> Prop with
    | Logic.eq_refl => fun v : f n => v = x
    end x.

(*|
Now, if you try to ``destruct e``, you get the following error
message:
|*)

  Fail destruct e. (* .unfold .messages *)
Abort. (* .none *)

(*|
After scratching my head for a while, I couldn't figure out what was
ill-typed in that term... So I tried this:
|*)

Definition illt :=
  fun (n : nat) (e : n = n) =>
    forall x : f n,
      match e in _ = _n return f _n -> Prop with
      | Logic.eq_refl => fun v : f n => v = x
      end x.

(*| And Coq accepts it, at type |*)

Check illt. (* .unfold .messages *)

(*|
So, what is wrong with this error message, and how could I solve/tweak
my initial goal?

----

EDIT: To address Robin Green's comment, here is the ``Set Printing
All`` versions of the error message:

.. coq:: none
|*)

Set Printing All.

Goal forall (n : nat) (e : n = n) (x : f n),
    match e in _ = _n return f _n -> Prop with
    | Logic.eq_refl => fun v : f n => v = x
    end x.

(*||*)

  Fail destruct e. (* .unfold .messages *)
Abort. (* .none *)

(*| It is a well-typed term, and nothing is implicit. |*)

(*|
Answer
******

Here is a possible explanation of the problem. What happens when
constructing a pattern-matching construct can also be described using
a theorem. Here is my view of the theorem that is being used in your
case.
|*)

Reset Initial. (* .none *)
Axiom f : nat -> Set. (* .none *)
Check eq_rect. (* .unfold *)

(*|
So when pattern matching on an equality, you have to provide a formula
``P`` parametrized on **any value** ``y`` that happens to be provably
equal to ``x``. Intuitively, you should be able to replace your
pattern-matching expression by ``apply eq_rect``, but the property
``P`` that should come up there is beyond the reach of what Coq can
guess, because every occurrence of ``x`` in your formula is bound to
be in type ``f n`` and cannot just be in type ``f m`` where ``m = n``.
The error message does not say that, it is probably a mistake.

To perform your proof, I suggest rather to use the fact that proofs of
equality are unique in certain classes of types, and ``nat`` belongs
to such a class. This is treated in the file ``Eqdep_dec``.
|*)

Require Eqdep_dec Arith.

(*| Now your proof goes through quite easily. |*)

Goal forall n (x : f n) (e : n = n),
    match e in _ = _n return f _n -> Prop with
    | Logic.eq_refl => fun v : f n => v = x
    end x.
  intros n x e. replace e with (eq_refl n).
  - reflexivity.
  - apply Eqdep_dec.UIP_dec, PeanoNat.Nat.eq_dec.
Qed.

(*|
Now, this solution may feel unsatisfactory. Where does this
``UIP_dec`` come from? UIP stands for *uniqueness of identity proofs*
and unfortunately, this property is not guaranteed for all arbitrary
types. It is guaranteed for all types where equality is decidable (as
expressed by ``UIP_dec``), for instance ``nat``.
|*)


(* Distributed under the terms of the MIT license. *)
Require Import ssreflect.
Require Import Equations.Type.Relation Equations.Type.Relation_Properties.
Require Import CRelationClasses.

#[global] Hint Mode Reflexive ! ! : typeclass_instances.

Infix "<~>" := iffT (at level 90).

Definition iffT_l {P Q} : P <~> Q -> P -> Q.
Proof.
  apply: fst.
Qed.
Coercion iffT_l : CRelationClasses.iffT >-> Funclass.

(** This allow to use implicit projections for move/ on "<~>" lemmas *)
Hint View for move/ fst|2.
Hint View for move/ snd|2.

Notation "'precompose'" := (fun R f x y => R (f x) (f y)) (only parsing).

Definition on_rel {A B} (R : A -> A -> Prop) (f : B -> A) : B -> B -> Prop :=
  fun x y => R (f x) (f y).

Definition on_Trel {A B} (R : A -> A -> Type) (f : B -> A) : B -> B -> Type :=
  fun x y => R (f x) (f y).

Notation Trel_conj R S :=
  (fun x y => R x y * S x y)%type.

Notation on_Trel_eq R f g :=
  (fun x y => (R (f x) (f y) * (g x = g y)))%type.

Section Flip.
  Local Set Universe Polymorphism.
  Context {A : Type} (R : crelation A).

  Lemma flip_Reflexive : Reflexive R -> Reflexive (flip R).
  Proof using Type.
    intros HR x. unfold flip. apply reflexivity.
  Qed.

  Lemma flip_Symmetric : Symmetric R -> Symmetric (flip R).
  Proof using Type.
    intros HR x y. unfold flip. apply symmetry.
  Qed.

  Lemma flip_Transitive : Transitive R -> Transitive (flip R).
  Proof using Type.
    intros HR x y z xy yz.
    unfold flip in *. eapply HR; eassumption.
  Qed.

End Flip.

Definition commutes {A} (R S : relation A) :=
  forall x y z, R x y -> S x z -> { w & S y w * R z w}%type.

Lemma clos_t_rt {A} {R : A -> A -> Type} x y : trans_clos R x y -> clos_refl_trans R x y.
Proof.
  induction 1; try solve [econstructor; eauto].
Qed.

Arguments rt_step {A} {R} {x y}.
#[global] Polymorphic Hint Resolve rt_refl rt_step : core.

Definition clos_rt_monotone {A} (R S : relation A) :
  inclusion R S -> inclusion (clos_refl_trans R) (clos_refl_trans S).
Proof.
  move => incls x y.
  induction 1; solve [econstructor; eauto].
Qed.

Lemma relation_equivalence_inclusion {A} (R S : relation A) :
  inclusion R S -> inclusion S R -> relation_equivalence R S.
Proof. firstorder. Qed.

Lemma clos_rt_disjunction_left {A} (R S : relation A) :
  inclusion (clos_refl_trans R)
            (clos_refl_trans (relation_disjunction R S)).
Proof.
  apply clos_rt_monotone.
  intros x y H; left; exact H.
Qed.

Lemma clos_rt_disjunction_right {A} (R S : relation A) :
  inclusion (clos_refl_trans S)
            (clos_refl_trans (relation_disjunction R S)).
Proof.
  apply clos_rt_monotone.
  intros x y H; right; exact H.
Qed.

Global Instance clos_rt_trans A R : Transitive (@clos_refl_trans A R).
Proof.
  intros x y z H H'. econstructor 3; eauto.
Qed.

Global Instance clos_rt_refl A R : Reflexive (@clos_refl_trans A R).
Proof. intros x. constructor 2. Qed.

Lemma clos_refl_trans_prod_l {A B} (R : relation A) (S : relation (A * B)) :
  (forall x y b, R x y -> S (x, b) (y, b)) ->
  forall (x y : A) b,
    clos_refl_trans R x y ->
    clos_refl_trans S (x, b) (y, b).
Proof.
  intros. induction X0; try solve [econstructor; eauto].
Qed.

Lemma clos_refl_trans_prod_r {A B} (R : relation B) (S : relation (A * B)) a :
  (forall x y, R x y -> S (a, x) (a, y)) ->
  forall (x y : B),
    clos_refl_trans R x y ->
    clos_refl_trans S (a, x) (a, y).
Proof.
  intros. induction X0; try solve [econstructor; eauto].
Qed.

Lemma clos_rt_t_incl {A} {R : relation A} `{Reflexive A R} :
  inclusion (clos_refl_trans R) (trans_clos R).
Proof.
  intros x y. induction 1; try solve [econstructor; eauto].
Qed.

Lemma clos_t_rt_incl {A} {R : relation A} `{Reflexive A R} :
  inclusion (trans_clos R) (clos_refl_trans R).
Proof.
  intros x y. induction 1; try solve [econstructor; eauto].
Qed.

Lemma clos_t_rt_equiv {A} {R} `{Reflexive A R} :
  relation_equivalence (trans_clos R) (clos_refl_trans R).
Proof.
  apply relation_equivalence_inclusion.
  apply clos_t_rt_incl.
  apply clos_rt_t_incl.
Qed.

Global Instance relation_disjunction_refl_l {A} {R S : relation A} :
  Reflexive R -> Reflexive (relation_disjunction R S).
Proof.
  intros HR x. left; auto.
Qed.

Global Instance relation_disjunction_refl_r {A} {R S : relation A} :
  Reflexive S -> Reflexive (relation_disjunction R S).
Proof.
  intros HR x. right; auto.
Qed.

Global Instance clos_rt_trans_Symmetric A R :
  Symmetric R -> Symmetric (@clos_refl_trans A R).
Proof.
  intros X x y H. induction H; eauto.
  eapply clos_rt_trans; eassumption.
Qed.

Definition clos_sym {A} (R : relation A) := relation_disjunction R (flip R).

Global Instance clos_sym_Symmetric A R :
  Symmetric (@clos_sym A R).
Proof.
  intros x y []; [right|left]; assumption.
Qed.

Global Instance clos_refl_sym_trans_Symmetric A R :
  Symmetric (@clos_refl_sym_trans A R)
  := rst_sym R.

Global Instance clos_refl_sym_trans_Reflexive A R :
  Reflexive (@clos_refl_sym_trans A R)
  := rst_refl R.

Global Instance clos_refl_sym_trans_Transitive A R :
  Transitive (@clos_refl_sym_trans A R)
  := rst_trans R.

Global Instance relation_disjunction_Symmetric {A} {R S : relation A} :
  Symmetric R -> Symmetric S -> Symmetric (relation_disjunction R S).
Proof.
  intros HR HS x y [X|X]; [left|right]; eauto.
Qed.

Ltac rst_induction h :=
  induction h; [constructor|reflexivity|etransitivity].

(* Definition MR {T M} (R : M -> M -> Prop) (m : T -> M) (x y: T): Prop := R (m x) (m y). *)

(* From measure_wf of Program.Wf *)
Lemma wf_precompose {T M} (R : M -> M -> Prop) (m : T -> M) :
  well_founded R -> well_founded (precompose R m).
Proof with auto.
  unfold well_founded. intro wf.
  cut (forall (a: M) (a0: T), m a0 = a -> Acc (precompose R m) a0).
  + intros.
    apply (H (m a))...
  + apply (@well_founded_ind M R wf (fun mm => forall a, m a = mm -> Acc _ a)).
    intros. apply Acc_intro.
    intros. rewrite H0 in H1. apply (H (m y))...
Defined.