(***************************************************************************
* Preservation and Progress for mini-ML (CBV) - Infrastructure             *
* Arthur Charguéraud, July 2007, Coq v8.1                                  *
***************************************************************************)

Set Implicit Arguments.
Require Import List Metatheory ML_Definitions.

(* move to environment *)

Lemma ok_iter_push : forall (A:Set) n E xs (vs:list A),
  fresh (dom E) n xs ->
  ok E ->
  ok (E & iter_push xs vs).
Proof.
  introv Fr Ok. gen E n vs. induction xs; intros; simpl. auto.
  destruct vs; simpls. auto. destruct n; destruct Fr.
  rewrite iter_push_cons. rewrite* <- concat_assoc.
Qed.

Hint Resolve ok_iter_push.

(* ====================================================================== *)
(** * Additional Definitions used in the Proofs *)

(* ********************************************************************** *)
(** ** Free Type Variables *)

(** Computing free variables of a list of terms. *)

Definition typ_fv_list :=
  List.fold_right (fun t acc => typ_fv t \u acc) {}.

(** Computing free variables of a type scheme. *)

Definition sch_fv M :=
  typ_fv (sch_type M).

(* ********************************************************************** *)
(** ** Free Term Variables *)

(** Computing free variables of a term. *)

Fixpoint trm_fv (t : trm) {struct t} : vars :=
  match t with
  | trm_bvar i j  => {}
  | trm_fvar x    => {{x}}
  | trm_abs t1    => (trm_fv t1)
  | trm_fix t1    => (trm_fv t1)
  | trm_let t1 t2 => (trm_fv t1) \u (trm_fv t2)
  | trm_match t1 p1 b t2 => (trm_fv t1) \u (trm_fv b) \u (trm_fv t2)
  | trm_app t1 t2 => (trm_fv t1) \u (trm_fv t2)
  | trm_unit      => {}
  | trm_nat n     => {}
  | trm_add       => {}
  | trm_pair t1 t2 => (trm_fv t1) \u (trm_fv t2)
  | trm_inj1 t1   => (trm_fv t1)
  | trm_inj2 t1   => (trm_fv t1)
  | trm_loc l     => {}
  | trm_ref t1    => (trm_fv t1)
  | trm_get t1    => (trm_fv t1)
  | trm_set t1 t2 => (trm_fv t1) \u (trm_fv t2)
  | trm_raise t1    => (trm_fv t1)
  | trm_catch t1 t2 => (trm_fv t1) \u (trm_fv t2)
  end.

(* ********************************************************************** *)
(** ** Free Variables in Environments *)

(** Computing free type variables of the values of an environment. *)

Definition env_fv :=
  fv_in sch_fv.

(** Computing free type variables of the values for store typing. *)

Definition phi_fv :=
  fv_in typ_fv.

(* ********************************************************************** *)
(** ** Type substitution for free names *)

(** Substitution for names for types *)

Fixpoint typ_subst (Z : var) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_bvar i      => typ_bvar i
  | typ_fvar X      => if X == Z then U else (typ_fvar X)
  | typ_arrow T1 T2 => typ_arrow (typ_subst Z U T1) (typ_subst Z U T2)
  | typ_unit        => typ_unit
  | typ_nat         => typ_nat
  | typ_prod T1 T2  => typ_prod (typ_subst Z U T1) (typ_subst Z U T2)
  | typ_sum T1 T2   => typ_sum (typ_subst Z U T1) (typ_subst Z U T2)
  | typ_ref T1      => typ_ref (typ_subst Z U T1)
  end.

(** Iterated substitution for types  *)

Fixpoint typ_substs (Zs : list var) (Us : list typ) (T : typ)
   {struct Zs} : typ :=
  match Zs, Us with
  | Z::Zs', U::Us' => typ_substs Zs' Us' (typ_subst Z U T)
  | _, _ => T
  end.

(** Substitution for names for schemes. *)

Definition sch_subst Z U M :=
  Sch (sch_arity M) (typ_subst Z U (sch_type M)).

(** Iterated substitution for schemes. *)

Definition sch_substs Zs Us M :=
  Sch (sch_arity M) (typ_substs Zs Us (sch_type M)).

(* ********************************************************************** *)
(** ** Term substitution for free names *)

(** Computing free variables of a list of terms. *)

Definition trm_fv_list :=
  List.fold_right (fun t acc => trm_fv t \u acc) {}.

(** Substitution for names *)

Fixpoint trm_subst (z : var) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i j  => trm_bvar i j
  | trm_fvar x    => if x == z then u else (trm_fvar x)
  | trm_abs t1    => trm_abs (trm_subst z u t1)
  | trm_fix t1    => trm_fix (trm_subst z u t1)
  | trm_let t1 t2 => trm_let (trm_subst z u t1) (trm_subst z u t2)
  | trm_match t1 p1 e t2 => trm_match (trm_subst z u t1) p1
                               (trm_subst z u e)
                               (trm_subst z u t2)
  | trm_app t1 t2 => trm_app (trm_subst z u t1) (trm_subst z u t2)
  | trm_unit      => trm_unit
  | trm_nat n     => trm_nat n
  | trm_add       => trm_add
  | trm_pair t1 t2 => trm_pair (trm_subst z u t1) (trm_subst z u t2)
  | trm_inj1 t1  => trm_inj1 (trm_subst z u t1)
  | trm_inj2 t1  => trm_inj2 (trm_subst z u t1)
  | trm_loc l     => trm_loc l
  | trm_ref t1    => trm_ref (trm_subst z u t1)
  | trm_get t1    => trm_get (trm_subst z u t1)
  | trm_set t1 t2 => trm_set (trm_subst z u t1) (trm_subst z u t2)
  | trm_raise t1    => trm_raise (trm_subst z u t1)
  | trm_catch t1 t2 => trm_catch (trm_subst z u t1) (trm_subst z u t2)
  end.

Notation "[ z ~> u ] t" := (trm_subst z u t) (at level 68).

(** Iterated substitution *)

Fixpoint substs (zs : list var) (us : list trm) (t : trm)
   {struct zs} : trm :=
  match zs, us with
  | z::zs', u::us' => substs zs' us' ([z ~> u]t)
  | _, _ => t
  end.

(** Predicate caraterizing lists of a given number of terms *)

Definition terms := list_for_n term.

(* ********************************************************************** *)
(** ** Iterated typing *)

(** Iterated typing *)

Inductive typings (E : env) (P : phi) : list trm -> list typ -> Prop :=
  | typings_nil : typings E P nil nil
  | typings_cons : forall ts Us t U,
      typings E P ts Us ->
      typing E P t U ->
      typings E P (t::ts) (U::Us).

(* ====================================================================== *)
(** * Tactics *)

(* ********************************************************************** *)
(** ** Instanciation of Tactics *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => {{ x }}) in
  let C := gather_vars_with (fun x : env => dom x) in
  let D := gather_vars_with (fun x : trm => trm_fv x) in
  let E := gather_vars_with (fun x : typ => typ_fv x) in
  let F := gather_vars_with (fun x : list trm => trm_fv_list x) in
  let G := gather_vars_with (fun x : list typ => typ_fv_list x) in
  let H := gather_vars_with (fun x : env => env_fv x) in
  let I := gather_vars_with (fun x : sch => sch_fv x) in
  let J := gather_vars_with (fun x : phi => phi_fv x) in
  constr:(A \u B \u C \u D \u E \u F \u G \u H \u I \u J).

Tactic Notation "pick_fresh" ident(x) :=
  let L := gather_vars in (pick_fresh_gen L x).

Tactic Notation "pick_freshes" constr(n) ident(x) :=
  let L := gather_vars in (pick_freshes_gen L n x).

Tactic Notation "apply_fresh" constr(T) :=
  apply_fresh_base_simple T gather_vars.

Tactic Notation "apply_fresh" "*" constr(T) :=
  apply_fresh T; auto*.

(* ********************************************************************** *)
(** ** Automation *)

Hint Constructors type term phi_ok sto_ok pat_typing typing value red typings.

Lemma trm_def_fresh : trm_fv trm_def = {}.
Proof.
  auto.
Qed.
Lemma typ_def_fresh : typ_fv typ_def = {}.
Proof.
  auto.
Qed.

Hint Extern 1 (_ \notin trm_fv trm_def) =>
  rewrite trm_def_fresh.
Hint Extern 1 (_ \notin typ_fv typ_def) =>
  rewrite typ_def_fresh.
Hint Extern 1 (_ \notin typ_fv typ_exn) =>
  rewrite typ_exn_fresh.

Hint Extern 1 (terms _ _) => split; auto.
Hint Extern 1 (types _ _) => split; auto.

(* ====================================================================== *)
(** ** Properties of iterated operator *)

Lemma typ_fv_list_map : forall ts1 ts2,
  typ_fv_list (ts1 ++ ts2) = typ_fv_list ts1 \u typ_fv_list ts2.
Proof.
  induction ts1; simpl; intros.
  rewrite* union_empty_l.
  rewrite IHts1. rewrite* union_assoc.
Qed.

Lemma trm_fv_list_map : forall ts1 ts2,
  trm_fv_list (ts1 ++ ts2) = trm_fv_list ts1 \u trm_fv_list ts2.
Proof.
  induction ts1; simpl; intros.
  rewrite* union_empty_l.
  rewrite IHts1. rewrite* union_assoc.
Qed.

Lemma typings_concat : forall E P ts1 Us1 ts2 Us2,
  typings E P ts1 Us1 ->
  typings E P ts2 Us2 ->
  typings E P (ts1++ts2) (Us1++Us2).
Proof.
  induction ts1; introv Typ1 Typ2; inversions Typ1; simpl*.
Qed.

(* ====================================================================== *)
(** * Properties of terms *)

(* ********************************************************************** *)
(** ** Properties of substitution *)

(* begin hide *)

(** Substitution on indices is identity on well-formed terms. *)

Lemma open_rec_term_core :forall t j v i u, i <> j ->
  {j ~> v}t = {i ~> u}({j ~> v}t) -> t = {i ~> u}t.
Proof.
  induction t; introv Neq Equ;
  simpl in *; inversion* Equ; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_rec_term : forall t u,
  term t -> forall k, t = {k ~> u}t.
Proof.
  induction 1; intros; simpl; f_equal*.
  pick_fresh x. forward~ (H0 x) as K.
   apply* (@open_rec_term_core t1 0 (trm_fvars (x::nil))).
  pick_fresh x. pick_fresh f. forward~ (H0 x f) as K.
   apply* (@open_rec_term_core t1 0 (trm_fvars (x::f::nil))).
  pick_fresh x. forward~ (H1 x) as K.
   apply* (@open_rec_term_core t2 0 (trm_fvars (x::nil))).
  pick_freshes (pat_arity p) xs. forward~ (H1 xs) as K.
   apply* (@open_rec_term_core b 0 (trm_fvars xs)).
Qed.

(* end hide *)

(** Substitution for a fresh name is identity. *)

Lemma subst_fresh : forall x t u,
  x \notin trm_fv t ->
  [x ~> u] t = t.
Proof.
  intros. induction t; simpls; f_equal*.
  case_var*. notin_contradiction.
Qed.

Lemma subst_fresh_list : forall z u ts,
  z \notin trm_fv_list ts ->
  ts = List.map (trm_subst z u) ts.
Proof.
  induction ts; simpl; intros Fr.
  auto. f_equal. rewrite~ subst_fresh. auto.
Qed.

Lemma subst_fresh_trm_fvars : forall z u xs,
  fresh ({{z}}) (length xs) xs ->
  trm_fvars xs = List.map (trm_subst z u) (trm_fvars xs).
Proof.
  intros. apply subst_fresh_list.
  induction xs; simpls. auto.
    destruct H. notin_simpls; auto.
Qed.

Lemma substs_fresh : forall xs us t,
  fresh (trm_fv t) (length xs) xs ->
  substs xs us t = t.
Proof.
  induction xs; simpl; intros us t Fr.
  auto. destruct us. auto.
  inversions Fr. rewrite* subst_fresh.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_open : forall x u t1 t2, term u ->
  [x ~> u] (t1 ^^ t2) = ([x ~> u]t1) ^^ (List.map (trm_subst x u) t2).
Proof.
  intros. unfold open, opens. simpl. generalize 0.
  induction t1; intros; simpl; f_equal*.
  case_nat*. unfold trm_nth.
   apply list_map_nth. apply* subst_fresh.
  case_var*. apply* open_rec_term.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_open_vars : forall x ys u t,
  fresh {{x}} (length ys) ys ->
  term u ->
  ([x ~> u]t) ^ ys = [x ~> u] (t ^ ys).
Proof.
  introv Fr Tu. rewrite* subst_open.
  unfold trm_fvars. f_equal.
  induction ys; simpls. auto.
  destruct Fr. case_var.
    notin_contradiction. f_equal*.
Qed.

(** Opening up an abstraction of body t with a term u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma substs_intro_ind : forall t xs us vs,
  fresh (trm_fv t \u trm_fv_list vs \u trm_fv_list us) (length xs) xs ->
  terms (length xs) us ->
  terms (length vs) vs ->
  t ^^ (vs ++ us) = substs xs us (t ^^ (vs ++ (trm_fvars xs))).
Proof.
  induction xs; simpl; introv Fr Tu Tv;
   destruct Tu; destruct us; try solve [ contradictions ].
  auto.
  inversions H0. inversions Fr. clear H0 Fr. simpls.
  rewrite list_concat_right.
  forward (IHxs us (vs++t0::nil)) as K; clear IHxs.
    rewrite* trm_fv_list_map.
    auto.
    split~. inversions Tv. apply* list_forall_concat.
  rewrite K. clear K.
  f_equal. rewrite~ subst_open. rewrite~ subst_fresh.
  f_equal. rewrite map_app.
  simpl. case_var; try solve [ contradictions* ].
  rewrite <- list_concat_right.
  f_equal. apply~ subst_fresh_list.
  f_equal. apply* subst_fresh_trm_fvars.
Qed.

Lemma substs_intro : forall xs t us,
  fresh (trm_fv t \u trm_fv_list us) (length xs) xs ->
  terms (length xs) us ->
  t ^^ us = substs xs us (t ^ xs).
Proof.
  intros. apply* (@substs_intro_ind t xs us nil).
Qed.

(* ********************************************************************** *)
(** ** Terms are stable through substitutions *)

(** Terms are stable by substitution *)

Lemma subst_term : forall t z u,
  term u -> term t -> term ([z ~> u]t).
Proof.
  induction 2; simpl*.
  case_var*.
  apply_fresh term_abs. intros y Fr.
   rewrite* subst_open_vars.
  apply_fresh term_fix. intros y f Fr.
   rewrite* subst_open_vars.
  apply_fresh term_let. auto. intros y Fr.
   rewrite* subst_open_vars.
  apply_fresh* term_match. intros ys Fr.
   rewrite* subst_open_vars.
Qed.

Hint Resolve subst_term.

(** Terms are stable by iterated substitution *)

Lemma substs_terms : forall xs us t,
  terms (length xs) us ->
  term t ->
  term (substs xs us t).
Proof.
  induction xs; destruct us; introv TU TT; simpl; auto.
  inversions TU. simpls. inversions H. inversions* H0.
Qed.

(* Bodys are stable by substitution *)

Lemma subst_bodys : forall z u n t,
  term u -> bodys n t -> bodys n ([z ~> u]t).
Proof.
  introv. intros Wu [L Bt]. exists (L \u {{z}}).
  introv Fr. rewrite~ subst_open_vars.
Qed.

Hint Resolve subst_bodys.

(* ********************************************************************** *)
(** ** Terms are stable through open *)

(** Conversion from locally closed abstractions and bodies *)

Lemma term_abs_to_body : forall t1,
  term (trm_abs t1) -> bodys 1 t1.
Proof.
  intros. unfold bodys. inversions* H.
  exists L. intros.
  destruct xs; simpl in H0; destruct H0.
  destruct xs; simpl in H2; destruct H2. auto.
Qed.

Lemma body_to_term_abs : forall t1,
  bodys 1 t1 -> term (trm_abs t1).
Proof.
  destruct 1. apply_fresh* term_abs.
Qed.

Lemma term_fix_to_body : forall t1,
  term (trm_fix t1) -> bodys 2 t1.
Proof.
  intros. unfold bodys. inversions* H.
  exists L. intros.
  destruct xs; simpl in H0; destruct H0.
  destruct xs; simpl in H2; destruct H2.
  destruct xs; simpl in H3; destruct H3.
  auto.
Qed.

Lemma body_to_term_fix : forall t1,
  bodys 2 t1 -> term (trm_fix t1).
Proof.
   destruct 1. apply_fresh* term_fix.
Qed.

Lemma term_let_to_body : forall t1 t2,
  term (trm_let t1 t2) -> bodys 1 t2.
Proof.
  intros. unfold bodys. inversions* H.
  exists L. intros.
  destruct xs; simpl in H0; destruct H0.
  destruct xs; simpl in H1; destruct H1. auto.
Qed.

Lemma body_to_term_let : forall t1 t2,
  term t1 -> bodys 1 t2 -> term (trm_let t1 t2).
Proof.
  destruct 2. apply_fresh* term_let.
Qed.

Lemma term_match_to_body : forall t1 t2 b p,
  term (trm_match t1 p b t2) -> bodys (pat_arity p) b.
Proof.
  intros. unfold bodys. inversions* H.
Qed.

Lemma body_to_term_match : forall t1 t2 b p,
  term t1 -> term t2 -> bodys (pat_arity p) b ->
  term (trm_match t1 p b t2).
Proof.
  destruct 3. apply_fresh* term_match.
Qed.

Hint Resolve body_to_term_abs term_abs_to_body
             body_to_term_fix term_fix_to_body
             body_to_term_match
             body_to_term_let.

Hint Extern 1 (bodys (pat_arity ?p) ?e) =>
  match goal with H: context [trm_match ?t1 p e ?t2] |- _ =>
    apply (@term_match_to_body t1 t2) end.

Hint Extern 1 (bodys 1 ?t2) =>
  match goal with H: context [trm_let ?t1 t2] |- _ =>
    apply (@term_let_to_body t1) end.

(** ** Opening a body with a term gives a term *)

Lemma open_terms : forall t us,
  bodys (length us) t ->
  terms (length us) us ->
  term (t ^^ us).
Proof.
  introv [L K] WT. pick_freshes (length us) xs. poses Fr' Fr.
  rewrite (fresh_length _ _ _  Fr) in WT, Fr'.
  rewrite~ (@substs_intro xs). apply* substs_terms.
Qed.

Hint Resolve open_terms.

(** The matching function returns a list of terms of the expected length. *)

Lemma pat_match_terms : forall p t ts,
  (pat_match p t) = Some ts -> term t ->
  terms (pat_arity p) ts.
Proof.
  induction p; simpl; introv EQ TT;
   try solve [ inversions EQ; auto ];
   destruct t; inversions EQ; inversions TT; auto*.
  remember (pat_match p1 t1) as K1. symmetry in HeqK1.
   remember (pat_match p2 t2) as K2. symmetry in HeqK2.
   destruct K1 as [ts1|]; destruct K2 as [ts2|]; try discriminate.
   inversions EQ. unfolds terms. apply* list_for_n_concat.
Qed.

(* ====================================================================== *)
(** * Properties of types *)

(** Open on a type is the identity. *)

Lemma typ_open_type : forall T Us,
  type T -> T = typ_open T Us.
Proof.
  introv W. induction T; simpls; inversions W; f_equal*.
Qed.

(** Substitution for a fresh name is identity. *)

Lemma typ_subst_fresh : forall X U T,
  X \notin typ_fv T ->
  typ_subst X U T = T.
Proof.
  intros. induction T; simpls; f_equal*.
  case_var*. notin_contradiction.
Qed.

Lemma typ_subst_fresh_list : forall z u ts,
  z \notin typ_fv_list ts ->
  ts = List.map (typ_subst z u) ts.
Proof.
  induction ts; simpl; intros Fr.
  auto. f_equal. rewrite~ typ_subst_fresh. auto.
Qed.

Lemma typ_subst_fresh_trm_fvars : forall z u xs,
  fresh ({{z}}) (length xs) xs ->
  typ_fvars xs = List.map (typ_subst z u) (typ_fvars xs).
Proof.
  intros. apply typ_subst_fresh_list.
  induction xs; simpls. auto.
    destruct H. notin_simpls; auto.
Qed.

Lemma typ_substs_fresh : forall xs us t,
  fresh (typ_fv t) (length xs) xs ->
  typ_substs xs us t = t.
Proof.
  induction xs; simpl; intros us t Fr.
  auto. destruct us. auto.
  inversions Fr. rewrite* typ_subst_fresh.
Qed.

(** Substitution distributes on the open operation. *)

Lemma typ_subst_open : forall X U T1 T2, type U ->
  typ_subst X U (typ_open T1 T2) =
   typ_open (typ_subst X U T1) (List.map (typ_subst X U) T2).
Proof.
  intros. induction T1; intros; simpl; f_equal*.
  apply list_map_nth. apply* typ_subst_fresh.
  case_var*. apply* typ_open_type.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma typ_subst_open_vars : forall X Ys U T,
  fresh {{X}} (length Ys) Ys ->
  type U ->
     typ_open_vars (typ_subst X U T) Ys
   = typ_subst X U (typ_open_vars T Ys).
Proof.
  introv Fr Tu. unfold typ_open_vars.
  rewrite* typ_subst_open. f_equal.
  induction Ys; simpls. auto.
  destruct Fr. case_var.
    notin_contradiction. f_equal*.
Qed.

(** Opening up an abstraction of body t with a term u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma typ_substs_intro_ind : forall T Xs Us Vs,
  fresh (typ_fv T \u typ_fv_list Vs \u typ_fv_list Us) (length Xs) Xs ->
  types (length Xs) Us ->
  types (length Vs) Vs ->
  typ_open T (Vs ++ Us) = typ_substs Xs Us (typ_open T (Vs ++ (typ_fvars Xs))).
Proof.
  induction Xs; simpl; introv Fr Tu Tv;
   destruct Tu; destruct Us; try solve [ contradictions ].
  auto.
  inversions H0. inversions Fr. clear H0 Fr. simpls.
  rewrite list_concat_right.
  forward (IHXs Us (Vs++t::nil)) as K; clear IHXs.
    rewrite* typ_fv_list_map.
    auto.
    split~. inversions Tv. apply* list_forall_concat.
  rewrite K. clear K.
  f_equal. rewrite~ typ_subst_open. rewrite~ typ_subst_fresh.
  f_equal. rewrite map_app.
  simpl. case_var; try solve [ contradictions* ].
  rewrite <- list_concat_right.
  f_equal. apply~ typ_subst_fresh_list.
  f_equal. apply* typ_subst_fresh_trm_fvars.
Qed.

Lemma typ_substs_intro : forall Xs Us T,
  fresh (typ_fv T \u typ_fv_list Us) (length Xs) Xs ->
  types (length Xs) Us ->
  (typ_open T Us) = typ_substs Xs Us (typ_open_vars T Xs).
Proof.
  intros. apply* (@typ_substs_intro_ind T Xs Us nil).
Qed.

(** Types are stable by type substitution *)

Lemma typ_subst_type : forall T Z U,
  type U -> type T -> type (typ_subst Z U T).
Proof.
  induction 2; simpl*. case_var*.
Qed.

Hint Resolve typ_subst_type.

(** Types are stable by iterated type substitution *)

Lemma typ_substs_types : forall Xs Us T,
  types (length Xs) Us ->
  type T ->
  type (typ_substs Xs Us T).
Proof.
  induction Xs; destruct Us; simpl; introv TU TT; auto.
  destruct TU. simpls. inversions H. inversions* H0.
Qed.

(** List of types are stable by type substitution *)

Lemma typ_subst_type_list : forall Z U Ts n,
  type U -> types n Ts ->
  types n (List.map (typ_subst Z U) Ts).
Proof.
  unfold types, list_for_n.
  induction Ts; destruct n; simpl; intros TU [EQ TT].
  auto. auto. inversion EQ.
  inversions TT. forward~ (IHTs n) as [K1 K2].
Qed.

(** ** Opening a body with a list of types gives a type *)

Lemma typ_open_types : forall T Us,
  typ_body (length Us) T ->
  types (length Us) Us ->
  type (typ_open T Us).
Proof.
  introv [L K] WT. pick_freshes (length Us) Xs. poses Fr' Fr.
  rewrite (fresh_length _ _ _  Fr) in WT, Fr'.
  rewrite~ (@typ_substs_intro Xs). apply* typ_substs_types.
Qed.

(* ====================================================================== *)
(** * Properties of schemes *)

(** Substitution for a fresh name is identity. *)

Lemma sch_subst_fresh : forall X U M,
  X \notin sch_fv M ->
  sch_subst X U M = M.
Proof.
  intros. destruct M as [n T]. unfold sch_subst.
  rewrite* typ_subst_fresh.
Qed.

(** Trivial lemma to unfolding definition of [sch_subst] by rewriting. *)

Lemma sch_subst_fold : forall Z U T n,
  Sch n (typ_subst Z U T) = sch_subst Z U (Sch n T).
Proof.
  auto.
Qed.

(** Distributivity of type substitution on opening of scheme. *)

Lemma sch_subst_open : forall Z U M Us,
   type U ->
    typ_subst Z U (sch_open M Us)
  = sch_open (sch_subst Z U M) (List.map (typ_subst Z U) Us).
Proof.
  unfold sch_open. intros. destruct M. simpl.
  rewrite* <- typ_subst_open.
Qed.

(** Distributivity of type substitution on opening of scheme with variables. *)

Lemma sch_subst_open_vars : forall Z U M Xs,
   fresh ({{Z}}) (length Xs) Xs ->
   type U ->
    typ_subst Z U (sch_open_vars M Xs)
  = sch_open_vars (sch_subst Z U M) Xs.
Proof.
  unfold sch_open_vars. intros. destruct M.
  rewrite* <- typ_subst_open_vars.
Qed.

(** Schemes are stable by type substitution. *)

Lemma sch_subst_type : forall Z U M,
  type U -> scheme M -> scheme (sch_subst Z U M).
Proof.
  unfold scheme, sch_subst. intros Z U [n T] TU S.
  simpls. destruct S as [L K]. exists (L \u {{Z}}).
  introv Fr. rewrite* typ_subst_open_vars.
Qed.

Hint Resolve sch_subst_type.

(** Scheme arity is preserved by type substitution. *)

Lemma sch_subst_arity : forall X U M,
  sch_arity (sch_subst X U M) = sch_arity M.
Proof.
  auto.
Qed.

(** ** Opening a scheme with a list of types gives a type *)

Lemma sch_open_types : forall M Us,
  scheme M ->
  types (sch_arity M) Us ->
  type (sch_open M Us).
Proof.
  unfold scheme, sch_open. intros [n T] Us WB [Ar TU].
  simpls. subst n. apply* typ_open_types.
Qed.

Hint Resolve sch_open_types.

(* ====================================================================== *)
(** * Properties of store *)

Lemma phi_ok_binds : forall P l T,
   phi_ok P -> binds l T P -> type T.
Proof.
  unfolds binds. introv. induction P as [|(l1,t1)];
   simpl; env_fix; introv Ok Binds.
  contradictions.
  inversions Ok. case_var.
    inversions* Binds.
    auto.
Qed.

Lemma sto_ok_binds : forall mu l t,
   sto_ok mu -> binds l t mu -> term t.
Proof.
  unfolds binds. introv. induction mu as [|(l1,t1)];
   simpl; env_fix; introv Ok Binds.
  contradictions.
  inversions Ok. case_var.
    inversions* Binds.
    auto.
Qed.

Hint Resolve phi_ok_binds sto_ok_binds.

(* ====================================================================== *)
(** * Properties of judgments *)

(* ********************************************************************** *)
(** ** Regularity of relations *)

(** The value predicate only holds on locally-closed terms. *)

Lemma value_regular : forall e,
  value e -> term e.
Proof.
  induction 1; auto*.
Qed.

(** A typing relation is restricted to well-formed objects. *)

(* Helper tactics to name all the hypotheses *)

Tactic Notation "split4" "in" ident(H) :=
  let H1 := fresh in let H2 := fresh in
  let H3 := fresh in let H4 := fresh in
  destruct H as [H1 [H2 [H3 H4]]].

Lemma typing_regular : forall E P e T,
  typing E P e T -> ok E /\ phi_ok P /\ term e /\ type T.
Proof.
  intros. induction H; try solve [ split4* ].
  pick_fresh x. forward~ (H1 x) as K. split4 in K.
   inversions H2. splits*.
   apply_fresh term_abs. intros y Fry. forward* (H1 y) as K2.
  pick_fresh x. pick_fresh f. forward~ (H1 f x) as K. split4 in K.
   inversions H2. inversions H8. splits*.
   apply_fresh term_fix. intros g y Fry. forward* (H1 g y) as K2.
  pick_fresh x. forward~ (H4 x) as K. split4 in K.
   inversions H5. splits*. puts value_regular.
   apply_fresh* term_let. intros y Fry. forward* (H4 y) as K2.
  pick_freshes (pat_arity p) xs. forward~ (H2 xs) as K. split4 in K.
   destruct (ok_concat_inv _ _ H4). splits*.
   apply_fresh* term_match. intros ys Frys. forward* (H2 ys) as K2.
  split4 in IHtyping1. inversions* H4.
  split4 in IHtyping. inversions* H3.
Qed.

(** A fails relation only holds on pairs of locally-closed terms. *)

Lemma fails_regular : forall t e,
  fails t e -> term t /\ term e.
Proof.
  induction 1; use value_regular.
Qed.

(** A reduction relation only holds only on well-formed objects. *)

Lemma red_regular : forall c c',
  red c c' ->
     (term (fst c) /\ term (fst c'))
  /\ (sto_ok (snd c) /\ sto_ok (snd c')).
Proof.
  induction 1; simpl; env_fix; use value_regular.
  splits~. forward~ (@pat_match_terms _ _ _ H3) as K.
   rewrite (proj1 K) in H1, K. apply* open_terms.
  use (fails_regular H1).
Qed.

(* ********************************************************************** *)
(** ** Automation for well-formedness *)

(** Automation for reasoning on well-formedness. *)

Hint Extern 1 (ok ?E) =>
  match goal with
  | H: typing E _ _ _ |- _ => apply (proj1 (typing_regular H))
  end.

Hint Extern 1 (term ?t) =>
  match goal with
  | H: typing _ _ t _ |- _ => apply (proj43 (typing_regular H))
  | H: red (t,_) _ |- _ => apply (proj41 (red_regular H))
  | H: red _ (t,_) |- _ => apply (proj42 (red_regular H))
  | H: value t |- _ => apply (value_regular H)
  | H: fails t _ |- _ => apply (proj1 (fails_regular H))
  | H: fails _ t |- _ => apply (proj2 (fails_regular H))
  end.

Hint Extern 1 (sto_ok ?mu) =>
  match goal with
  | H: red (_,mu) _ |- _ => apply (proj1 (proj2 (red_regular H)))
  | H: red _ (_,mu) |- _ => apply (proj2 (proj2 (red_regular H)))
  | H: sto_typing _ mu |- _ => apply (proj42 H)
  end.

Hint Extern 1 (phi_ok ?P) =>
  match goal with
  | H: typing _ P _ _ |- _ => apply (proj42 (typing_regular H))
  | H: sto_typing P _ |- _ => apply (proj41 H)
  end.

Hint Extern 1 (type ?T) => match goal with
  | H: typing _ _ _ T |- _ => apply (proj44 (typing_regular H))
  end.


(** * Combi.Combi.tableau : Young Tableaux *)
(******************************************************************************)
(*      Copyright (C) 2014-2018 Florent Hivert <florent.hivert@lri.fr>        *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of          *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU       *)
(*    General Public License for more details.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
(** * Young Tableaux over an [ordtype]

We define the notion of (semistandard) Young tableau over an [ordType]
denoted [T].

- [is_row r] == [r] is sorted
- [dominate u v] == [u] dominate [v], that is [v] is longer than [u] and
            the i-th letter of [u] is strictly larger than the i-th letter of [v].
            this is an order relation on [seq T].
- [is_tableau t] == [t] of type [(seq (seq T))] is a tableau that is a sequence
            of non empty rows which is sorted for the dominate order.
- [get_tab t (r, c)] == the element of [t] of coordinate [(r, c)],
            or [inhabitant T] if [(r, c)] is not is the tableau
- [to_word t] == the row reading of the tableau [t]
- [size_tab t] == the size (number of boxes) of [t]
- [filter_gtnX_tab n t] == the sub-tableau of [t] formed by the element smaller
            than [n].

- [tabsh_reading sh w] == [w] is the row reading of a tableau of shape [sh]

In the following tableaux are considered on ['I_n.+1] for a given [n].

- [is_tab_of_shape sh t] == [t] is a tableau of shape [sh].
- [tabsh sh] == a sigma-type for the predicate [is_tab_of_shape sh] where
            [sh] is a partition of [d] (type ['P_d]). This is canonically
            a [subFinType].
- [tabrowconst pf] == if [pf] is a proof that [size sh <= n.+1] then
            construct the tableau (of type [tabsh sh]) whose i-th row
            contains only [i]'s as elements of ['I_n.+1].
*****)

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrbool ssrfun ssrnat eqtype fintype choice seq.
From mathcomp Require Import path tuple order.
Require Import tools partition ordtype sorted.

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

Open Scope N.

Import Order.Theory.

(** ** Specialization of sorted Lemmas *)
Section Rows.

Variables (disp : unit) (T : inhOrderType disp).

Implicit Type l : T.
Implicit Type r : seq T.

Notation is_row := (sorted <=%O).

Definition is_row1P Z r := sorted1P Z <=%O r.
Definition is_rowP Z r := sortedP Z (@le_trans _ T) (@le_refl _ T) r.
Definition is_row_cons := sorted_cons (@le_refl _ T).
Definition is_row_consK := sorted_consK (T := T) (R := <=%O).
Definition is_row_rcons := sorted_rcons (T := T) (R := <=%O).
Definition is_row_rconsK := sorted_rconsK (T := T) (R := <=%O).
Definition is_row_last := sorted_last (@le_refl _ T).
Definition is_row_take := sorted_take (T := T) (R := <=%O).
Definition is_row_drop := sorted_drop (T := T) (R := <=%O).
Definition is_row_catL := sorted_catL (T := T) (R := <=%O).
Definition is_row_catR := sorted_catR (T := T) (R := <=%O).
Definition head_leq_last_row :=
  head_leq_last_sorted (@le_trans _ T) (@le_refl _ T).
Lemma row_lt_by_pos Z r p q:
  is_row r -> p < size r -> q < size r ->
  (nth Z r p < nth Z r q)%O -> p < q.
Proof using.
rewrite lt_neqAle.
exact: (sorted_lt_by_pos (@le_trans _ T) (@le_refl _ T) (@le_anti _ T)).
Qed.

End Rows.

Notation is_row := (sorted <=%O).

(** ** Dominance order for rows *)
Section Dominate.

Context {disp : unit} {T : inhOrderType disp}.

Implicit Type l : T.
Implicit Type r u v : seq T.
Implicit Type t : seq (seq T).

Lemma in_shape_tab_size t i j :
  in_shape (shape t) (i, j) -> i < size t.
Proof. by rewrite -(size_map size) -/shape; exact: in_shape_size. Qed.
Lemma in_shape_tab i j t :
  in_shape (shape t) (i, j) -> j < size (nth [::] t i).
Proof.
move=> Hin; have:= Hin; rewrite /in_shape /shape (nth_map [::]) //.
exact: (in_shape_tab_size Hin).
Qed.

Lemma is_row_set_nth l r pos :
  is_row r -> (l < nth l r pos)%O ->
  (forall n : nat, (l < nth l r n)%O -> pos <= n) ->
  is_row (set_nth l r pos l).
Proof using.
move=> /is_row1P Hrow Hl Hmin. apply/(is_row1P l) => i.
rewrite (lock (i.+1)) !nth_set_nth /=; unlock.
case: (ltnP pos (size r)) Hl => [Hpos Hl |HH]; first last.
  by rewrite (nth_default l HH) ltxx.
rewrite size_set_nth maxnC /maxn.
move: Hpos; rewrite leqNgt; move/negbTE => -> Hi1lt.
case eqP => Hipos; case eqP => Hi1pos.
- exact: le_refl.
- by apply: ltW; apply: (lt_le_trans Hl); rewrite -Hipos; apply: Hrow.
- move: {Hmin} (contra (Hmin i)); rewrite -leNgt -ltnNge; apply.
  by rewrite Hi1pos leqnn.
- exact: Hrow.
Qed.

Fixpoint dominate_rec u v :=
  if u is u0 :: u' then
    if v is v0 :: v' then (u0 > v0)%O && (dominate_rec u' v')
    else false
  else true.

Definition dominate u v :=
  (size u <= size v) &&
   (all (fun i => nth inh u i > nth inh v i)%O (iota 0 (size u))).

Lemma dominate_recE : dominate =2 dominate_rec.
Proof using.
rewrite /dominate; elim=> [//| u0 u IHu] [//| v0 v] /=.
rewrite -IHu ltnS [RHS]andbA [LHS]andbA [_&& (v0 < u0)%O]andbC; congr (_ && _).
by rewrite -add1n iotaDl all_map; apply eq_all => i.
Qed.

Lemma dominateP u v :
  reflect (size u <= size v /\
           forall i, i < size u -> (nth inh u i > nth inh v i)%O)
          (dominate u v).
Proof using.
rewrite /dominate /mkseq ; apply/(iffP idP).
- move=> /andP [] Hsz /allP Hall; split; first exact Hsz.
  by move=> i Hi; apply: Hall; rewrite mem_iota add0n.
- by move=> [] -> /= H; apply/allP => i; rewrite mem_iota add0n; apply: H.
Qed.

Lemma dominate_trans : transitive dominate.
Proof using.
move=> r2 r1 r3; rewrite !dominate_recE.
elim: r1 r2 r3 => [//| a1 l1] IHl [|a2 l2] [|a3 l3] //=.
by move=> /andP [/(lt_trans _) Ha21 /IHl{IHl}Hrec] /andP [/Ha21 -> /Hrec ->].
Qed.

Definition dominate_rev_trans := rev_trans dominate_trans.

Lemma dominate_rcons v u l : dominate u v -> dominate u (rcons v l).
Proof using.
rewrite !dominate_recE.
by elim: u v => [//| u0 u IHu] [|v0 v] //= /andP [-> /IHu ->].
Qed.

Lemma dominate_take v u n : dominate u (take n v) -> dominate u v.
Proof.
rewrite !dominate_recE -{2}(cat_take_drop n v).
elim/last_ind: {v} (drop n v) (take n v) => [| v vn IHv]/= w.
  by rewrite cats0.
move=> /IHv {IHv}.
by rewrite -cats1 catA cats1 -!dominate_recE; exact: dominate_rcons.
Qed.

Lemma dominate_cut u v w:
  size u <= size v -> dominate u (v ++ w) -> dominate u v.
Proof using.
rewrite !dominate_recE.
elim: u v => [//| u0 u IHu] [|v0 v] //=.
by rewrite ltnS => /IHu{IHu}Hrec /andP [-> /Hrec ->].
Qed.

Lemma dominate_head u v :
  u != [::] -> dominate u v -> (head inh v < head inh u)%O.
Proof using.
by rewrite !dominate_recE; case: u v => [//| u0 u] [|v0 v] //= _ /andP [].
Qed.

Lemma dominate_tl a u b v :
  dominate (a :: u) (b :: v) -> dominate u v.
Proof using. by rewrite !dominate_recE => /= /andP []. Qed.

End Dominate.
Arguments dominate_trans {disp T}.
Arguments dominate_rev_trans {disp T}.

(** * Tableaux : definition and basic properties *)
Section Tableau.

Variables (disp : unit) (T : inhOrderType disp).

Implicit Type l : T.
Implicit Type r w : seq T.
Implicit Type t : seq (seq T).

Fixpoint is_tableau t :=
  if t is t0 :: t'
  then [&& (t0 != [::]), is_row t0, dominate (head [::] t') t0 & is_tableau t']
  else true.

Definition get_tab t (rc : nat * nat) := nth inh (nth [::] t rc.1) rc.2.

Definition to_word t := flatten (rev t).

(* Shape is defined in seq.v *)
(* Definition shape t := map size t. *)

Lemma is_tableauP t :
  reflect
    [/\ forall i, i < size t -> (nth [::] t i) != [::], (* forbid empty lines *)
        forall i, is_row (nth [::] t i) &
        forall i j, i < j -> dominate (nth [::] t j) (nth [::] t i)]
    (is_tableau t).
Proof using.
apply (iffP idP).
- elim: t => [_ | t0 t IHt] /=.
    split=> i //=; first by rewrite nth_default.
    by move=> j; rewrite !nth_default.
  move=> /and4P [] Ht0 Hrow0 Hdom0 /IHt {IHt} [] Hnnil Hrow Hdom.
  split; try by case.
  case=> [| i] [| j] //=.
  + case: j => [|j] _; first by rewrite nth0.
    apply: (dominate_trans _ _ _ _ Hdom0).
    by rewrite -nth0; apply: Hdom.
  + by rewrite ltnS; apply: Hdom.
- elim: t => [| t0 t IHt] //= [] Hnnil Hrow Hdom.
  apply/and4P; split.
  + exact: (Hnnil 0).
  + exact: (Hrow 0).
  + move: Hdom; case t => [| t1 tt] //= H.
    rewrite -/(nth [::] (t0 :: t1 :: tt) 0) -/(nth [::] (t0 :: t1 :: tt) 1).
    exact: H.
  + apply IHt; split => [i H | i | i j H].
    * exact: (Hnnil i.+1).
    * exact: (Hrow i.+1).
    * exact: (Hdom i.+1 j.+1).
Qed.

Lemma get_tab_default t rc :
  ~~ in_shape (shape t) rc -> get_tab t rc = inh.
Proof using.
rewrite /in_shape /get_tab -leqNgt nth_shape => Hc.
exact: nth_default.
Qed.

Lemma to_word_cons r t : to_word (r :: t) = to_word t ++ r.
Proof using. by rewrite /to_word rev_cons flatten_rcons. Qed.
Lemma to_word_rcons r t : to_word (rcons t r) = r ++ to_word t.
Proof using. by rewrite /to_word rev_rcons /=. Qed.

Lemma mem_to_word t rc :
  in_shape (shape t) rc -> get_tab t rc \in (to_word t).
Proof using.
move: rc => [r c]; rewrite /in_shape /get_tab.
elim: t r c => [//= | t0 t IHt] /= r c; first by rewrite nth_default.
rewrite to_word_cons mem_cat => H.
case: r H => [/mem_nth ->| r] /=; first by rewrite orbT.
by move/IHt ->.
Qed.

Lemma to_wordK t : rev (reshape (rev (shape t)) (to_word t)) = t.
Proof using. by rewrite -shape_rev /to_word flattenK revK. Qed.

Lemma tableau_is_row r t : is_tableau (r :: t) -> is_row r.
Proof using. by move=> /= /and4P []. Qed.

Lemma  is_tableau_rconsK t (tn : seq T) :
  is_tableau (rcons t tn) -> is_tableau t.
Proof using.
elim: t => [//= | t0 t IHt] /= /and4P [] -> -> Hdom /IHt -> /= {IHt}.
by case: t Hdom => [//=| t1 t]; rewrite rcons_cons /= => ->.
Qed.

Lemma is_tableau_catl t1 t2 :
  is_tableau (t1 ++ t2) -> is_tableau t1.
Proof.
elim: t1 => [//= | t t1 IHt1] /= /and4P [] -> -> /= Hdom /IHt1 {IHt1} ->.
by rewrite andbT; case: t1 Hdom => [//= | r1 t1].
Qed.

Lemma is_tableau_catr t1 t2 :
  is_tableau (t1 ++ t2) -> is_tableau t2.
Proof. by elim: t1 => [//= | r t1 IHt1] /= /and4P [] _ _ _. Qed.

Lemma is_part_sht t : is_tableau t -> is_part (shape t).
Proof using.
elim: t => [//= | t0 t IHt] /= /and4P [] Ht0 _ /dominateP [] Hdom _ Htab.
rewrite (IHt Htab) andbT {IHt Htab} /shape.
by case: t Hdom => //=; case: t0 Ht0.
Qed.

Lemma tab_eqP p q :
  is_tableau p -> is_tableau q ->
  reflect (forall i, nth [::] p i = nth [::] q i) (p == q).
Proof using.
move=> Hp Hq.
apply (iffP idP) => [/eqP -> //| H].
have Hnth t i : nth 0 (shape t) i = size (nth [::] t i).
  case: (ltnP i (size t)) => Hi.
  - by rewrite /shape (nth_map [::] _ _ Hi).
  - by rewrite !nth_default // size_map.
have Hsz : size p = size q.
  rewrite -!(size_map size); congr (size _).
  apply/eqP/(part_eqP (is_part_sht Hp) (is_part_sht Hq)) => i.
  by rewrite !Hnth H.
by apply/eqP; apply (eq_from_nth (x0 := [::]) Hsz) => i _.
Qed.

Lemma is_tableau_sorted_dominate t :
  is_tableau t =
  [&& is_part (shape t),
   all (sorted <=%O) t &
   sorted (fun (r s : seq T) => dominate s r) t].
Proof using.
apply/idP/idP; elim: t => [//= | t0 t IHt].
- move=> /=/and4P [] Hnnil Hrow0 Hdom /IHt /and3P [] Hpart Hall Hsort.
  rewrite Hpart Hrow0 Hall {Hpart Hrow0 Hall IHt} !andbT /=; apply/andP; split.
  + case: t Hdom {Hsort} => [_ | t1 t] /=; first by case: t0 Hnnil.
    by move => /dominateP [].
  + by case: t Hdom Hsort => [//=| t1 t]/= -> ->.
- move=>/and3P [] Hpart.
  have:= part_head_non0 Hpart.
  rewrite [head _ _]/= [all _ _]/= [is_tableau _]/=.
  move=> /nilP /eqP -> /andP [] -> Hall Hsort /=.
  apply/andP; split.
  + by case: t Hsort {Hpart Hall IHt} => [//= | t1 t] /= /andP [].
  + apply: IHt; rewrite (is_part_consK Hpart) Hall /=.
    exact: (sorted_consK Hsort).
Qed.

Lemma is_tableau_getP t :
  reflect
    [/\ is_part (shape t),
     (forall (r c : nat), in_shape (shape t) (r, c.+1) ->
                          (get_tab t (r, c) <= get_tab t (r, c.+1))%O) &
     (forall (r c : nat), in_shape (shape t) (r.+1, c) ->
                          (get_tab t (r, c) < get_tab t (r.+1, c))%O)]
    (is_tableau t).
Proof using.
rewrite is_tableau_sorted_dominate.
apply/(iffP idP) => [|[Hpart]].
- move=> /and3P [Hpart /allP Hrow /(sorted_strictP _ dominate_rev_trans)] Hdom.
  split; rewrite /get_tab => // r c Hin.
  + have/Hrow/is_row1P : (nth [::] t r) \in t.
      by apply/mem_nth/in_shape_tab_size/Hin.
    by apply; exact: in_shape_tab.
  + have/(Hdom [::])/dominateP [_] : r < r.+1 < size t.
      by rewrite ltnSn (in_shape_tab_size Hin).
    by apply; exact: in_shape_tab.
- rewrite /get_tab Hpart => Hrow Hcol /=; apply/andP; split.
  + apply/allP => /= c Hrin.
    have Hr := nth_index [::] Hrin.
    move: Hrin Hr; rewrite -index_mem; move: (index c t) => r Hr Hc; subst c.
    apply/is_row1P => i Hi; apply Hrow.
    by rewrite /in_shape (nth_map [::]).
  + apply/(sorted_strictP [::] dominate_rev_trans).
    rewrite (incr_equiv _ dominate_rev_trans) => r Hr.
    apply/dominateP; split.
    * rewrite -!(nth_map _ 0) -/shape //; last by move: Hr; apply ltnW.
      by move/is_partP: Hpart => [_].
    * move=> i Hi; apply Hcol.
      by rewrite /in_shape (nth_map [::]).
Qed.

(** ** Cuting rows and tableaux *)
Lemma row_dominate (u v : seq T) :
  is_row (u ++ v) -> dominate u v -> u = [::].
Proof using.
case: u => [//= | u0 u] /=.
case: v => [//= | v0 v] /= /order_path_min -/(_ le_trans)/allP Hall.
rewrite dominate_recE /= => /andP [Habs]; exfalso.
have /Hall : v0 \in u ++ v0 :: v by rewrite mem_cat in_cons eq_refl /= orbT.
by rewrite leNgt Habs.
Qed.

Lemma filter_gt_row r n :
  is_row r -> filter (>%O n) r = take (count (>%O n) r) r.
Proof using.
elim: r => [//= | r0 r IHr] Hrow /=.
case: (ltP r0 n) => Hr0.
- by rewrite add1n (IHr (is_row_consK Hrow)).
- rewrite add0n; have Hcount : count (>%O n) r = 0.
  elim: r r0 Hr0 Hrow {IHr} => [//= | r1 r /= IHr] r0 Hr0 /andP [] Hr0r1 Hpath.
  have Hr1 := le_trans Hr0 Hr0r1.
    by rewrite ltNge Hr1 (IHr r1 Hr1 Hpath).
  rewrite Hcount.
  by apply/nilP; rewrite /nilp size_filter Hcount.
Qed.

Lemma filter_le_row n r :
  is_row r -> filter (<=%O n) r = drop (count (>%O n) r) r.
Proof using.
elim: r => //= r0 r IHr Hrow /=.
case: (leP n r0) => Hr0.
- rewrite add0n; have Hcount : count (>%O n) r = 0.
  elim: r r0 Hr0 Hrow {IHr} => //= r1 r IHr r0 Hr0 /andP [] Hr0r1 Hpath.
  have Hr1 := le_trans Hr0 Hr0r1.
    by rewrite ltNge Hr1 (IHr r1 Hr1 Hpath).
  by rewrite Hcount (IHr (is_row_consK Hrow)) Hcount drop0.
- by rewrite add1n (IHr (is_row_consK Hrow)).
Qed.

Lemma count_gt_dominate r1 r0 n :
  dominate r1 r0 -> (count (>%O n) r1) <= (count (>%O n) r0).
Proof using.
move=> /dominateP [] Hsz Hdom.
rewrite -[r0](mkseq_nth inh) -[r1](mkseq_nth inh) /mkseq !count_map.
rewrite -(subnKC Hsz).
rewrite iotaD count_cat.
set s0 := (X in X + _).
apply (@leq_trans s0); last exact: leq_addr.
rewrite /s0 {s0} -!size_filter.
set f1 := (X in filter X ); set f0 := (X in _ <= size (filter X _)).
rewrite (eq_in_filter (a1 := f1) (a2 := predI f1 (gtn (size r1)))); first last.
  by move=> i; rewrite mem_iota /= add0n => ->; rewrite andbT.
rewrite (eq_in_filter (a1 := f0) (a2 := predI f0 (gtn (size r1)))); first last.
  by move=> i; rewrite mem_iota /= add0n => ->; rewrite andbT.
rewrite !size_filter; apply sub_count => i /=.
rewrite /f1 /f0 {f1 f0} /= => /andP [] Hn Hi.
rewrite Hi andbT.
exact: lt_trans (Hdom i Hi) Hn.
Qed.

Lemma filter_gt_dominate r1 r0 n :
  is_row r0 -> is_row r1 -> dominate r1 r0 ->
  dominate (filter (>%O n) r1) (filter (>%O n) r0).
Proof using.
move=> Hrow0 Hrow1 Hdom.
have Hsize := count_gt_dominate n Hdom.
move: Hdom => /dominateP [] Hsz Hdom.
apply/dominateP; rewrite !size_filter.
split; first exact Hsize.
move=> i Hi.
rewrite (filter_gt_row _ Hrow0) (filter_gt_row _ Hrow1) !nth_take.
- by apply Hdom; apply (leq_trans Hi); apply: count_size.
- exact: Hi.
- exact: (leq_trans Hi).
Qed.

Definition filter_gt_tab n :=
  [fun t : (seq (seq T)) => filter (fun r => r != [::])
                                   [seq [seq x <- i | (n > x)%O] | i <- t]].

Lemma to_word_filter_nnil t : to_word (filter (fun r => r != [::]) t) = to_word t.
Proof using.
elim: t => [//= | t0 t IHt] /=.
rewrite to_word_cons -IHt.
case: (altP (t0 =P [::])) => [-> | _] /=; first by rewrite cats0.
by rewrite to_word_cons.
Qed.

Lemma filter_to_word t p : filter p (to_word t) = to_word (map (filter p) t).
Proof using.
elim: t => [//= | t0 t IHt] /=.
by rewrite !to_word_cons -IHt filter_cat.
Qed.

Lemma head_filter_gt_tab n t :
  is_tableau t ->
  head [::] (filter_gt_tab n t) = [seq x <- head [::] t | (x < n)%O].
Proof using.
elim: t => [//= | t0 t /= IHt] /and4P [] Hnnil0 Hrow0 Hdom Htab.
case: (altP ([seq x <- t0 | (x < n)%O] =P [::])) => Ht0 //=.
rewrite (IHt Htab) Ht0 {IHt}.
case: t Hdom Htab => [//= | t1 t] /= Hdom /and3P [] Hnnil1 Hrow1 _.
have /dominateP := filter_gt_dominate n Hrow0 Hrow1 Hdom => [] [].
by rewrite Ht0 /= leqn0 => /nilP ->.
Qed.

Lemma is_tableau_filter_gt t n :
  is_tableau t -> is_tableau (filter_gt_tab n t).
Proof using.
elim: t => [//= | t0 t /= IHt] /and4P [] Hnnil Hrow Hdom Htab.
case: (altP ([seq x <- t0 | (x < n)%O] =P [::])) => Ht0 /=; first exact: IHt.
rewrite Ht0 /=; apply/and3P; split; last exact: IHt.
- apply sorted_filter; last exact Hrow.
  by move=> a b c; apply: le_trans.
- rewrite (head_filter_gt_tab _ Htab).
  apply filter_gt_dominate => //=.
  by move: Htab; case t => [//= | t1 t'] /= /and3P [].
Qed.

(** ** The size of a tableau *)
Definition size_tab t := sumn (shape t).

Lemma tab0 t : is_tableau t -> size_tab t = 0 -> t = [::].
Proof using.
move/is_part_sht; rewrite /size_tab => /part0 H{}/H.
by rewrite /shape; case t.
Qed.

Lemma size_to_word t : size (to_word t) = size_tab t.
Proof using.
rewrite /size_tab; elim: t => [//= | t0 t IHt] /=.
by rewrite to_word_cons size_cat IHt addnC.
Qed.

End Tableau.

Prenex Implicits is_tableau to_word size_tab.

(** ** Tableaux from their row reading *)
Section TableauReading.

Variables (disp : unit) (A : inhOrderType disp).

Definition tabsh_reading (sh : seq nat) (w : seq A) :=
  (size w == sumn sh) && (is_tableau (rev (reshape (rev sh) w))).

Lemma tabsh_readingP (sh : seq nat) (w : seq A) :
  reflect
    (exists tab, [/\ is_tableau tab, shape tab = sh & to_word tab = w])
    (tabsh_reading sh w).
Proof using.
apply (iffP idP).
- move=> /andP [] /eqP Hsz Htab.
  exists (rev (reshape (rev sh) w)); split => //.
  + rewrite shape_rev -{2}(revK sh); congr (rev _).
    by apply: reshapeKl; rewrite sumn_rev Hsz.
  + by rewrite /to_word revK; apply: reshapeKr; rewrite sumn_rev Hsz.
- move=> [] tab [] Htab Hsh Hw; apply/andP; split.
  + by rewrite -Hw size_to_word /size_tab Hsh.
  + rewrite -Hw /to_word -Hsh.
    by rewrite /shape -map_rev -/(shape _) flattenK revK.
Qed.

End TableauReading.

(** ** Sigma type for tableaux *)
Section FinType.

Context {disp : unit} {T : inhFinOrderType disp}.
Variables (d : nat) (sh : 'P_d).

Definition is_tab_of_shape (sh : seq nat) :=
  [pred t : seq (seq T) | (is_tableau t) && (shape t == sh) ].

Structure tabsh : predArgType :=
  TabSh {tabshval :> seq (seq T); _ : is_tab_of_shape sh tabshval}.
Canonical tabsh_subType := Eval hnf in [subType for tabshval].
Definition tabsh_eqMixin := Eval hnf in [eqMixin of tabsh by <:].
Canonical tabsh_eqType := Eval hnf in EqType tabsh tabsh_eqMixin.
Definition tabsh_choiceMixin := Eval hnf in [choiceMixin of tabsh by <:].
Canonical tabsh_choiceType := Eval hnf in ChoiceType tabsh tabsh_choiceMixin.
Definition tabsh_countMixin := Eval hnf in [countMixin of tabsh by <:].
Canonical tabsh_countType := Eval hnf in CountType tabsh tabsh_countMixin.
Canonical tabsh_subCountType := Eval hnf in [subCountType of tabsh].

Implicit Type (t : tabsh).

Lemma tabshP t : is_tableau t.
Proof using. by case: t => t /= /andP []. Qed.

Lemma shape_tabsh t : shape t = sh.
Proof using. by case: t => t /= /andP [] _ /eqP. Qed.

Lemma tabsh_to_wordK t : rev (reshape (rev sh) (to_word (val t))) = t.
Proof using. by rewrite /= -(shape_tabsh t); apply: to_wordK. Qed.

Let tabsh_enum :
  seq tabsh := pmap insub
              [seq rev (reshape (rev sh) (val w)) | w in {:d.-tuple T}].

Lemma finite_tabsh : Finite.axiom tabsh_enum.
Proof using.
case=> /= t Ht; rewrite -(count_map _ (pred1 t)) (pmap_filter (@insubK _ _ _)).
rewrite count_filter -(@eq_count _ (pred1 t)) => [|s /=]; last first.
  by rewrite isSome_insub; case: eqP=> // ->.
move: Ht => /andP [] Htab /eqP Hsh.
rewrite count_map.
have Htw : size (to_word t) == d.
  by rewrite size_to_word /size_tab Hsh sumn_intpartn.
rewrite (eq_in_count (a2 := pred1 (Tuple Htw))).
  by rewrite enumT; apply: enumP (Tuple Htw).
move=> w _ /=; apply/idP/idP.
- move=> /eqP Ht; subst t.
  apply/eqP/val_inj => /=; rewrite /to_word revK.
  by apply esym; apply: reshapeKr; rewrite sumn_rev size_tuple sumn_intpartn.
- move=> /eqP Hw; subst w; rewrite /=.
  by rewrite /to_word -Hsh -shape_rev flattenK revK.
Qed.

Definition tabsh_finMixin := Eval hnf in FinMixin finite_tabsh.
Canonical tabsh_finType := Eval hnf in FinType tabsh tabsh_finMixin.
Canonical tabsh_subFinType := Eval hnf in [subFinType of tabsh_countType].

Lemma to_word_enum_tabsh :
  perm_eq
    [seq to_word (tabshval t) | t : tabsh]
    [seq x <- [seq (i : seq _) | i : d.-tuple T]  | tabsh_reading sh x].
Proof using.
apply uniq_perm.
- rewrite map_inj_in_uniq; first exact: enum_uniq.
  move=> t u _ _ /= Heq; apply val_inj.
  by rewrite /= -(tabsh_to_wordK t) -(tabsh_to_wordK u) Heq /=.
- apply filter_uniq; rewrite map_inj_uniq; last exact: val_inj.
  exact: enum_uniq.
move=> w /=; rewrite /tabsh_reading mem_filter; apply/idP/idP.
- move=> /mapP [] t _ -> {w}.
  rewrite size_to_word /size_tab shape_tabsh eq_refl /=.
  rewrite tabsh_to_wordK tabshP /=.
  have Ht : size (to_word (val t)) == d.
    by rewrite size_to_word /size_tab shape_tabsh sumn_intpartn.
  have -> : to_word (val t) = val (Tuple Ht) by [].
  rewrite mem_map; last exact: val_inj.
  exact: mem_enum.
- move=> /andP [] /andP [] /eqP Hsz Htab /mapP [] tpl _ hw; subst w.
  have Htsh : is_tab_of_shape sh (rev (reshape (rev sh) tpl)).
    rewrite /is_tab_of_shape /= Htab /= shape_rev reshapeKl ?revK //.
    by rewrite sumn_rev Hsz.
  suff -> : val tpl = to_word (TabSh Htsh).
    by apply/mapP; exists (TabSh Htsh) => //; apply: mem_enum.
  rewrite /= /to_word revK reshapeKr //.
  by rewrite sumn_rev Hsz.
Qed.

End FinType.

Notation "'tabsh[' T ']' mu" :=
  (tabsh (T := [inhFinOrderType of T]) mu) (at level 10).

#[export] Hint Resolve tabshP : core.

(** TODO : Generalise to any finite order using Order.enum_val when released *)
Section OrdTableau.

Variable n : nat.
Variables (d : nat) (sh : 'P_d).

Implicit Type (t : tabsh['I_n.+1] sh).

Lemma all_ltn_nth_tabsh t (i : nat) :
  all (fun x : 'I_n.+1 => (i <= x)%O) (nth [::] t i).
Proof.
have:= tabshP t => /is_tableauP [_ _ Hdom].
elim: i => [|i /allP IHi]; apply/allP => x //.
move/(_ _ _ (ltnSn i)): Hdom => /dominateP [Hsz]; move: inh => Z.
move: (nth [::] t i) (nth [::] t i.+1) Hsz IHi => Ri Ri1 Hsz IHi Hdom Hx.
have:= Hx; rewrite -index_mem => Hxind.
have:= Hxind => /leq_trans/(_ Hsz)/(mem_nth Z)/IHi{IHi}/leq_ltn_trans; apply.
by move/(_ _ Hxind): Hdom; rewrite nth_index.
Qed.

Lemma size_tabsh t : size t <= n.+1.
Proof.
have Hall := all_ltn_nth_tabsh t.
have:= tabshP t => /is_tableauP [Hnnil _ _].
apply contraT; rewrite -ltnNge => Hn.
move/(_ n.+1): Hall; move/(_ _ Hn): Hnnil => {Hn}.
case: (nth [::] t n.+1) => //= x s _ /andP [Hn _ {s}].
have:= ltn_ord x; rewrite ltnS => /(leq_trans Hn).
by rewrite ltnn.
Qed.

Hypothesis Hszs : size sh <= n.+1.
Lemma tabrowconst_subproof :
  is_tab_of_shape
    sh (take (size sh) [tuple nseq (nth 0 sh (i : 'I_n.+1)) i | i < n.+1]).
Proof.
have Hsz : size (take (size sh) [tuple nseq (nth 0 sh i0) i0  | i0 < n.+1]) =
           size sh.
  by rewrite size_take size_tuple -/(minn _ _) (minn_idPl Hszs).
have Hnth j (Hj : j < size sh) :
              nth [::] [tuple nseq (nth 0 sh i) i | i < n.+1] j =
              nseq (nth 0 sh j) (Ordinal (leq_trans Hj Hszs)).
  by rewrite -/(nat_of_ord (Ordinal (leq_trans Hj Hszs))) -tnth_nth tnth_mktuple.
apply/andP; split; first apply/is_tableauP; try split.
- move=> i; rewrite Hsz => Hi; rewrite nth_take //.
  rewrite (Hnth _ Hi) /=; apply/negP => /eqP/nilP.
  by rewrite /nilp size_nseq; apply/negP/nth_part_non0.
- move=> r; case: (ltnP r (size sh)) => Hr; last by rewrite nth_default // Hsz.
  apply/(is_rowP (ord0)) => i j; rewrite nth_take // (Hnth _ Hr) /=.
  rewrite size_nseq => /andP [Hij Hj].
  by rewrite !nth_nseq (leq_ltn_trans Hij Hj) Hj.
- move=> i j Hij; apply/dominateP.
  case: (ltnP j (size sh)) => Hj; last by rewrite nth_default // Hsz.
  have Hi := ltn_trans Hij Hj; rewrite !nth_take //.
  rewrite (Hnth _ Hi) (Hnth _ Hj) !size_nseq.
  have:= (is_part_ijP _ (intpartnP sh)) => [] [_] /(_ _ _ (ltnW Hij)) => Hleq.
  split; first exact: Hleq.
  by move=> c Hc; rewrite !nth_nseq Hc (leq_trans Hc Hleq).
- apply/eqP/(eq_from_nth (x0 := 0)); rewrite size_map // => i.
  by rewrite Hsz => Hi; rewrite nth_shape nth_take // Hnth size_nseq.
Qed.
Definition tabrowconst := TabSh (tabrowconst_subproof).

End OrdTableau.

(** ** Tableaux and increasing maps *)
Section IncrMap.

Context (disp1 disp2 : unit)
        (T1 : inhOrderType disp1)
        (T2 : inhOrderType disp2).
Variable F : T1 -> T2.

Lemma shape_map_tab (t : seq (seq T1)) :
  shape [seq map F r | r <- t] = shape t.
Proof.
by rewrite /shape -map_comp; apply eq_map => s /=; rewrite size_map.
Qed.

Lemma get_map_tab (t : seq (seq T1)) rc :
  in_shape (shape t) rc ->
  get_tab [seq [seq F i | i <- r0] | r0 <- t] rc = F (get_tab t rc).
Proof.
move=> Hin; have:= in_shape_size Hin; rewrite size_map => Hr.
move: Hin; rewrite /in_shape (nth_map [::]) // /get_tab => Hc.
by rewrite (nth_map [::] _ _ Hr) (nth_map inh).
Qed.

Lemma to_word_map_tab (t : seq (seq T1)) :
  to_word [seq map F r | r <- t] = map F (to_word t).
Proof. by rewrite /to_word map_flatten map_rev. Qed.

Lemma incr_tab (t : seq (seq T1)) :
  {in (to_word t) &, {homo F : x y / (x < y)%O}} ->
  (is_tableau t) = (is_tableau [seq map F r | r <- t]).
Proof.
move=> Hincr.
have Hndecr := in_incr_nondecrE Hincr.
move/in_incrE in Hincr.
apply/is_tableau_getP/is_tableau_getP;
  rewrite ?shape_map_tab=> [] [H1 H2 H3]; split => // r c Hrc1;
  have Hrc : in_shape (shape t) (r, c) by apply: (in_part_le H1 Hrc1).
- rewrite !get_map_tab //.
  rewrite Hndecr; [exact: H2 | exact: mem_to_word | exact: mem_to_word].
- rewrite !get_map_tab //.
  rewrite Hincr; [exact: H3 | exact: mem_to_word | exact: mem_to_word].
- rewrite -Hndecr; [|exact: mem_to_word | exact: mem_to_word].
  by rewrite -!get_map_tab //; apply: H2.
- rewrite -Hincr; [|exact: mem_to_word | exact: mem_to_word].
  by rewrite -!get_map_tab //; apply: H3.
Qed.

End IncrMap.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2005-02-17

general lemmas and tactics
*)

Set Implicit Arguments.

Require Import LogicUtil Structures.Equalities RelUtil BoolUtil.
Require Export EqdepFacts Eqdep_dec.
Require Setoid.

(***********************************************************************)
(** Functor providing properties of Leibniz equality. *)

Module LeibnizFacts (Import T : Typ).

  Definition eq : relation t := @Logic.eq t.

  Instance eq_refl : Reflexive eq.

  Proof. fo. Qed.

  Instance eq_sym : Symmetric eq.

  Proof. fo. Qed.

  Instance eq_trans : Transitive eq.

  Proof. unfold eq; class. Qed.

End LeibnizFacts.

(***********************************************************************)
(** type equipped with a boolean equility *)

Record Bool_eq_type : Type := mkBool_eq_type {
  bet_type :> Type;
  bet_eq : bet_type -> bet_type -> bool;
  bet_ok : forall x y, bet_eq x y = true <-> x = y }.

(***********************************************************************)
(** dependent equality on decidable types *)

Section eq_dep.

  Variables (A : Type) (eq_dec : forall x y : A, {x=y}+{~x=y}).

  Lemma eq_rect_eq : forall (p : A) Q x h, x = eq_rect p Q x p h.

  Proof. exact (eq_rect_eq_dec eq_dec). Qed.

  Lemma eq_dep_eq : forall P (p : A) x y, eq_dep A P p x p y -> x = y.

  Proof. exact (eq_rect_eq__eq_dep_eq A eq_rect_eq). Qed.

  Lemma UIP : forall (x y : A) (p1 p2 : x = y), p1 = p2.

  Proof. exact (eq_dep_eq__UIP A eq_dep_eq). Qed.

  Lemma UIP_refl : forall (x : A) (p : x = x), p = refl_equal x.

  Proof. exact (UIP__UIP_refl A UIP). Qed.

  Lemma Streicher_K :
    forall (x : A) (P : x = x -> Prop), P (refl_equal x) -> forall p, P p.

  Proof. exact (K_dec_type eq_dec). Qed.

  Lemma inj_pairT2 : forall P (x : A) (p q : P x),
    existT x p = existT x q -> p = q.

  Proof. exact (eq_dep_eq__inj_pairT2 A eq_dep_eq). Qed.

  Lemma inj_pairP2 :
    forall P (x : A) p q, ex_intro P x p = ex_intro P x q -> p = q.

  Proof.
    intros. apply inj_right_pair with (A:=A).
    intros x0 y0; case (eq_dec x0 y0); [left|right]; hyp.
    hyp.
  Qed.

End eq_dep.

Implicit Arguments UIP_refl [A x].

(***********************************************************************)
(** boolean function testing equality *)

Section beq.

  Variable A : Type.
  Variable beq : A -> A -> bool.
  Variable beq_ok : forall x y, beq x y = true <-> x = y.

  Lemma beq_refl : forall x, beq x x = true.

  Proof. intro. ded (beq_ok x x). rewrite H. refl. Qed.

  Lemma beq_ko : forall x y, beq x y = false <-> x <> y.

  Proof.
    intros. destruct (beq_ok x y). case_eq (beq x y); intuition.
    rewrite H1 in H4. discr.
  Defined.

  Lemma dec_beq : forall x y : A, {x=y}+{~x=y}.

  Proof.
    intros. set (b := beq x y). case_eq b; intros.
    left. exact (proj1 (beq_ok x y) H).
    right. intro. unfold b in H. subst. rewrite beq_refl in H. discr.
  Defined.

  Lemma beq_com : forall x y, beq x y = beq y x.

  Proof.
    intros. case_eq (beq x y); intros; sym.
    rewrite beq_ok. sym. rewrite <- beq_ok. hyp.
    rewrite beq_ko. cut (x<>y). auto. rewrite <- beq_ko. hyp.
  Qed.

  Lemma beq_sym : forall x y, beq x y = true -> beq y x = true.

  Proof. intros. rewrite beq_com. exact H. Qed.

  Lemma beq_trans : forall x y z,
    beq x y = true -> beq y z = true -> beq x z = true.

  Proof.
    intros. rewrite beq_ok in H. rewrite beq_ok in H0.
    assert (x = z). apply trans_eq with y; hyp.
    rewrite beq_ok. exact H1.
  Qed.

End beq.

Implicit Arguments beq_refl [A beq].
Implicit Arguments dec_beq [A beq].
Implicit Arguments beq_com [A beq].
Implicit Arguments beq_ko [A beq].

Ltac case_beq beq beq_ok x y := case_eq (beq x y);
  [let h := fresh in intro h; rewrite beq_ok in h;
    match type of h with ?x = ?y => subst y end
    | intro].

(***********************************************************************)
(** boolean function testing equality from decidability predicate *)

Section eq_dec.

  Variable A : Type.
  Variable eq_dec : forall x y : A, {x=y}+{~x=y}.

  Definition beq_dec x y :=
    match eq_dec x y with
      | left _ => true
      | right _ => false
    end.

  Lemma beq_dec_ok : forall x y, beq_dec x y = true <-> x = y.

  Proof. intros. unfold beq_dec. case (eq_dec x y); intuition. discr. Qed.

  Lemma beq_dec_refl : forall x, beq_dec x x = true.

  Proof. intro. unfold beq_dec. case (eq_dec x x); intros. refl. irrefl. Qed.

  Lemma beq_dec_sym : forall x y, beq_dec x y = beq_dec y x.

  Proof.
    intros. unfold beq_dec. case (eq_dec x y); case (eq_dec y x); intros;
    (refl || irrefl).
  Qed.

  Lemma beq_dec_trans : forall x y z,
    implb (beq_dec x y && beq_dec y z) (beq_dec x z) = true.

  Proof.
    intros. unfold beq_dec.
    case (eq_dec x y); case (eq_dec y z); case (eq_dec x z);
      intros; (refl || (irrefl || idtac)).
  Qed.

  Lemma beq_dec_ko : forall x y, beq_dec x y = false <-> x <> y.

  Proof.
    intros. case (eq_dec x y); case_eq (beq_dec x y); intuition.
    subst y. rewrite beq_dec_refl in H. discr.
    rewrite beq_dec_ok in H. contr.
  Qed.

End eq_dec.